ADD global parent->child function
This commit is contained in:
parent
655b66dd92
commit
6867b127ee
|
@ -635,8 +635,8 @@ be uncommitted if it is also incubated."
|
||||||
(defun org-x-dag->current-date ()
|
(defun org-x-dag->current-date ()
|
||||||
(plist-get org-x-dag :current-date))
|
(plist-get org-x-dag :current-date))
|
||||||
|
|
||||||
;; (defun org-x-dag->qtp-ids ()
|
(defun org-x-dag->qtp-ids ()
|
||||||
;; (org-x-dag-file->ids (org-x-qtp-get-file)))
|
(org-x-dag-file->ids (org-x-dag->planning-file :quarterly)))
|
||||||
|
|
||||||
;; (defun org-x-dag->wkp-ids ()
|
;; (defun org-x-dag->wkp-ids ()
|
||||||
;; (org-x-dag-file->ids (org-x-get-weekly-plan-file)))
|
;; (org-x-dag-file->ids (org-x-get-weekly-plan-file)))
|
||||||
|
@ -686,15 +686,15 @@ be uncommitted if it is also incubated."
|
||||||
;; (let ((target-tags (funcall tag-getter date)))
|
;; (let ((target-tags (funcall tag-getter date)))
|
||||||
;; (org-x-dag-filter-ids-tags target-tags ids))
|
;; (org-x-dag-filter-ids-tags target-tags ids))
|
||||||
|
|
||||||
;; (defun org-x-dag-date->qtp-ids (date)
|
(defun org-x-dag-date->qtp-ids (date)
|
||||||
;; (org-x-dag-date->tagged-ids #'org-x-dag->qtp-ids
|
(org-x-dag-date->tagged-ids (org-x-dag->qtp-ids)
|
||||||
;; #'org-x-dag-date-to-quarter-tags
|
#'org-x-dag-quarter-tags-to-date
|
||||||
;; date))
|
date))
|
||||||
|
|
||||||
;; (defun org-x-dag-date->wkp-ids (date)
|
(defun org-x-dag-date->wkp-ids (date)
|
||||||
;; (org-x-dag-date->tagged-ids #'org-x-dag->wkp-ids
|
(org-x-dag-date->tagged-ids (org-x-dag->wkp-ids)
|
||||||
;; #'org-x-dag-date-to-week-tags
|
#'org-x-dag-week-tags-to-date
|
||||||
;; date))
|
date))
|
||||||
|
|
||||||
;; (defun org-x-dag->qtp-current-ids ()
|
;; (defun org-x-dag->qtp-current-ids ()
|
||||||
;; (org-x-dag-date->qtp-ids (org-x-dag->current-date)))
|
;; (org-x-dag-date->qtp-ids (org-x-dag->current-date)))
|
||||||
|
@ -726,11 +726,11 @@ be uncommitted if it is also incubated."
|
||||||
(`current (date-ids ids (org-x-dag->current-date)))
|
(`current (date-ids ids (org-x-dag->current-date)))
|
||||||
(date (date-ids ids date))))))
|
(date (date-ids ids date))))))
|
||||||
|
|
||||||
(defun org-x-dag->qtp-ids (which)
|
;; (defun org-x-dag->qtp-ids (which)
|
||||||
(org-x-dag-which->ids :quarterly #'org-x-dag-date-to-quarter-tags which))
|
;; (org-x-dag-which->ids :quarterly #'org-x-dag-date-to-quarter-tags which))
|
||||||
|
|
||||||
(defun org-x-dag->wkp-ids (which)
|
;; (defun org-x-dag->wkp-ids (which)
|
||||||
(org-x-dag-which->ids :weekly #'org-x-dag-date-to-week-tags which))
|
;; (org-x-dag-which->ids :weekly #'org-x-dag-date-to-week-tags which))
|
||||||
|
|
||||||
;; (defun org-x-dag->dlp-ids (which)
|
;; (defun org-x-dag->dlp-ids (which)
|
||||||
;; (org-x-dag-which->ids :daily #'org-x-dag-date-to-daily-tags which))
|
;; (org-x-dag-which->ids :daily #'org-x-dag-date-to-daily-tags which))
|
||||||
|
@ -3554,7 +3554,7 @@ except it ignores inactive timestamps."
|
||||||
(org-ml-update-this-headline*
|
(org-ml-update-this-headline*
|
||||||
(org-x-dag-headline-add-parent-link id it)))
|
(org-x-dag-headline-add-parent-link id it)))
|
||||||
|
|
||||||
(defun org-x-dag-id->path (id)
|
(defun org-x-dag-id->buffer-lineage (id)
|
||||||
(cl-labels
|
(cl-labels
|
||||||
((get-parents
|
((get-parents
|
||||||
(acc id)
|
(acc id)
|
||||||
|
@ -3563,11 +3563,199 @@ except it ignores inactive timestamps."
|
||||||
(cons id acc))))
|
(cons id acc))))
|
||||||
(get-parents nil id)))
|
(get-parents nil id)))
|
||||||
|
|
||||||
|
(defun org-x-dag-id->path (category? id)
|
||||||
|
(let ((path (->> (org-x-dag-id->buffer-lineage id)
|
||||||
|
(-map #'org-x-dag-id->title)
|
||||||
|
(s-join "/")
|
||||||
|
(s-prepend))))
|
||||||
|
(if category?
|
||||||
|
(format "%s:%s" (org-x-dag-id->hl-meta-prop id :category) path)
|
||||||
|
path)))
|
||||||
|
|
||||||
|
(defun org-x-dag-group-code (group)
|
||||||
|
(pcase group
|
||||||
|
(:lifetime "LTG")
|
||||||
|
(:survival "SVG")
|
||||||
|
(:endpoint "EPG")
|
||||||
|
(:action "ACT")
|
||||||
|
(:quarterly "QTP")
|
||||||
|
(:weekly "WKP")
|
||||||
|
(:daily "DLP")
|
||||||
|
(_ "???")))
|
||||||
|
|
||||||
|
;; parent -> child linkers
|
||||||
|
;;
|
||||||
|
;; functions to set the current headline as a parent link for a child headline
|
||||||
|
|
||||||
|
(defun org-x-dag--link-parent-to-child (parent-id-fun child-id-fun fmt-fun)
|
||||||
|
(cl-flet*
|
||||||
|
(;; (is-valid-node
|
||||||
|
;; (id)
|
||||||
|
;; (-some-> (org-x-dag-id->ns id)
|
||||||
|
;; (either-is-right-p)))
|
||||||
|
(to-menu-line
|
||||||
|
(this-id id)
|
||||||
|
(let* ((presentp (member this-id (org-x-dag-id->linked-parents id)))
|
||||||
|
(title (funcall fmt-fun id))
|
||||||
|
(line (format "%c %s" (if presentp ?* ?\s) title)))
|
||||||
|
`(,line :id ,id :presentp ,presentp)))
|
||||||
|
(choose-child-id
|
||||||
|
(this-id)
|
||||||
|
(-if-let (collection (->> (funcall child-id-fun it)
|
||||||
|
;; (-filter #'is-valid-node)
|
||||||
|
(--map (to-menu-line this-id it))))
|
||||||
|
(-let* (((&plist :id :presentp)
|
||||||
|
(-> (completing-read "Child: " collection nil t)
|
||||||
|
(alist-get collection nil nil #'equal)))
|
||||||
|
((update-fun fmt)
|
||||||
|
(if presentp
|
||||||
|
(list #'org-x-dag-headline-remove-parent-link
|
||||||
|
"Successfully removed '%s' from '%s'")
|
||||||
|
(list #'org-x-dag-headline-add-parent-link
|
||||||
|
"Successfully added '%s' to '%s'"))))
|
||||||
|
(org-x-with-file (org-x-dag-id->file id)
|
||||||
|
(goto-char (org-x-dag-id->point id))
|
||||||
|
(org-ml-update-this-headline*
|
||||||
|
(funcall update-fun this-id it)))
|
||||||
|
(message fmt (org-x-dag-id->title id) (org-x-dag-id->title this-id)))
|
||||||
|
(message "No children available"))))
|
||||||
|
(if (org-on-heading-p)
|
||||||
|
(either-from (funcall parent-id-fun)
|
||||||
|
(message it)
|
||||||
|
(choose-child-id it))
|
||||||
|
(message "Not on a headline"))))
|
||||||
|
|
||||||
|
(defun org-x-dag-link-parent-to-child ()
|
||||||
|
(interactive)
|
||||||
|
(cl-flet*
|
||||||
|
;; parent id functions
|
||||||
|
;;
|
||||||
|
;; TODO might make sense to check for validity here so I don't link
|
||||||
|
;; poisoned nodes together
|
||||||
|
((id-getter
|
||||||
|
()
|
||||||
|
(-if-let (id (org-id-get))
|
||||||
|
(either :right id)
|
||||||
|
(either :left "Not on a valid node")))
|
||||||
|
(leaf-id-getter
|
||||||
|
()
|
||||||
|
(either>>= (id-getter)
|
||||||
|
(if (org-x-dag-id->is-buffer-leaf-p it)
|
||||||
|
(either :right it)
|
||||||
|
(either :left "Not on a leaf node"))))
|
||||||
|
(action-id-getter
|
||||||
|
()
|
||||||
|
(either>>= (id-getter)
|
||||||
|
(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)
|
||||||
|
(org-x-dag-datetime-split)
|
||||||
|
(nth 1))
|
||||||
|
(either :left "Action has scheduled time"))
|
||||||
|
(t
|
||||||
|
(either :right it)))))
|
||||||
|
|
||||||
|
;; child id functions
|
||||||
|
(action-qtp-getter
|
||||||
|
(_)
|
||||||
|
(let ((action (->> (org-x-dag->action-files)
|
||||||
|
(org-x-dag-files->ids)
|
||||||
|
;; TODO could also remove DONE/CANC and things
|
||||||
|
;; underneath these
|
||||||
|
(--remove (org-x-dag-id->ns-key :survivalp it))))
|
||||||
|
(qtp (-> (plist-get org-x-dag :selected-date)
|
||||||
|
(org-x-dag-date-to-quarter)
|
||||||
|
(org-x-dag-quarter-to-date)
|
||||||
|
(org-x-dag-date->qtp-ids))))
|
||||||
|
(append epg action qtp)))
|
||||||
|
(svg-action-getter
|
||||||
|
(_)
|
||||||
|
(->> (org-x-dag->action-files)
|
||||||
|
(org-x-dag-files->ids)
|
||||||
|
;; TODO could also remove DONE/CANC and things
|
||||||
|
;; underneath these
|
||||||
|
(--remove (and (org-x-dag-id->ns-key :committed it)
|
||||||
|
(not (org-x-dag-id->ns-key :survivalp it))))))
|
||||||
|
(epg-action-qtp-getter
|
||||||
|
(id)
|
||||||
|
`(,@(org-x-dag->epg-ids) ,@(funcall action-qtp-getter id)))
|
||||||
|
(wkp-getter
|
||||||
|
(_)
|
||||||
|
(-> (plist-get org-x-dag :selected-date)
|
||||||
|
(org-x-dag-date-to-week-number)
|
||||||
|
(org-x-dag-week-number-to-date)
|
||||||
|
(org-x-dag-date->wkp-ids)))
|
||||||
|
(dlp-getter
|
||||||
|
(_)
|
||||||
|
(-> (plist-get org-x-dag :selected-date)
|
||||||
|
(org-x-dag-date->dlp-ids)))
|
||||||
|
(add-group
|
||||||
|
(s id)
|
||||||
|
(let ((g (->> (org-x-dag-id->hl-meta-prop id :group)
|
||||||
|
(org-x-dag-group-code))))
|
||||||
|
(format "%s | %s" g s)))
|
||||||
|
|
||||||
|
;; formatters
|
||||||
|
(toplevel-formatter
|
||||||
|
(id)
|
||||||
|
(let ((title (if (eq group :quarterly)
|
||||||
|
(org-x-dag-id->title id)
|
||||||
|
(org-x-dag-id->path (eq group :action) id))))
|
||||||
|
(add-group title id)))
|
||||||
|
(toplevel-formatter
|
||||||
|
(id)
|
||||||
|
(org-x-dag-id->path t id))
|
||||||
|
(plan-formatter
|
||||||
|
(id)
|
||||||
|
(org-x-dag-id->title id)))
|
||||||
|
|
||||||
|
(org-x-dag-sync)
|
||||||
|
(let ((f (buffer-file-name)))
|
||||||
|
(cond
|
||||||
|
((equal f (org-x-dag->goal-file :lifetime))
|
||||||
|
(org-x-dag--link-parent-to-child
|
||||||
|
#'leaf-id-getter
|
||||||
|
#'epg-action-qtp-getter
|
||||||
|
#'toplevel-formatter))
|
||||||
|
((equal f (org-x-dag->goal-file :endpoint))
|
||||||
|
(org-x-dag--link-parent-to-child
|
||||||
|
#'leaf-id-getter
|
||||||
|
#'action-qtp-getter
|
||||||
|
#'toplevel-formatter))
|
||||||
|
((equal f (org-x-dag->goal-file :survival))
|
||||||
|
(org-x-dag--link-parent-to-child
|
||||||
|
#'leaf-id-getter
|
||||||
|
#'svg-action-getter
|
||||||
|
#'svg-formatter))
|
||||||
|
((member f (org-x-dag->action-files))
|
||||||
|
(org-x-dag--link-parent-to-child
|
||||||
|
#'action-id-getter
|
||||||
|
#'dlp-getter
|
||||||
|
#'plan-formatter))
|
||||||
|
((equal f (org-x-dag->planning-file :quarterly))
|
||||||
|
(org-x-dag--link-parent-to-child
|
||||||
|
#'id-getter
|
||||||
|
#'wkp-getter
|
||||||
|
#'plan-formatter))
|
||||||
|
((equal f (org-x-dag->planning-file :weekly))
|
||||||
|
(org-x-dag--link-parent-to-child
|
||||||
|
#'id-getter
|
||||||
|
#'dlp-getter
|
||||||
|
#'plan-formatter))
|
||||||
|
(t
|
||||||
|
(message "Cannot link child from parent in current file"))))))
|
||||||
|
|
||||||
|
;; child -> parent linkers
|
||||||
|
;;
|
||||||
|
;; functions to retrieve a parent headline id and add it to the current
|
||||||
|
;; headline's (or file's) parent links
|
||||||
|
|
||||||
(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 type)
|
(id type)
|
||||||
(-let ((title (->> (org-x-dag-id->path id)
|
(-let ((title (->> (org-x-dag-id->parents id)
|
||||||
(--map (org-x-dag-id->title it))
|
(--map (org-x-dag-id->title it))
|
||||||
(s-join "/")
|
(s-join "/")
|
||||||
(s-prepend "/")))
|
(s-prepend "/")))
|
||||||
|
@ -3616,52 +3804,13 @@ except it ignores inactive timestamps."
|
||||||
#'org-x-dag-headline-add-parent-link
|
#'org-x-dag-headline-add-parent-link
|
||||||
ids it))))))
|
ids it))))))
|
||||||
|
|
||||||
(defun org-x-dag-this-headline-put-link (collection)
|
|
||||||
(-if-let (desc (-some->> (org-ml-parse-this-headline)
|
|
||||||
(org-ml-get-property :raw-value)))
|
|
||||||
(-if-let (path (org-id-get-create))
|
|
||||||
(let ((id (-> (completing-read "Metablock: " collection nil t)
|
|
||||||
(alist-get collection nil nil #'equal))))
|
|
||||||
(org-x-with-file (org-x-dag-id->file id)
|
|
||||||
(goto-char (org-x-dag-id->point id))
|
|
||||||
(org-ml-update-this-headline*
|
|
||||||
(org-x-dag-headline-add-parent-link path it)))
|
|
||||||
(->> (org-x-dag-id->title id)
|
|
||||||
(message "Successfully added '%s' to headline '%s'" desc)))
|
|
||||||
(message "Could not make/get link for current headline"))
|
|
||||||
(message "Not on a headline")))
|
|
||||||
|
|
||||||
(defun org-x-dag-id-store-link-metablock ()
|
|
||||||
"Make and ID for the current headline and store it in the org link ring.
|
|
||||||
ARG and INTERACTIVE are passed to `org-store-link'."
|
|
||||||
(interactive)
|
|
||||||
(cl-flet
|
|
||||||
((is-valid-daily-node
|
|
||||||
(id)
|
|
||||||
(-some-> (org-x-dag-id->ns id)
|
|
||||||
(either-is-right-p)))
|
|
||||||
(to-menu-line
|
|
||||||
(id)
|
|
||||||
(print (org-x-dag-id->planning-datetime :scheduled id))
|
|
||||||
(let* ((time (-some->> (org-x-dag-id->planning-datetime :scheduled id)
|
|
||||||
(org-x-dag-datetime-split)
|
|
||||||
(nth 1)))
|
|
||||||
(stime (if time (apply #'format "%02d:%02d" time) "--:--"))
|
|
||||||
(title (org-x-dag-id->title id)))
|
|
||||||
(cons (format "%s | %s" stime title) id))))
|
|
||||||
(-if-let (collection (->> (plist-get org-x-dag :selected-date)
|
|
||||||
(org-x-dag-date->dlp-ids)
|
|
||||||
(-map #'to-menu-line)))
|
|
||||||
(org-x-dag-this-headline-put-link collection)
|
|
||||||
(message "No metablocks available"))))
|
|
||||||
|
|
||||||
(defun org-x-dag-link-ltg-to-epg ()
|
(defun org-x-dag-link-ltg-to-epg ()
|
||||||
(interactive)
|
(interactive)
|
||||||
(let ((ids (org-x-dag->ltg-ids))
|
(let ((ids (org-x-dag->ltg-ids))
|
||||||
(legal (list (org-x-get-endpoint-goal-file))))
|
(legal (list (org-x-get-endpoint-goal-file))))
|
||||||
(org-x-dag-this-headline-add-link nil legal "endpoint goal file" ids)))
|
(org-x-dag-this-headline-add-link nil legal "endpoint goal file" ids)))
|
||||||
|
|
||||||
(defun org-x-dag-link-goal-to-qtp ()
|
(defun org-x-dag-link-qtp-to-goal ()
|
||||||
(interactive)
|
(interactive)
|
||||||
(let ((ids (->> (list (org-x-dag->goal-file :endpoint)
|
(let ((ids (->> (list (org-x-dag->goal-file :endpoint)
|
||||||
(org-x-dag->goal-file :lifetime))
|
(org-x-dag->goal-file :lifetime))
|
||||||
|
@ -3677,7 +3826,7 @@ ARG and INTERACTIVE are passed to `org-store-link'."
|
||||||
;; TODO this won't work on the toplevel section
|
;; TODO this won't work on the toplevel section
|
||||||
(org-x-dag-this-headline-add-link t legal "an action file" ids)))
|
(org-x-dag-this-headline-add-link t legal "an action file" ids)))
|
||||||
|
|
||||||
(defun org-x-dag-link-action-to-daily-metablock ()
|
(defun org-x-dag-link-dlp-to-action ()
|
||||||
(interactive)
|
(interactive)
|
||||||
;; TODO there are lots of ids here that I likely don't need
|
;; TODO there are lots of ids here that I likely don't need
|
||||||
;; TODO show the path
|
;; TODO show the path
|
||||||
|
@ -3687,6 +3836,20 @@ ARG and INTERACTIVE are passed to `org-store-link'."
|
||||||
(legal (list (org-x-dag->planning-file :daily))))
|
(legal (list (org-x-dag->planning-file :daily))))
|
||||||
(org-x-dag-this-headline-add-link t legal "the daily metablock file" ids)))
|
(org-x-dag-this-headline-add-link t legal "the daily metablock file" ids)))
|
||||||
|
|
||||||
|
(defun org-x-dag-link-child-to-parent ()
|
||||||
|
(interactive)
|
||||||
|
(let ((f (buffer-file-name)))
|
||||||
|
(cond
|
||||||
|
((equal f (org-x-dag->goal-file :endpoint)))
|
||||||
|
((member f (org-x-dag->action-files)))
|
||||||
|
((equal f (org-x-dag->planning-file :quarterly)))
|
||||||
|
((equal f (org-x-dag->planning-file :weekly)))
|
||||||
|
((equal f (org-x-dag->planning-file :daily)))
|
||||||
|
(t
|
||||||
|
(message "Cannot link parent from child in current file")))))
|
||||||
|
|
||||||
|
;; add nodes
|
||||||
|
|
||||||
(defun org-x-dag-read-string-until (prompt pred msg)
|
(defun org-x-dag-read-string-until (prompt pred msg)
|
||||||
(declare (indent 1))
|
(declare (indent 1))
|
||||||
(let (ret)
|
(let (ret)
|
||||||
|
|
Loading…
Reference in New Issue