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

ENH use IDs entirely for the DAG

This commit is contained in:
Nathan Dwarshuis 2022-01-22 18:05:07 -05:00
parent 94c00b7af5
commit ba6aab1702
1 changed files with 322 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -32,7 +32,14 @@
;; variables to store state ;; variables to store state
(defvar org-x-dag nil (defun org-x-dag-create (d m f)
(list :dag d :id->meta m :file->ids f))
(defun org-x-dag-empty ()
(org-x-dag-create (dag-empty) (ht-create #'equal) (ht-create #'equal)))
(defvar org-x-dag (org-x-dag-empty)
"The org-x DAG. "The org-x DAG.
Each node in this DAG represents a headline with the following Each node in this DAG represents a headline with the following
@ -55,24 +62,35 @@ that file as it currently sits on disk.")
;; functions to construct nodes within state ;; functions to construct nodes within state
(defun org-x-dag-build-key (file point level todo tags toplevelp id) ;; (defun org-x-dag-build-key (file point level todo tags toplevelp id)
(defun org-x-dag-build-key (file point level todo tags toplevelp)
(list :file file (list :file file
:point point :point point
:level level :level level
:todo todo :todo todo
:tags tags :tags tags
:toplevelp toplevelp :toplevelp toplevelp))
:id id)) ;; :id id))
;; (if id (list :id file point id) (list :pm file point))) ;; (if id (list :id file point id) (list :pm file point)))
(defun org-x-dag-build-meta (file point level todo tags toplevelp)
(list :file file
:point point
:level level
:todo todo
:tags tags
:toplevelp toplevelp))
(defun org-x-dag-key-get-file (key) (defun org-x-dag-key-get-file (key)
"Return file for KEY." "Return file for KEY."
(plist-get key :file)) (org-x-dag-id-lookup-prop key :file))
;; (plist-get key :file))
;; (nth 1 key)) ;; (nth 1 key))
(defun org-x-dag-key-get-point (key) (defun org-x-dag-key-get-point (key)
"Return point for KEY." "Return point for KEY."
(plist-get key :point)) (org-x-dag-id-lookup-prop key :point))
;; (plist-get key :point))
;; (nth 2 key)) ;; (nth 2 key))
;;; DAG SYNCHRONIZATION/CONSTRUCTION ;;; DAG SYNCHRONIZATION/CONSTRUCTION
@ -88,12 +106,13 @@ that file as it currently sits on disk.")
(defun org-x-dag-get-md5 (path) (defun org-x-dag-get-md5 (path)
"Get the md5 checksum of PATH." "Get the md5 checksum of PATH."
(with-temp-buffer (org-x-with-file path (buffer-hash)))
(let ((rc (call-process "md5sum" nil (current-buffer) nil path))) ;; (with-temp-buffer
(if (/= 0 rc) (error "Could not get md5 of %s" path) ;; (let ((rc (call-process "md5sum" nil (current-buffer) nil path)))
(->> (buffer-string) ;; (if (/= 0 rc) (error "Could not get md5 of %s" path)
(s-match "^\\([0-9a-z]+\\)") ;; (->> (buffer-string)
(cadr)))))) ;; (s-match "^\\([0-9a-z]+\\)")
;; (cadr))))))
(defun org-x-dag-md5-matches-p (path md5) (defun org-x-dag-md5-matches-p (path md5)
"Return t if the md5 of PATH on disk `equal's MD5." "Return t if the md5 of PATH on disk `equal's MD5."
@ -101,8 +120,10 @@ that file as it currently sits on disk.")
(defun org-x-dag-file-is-dirty (file md5) (defun org-x-dag-file-is-dirty (file md5)
"Return t if FILE with MD5 has been recently changed." "Return t if FILE with MD5 has been recently changed."
(or (org-x-with-file file (buffer-modified-p)) (org-x-with-file file
(not (org-x-dag-md5-matches-p file md5)))) (let ((new-md5 (buffer-hash)))
(unless (equal new-md5 md5)
new-md5))))
(defun org-x-dag-set-sync-state () (defun org-x-dag-set-sync-state ()
"Set the sync state to reflect the current files on disk." "Set the sync state to reflect the current files on disk."
@ -123,12 +144,47 @@ removed from, added to, or edited within the DAG respectively."
(-let* ((existing-files (org-x-dag-get-files)) (-let* ((existing-files (org-x-dag-get-files))
(state-files (-map #'car org-x-dag-sync-state)) (state-files (-map #'car org-x-dag-sync-state))
(to-remove (-difference state-files existing-files)) (to-remove (-difference state-files existing-files))
(to-insert (-difference existing-files state-files)) ((&alist 'to-insert 'to-update 'no-change)
(to-update (->> (--map (cons it (org-x-dag-get-md5 it)) existing-files)
(->> (-intersection existing-files state-files) (--group-by (-let* (((path . new-md5) it)
(--filter (org-x-dag-file-is-dirty it (lookup-md5 it)))))) (old-md5 (lookup-md5 path)))
;; (print (list to-remove to-insert to-update)) (cond
(list to-remove to-insert to-update)))) ((null old-md5) 'to-insert)
((equal old-md5 new-md5) 'no-change)
(t 'to-update)))))))
(list to-remove to-insert to-update no-change))))
(defun org-x-dag-get-local-property (prop)
(car (org--property-local-values prop nil)))
(defun org-x-dag-get-link-property ()
(-some->> (org-x-dag-get-local-property org-x-prop-goal)
(s-split ";")
(--map (->> (s-trim it)
(s-match "^\\[\\[id:\\(.*\\)\\]\\[.*\\]\\]$")
(cadr)))))
;; (defun org-x-dag-link-buffer-nodes (id-cache raw)
;; (let (this this-key these-links these-parents this-link link-target broken acc)
;; (while raw
;; (setq this (car raw)
;; this-key (plist-get this :key)
;; these-links (plist-get this :links)
;; these-parents (plist-get this :parents))
;; (while these-links
;; (setq this-link (car these-links))
;; (if (setq link-target (ht-get id-cache this-link))
;; (!cons link-target these-parents)
;; (!cons (list :key this-key :link this-link) broken))
;; (!cdr these-links))
;; (!cons (cons this-key these-parents) acc)
;; (!cdr raw))
;; ;; TODO this warning message won't be all the helpful seeing as the keys
;; ;; are actually semi-obscure plists with extra information and such
;; (--each broken
;; (-let (((&plist :key :link) it))
;; (message "WARNING: broken link for key %S: %s" key link)))
;; acc))
;; TODO this assumes the `org-id-locations' is synced ;; TODO this assumes the `org-id-locations' is synced
(defun org-x-dag-get-buffer-nodes (file kws) (defun org-x-dag-get-buffer-nodes (file kws)
@ -138,10 +194,14 @@ A node will only be returned if the headline to which it points
has a valid (meaning in KWS) keyword and either its parent has a has a valid (meaning in KWS) keyword and either its parent has a
valid keyword or none of its parents have valid keywords." valid keyword or none of its parents have valid keywords."
(let ((more t) (let ((more t)
;; (id-cache (ht-create #'equal))
cur-path this-point this-key this-level this-todo has-todo this-parent cur-path this-point this-key this-level this-todo has-todo this-parent
tags toplevelp acc) tags toplevelp this-file-links acc acc-meta)
;; TODO add org-mode sanity check ;; TODO add org-mode sanity check
(goto-char (point-min)) (goto-char (point-min))
;; If not on a headline, check for a property drawer with links in it
(unless (= ?* (following-char))
(setq this-file-links (org-x-dag-get-link-property)))
;; move forward until on a headline ;; move forward until on a headline
(while (and (not (= ?* (following-char))) (= 0 (forward-line 1)))) (while (and (not (= ?* (following-char))) (= 0 (forward-line 1))))
;; Build alist; Keep track of how 'deep' we are in a given org-tree using a ;; Build alist; Keep track of how 'deep' we are in a given org-tree using a
@ -173,7 +233,8 @@ valid keyword or none of its parents have valid keywords."
toplevelp (not (nth 1 this-parent))) toplevelp (not (nth 1 this-parent)))
;; Add the current headline to accumulator if it has a keyword, but only ;; Add the current headline to accumulator if it has a keyword, but only
;; if its parent has a keyword or none of its parents have keywords ;; if its parent has a keyword or none of its parents have keywords
(when (and has-todo (or (not toplevelp) (--none-p (nth 1 it) cur-path))) (when (and has-todo (or (not toplevelp) (--none-p (nth 1 it) cur-path))
(setq this-key (org-x-dag-get-local-property "ID")))
;; If parent is not a todo and we want tag inheritance, store all tags ;; If parent is not a todo and we want tag inheritance, store all tags
;; above this headline (sans file-tags which we can get later easily) ;; above this headline (sans file-tags which we can get later easily)
(setq tags (if (and toplevelp org-use-tag-inheritance) (setq tags (if (and toplevelp org-use-tag-inheritance)
@ -181,24 +242,19 @@ valid keyword or none of its parents have valid keywords."
(--mapcat (nth 2 it)) (--mapcat (nth 2 it))
(append this-tags)) (append this-tags))
this-tags) this-tags)
this-key (org-x-dag-build-key file this-meta (org-x-dag-build-meta file
this-point this-point
this-level this-level
(substring-no-properties this-todo) (substring-no-properties this-todo)
tags tags
toplevelp toplevelp))
(car (org--property-local-values "ID" nil)))) (!cons (cons this-key this-meta) acc-meta)
;; (org-entry-get nil "ID")))
;; TODO also get a list of link parent targets and add them to the
;; parent list
(!cons (cons this-key (-some-> (nth 1 this-parent) (list))) acc)) (!cons (cons this-key (-some-> (nth 1 this-parent) (list))) acc))
;; Add current headline to stack ;; Add current headline to stack
;; (when (and (s-contains-p "general" file) (not (nth 1 this-parent)))
;; (print (--map (nth 2 it) cur-path)))
;; (print (list cur-path this-tags)))
(!cons (list this-level this-key this-tags) cur-path)) (!cons (list this-level this-key this-tags) cur-path))
(setq more (= 0 (forward-line 1)))) (setq more (= 0 (forward-line 1))))
(nreverse acc))) ;; TODO reverse these to make things make sense later?
(list acc acc-meta)))
(defun org-x-dag-get-file-nodes (file) (defun org-x-dag-get-file-nodes (file)
"Return all nodes in FILE in one pass." "Return all nodes in FILE in one pass."
@ -240,11 +296,36 @@ valid keyword or none of its parents have valid keywords."
(-map #'car))) (-map #'car)))
(y (dag-get-floating-nodes-where org-x-dag (y (dag-get-floating-nodes-where org-x-dag
(org-x-dag-files-contains-key-p it files)))) (org-x-dag-files-contains-key-p it files))))
;; (print (list x y))
;; (print x)
;; (print (list (length x) (length y) (length (-intersection x y))))
(append x y))) (append x y)))
(defun org-x-dag-get-data-to-insert (files)
;; TODO could also make another data structure to link each id to a file
;; since this is a very common lookup operation
(cl-flet
((append-results
(acc file)
(-let* (((acc-ids acc-meta acc-filemaps) acc)
((ids metas) (org-x-dag-get-file-nodes file))
(filemap (cons file (-map #'car ids))))
(list (append ids acc-ids)
(append metas acc-meta)
(cons filemap acc-filemaps)))))
(-reduce-from #'append-results nil files)))
(defun org-x-dag-update-ht (to-remove to-insert ht)
(--each to-remove
(ht-remove ht it))
(--each to-insert
(ht-set ht (car it) (cdr it)))
ht)
(defun org-x-dag-get-ids-in-files (files)
(let ((filemap (plist-get org-x-dag :file->ids)))
(--mapcat (ht-get filemap it) files)))
(defun org-x-dag->adjacency-list ()
(-> (plist-get org-x-dag :dag) (dag-get-adjacency-list)))
;; TODO there is a HUGE DIFFERENCE between a 'key' (the things in the hash table ;; TODO there is a HUGE DIFFERENCE between a 'key' (the things in the hash table
;; the look things up) and a 'node' (which is a cons cell, the car of which is a ;; the look things up) and a 'node' (which is a cons cell, the car of which is a
;; 'key' and the cdr of which is a 'relation'). These names suck, but the point ;; 'key' and the cdr of which is a 'relation'). These names suck, but the point
@ -254,17 +335,21 @@ valid keyword or none of its parents have valid keywords."
TO-REMOVE, TO-INSERT, and TO-UPDATE are lists of files to remove TO-REMOVE, TO-INSERT, and TO-UPDATE are lists of files to remove
from, add to, and update with the DAG." from, add to, and update with the DAG."
(let* ((files-to-insert (append to-update to-insert)) (-let* (((&plist :dag :id->meta :file->ids) org-x-dag)
(nodes-to-insert (-mapcat #'org-x-dag-get-file-nodes files-to-insert))) (files2rem (append to-update to-remove))
(if org-x-dag (files2ins (append to-update to-insert))
(let* ((files-to-remove (append to-update to-remove)) (ids2rem (org-x-dag-get-ids-in-files files2rem))
(keys-to-remove (->> (org-x-dag-get-nodes-in-files ((ids2ins meta2ins fms2ins) (org-x-dag-get-data-to-insert files2ins)))
org-x-dag files-to-remove)))) (org-x-dag-update-ht ids2rem meta2ins id->meta)
(when (or keys-to-remove nodes-to-insert) (org-x-dag-update-ht files2rem fms2ins file->ids)
(setq org-x-dag (dag-edit-nodes keys-to-remove (->> (if (dag-is-empty-p dag) (dag-alist-to-dag ids2ins)
nodes-to-insert (dag-edit-nodes ids2rem ids2ins dag))
org-x-dag)))) (plist-put org-x-dag :dag))))
(setq org-x-dag (dag-alist-to-dag nodes-to-insert)))))
(defun org-x-dag-id-lookup-prop (id prop)
(-> (plist-get org-x-dag :id->meta)
(ht-get id)
(plist-get prop)))
(defun org-x-dag-sync (&optional force) (defun org-x-dag-sync (&optional force)
"Sync the DAG with files from `org-x-dag-get-files'. "Sync the DAG with files from `org-x-dag-get-files'.
@ -272,10 +357,11 @@ from, add to, and update with the DAG."
If FORCE is non-nil, sync no matter what." If FORCE is non-nil, sync no matter what."
(when force (when force
(setq org-x-dag-sync-state nil (setq org-x-dag-sync-state nil
org-x-dag nil)) org-x-dag (org-x-dag-empty)))
(-let (((to-remove to-insert to-update) (org-x-dag-get-sync-state))) ;; TODO verify integrity somewhere in here
(org-x-dag-update to-remove to-insert to-update) (-let (((to-remove to-insert to-update no-change) (org-x-dag-get-sync-state)))
(org-x-dag-set-sync-state) (org-x-dag-update to-remove (-map #'car to-insert) (-map #'car to-update))
(setq org-x-dag-sync-state (append to-insert to-update no-change))
nil)) nil))
;;; DAG -> HEADLINE RETRIEVAL ;;; DAG -> HEADLINE RETRIEVAL
@ -297,6 +383,24 @@ If FORCE is non-nil, sync no matter what."
;; (defun org-x-dag-key-has-child-headlines-p (key dag) ;; (defun org-x-dag-key-has-child-headlines-p (key dag)
;; (org-x-dag-relation-has-child-headlines-p key (dag-get-relationships key dag))) ;; (org-x-dag-relation-has-child-headlines-p key (dag-get-relationships key dag)))
(defun org-x-dag-partition-task-nodes (files)
(->> (org-x-dag-get-ids-in-files files)
(--separate (org-x-dag-id-lookup-prop it :toplevelp))))
;; (-let (((from-adjlist-proj from-adjlist-task)
;; (->> (dag-get-nodes-and-edges-where dag
;; (and (org-x-dag-files-contains-key-p it files)
;; (plist-get it :toplevelp)))
;; (--separate (org-x-dag-relation-has-child-headlines-p (car it) (cdr it))))))
;; (list (-map #'car from-adjlist-task) (-map #'car from-adjlist-proj))))
(defun org-x-dag-partition-all-task-nodes (files dag)
(-let (((from-adjlist-proj from-adjlist-task)
(org-x-dag-partition-task-nodes files dag))
(from-floating
(dag-get-floating-nodes-where dag
(org-x-dag-files-contains-key-p it files))))
(list (append from-adjlist-task from-floating) from-adjlist-proj)))
(defun org-x-dag-get-standalone-task-nodes (dag) (defun org-x-dag-get-standalone-task-nodes (dag)
"Return the standalone task nodes of DAG." "Return the standalone task nodes of DAG."
(let* ((action-files (org-x-get-action-files)) (let* ((action-files (org-x-get-action-files))
@ -310,19 +414,20 @@ If FORCE is non-nil, sync no matter what."
(org-x-dag-files-contains-key-p it action-files)))) (org-x-dag-files-contains-key-p it action-files))))
(append (-map #'car from-adjlist) from-floating))) (append (-map #'car from-adjlist) from-floating)))
(defun org-x-dag-get-toplevel-project-nodes (dag) (defun org-x-dag-get-toplevel-project-nodes ()
"Return the toplevel project nodes of DAG." "Return the toplevel project nodes of DAG."
(let ((action-files (org-x-get-action-files))) (let ((action-files (org-x-get-action-files)))
(dag-get-nodes-and-edges-where dag (dag-get-nodes-and-edges-where (plist-get org-x-dag :dag)
(and (org-x-dag-files-contains-key-p it action-files) (and (org-x-dag-files-contains-key-p it action-files)
(plist-get it :toplevelp) (org-x-dag-id-lookup-prop it :toplevelp)
;; (plist-get it :toplevelp)
(org-x-dag-relation-has-child-headlines-p it it-rel))))) (org-x-dag-relation-has-child-headlines-p it it-rel)))))
;;; DAG -> HEADLINE RETRIEVAL (CHILD/PARENT) ;;; DAG -> HEADLINE RETRIEVAL (CHILD/PARENT)
(defun org-x-dag-filter-children (dag key fun) (defun org-x-dag-filter-children (dag key fun)
(declare (indent 2)) (declare (indent 2))
(-filter fun (dag-get-children key dag))) (-filter fun (dag-get-children key (plist-get org-x-dag :dag))))
(defun org-x-dag-separate-children (dag key fun) (defun org-x-dag-separate-children (dag key fun)
(declare (indent 2)) (declare (indent 2))
@ -339,14 +444,14 @@ If FORCE is non-nil, sync no matter what."
;; NOTE if this is a standalone task it will return itself ;; NOTE if this is a standalone task it will return itself
(-if-let (cs (org-x-dag-node-get-headline-children dag key)) (-if-let (cs (org-x-dag-node-get-headline-children dag key))
;; TODO don't hardcode this ;; TODO don't hardcode this
(->> (--remove (member (plist-get it :todo) (list org-x-kw-canc org-x-kw-hold)) cs) (->> (--remove (member (org-x-dag-id-lookup-prop it :todo) (list org-x-kw-canc org-x-kw-hold)) cs)
(--mapcat (org-x-dag-project-node-get-task-nodes dag it))) (--mapcat (org-x-dag-project-node-get-task-nodes dag it)))
(list key))) (list key)))
(defun org-x-dag-get-project-task-nodes (fun dag) (defun org-x-dag-get-project-task-nodes (fun dag)
"Return project task nodes of DAG." "Return project task nodes of DAG."
(-let (((&plist :adjlist) dag)) (-let (((&plist :adjlist) dag))
(->> (org-x-dag-get-toplevel-project-nodes dag) (->> (org-x-dag-get-toplevel-project-nodes)
(-map #'car) (-map #'car)
(-remove fun) (-remove fun)
(--mapcat (org-x-dag-project-node-get-task-nodes dag it))))) (--mapcat (org-x-dag-project-node-get-task-nodes dag it)))))
@ -444,7 +549,7 @@ encountered will be returned."
;; ASSUME I don't use subtree-level categories ;; ASSUME I don't use subtree-level categories
(-let* (;; (category (org-get-category)) (-let* (;; (category (org-get-category))
(head (org-get-heading)) (head (org-get-heading))
(level (-> (plist-get key :level) (level (-> (org-x-dag-id-lookup-prop key :level)
(make-string ?s))) (make-string ?s)))
;; no idea what this does... ;; no idea what this does...
(help-echo (format "mouse-2 or RET jump to Org file %S" (help-echo (format "mouse-2 or RET jump to Org file %S"
@ -466,7 +571,7 @@ encountered will be returned."
'org-hd-marker marker 'org-hd-marker marker
'org-marker marker 'org-marker marker
;; headline stuff ;; headline stuff
'todo-state (plist-get key :todo) 'todo-state (org-x-dag-id-lookup-prop key :todo)
'priority priority 'priority priority
'ts-date ts 'ts-date ts
;; misc ;; misc
@ -539,42 +644,46 @@ encountered will be returned."
((org-x-headline-is-closed nil) :undone-closed) ((org-x-headline-is-closed nil) :undone-closed)
(t :active)))) (t :active))))
(defmacro org-x--descend-into-project (dag key children statuscode-tree get-task-status callback-form) ;; (defmacro org-x--descend-into-project (dag key children statuscode-tree get-task-status callback-form)
;; define "breaker-status" as the last of the allowed-statuscodes ;; ;; define "breaker-status" as the last of the allowed-statuscodes
;; when this is encountered the loop is broken because we are done ;; ;; when this is encountered the loop is broken because we are done
;; (the last entry trumps all others) ;; ;; (the last entry trumps all others)
(declare (indent 3)) ;; (declare (indent 3))
(let* ((allowed-statuscodes (-map #'car statuscode-tree)) ;; (let* ((allowed-statuscodes (-map #'car statuscode-tree))
(trans-tbl (->> statuscode-tree ;; (trans-tbl (->> statuscode-tree
(--map (-let (((a . bs) it)) (--map (cons it a) bs))) ;; (--map (-let (((a . bs) it)) (--map (cons it a) bs)))
(-flatten-n 1))) ;; (-flatten-n 1)))
(breaker-status (-last-item allowed-statuscodes)) ;; (breaker-status (-last-item allowed-statuscodes))
(initial-status (car allowed-statuscodes))) ;; (initial-status (car allowed-statuscodes)))
`(save-excursion ;; `(save-excursion
(let ((project-status ,initial-status) ;; (let ((project-status ,initial-status)
(this-child nil) ;; (this-child nil)
(it-kw nil) ;; (it-kw nil)
(new-status nil)) ;; (new-status nil))
;; loop through tasks one level down until breaker-status found ;; ;; loop through tasks one level down until breaker-status found
(while (and children (not (eq project-status ,breaker-status))) ;; (while (and children (not (eq project-status ,breaker-status)))
(setq this-child (car children) ;; (setq this-child (car children)
it-kw (plist-get this-child :todo)) ;; it-kw (plist-get this-child :todo))
;; If project returns an allowed status then use that. Otherwise look ;; ;; If project returns an allowed status then use that. Otherwise look
;; up the value in the translation table and return error if not ;; ;; up the value in the translation table and return error if not
;; found. ;; ;; found.
(-if-let (cs (org-x-dag-node-get-headline-children dag this-child)) ;; (-if-let (cs (org-x-dag-node-get-headline-children dag this-child))
(unless (member (setq new-status ;; (unless (member (setq new-status
(funcall ,callback-form ;; (funcall ,callback-form
,dag this-child cs)) ;; ,dag this-child cs))
',allowed-statuscodes) ;; ',allowed-statuscodes)
(setq new-status (alist-get new-status ',trans-tbl))) ;; (setq new-status (alist-get new-status ',trans-tbl)))
(goto-char (org-x-dag-key-get-point this-child)) ;; (goto-char (org-x-dag-key-get-point this-child))
(setq new-status (nth ,get-task-status ',allowed-statuscodes))) ;; (setq new-status (nth ,get-task-status ',allowed-statuscodes)))
(when (org-x--compare-statuscodes ',allowed-statuscodes ;; (when (org-x--compare-statuscodes ',allowed-statuscodes
new-status > project-status) ;; new-status > project-status)
(setq project-status new-status)) ;; (setq project-status new-status))
(!cdr children)) ;; (!cdr children))
project-status)))) ;; project-status))))
(defun org-x-dag-get-max-index (ys xs)
"Return the member of XS that has the highest index in YS."
(--max-by (> (-elem-index it ys) (-elem-index other ys)) xs))
(defmacro org-x-dag-descend-into-project (dag keys parent-tags codetree (defmacro org-x-dag-descend-into-project (dag keys parent-tags codetree
task-form callback) task-form callback)
@ -587,7 +696,7 @@ encountered will be returned."
((get-project-or-task-status ((get-project-or-task-status
(key) (key)
(-if-let (children (org-x-dag-node-get-headline-children ,dag key)) (-if-let (children (org-x-dag-node-get-headline-children ,dag key))
(let* ((tags (-> (plist-get key :tags) (let* ((tags (-> (org-x-dag-id-lookup-prop key :tags)
(append ,parent-tags) (append ,parent-tags)
(org-x-dag-collapse-tags))) (org-x-dag-collapse-tags)))
(child-results (funcall ,callback ,dag key tags children)) (child-results (funcall ,callback ,dag key tags children))
@ -598,21 +707,20 @@ encountered will be returned."
top-status top-status
(alist-get top-status ',trans-tbl)))) (alist-get top-status ',trans-tbl))))
(cons top-status* child-results)) (cons top-status* child-results))
(let ((it-kw (plist-get key :todo))) (let ((it-kw (org-x-dag-id-lookup-prop key :todo)))
(goto-char (org-x-dag-key-get-point key)) (org-x-dag-with-key key
(-> ,task-form (-> ,task-form
(nth ',allowed-codes) (nth ',allowed-codes)
(list)))))) (list)))))))
(let* ((results (-map #'get-project-or-task-status ,keys)) (let* ((results (-map #'get-project-or-task-status ,keys))
(status (->> (-map #'car results) (status (->> (-map #'car results)
(--max-by (> (-elem-index it ',allowed-codes) (org-x-dag-get-max-index ',allowed-codes))))
(-elem-index other ',allowed-codes))))))
(cons status (-mapcat #'cdr results)))))) (cons status (-mapcat #'cdr results))))))
(defun org-x-dag-headline-get-project-status (dag key tags children) (defun org-x-dag-headline-get-project-status (dag key tags children)
;; ASSUME children will always be at least 1 long ;; ASSUME children will always be at least 1 long
(goto-char (org-x-dag-key-get-point key)) (goto-char (org-x-dag-key-get-point key))
(let ((keyword (plist-get key :todo))) (let ((keyword (org-x-dag-id-lookup-prop key :todo)))
(-let (((status . child-results) (-let (((status . child-results)
(cond (cond
((org-x-headline-is-scheduled nil) ((org-x-headline-is-scheduled nil)
@ -659,6 +767,62 @@ encountered will be returned."
(t (error "Invalid keyword detected: %s" keyword))))) (t (error "Invalid keyword detected: %s" keyword)))))
(cons (list :key key :status status :tags tags) child-results)))) (cons (list :key key :status status :tags tags) child-results))))
(defun org-x-dag-headline-get-iterator-project-status (dag key children)
(org-x-dag-with-key key
(let* ((kw (org-x-dag-id-lookup-prop key :todo))
(status
(cond
((or (member kw org-x--project-invalid-todostates)
(org-x-headline-is-scheduled nil))
(list :project-error))
((equal kw org-x-kw-canc)
(list :empt))
;; TODO this is a bit awkward since I don't care about the child statuses
;; and I don't care about tags
((equal kw org-x-kw-done)
(org-x-dag-descend-into-project dag children nil
((:empt)
(:project-error :unscheduled :actv))
(if (member it-kw org-x-done-keywords) 0 1)
#'org-x-dag-headline-get-iterator-project-status))
((equal kw org-x-kw-todo)
(org-x-dag-descend-into-project dag children nil
((:unscheduled :project-error)
(:empt)
(:actv))
(let ((ts (org-x-headline-is-scheduled t)))
(cond
((not ts) 0)
((> org-x-iterator-active-future-offset (- ts (float-time))) 1)
(t 2)))
#'org-x-dag-headline-get-iterator-project-status))
(t (error "Invalid keyword detected: %s" kw)))))
status)))
(defun org-x-dag-headline-get-iterator-task-status (key)
(org-x-dag-with-key key
(let ((kw (org-x-dag-id-lookup-prop key :todo)))
(if (member kw org-x-done-keywords) :empt
(-if-let (ts (or (org-x-headline-is-scheduled t)
(org-x-headline-is-deadlined t)))
(if (< org-x-iterator-active-future-offset (- ts (float-time)))
:actv
:empt)
:unscheduled)))))
(defun org-x-dag-headline-get-iterator-status (dag key)
(cl-flet
((get-status
(key)
(-if-let (children (org-x-dag-node-get-headline-children dag key))
(->> children
(org-x-dag-headline-get-iterator-project-status dag key)
(car))
(org-x-dag-headline-get-iterator-task-status key))))
(->> (org-x-dag-node-get-headline-children dag key)
(-map #'get-status)
(org-x-dag-get-max-index org-x--iter-statuscodes))))
(defmacro org-x-dag-with-keys-in-files (keys form) (defmacro org-x-dag-with-keys-in-files (keys form)
(declare (indent 1)) (declare (indent 1))
`(->> (-group-by #'org-x-dag-key-get-file ,keys) `(->> (-group-by #'org-x-dag-key-get-file ,keys)
@ -682,15 +846,15 @@ encountered will be returned."
(org-x-dag-with-key key (org-x-dag-with-key key
(-> (org-x-dag-format-tag-node cat tags key) (-> (org-x-dag-format-tag-node cat tags key)
(org-add-props nil (org-add-props nil
'x-toplevelp (plist-get key :toplevelp) 'x-toplevelp (org-x-dag-id-lookup-prop key :toplevelp)
'x-status status 'x-status status
'x-priority priority))))))) 'x-priority priority)))))))
(let ((keys (->> (org-x-dag-get-toplevel-project-nodes org-x-dag) (let ((keys (->> (org-x-dag-get-toplevel-project-nodes)
(-map #'car)))) (-map #'car))))
(org-x-dag-with-keys-in-files keys (org-x-dag-with-keys-in-files keys
(org-x-dag-with-key it (org-x-dag-with-key it
(let ((cat (org-get-category)) (let ((cat (org-get-category))
(tags (-> (plist-get it :tags) (tags (-> (org-x-dag-id-lookup-prop it :tags)
(append org-file-tags) (append org-file-tags)
(org-x-dag-collapse-tags)))) (org-x-dag-collapse-tags))))
;; TODO don't hardcode these things ;; TODO don't hardcode these things
@ -704,10 +868,37 @@ encountered will be returned."
(org-x-dag-headline-get-project-status org-x-dag it tags) (org-x-dag-headline-get-project-status org-x-dag it tags)
(--map (format-result cat it)))))))))) (--map (format-result cat it))))))))))
(defun org-x-dag-scan-iterators ()
(cl-flet*
((format-result
(tags cat key)
(-let* ((status (org-x-dag-headline-get-iterator-status (plist-get org-x-dag :dag) key)))
(org-x-dag-with-key key
(-> (org-x-dag-format-tag-node cat tags key)
(org-add-props nil
'x-status status))))))
(let ((keys (->> (org-x-dag-get-toplevel-project-nodes)
(-map #'car))))
(org-x-dag-with-keys-in-files keys
(org-x-dag-with-key it
(let ((cat (org-get-category))
(tags (-> (org-x-dag-id-lookup-prop it :tags)
(append org-file-tags)
(org-x-dag-collapse-tags))))
;; TODO don't hardcode these things
(when (and (not (member org-x-tag-incubated tags))
(save-excursion
(-> org-x-prop-parent-type
(org--property-local-values nil)
(car)
(equal org-x-prop-parent-type-iterator))))
(list (format-result tags cat it)))))))))
;; TODO making this an imperative-style loop doesn't speed it up 'that-much' ;; TODO making this an imperative-style loop doesn't speed it up 'that-much'
(defun org-x-dag-scan-tasks () (defun org-x-dag-scan-tasks ()
(let* ((dag org-x-dag) (let* ((dag org-x-dag)
(sats (->> (org-x-dag-get-standalone-task-nodes dag) (sats (->> (org-x-dag-get-standalone-task-nodes (plist-get org-x-dag :dag))
(--map (cons it :is-standalone)))) (--map (cons it :is-standalone))))
(pts (->> (org-x-dag-get-project-task-nodes #'org-x-dag-key-is-iterator dag) (pts (->> (org-x-dag-get-project-task-nodes #'org-x-dag-key-is-iterator dag)
(--map (list it)))) (--map (list it))))
@ -725,26 +916,27 @@ encountered will be returned."
;; (let ((category (org-get-category))) ;; (let ((category (org-get-category)))
(--each key-cells (--each key-cells
(-setq (key . is-standalone) it) (-setq (key . is-standalone) it)
(setq tags (->> (org-x-dag-get-inherited-tags org-file-tags dag key) (setq tags (->> (org-x-dag-get-inherited-tags org-file-tags (plist-get org-x-dag :dag) key)
(append (plist-get key :tags)) (append (org-x-dag-id-lookup-prop key :tags))
(org-x-dag-collapse-tags))) (org-x-dag-collapse-tags)))
;; (-let* (((key . is-standalone) it) ;; (-let* (((key . is-standalone) it)
;; (tags (->> (org-x-dag-get-inherited-tags org-file-tags dag key) ;; (tags (->> (org-x-dag-get-inherited-tags org-file-tags dag key)
;; (append (plist-get key :tags)) ;; (append (plist-get key :tags))
;; (org-x-dag-collapse-tags)))) ;; (org-x-dag-collapse-tags))))
;; filter out incubators ;; filter out incubators
(goto-char (plist-get key :point)) (org-x-dag-with-key key
;; (goto-char (plist-get key :point))
(unless (or (member org-x-tag-incubated tags) (unless (or (member org-x-tag-incubated tags)
(org-x-headline-is-scheduled nil) (org-x-headline-is-scheduled nil)
(org-x-headline-is-deadlined nil)) (org-x-headline-is-deadlined nil))
(let* ((s (org-x-headline-get-task-status-0 (plist-get key :todo))) (let* ((s (org-x-headline-get-task-status-0 (org-x-dag-id-lookup-prop key :todo)))
(p (alist-get s org-x-headline-task-status-priorities))) (p (alist-get s org-x-headline-task-status-priorities)))
(unless (= p -1) (unless (= p -1)
(setq acc (-> (org-x-dag-format-tag-node category tags key) (setq acc (-> (org-x-dag-format-tag-node category tags key)
(org-add-props nil (org-add-props nil
'x-is-standalone is-standalone 'x-is-standalone is-standalone
'x-status s) 'x-status s)
(cons acc))))))))) (cons acc))))))))))
acc)) acc))
;; (defun org-x-dag-scan-tags () ;; (defun org-x-dag-scan-tags ()
@ -768,7 +960,7 @@ encountered will be returned."
(-if-let (parent (->> (dag-get-parents k dag) (-if-let (parent (->> (dag-get-parents k dag)
(--first (equal (org-x-dag-key-get-file it) (--first (equal (org-x-dag-key-get-file it)
this-file)))) this-file))))
(->> (plist-get parent :tags) (->> (org-x-dag-id-lookup-prop parent :tags)
(append tags) (append tags)
(ascend parent)) (ascend parent))
tags))) tags)))