ndwarshuis
/
emacs-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

REF clean up link functions

This commit is contained in:
Nathan Dwarshuis 2022-04-12 23:32:45 -04:00
parent 909d1f7148
commit 621754f5e8
1 changed files with 91 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

186
local/lib/org-x/org-x-dag.el
View File

@ -1261,8 +1261,6 @@ used for optimization."
(org-x-dag-ht-add-links id ht-l :fulfilled))))) (org-x-dag-ht-add-links id ht-l :fulfilled)))))
ns)) ns))
;; TODO check that actions that are linked here are not linked to survival
;; goals here (since those can't be planned)
(defun org-x-dag-ns-dlp (adjlist links ns) (defun org-x-dag-ns-dlp (adjlist links ns)
(cl-flet (cl-flet
((get-committed ((get-committed
@ -1276,6 +1274,8 @@ used for optimization."
(let ((qgoals (->> (get-committed ht-w w) (let ((qgoals (->> (get-committed ht-w w)
(get-committed ht-q))) (get-committed ht-q)))
(agoals (get-committed ht-a a))) (agoals (get-committed ht-a a)))
;; TODO this check doesn't matter for survival goals since
;; those won't be on the quarterly plan
(-if-let (gs (-intersection qgoals agoals)) (-if-let (gs (-intersection qgoals agoals))
(progn (progn
(->> (list :scheduled w (->> (list :scheduled w
@ -1821,20 +1821,34 @@ Return value is a list like (BUFFER NON-BUFFER)."
(defun org-x-dag-files->ids (files) (defun org-x-dag-files->ids (files)
(-mapcat #'org-x-dag-file->ids files)) (-mapcat #'org-x-dag-file->ids files))
(defun org-x-dag->goal-ids (which)
(org-x-dag-file->ids (org-x-dag->goal-file which)))
(defun org-x-dag->planning-ids (which)
(->> (org-x-dag->goal-file which)
(org-x-dag-file->ids)))
(defun org-x-dag->epg-ids () (defun org-x-dag->epg-ids ()
(org-x-dag-file->ids (org-x-get-endpoint-goal-file))) (org-x-dag->goal-ids :endpoint))
(defun org-x-dag->ltg-ids () (defun org-x-dag->ltg-ids ()
(org-x-dag-file->ids (org-x-get-lifetime-goal-file))) (org-x-dag->goal-ids :lifetime))
(defun org-x-dag->svg-ids () (defun org-x-dag->svg-ids ()
(org-x-dag-file->ids (org-x-get-survival-goal-file))) (org-x-dag->goal-ids :survival))
(defun org-x-dag->qtp-ids () (defun org-x-dag->qtp-ids ()
(org-x-dag-file->ids (org-x-dag->planning-file :quarterly))) (org-x-dag->planning-ids :quarterly))
(defun org-x-dag->wkp-ids () (defun org-x-dag->wkp-ids ()
(org-x-dag-file->ids (org-x-dag->planning-file :weekly))) (org-x-dag->planning-ids :weekly))
(defun org-x-dag->dlp-ids ()
(org-x-dag->planning-ids :weekly))
(defun org-x-dag->action-ids ()
(->> (org-x-dag->action-files)
(org-x-dag-files->ids)))
(defun org-x-dag-filter-ids-tags (tags ids) (defun org-x-dag-filter-ids-tags (tags ids)
(--filter (-intersection (org-x-dag-id->tags nil it) tags) ids)) (--filter (-intersection (org-x-dag-id->tags nil it) tags) ids))
@ -1852,15 +1866,26 @@ Return value is a list like (BUFFER NON-BUFFER)."
#'org-x-dag-weekly-tags-to-date #'org-x-dag-weekly-tags-to-date
date)) date))
(defun org-x-dag->dlp-ids ()
(org-x-dag-file->ids (org-x-dag->planning-file :daily)))
(defun org-x-dag-date->dlp-ids (date) (defun org-x-dag-date->dlp-ids (date)
(org-x-dag-date->tagged-ids (org-x-dag-date->tagged-ids
(org-x-dag->dlp-ids) (org-x-dag->dlp-ids)
#'org-x-dag-daily-tags-to-date #'org-x-dag-daily-tags-to-date
date)) date))
(defun org-x-dag->current-qtp-ids ()
(-> (org-x-dag->selected-date)
(org-x-dag-date-to-quarter-start)
(org-x-dag-date->qtp-ids)))
(defun org-x-dag->current-wkp-ids ()
(-> (org-x-dag->selected-date)
(org-x-dag-date-to-week-start)
(org-x-dag-date->wkp-ids)))
(defun org-x-dag->current-dlp-ids ()
(-> (org-x-dag->selected-date)
(org-x-dag-date->dlp-ids)))
(defun org-x-dag-goal-count-tasks (id) (defun org-x-dag-goal-count-tasks (id)
(->> (org-x-dag-id->children id) (->> (org-x-dag-id->children id)
(-mapcat #'org-x-dag-id->all-buffer-children) (-mapcat #'org-x-dag-id->all-buffer-children)
@ -2216,18 +2241,17 @@ FUTURE-LIMIT in a list."
;; auxiliary macros ;; auxiliary macros
(defmacro org-x-dag-with-file-ids (files id-form) (defmacro org-x-dag-with-ids (ids id-form)
(declare (indent 1)) (declare (indent 1))
`(with-temp-buffer `(with-temp-buffer
;; TODO this is silly and it adds 0.1 seconds to this function's runtime; ;; TODO this is silly and it adds 0.1 seconds to this function's runtime;
;; it is only needed to get the todo keyword the right color ;; it is only needed to get the todo keyword the right color
(org-mode) (org-mode)
(->> (org-x-dag-files->ids ,files) (--mapcat ,id-form ,ids)))
(--mapcat ,id-form))))
(defmacro org-x-dag-with-action-ids (id-form) (defmacro org-x-dag-with-action-ids (id-form)
(declare (indent 0)) (declare (indent 0))
`(org-x-dag-with-file-ids (org-x-dag->action-files) `(org-x-dag-with-ids (org-x-dag->action-ids)
,id-form)) ,id-form))
(defmacro org-x-dag-with-files (files pre-form form) (defmacro org-x-dag-with-files (files pre-form form)
@ -2440,7 +2464,7 @@ FUTURE-LIMIT in a list."
(format-deadlines todayp sel-date it dead)) (format-deadlines todayp sel-date it dead))
(when sched (when sched
(format-scheduleds todayp sel-date it sched)))))))) (format-scheduleds todayp sel-date it sched))))))))
(daily (org-x-dag-with-file-ids (org-x-dag->planning-file :daily) (daily (org-x-dag-with-ids (org-x-dag->dlp-ids)
(pcase (either-from-right (org-x-dag-id->bs it) nil) (pcase (either-from-right (org-x-dag-id->bs it) nil)
(`(:daily :active (:sched ,sched)) (`(:daily :active (:sched ,sched))
(format-scheduleds todayp sel-date it sched)))))) (format-scheduleds todayp sel-date it sched))))))
@ -3527,6 +3551,20 @@ review phase)"
(:daily "DLP") (:daily "DLP")
(_ "???"))) (_ "???")))
(defun org-x-dag--format-link-menu-line (id title-fun)
(declare (indent 1))
(let* ((group (org-x-dag-id->group id))
(s (funcall title-fun id group))
(g (org-x-dag-group-code group)))
(format "%s | %s" g s)))
(defun org-x-dag--format-link-menu-line-expanded (id)
(org-x-dag--format-link-menu-line id
(lambda (id group)
(if (memq group '(:weekly :daily :quarterly))
(org-x-dag-id->title id)
(org-x-dag-id->path (eq group :action) id)))))
(defun org-x-dag--link-parent-to-child (parent-id-fun child-id-fun fmt-fun) (defun org-x-dag--link-parent-to-child (parent-id-fun child-id-fun fmt-fun)
(cl-flet* (cl-flet*
(;; (is-valid-node (;; (is-valid-node
@ -3586,8 +3624,6 @@ review phase)"
() ()
(either>>= (id-getter) (either>>= (id-getter)
(cond (cond
((org-x-dag-id->ns-key :survivalp it)
(either :left "Action has survival goal parents"))
((-some->> (org-x-dag-id->planning-datetime :scheduled it) ((-some->> (org-x-dag-id->planning-datetime :scheduled it)
(org-x-dag-datetime-split) (org-x-dag-datetime-split)
(nth 1)) (nth 1))
@ -3598,52 +3634,21 @@ review phase)"
;; child id functions ;; child id functions
(action-qtp-getter (action-qtp-getter
() ()
(let ((action (->> (org-x-dag->action-files) (let ((action (->> (org-x-dag->action-ids)
(org-x-dag-files->ids)
;; TODO could also remove DONE/CANC and things ;; TODO could also remove DONE/CANC and things
;; underneath these ;; underneath these
(--remove (org-x-dag-id->ns-key :survivalp it)))) (--remove (org-x-dag-id->ns-key :survivalp it))))
(qtp (-> (plist-get org-x-dag :selected-date) (append action (org-x-dag->current-qtp-ids)))))
(org-x-dag-date-to-quarter)
(org-x-dag-quarter-to-date)
(org-x-dag-date->qtp-ids))))
(append action qtp)))
(svg-action-getter (svg-action-getter
() ()
(->> (org-x-dag->action-files) (->> (org-x-dag->action-ids)
(org-x-dag-files->ids)
;; TODO could also remove DONE/CANC and things ;; TODO could also remove DONE/CANC and things
;; underneath these ;; underneath these
(--remove (and (org-x-dag-id->ns-key :committed it) (--remove (and (org-x-dag-id->ns-key :committed it)
(not (org-x-dag-id->ns-key :survivalp it)))))) (not (org-x-dag-id->ns-key :survivalp it))))))
(epg-action-qtp-getter (epg-action-qtp-getter
() ()
`(,@(org-x-dag->epg-ids) ,@(action-qtp-getter))) `(,@(org-x-dag->epg-ids) ,@(action-qtp-getter))))
(wkp-getter
()
(-> (plist-get org-x-dag :selected-date)
(org-x-dag-date-to-week-number)
(org-x-dag-date->wkp-ids)))
(dlp-getter
()
(-> (plist-get org-x-dag :selected-date)
(org-x-dag-date->dlp-ids)))
;; formatters
(toplevel-formatter
(id)
(let* ((group (org-x-dag-id->group id))
(s (if (eq group :quarterly)
(org-x-dag-id->title id)
(org-x-dag-id->path (eq group :action) id)))
(g (org-x-dag-group-code group)))
(format "%s | %s" g s)))
(svg-formatter
(id)
(org-x-dag-id->path t id))
(plan-formatter
(id)
(org-x-dag-id->title id)))
(org-x-dag-sync) (org-x-dag-sync)
(let ((f (buffer-file-name))) (let ((f (buffer-file-name)))
@ -3652,32 +3657,32 @@ review phase)"
(org-x-dag--link-parent-to-child (org-x-dag--link-parent-to-child
#'leaf-id-getter #'leaf-id-getter
#'epg-action-qtp-getter #'epg-action-qtp-getter
#'toplevel-formatter)) #'org-x-dag--format-link-menu-line-expanded))
((equal f (org-x-dag->goal-file :endpoint)) ((equal f (org-x-dag->goal-file :endpoint))
(org-x-dag--link-parent-to-child (org-x-dag--link-parent-to-child
#'leaf-id-getter #'leaf-id-getter
#'action-qtp-getter #'action-qtp-getter
#'toplevel-formatter)) #'org-x-dag--format-link-menu-line-expanded))
((equal f (org-x-dag->goal-file :survival)) ((equal f (org-x-dag->goal-file :survival))
(org-x-dag--link-parent-to-child (org-x-dag--link-parent-to-child
#'leaf-id-getter #'leaf-id-getter
#'svg-action-getter #'svg-action-getter
#'svg-formatter)) (-partial #'org-x-dag-id->path t)))
((member f (org-x-dag->action-files)) ((member f (org-x-dag->action-files))
(org-x-dag--link-parent-to-child (org-x-dag--link-parent-to-child
#'action-id-getter #'action-id-getter
#'dlp-getter #'org-x-dag->current-dlp-ids
#'plan-formatter)) #'org-x-dag-id->title))
((equal f (org-x-dag->planning-file :quarterly)) ((equal f (org-x-dag->planning-file :quarterly))
(org-x-dag--link-parent-to-child (org-x-dag--link-parent-to-child
#'id-getter #'id-getter
#'wkp-getter #'org-x-dag->current-wkp-ids
#'plan-formatter)) #'org-x-dag-id->title))
((equal f (org-x-dag->planning-file :weekly)) ((equal f (org-x-dag->planning-file :weekly))
(org-x-dag--link-parent-to-child (org-x-dag--link-parent-to-child
#'id-getter #'id-getter
#'dlp-getter #'org-x-dag->current-dlp-ids
#'plan-formatter)) #'org-x-dag-id->title))
(t (t
(message "Cannot link child from parent in current file")))))) (message "Cannot link child from parent in current file"))))))
@ -3735,7 +3740,9 @@ review phase)"
sec))) sec)))
(either-from* (funcall parse-fun) (either-from* (funcall parse-fun)
(message it) (message it)
(if it (update-headline it) (update-tl-section it))))) (if (org-ml-is-type 'headline it)
(update-headline it)
(update-tl-section it)))))
(defun org-x-dag-link-child-to-parent () (defun org-x-dag-link-child-to-parent ()
(interactive) (interactive)
@ -3757,55 +3764,22 @@ review phase)"
(parse-hl))) (parse-hl)))
;; parent id getters ;; parent id getters
(ltg-getter
()
(->> (org-x-dag->goal-file :lifetime)
(org-x-dag-file->ids)))
(tlg-getter (tlg-getter
() ()
(->> (org-x-dag->goal-file :endpoint) (append (org-x-dag->epg-ids) (org-x-dag->ltg-ids)))
(org-x-dag-file->ids)
(append (ltg-getter))))
(goal-getter (goal-getter
() ()
(->> (org-x-dag->goal-file :survival) (append (org-x-dag->svg-ids) (tlg-getter)))
(org-x-dag-file->ids)
(append (tlg-getter))))
(wkp-getter
()
(->> (plist-get org-x-dag :selected-date)
(org-x-dag-date-to-quarter-start)
(org-x-dag-date->qtp-ids)))
(dlp-getter (dlp-getter
() ()
(let ((wkp-ids (->> (plist-get org-x-dag :selected-date) (append (org-x-dag->current-wkp-ids) (org-x-dag->action-ids)))
(org-x-dag-date-to-week-start)
(org-x-dag-date->wkp-ids)))
(action-ids (->> (org-x-dag->action-files)
(org-x-dag-files->ids))))
(append wkp-ids action-ids)))
;; formatters ;; formatters
(ltg-formatter
(id)
(org-x-dag-id->path t id))
(goal-formatter (goal-formatter
(id) (id)
(let* ((group (org-x-dag-id->group id)) (org-x-dag--format-link-menu-line id
(s (org-x-dag-id->path nil id)) (lambda (id _)
(g (org-x-dag-group-code group))) (org-x-dag-id->path nil id)))))
(format "%s | %s" g s)))
(plan-formatter
(id)
(org-x-dag-id->title id))
(dlp-formatter
(id)
(let* ((group (org-x-dag-id->group id))
(s (if (eq group :weekly)
(org-x-dag-id->title id)
(org-x-dag-id->path (eq group :action) id)))
(g (org-x-dag-group-code group)))
(format "%s | %s" g s))))
(org-x-dag-sync) (org-x-dag-sync)
(let ((f (buffer-file-name))) (let ((f (buffer-file-name)))
@ -3813,8 +3787,8 @@ review phase)"
((equal f (org-x-dag->goal-file :endpoint)) ((equal f (org-x-dag->goal-file :endpoint))
(org-x-dag--link-child-to-parent (org-x-dag--link-child-to-parent
#'parse-hl #'parse-hl
#'ltg-getter #'org-x-dag->ltg-ids
#'ltg-formatter)) (-partial #'org-x-dag-id->path t)))
((member f (org-x-dag->action-files)) ((member f (org-x-dag->action-files))
(org-x-dag--link-child-to-parent (org-x-dag--link-child-to-parent
#'parse-hl-sec #'parse-hl-sec
@ -3828,13 +3802,13 @@ review phase)"
((equal f (org-x-dag->planning-file :weekly)) ((equal f (org-x-dag->planning-file :weekly))
(org-x-dag--link-child-to-parent (org-x-dag--link-child-to-parent
#'parse-hl #'parse-hl
#'wkp-getter #'org-x-dag->current-qtp-ids
#'plan-formatter)) #'org-x-dag-id->title))
((equal f (org-x-dag->planning-file :daily)) ((equal f (org-x-dag->planning-file :daily))
(org-x-dag--link-child-to-parent (org-x-dag--link-child-to-parent
#'parse-hl #'parse-hl
#'dlp-getter #'dlp-getter
#'dlp-formatter)) #'org-x-dag--format-link-menu-line-expanded))
(t (t
(message "Cannot link parent from child in current file")))))) (message "Cannot link parent from child in current file"))))))