ADD linker for actions to goals

This commit is contained in:
Nathan Dwarshuis 2022-02-19 19:12:47 -05:00
parent 71e8e818d0
commit 84977f9947
1 changed files with 89 additions and 44 deletions

View File

@ -2070,7 +2070,12 @@ FUTURE-LIMIT in a list."
(defconst org-x-drwr-parent-links "X_PARENT_LINKS") (defconst org-x-drwr-parent-links "X_PARENT_LINKS")
(defun org-x-dag-headline-get-parent-links (headline) (defun org-x-dag-build-parent-link-drawer (ids)
(->> (-map #'org-x-dag-id->link-item ids)
(apply #'org-ml-build-plain-list)
(org-ml-build-drawer org-x-drwr-parent-links)))
(defun org-x-dag-section-get-parent-links (children)
(cl-flet (cl-flet
((parse-item ((parse-item
(item) (item)
@ -2078,13 +2083,8 @@ FUTURE-LIMIT in a list."
(if (and (org-ml-is-type 'link first) (if (and (org-ml-is-type 'link first)
(equal (org-ml-get-property :type first) "id")) (equal (org-ml-get-property :type first) "id"))
(org-ml-get-property :path first) (org-ml-get-property :path first)
;; (->> (org-ml-get-children first)
;; (-map #'org-ml-to-trimmed-string)
;; (apply #'concat)
;; (cons (org-ml-get-property :path first)))
(error "Invalid link node: %S" first))))) (error "Invalid link node: %S" first)))))
(-when-let (first (->> headline (-when-let (first (->> children
(org-ml-headline-get-contents (org-x-logbook-config))
(--find (org-x--is-drawer-with-name org-x-drwr-parent-links it)) (--find (org-x--is-drawer-with-name org-x-drwr-parent-links it))
(org-ml-get-children) (org-ml-get-children)
(car))) (car)))
@ -2093,22 +2093,38 @@ FUTURE-LIMIT in a list."
(-map #'parse-item)) (-map #'parse-item))
(error "Invalid parent link drawer"))))) (error "Invalid parent link drawer")))))
(defun org-x-dag-build-parent-link-drawer (ids) (defun org-x-dag-section-set-parent-links (ids children)
(->> (-map #'org-x-dag-id->link-item ids) (-if-let (i (--find-index (org-x--is-drawer-with-name org-x-drwr-parent-links it)
(apply #'org-ml-build-plain-list) children))
(org-ml-build-drawer "X_PARENT_LINKS"))) (let ((d (nth i children)))
(-if-let (pl (-some->> (-map #'org-x-dag-id->link-item ids)
(apply #'org-ml-build-plain-list)))
(-replace-at i (org-ml-set-children (list pl) d) children)
(-remove-at i children)))
(if ids (cons (org-x-dag-build-parent-link-drawer ids) children) children)))
(defmacro org-x-dag-section-map-parent-links* (form children)
(let ((c (make-symbol "--headline")))
`(let* ((,c ,children)
(it (org-x-dag-section-get-parent-links ,c)))
(org-x-dag-section-set-parent-links ,form ,c))))
(defun org-x-dag-section-add-parent-link (id children)
(org-x-dag-section-map-parent-links* (cons id it) children))
(defun org-x-dag-section-remove-parent-link (id children)
(org-x-dag-section-map-parent-links*
(--remove-first (equal it id) it)
children))
(defun org-x-dag-headline-get-parent-links (headline)
(->> headline
(org-ml-headline-get-contents (org-x-logbook-config))
(org-x-dag-section-get-parent-links)))
(defun org-x-dag-headline-set-parent-links (ids headline) (defun org-x-dag-headline-set-parent-links (ids headline)
(org-ml-headline-map-contents* (org-x-logbook-config) (org-ml-headline-map-contents* (org-x-logbook-config)
(-if-let (i (--find-index (org-x--is-drawer-with-name (org-x-dag-section-set-parent-links ids it)
org-x-drwr-parent-links it)
it))
(let ((d (nth i it)))
(-if-let (pl (-some->> (-map #'org-x-dag-id->link-item ids)
(apply #'org-ml-build-plain-list)))
(-replace-at i (org-ml-set-children (list pl) d) it)
(-remove-at i it)))
(if ids (cons (org-x-dag-build-parent-link-drawer ids) it) it))
headline)) headline))
(defmacro org-x-dag-headline-map-parent-links* (form headline) (defmacro org-x-dag-headline-map-parent-links* (form headline)
@ -2117,6 +2133,7 @@ FUTURE-LIMIT in a list."
(it (org-x-dag-headline-get-parent-links ,h))) (it (org-x-dag-headline-get-parent-links ,h)))
(org-x-dag-headline-set-parent-links ,form ,h)))) (org-x-dag-headline-set-parent-links ,form ,h))))
;; TODO not DRY
(defun org-x-dag-headline-add-parent-link (id headline) (defun org-x-dag-headline-add-parent-link (id headline)
(org-x-dag-headline-map-parent-links* (cons id it) headline)) (org-x-dag-headline-map-parent-links* (cons id it) headline))
@ -2168,41 +2185,69 @@ FUTURE-LIMIT in a list."
(defun org-x-dag-read-id (ids cur-ids) (defun org-x-dag-read-id (ids cur-ids)
(cl-flet (cl-flet
((make-cell ((make-cell
(id cur-ids) (id type)
(let ((title (org-x-dag-id->title id)) (-let ((title (org-x-dag-id->title id))
(presentp (and (member id cur-ids) t))) (presentp (not (eq type 'toadd)))
(list (format "%c %s" (if presentp ?* ?\s) title) (prefix (pcase type
(`present ?*)
(`noexist ?!)
(`toadd ?\s))))
(list (format "%c %s" prefix title)
:id id :id id
:title title :title title
:presentp presentp)))) :presentp presentp))))
(let ((mapper (->> ids (let* ((present (--map (list it 'present) (-intersection cur-ids ids)))
(--map (make-cell it cur-ids)) (noexist (--map (list it 'noexist) (-difference cur-ids ids)))
(--sort (plist-get (cdr it) :presentp))))) (toadd (--map (list it 'toadd) (-difference ids cur-ids)))
(mapper (->> (append present noexist toadd)
(--map (apply #'make-cell it))
(--sort (plist-get (cdr it) :presentp)))))
(print (-map #'cdr mapper)) (print (-map #'cdr mapper))
(alist-get (completing-read "Node: " mapper) mapper nil nil #'equal)))) (alist-get (completing-read "Node: " mapper) mapper nil nil #'equal))))
(defun org-x-dag-this-headline-choose-id (toplevel-allowed? legal-files msg ids)
(cl-flet
((update-nodes
(link-getter remover adder ids children)
(-let* ((cur-ids (funcall link-getter children))
((&plist :id i :presentp p) (org-x-dag-read-id ids cur-ids)))
(funcall (if p remover adder) i children))))
(if (not (member (buffer-file-name) legal-files)) (message "Not in %s" msg)
(if (org-before-first-heading-p)
(if (not toplevel-allowed?) (message "Cannot set toplevel drawer.")
(org-ml-update-this-section*
;; TODO org-ml shouldn't require this, just map the children
;; directly
(org-ml-map-children*
(update-nodes #'org-x-dag-section-get-parent-links
#'org-x-dag-section-remove-parent-link
#'org-x-dag-section-add-parent-link
ids it)
it)))
(org-ml-update-this-headline*
(update-nodes #'org-x-dag-headline-get-parent-links
#'org-x-dag-headline-remove-parent-link
#'org-x-dag-headline-add-parent-link
ids it))))))
(defun org-x-dag-link-ltg-to-epg () (defun org-x-dag-link-ltg-to-epg ()
(interactive) (interactive)
(if (not (equal (buffer-file-name) (org-x-get-endpoint-goal-file))) (let ((ids (org-x-dag->ltg-ids))
(message "Not in endpoint goal file") (legal (list (org-x-get-endpoint-goal-file))))
(org-ml-update-this-headline* (org-x-dag-this-headline-choose-id nil legal "endpoint goal file" ids)))
(-let* ((ltg-ids (org-x-dag->ltg-ids))
(cur-ids (org-x-dag-headline-get-parent-links it))
((&plist :id i :presentp p) (org-x-dag-read-id ltg-ids cur-ids)))
(if p (org-x-dag-headline-remove-parent-link i it)
(org-x-dag-headline-add-parent-link i it))))))
(defun org-x-dag-link-goal-to-qtp () (defun org-x-dag-link-goal-to-qtp ()
(interactive) (interactive)
(if (not (equal (buffer-file-name) (org-x-qtp-get-file))) (let ((ids (append (org-x-dag->ltg-ids) (org-x-dag->epg-ids)))
(message "Not in quarterly plan file") (legal (list (org-x-qtp-get-file))))
(org-ml-update-this-headline* (org-x-dag-this-headline-choose-id nil legal "quarterly plan file" ids)))
(-let* ((goal-ids (append (org-x-dag->ltg-ids)
(org-x-dag->epg-ids))) (defun org-x-dag-link-action-to-goal ()
(cur-ids (org-x-dag-headline-get-parent-links it)) (interactive)
((&plist :id i :presentp p) (org-x-dag-read-id goal-ids cur-ids))) (let ((ids (append (org-x-dag->ltg-ids) (org-x-dag->epg-ids)))
(if p (org-x-dag-headline-remove-parent-link i it) (legal (org-x-get-action-and-incubator-files)))
(org-x-dag-headline-add-parent-link i it)))))) ;; TODO this won't work on the toplevel section
(org-x-dag-this-headline-choose-id t legal "an action/incubator file" ids)))
;;; AGENDA VIEWS ;;; AGENDA VIEWS