From 919911493971e4afcc1ae8a533ffd7ade334eb90 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 23 Jan 2022 20:05:08 -0500 Subject: [PATCH] REF dry off org dag code --- local/lib/org-x/org-x-dag.el | 896 +++++++++++------------------------ 1 file changed, 286 insertions(+), 610 deletions(-) diff --git a/local/lib/org-x/org-x-dag.el b/local/lib/org-x/org-x-dag.el index 732a402..fdbe124 100644 --- a/local/lib/org-x/org-x-dag.el +++ b/local/lib/org-x/org-x-dag.el @@ -62,97 +62,108 @@ that file as it currently sits on disk.") ;; 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) +(defun org-x-dag-build-meta (file point level todo tags parent) (list :file file :point point :level level :todo todo :tags tags - :toplevelp toplevelp)) - ;; :id id)) - ;; (if id (list :id file point id) (list :pm file point))) + :buffer-parent parent)) -(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)) +;; state lookup functions +;; +;; all functions with `org-x-dag->' or `org-x-dag-id->' depend on the value of +;; `org-x-dag' -(defun org-x-dag-key-get-file (key) - "Return file for KEY." - (org-x-dag-id-lookup-prop key :file)) - ;; (plist-get key :file)) - ;; (nth 1 key)) +(defun org-x-dag->metatable () + (plist-get org-x-dag :id->meta)) -(defun org-x-dag-key-get-point (key) - "Return point for KEY." - (org-x-dag-id-lookup-prop key :point)) - ;; (plist-get key :point)) - ;; (nth 2 key)) +(defun org-x-dag->dag () + (plist-get org-x-dag :dag)) -;;; DAG SYNCHRONIZATION/CONSTRUCTION +(defun org-x-dag->adjacency-list () + (dag-get-adjacency-list (org-x-dag->dag))) -(defun org-x-dag-get-files () - "Return a list of all files to be used in the DAG." - ;; (list "/mnt/data/Org/projects/router.org" - ;; "/mnt/data/Org/projects/omnimacs.org" - ;; )) - `(,(org-x-get-lifetime-goal-file) - ,(org-x-get-endpoint-goal-file) - ,@(org-x-get-action-and-incubator-files))) +(defun org-x-dag-id->metaprop (id prop) + (-> (org-x-dag->metatable) + (ht-get id) + (plist-get prop))) -(defun org-x-dag-get-md5 (path) - "Get the md5 checksum of PATH." - (org-x-with-file path (buffer-hash))) - ;; (with-temp-buffer - ;; (let ((rc (call-process "md5sum" nil (current-buffer) nil path))) - ;; (if (/= 0 rc) (error "Could not get md5 of %s" path) - ;; (->> (buffer-string) - ;; (s-match "^\\([0-9a-z]+\\)") - ;; (cadr)))))) +(defun org-x-dag-id->file (id) + "Return file for ID." + (org-x-dag-id->metaprop id :file)) -(defun org-x-dag-md5-matches-p (path md5) - "Return t if the md5 of PATH on disk `equal's MD5." - (equal (org-x-dag-get-md5 path) md5)) +(defun org-x-dag-id->point (id) + "Return point for ID." + (org-x-dag-id->metaprop id :point)) -(defun org-x-dag-file-is-dirty (file md5) - "Return t if FILE with MD5 has been recently changed." - (org-x-with-file file - (let ((new-md5 (buffer-hash))) - (unless (equal new-md5 md5) - new-md5)))) +(defun org-x-dag-id->todo (id) + "Return todo keyword for ID." + (org-x-dag-id->metaprop id :todo)) -(defun org-x-dag-set-sync-state () - "Set the sync state to reflect the current files on disk." - (->> (org-x-dag-get-files) - (--map (cons it (org-x-dag-get-md5 it))) - (setq org-x-dag-sync-state))) +(defun org-x-dag-id->local-tags (id) + "Return local tags for ID." + (org-x-dag-id->metaprop id :tags)) -(defun org-x-dag-get-sync-state () - "Return the sync state. +(defun org-x-dag-id->is-done-p (id) + "Return t if ID has done keywords." + (member (org-x-dag-id->todo id) org-x-done-keywords)) -The returned value will be a list like (TO-REMOVE TO-INSERT -TO-UPDATE) which will contain the file paths the should be -removed from, added to, or edited within the DAG respectively." - (cl-flet - ((lookup-md5 - (path) - (alist-get path org-x-dag-sync-state nil nil #'equal))) - (-let* ((existing-files (org-x-dag-get-files)) - (state-files (-map #'car org-x-dag-sync-state)) - (to-remove (-difference state-files existing-files)) - ((&alist 'to-insert 'to-update 'no-change) - (->> (--map (cons it (org-x-dag-get-md5 it)) existing-files) - (--group-by (-let* (((path . new-md5) it) - (old-md5 (lookup-md5 path))) - (cond - ((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-id->is-floating-p (id) + (-> (plist-get org-x-dag :dag) + (dag-get-floating-nodes) + (ht-get id))) + +(defun org-x-dag-id->is-toplevel-p (id) + (or (not (org-x-dag-id->metaprop id :buffer-parent)) + ;; TODO pretty sure this will never be used + (org-x-dag-id->is-floating-p id))) + +(defun org-x-dag-collapse-tags (tags) + "Return TAGS with duplicates removed. + +In the case of mutually exclusive tags, only the first tag +encountered will be returned." + (-let (((x non-x) (--separate (memq (elt it 0) org-x-exclusive-prefixes) tags))) + (->> (--group-by (elt it 0) x) + (--map (car (cdr it)) ) + (append (-uniq non-x)) + ;; this removes the 'inherited' property on some of the tags, which + ;; makes the agenda look cleaner (to me) since there are no + ;; double-colons to separate inherited from non-inherited + ;; + ;; NOTE: this appears to have no effect on `org-agenda-tags' (eg the + ;; inherited tags still show up in the menu properly) + (-map #'substring-no-properties)))) + +(defun org-x-dag-id->tags (inherit? init id) + (cl-labels + ((ascend + (id tags) + (-if-let (parent (org-x-dag-id->metaprop id :buffer-parent)) + ;; tags in the front of the list have precedence over latter tags, + ;; so putting parent tags at the end means child tags have + ;; precedence + (->> (org-x-dag-id->local-tags parent) + (append tags) + (ascend parent)) + tags))) + ;; likewise, init tags have the lowest precedence (the likely use case for + ;; this argument is for file tags) + (org-x-dag-collapse-tags (append (org-x-dag-id->local-tags id) + (and inherit? (ascend id nil)) + init)))) + +(defun org-x-dag-id->headline-children (id) + (->> (plist-get org-x-dag :dag) + (dag-get-children id) + (--filter (equal (org-x-dag-id->metaprop it :buffer-parent) id)))) + +(defun org-x-dag-files->ids (files) + (let ((filemap (plist-get org-x-dag :file->ids))) + (--mapcat (ht-get filemap it) files))) + +;;; BUFFER SCANNING (defun org-x-dag-get-local-property (prop) (car (org--property-local-values prop nil))) @@ -164,29 +175,6 @@ removed from, added to, or edited within the DAG respectively." (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 (defun org-x-dag-get-buffer-nodes (file kws) "Return a list of nodes from FILE. @@ -194,9 +182,8 @@ 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 valid keyword or none of its parents have valid keywords." (let ((more t) - ;; (id-cache (ht-create #'equal)) cur-path this-point this-key this-level this-todo has-todo this-parent - tags toplevelp this-file-links acc acc-meta) + tags this-file-links acc acc-meta this-parent-key) ;; TODO add org-mode sanity check (goto-char (point-min)) ;; If not on a headline, check for a property drawer with links in it @@ -234,14 +221,15 @@ valid keyword or none of its parents have valid keywords." (while (and cur-path (<= this-level (nth 0 (car cur-path)))) (!cdr cur-path)) (setq this-parent (car cur-path) - toplevelp (not (nth 1 this-parent))) + this-parent-key (nth 1 this-parent)) ;; 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 - (when (and has-todo (or (not toplevelp) (--none-p (nth 1 it) cur-path)) + (when (and has-todo (or this-parent-key (--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 ;; above this headline (sans file-tags which we can get later easily) - (setq tags (if (and toplevelp org-use-tag-inheritance) + ;; (org-entry-get nil org-x-prop-parent-type) + (setq tags (if (and (not this-parent-key) org-use-tag-inheritance) (->> cur-path (--mapcat (nth 2 it)) (append this-tags)) @@ -251,7 +239,7 @@ valid keyword or none of its parents have valid keywords." this-level (substring-no-properties this-todo) tags - toplevelp)) + this-parent-key)) (!cons (cons this-key this-meta) acc-meta) (!cons (cons this-key (append (list (nth 1 this-parent)) (org-x-dag-get-link-property))) @@ -267,46 +255,42 @@ valid keyword or none of its parents have valid keywords." (org-x-with-file file (org-x-dag-get-buffer-nodes file org-todo-keywords-1))) -;; (defun org-x-dag-key-is-pseudo-marker (key) -;; "Return t if KEY is a pseudo marker." -;; (eq (car key) :pm)) -;; ;; (= 2 (length key))) -;; ;; (and (consp key) (stringp (car key)) (numberp (cdr key)))) +;;; DAG SYNCHRONIZATION/CONSTRUCTION -;; (defun org-x-dag-key-is-id (key) -;; "Return t if KEY is an ID." -;; ;; (= 3 (length key))) -;; (eq (car key) :id)) +(defun org-x-dag-get-files () + "Return a list of all files to be used in the DAG." + `(,(org-x-get-lifetime-goal-file) + ,(org-x-get-endpoint-goal-file) + ,@(org-x-get-action-and-incubator-files))) -(defun org-x-dag-files-contains-key-p (key files) - "Return t if KEY represents a node contained in FILES." - (-if-let (other-file (org-x-dag-key-get-file key)) - (--any-p (equal other-file it) files) - (error "Invalid key: %s" key))) - ;; (cl-flet - ;; ((contains-key - ;; (files other-file) - ;; (--any-p (equal other-file it) files))) - ;; (cond - ;; ((org-x-dag-key-is-id key) - ;; (-some->> (ht-get org-id-locations key) - ;; (contains-key files))) - ;; ((org-x-dag-key-is-pseudo-marker key) - ;; (contains-key files (car key))) - ;; (t - ;; (error "Invalid key: %s" key))))) +(defun org-x-dag-get-md5 (path) + "Get the md5 checksum of PATH." + (org-x-with-file path (buffer-hash))) -(defun org-x-dag-get-nodes-in-files (dag files) - (let ((x (->> (dag-get-nodes-and-edges-where org-x-dag - (org-x-dag-files-contains-key-p it files)) - (-map #'car))) - (y (dag-get-floating-nodes-where org-x-dag - (org-x-dag-files-contains-key-p it files)))) - (append x y))) +(defun org-x-dag-get-sync-state () + "Return the sync state. -(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 +The returned value will be a list like (TO-REMOVE TO-INSERT +TO-UPDATE) which will contain the file paths the should be +removed from, added to, or edited within the DAG respectively." + (cl-flet + ((lookup-md5 + (path) + (alist-get path org-x-dag-sync-state nil nil #'equal))) + (-let* ((existing-files (org-x-dag-get-files)) + (state-files (-map #'car org-x-dag-sync-state)) + (to-remove (-difference state-files existing-files)) + ((&alist 'to-insert 'to-update 'no-change) + (->> (--map (cons it (org-x-dag-get-md5 it)) existing-files) + (--group-by (-let* (((path . new-md5) it) + (old-md5 (lookup-md5 path))) + (cond + ((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-read-files (files) (cl-flet ((append-results (acc file) @@ -322,15 +306,13 @@ valid keyword or none of its parents have valid keywords." (--each to-remove (ht-remove ht it)) (--each to-insert - (ht-set ht (car it) (cdr it))) - ht) + (ht-set ht (car it) (cdr it)))) -(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))) +(defun org-x-dag-update-dag (to-insert to-remove) + (let* ((dag (org-x-dag->dag)) + (dag* (if (dag-is-empty-p dag) (dag-alist-to-dag to-insert) + (dag-edit-nodes to-remove to-insert dag)))) + (plist-put org-x-dag :dag dag*))) ;; 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 @@ -341,21 +323,14 @@ valid keyword or none of its parents have valid keywords." TO-REMOVE, TO-INSERT, and TO-UPDATE are lists of files to remove from, add to, and update with the DAG." - (-let* (((&plist :dag :id->meta :file->ids) org-x-dag) + (-let* (((&plist :id->meta :file->ids) org-x-dag) (files2rem (append to-update to-remove)) (files2ins (append to-update to-insert)) - (ids2rem (org-x-dag-get-ids-in-files files2rem)) - ((ids2ins meta2ins fms2ins) (org-x-dag-get-data-to-insert files2ins))) + (ids2rem (org-x-dag-files->ids files2rem)) + ((ids2ins meta2ins fms2ins) (org-x-dag-read-files files2ins))) (org-x-dag-update-ht ids2rem meta2ins id->meta) (org-x-dag-update-ht files2rem fms2ins file->ids) - (->> (if (dag-is-empty-p dag) (dag-alist-to-dag ids2ins) - (dag-edit-nodes ids2rem ids2ins dag)) - (plist-put org-x-dag :dag)))) - -(defun org-x-dag-id-lookup-prop (id prop) - (-> (plist-get org-x-dag :id->meta) - (ht-get id) - (plist-get prop))) + (org-x-dag-update-dag ids2ins ids2rem))) (defun org-x-dag-sync (&optional force) "Sync the DAG with files from `org-x-dag-get-files'. @@ -370,192 +345,20 @@ If FORCE is non-nil, sync no matter what." (setq org-x-dag-sync-state (append to-insert to-update no-change)) nil)) -;;; DAG -> HEADLINE RETRIEVAL - -;; ;; TODO this is silly since there can only be one parent, this function may -;; ;; be doing too much -;; (defun org-x-dag-relation-has-parent-headlines-p (key relation) -;; "" -;; (let ((this-file (org-x-dag-key-get-file key))) -;; (->> (dag-relation-get-parents relation) -;; (--any-p (equal this-file (org-x-dag-key-get-file it)))))) - -(defun org-x-dag-relation-has-child-headlines-p (key relation) - "" - (let ((this-file (org-x-dag-key-get-file key))) - (->> (dag-relation-get-children relation) - (--any-p (equal this-file (org-x-dag-key-get-file it)))))) - -;; (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))) - -(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) - "Return the standalone task nodes of DAG." - (let* ((action-files (org-x-get-action-files)) - (from-adjlist - (dag-get-nodes-and-edges-where dag - (and (org-x-dag-files-contains-key-p it action-files) - (plist-get it :toplevelp) - (not (org-x-dag-relation-has-child-headlines-p it it-rel))))) - (from-floating - (dag-get-floating-nodes-where dag - (org-x-dag-files-contains-key-p it action-files)))) - (append (-map #'car from-adjlist) from-floating))) - -(defun org-x-dag-get-toplevel-project-nodes () - "Return the toplevel project nodes of DAG." - (let ((action-files (org-x-get-action-files))) - (dag-get-nodes-and-edges-where (plist-get org-x-dag :dag) - (and (org-x-dag-files-contains-key-p it action-files) - (org-x-dag-id-lookup-prop it :toplevelp) - ;; (plist-get it :toplevelp) - (org-x-dag-relation-has-child-headlines-p it it-rel))))) - -;;; DAG -> HEADLINE RETRIEVAL (CHILD/PARENT) - -(defun org-x-dag-filter-children (dag key fun) - (declare (indent 2)) - (-filter fun (dag-get-children key (plist-get org-x-dag :dag)))) - -(defun org-x-dag-separate-children (dag key fun) - (declare (indent 2)) - (-separate fun (dag-get-children key dag))) - -(defun org-x-dag-node-get-headline-children (dag key) - (let ((this-file (org-x-dag-key-get-file key))) - (org-x-dag-filter-children dag key - (lambda (it) (equal this-file (org-x-dag-key-get-file it)))))) - -;; TODO somewhere in here I need to filter based on headline like CANC -(defun org-x-dag-project-node-get-task-nodes (dag key) - (declare (indent 2)) - ;; NOTE if this is a standalone task it will return itself - (-if-let (cs (org-x-dag-node-get-headline-children dag key)) - ;; TODO don't hardcode this - (->> (--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))) - (list key))) - -(defun org-x-dag-get-project-task-nodes (fun dag) - "Return project task nodes of DAG." - (-let (((&plist :adjlist) dag)) - (->> (org-x-dag-get-toplevel-project-nodes) - (-map #'car) - (-remove fun) - (--mapcat (org-x-dag-project-node-get-task-nodes dag it))))) - -(defun org-x-dag-project-node-get-subproject-nodes (dag key) - (-when-let (cs (org-x-dag-node-get-headline-children dag key)) - (cons key (--mapcat (org-x-dag-project-node-get-subproject-nodes dag it) cs)))) - -(defun org-x-dag-get-subproject-task-nodes (dag) - "Return subproject nodes of DAG." - ;; ignore floating nodes since these by definition can't be part of projects - (-let (((&plist :adjlist) dag)) - (->> (org-x-dag-get-toplevel-project-nodes dag) - (-map #'car) - (--mapcat (org-x-dag-project-node-get-subproject-nodes dag it))))) - -;; (defmacro org-x-dag-with-key (key &rest body) -;; (declare (indent 1)) -;; `(cond -;; ((org-x-dag-key-is-pseudo-marker ,key) -;; (org-x-with-file (car ,key) -;; (goto-char (cdr ,key)) -;; ,@body)) -;; ((org-x-dag-key-is-id ,key) -;; (org-x-with-id-target ,key -;; ,@body)))) - ;; NODE FORMATTING -(defun org-x-dag-get-headline-with-props (pos type face) - (goto-char pos) - (let* ((head (org-get-heading)) - (level (-> (org-outline-level) - (org-reduced-level) - (1-) - (make-string ?.))) - (category (org-get-category)) - (todo-state (org-get-todo-state)) - (inherited-tags - (or (eq org-agenda-show-inherited-tags 'always) - (and (listp org-agenda-show-inherited-tags) - (memq 'agenda org-agenda-show-inherited-tags)) - (and (eq org-agenda-show-inherited-tags t) - (or (eq org-agenda-use-tag-inheritance t) - (memq 'agenda - org-agenda-use-tag-inheritance))))) - (tags (org-get-tags nil (not inherited-tags))) - (item (org-agenda-format-item "" head level category tags nil nil nil)) - (marker (org-agenda-new-marker pos))) - (org-add-props item nil - 'org-marker marker - 'org-hd-marker marker - 'org-not-done-regexp org-not-done-regexp - 'org-todo-regexp org-todo-regexp - 'org-complex-heading-regexp org-complex-heading-regexp - 'mouse-face 'highlight - 'help-echo (format "mouse-2 or RET jump to Org file %s" - (abbreviate-file-name buffer-file-name)) - 'undone-face face - ;; TODO in the case of scheduled headline this has other stuff in it - 'priority (org-get-priority item) - 'todo-state todo-state - 'face face - 'type type))) - -(defun org-x-dag-nodes-to-headlines (nodes) - (->> (-group-by #'org-x-dag-key-get-file nodes) - (--map (-let (((path . nodes) it)) - (org-x-with-file path - (->> (-map #'org-x-dag-key-get-point nodes) - (--map (progn (goto-char it) - (substring-no-properties (org-get-heading)))))))) - ;; (->> (-map #'org-x-dag-key-get-point nodes) - ;; (-map #'org-x-dag-get-headline-with-props))))) - (-flatten-n 1))) - -(defun org-x-dag-collapse-tags (tags) - "Return TAGS with duplicates removed. - -In the case of mutually exclusive tags, only the first tag -encountered will be returned." - (-let (((x non-x) (--separate (memq (elt it 0) org-x-exclusive-prefixes) tags))) - (->> (--group-by (elt it 0) x) - (--map (car (cdr it)) ) - (append (-uniq non-x))))) - (defun org-x-dag-add-default-props (item) (org-add-props item nil 'org-not-done-regexp org-not-done-regexp 'org-todo-regexp org-todo-regexp 'org-complex-heading-regexp org-complex-heading-regexp - 'mouse-face 'default)) + 'mouse-face 'highlight)) (defun org-x-dag-format-tag-node (category tags key) ;; ASSUME I don't use subtree-level categories (-let* (;; (category (org-get-category)) (head (org-get-heading)) - (level (-> (org-x-dag-id-lookup-prop key :level) + (level (-> (org-x-dag-id->metaprop key :level) (make-string ?s))) ;; no idea what this does... (help-echo (format "mouse-2 or RET jump to Org file %S" @@ -577,43 +380,36 @@ encountered will be returned." 'org-hd-marker marker 'org-marker marker ;; headline stuff - 'todo-state (org-x-dag-id-lookup-prop key :todo) + 'todo-state (org-x-dag-id->todo key) 'priority priority 'ts-date ts ;; misc 'type (concat "tagsmatch" ts-type) 'help-echo help-echo)))) -(defun org-x-dag-key-is-iterator (key) - (->> (org-entry-get (org-x-dag-id-lookup-prop key :point) org-x-prop-parent-type) - (equal org-x-prop-parent-type-iterator))) +;;; HEADLINE PREDICATES +;; +;; The following are predicates that require the point to be above the +;; headline in question -;; (defmacro org-x-dag-do-file-nodes (path keys form) -;; (declare (indent 2)) -;; `(let ((acc)) -;; (org-x-with-file ,path -;; ;; ;; TODO tbh this could just be the file basename since that's all -;; ;; ;; I ever use -;; ;; (let ((it-category (org-get-category))) -;; (--each keys -;; (goto-char (org-x-dag-key-get-point it)) -;; ,form)) -;; (nreverse acc))) +(defun org-x-dag-headline-is-deadlined-p (want-time) + (org-x-headline-has-timestamp org-deadline-time-regexp want-time)) + +(defun org-x-dag-headline-is-scheduled-p (want-time) + (org-x-headline-has-timestamp org-scheduled-time-regexp want-time)) + +(defun org-x-dag-headline-is-closed-p (want-time) + (org-x-headline-has-timestamp org-closed-time-regexp want-time)) + +(defun org-x-dag-headline-is-iterator-p () + (->> (org-x-dag-get-local-property org-x-prop-parent-type) + (equal org-x-prop-parent-type-iterator))) (defun org-x-headline-has-timestamp (re want-time) (let ((end (save-excursion (outline-next-heading)))) (-when-let (p (save-excursion (re-search-forward re end t))) (if want-time (org-2ft (match-string 1)) p)))) -(defun org-x-headline-is-deadlined (want-time) - (org-x-headline-has-timestamp org-deadline-time-regexp want-time)) - -(defun org-x-headline-is-scheduled (want-time) - (org-x-headline-has-timestamp org-scheduled-time-regexp want-time)) - -(defun org-x-headline-is-closed (want-time) - (org-x-headline-has-timestamp org-closed-time-regexp want-time)) - (defconst org-x-headline-task-status-priorities '((:archivable . -1) (:complete . -1) @@ -636,63 +432,29 @@ encountered will be returned." (:active . 3) (:inert . 4))) +(defun org-x-dag-time-is-archivable-p (epochtime) + (< (- (float-time) epochtime) (* 60 60 24 org-x-archive-delay))) + (defun org-x-headline-get-task-status-0 (kw) (if (member kw org-x-done-keywords) - (-if-let (c (org-x-headline-is-closed t)) - (if (< (- (float-time) c) (* 60 60 24 org-x-archive-delay)) + (-if-let (c (org-x-dag-headline-is-closed-p t)) + (if (org-x-dag-time-is-archivable-p c) :archivable :complete) :done-unclosed) (cond ((org-x-headline-is-expired-p) :expired) ((org-x-headline-is-inert-p) :inert) - ((org-x-headline-is-closed nil) :undone-closed) + ((org-x-dag-headline-is-closed-p nil) :undone-closed) (t :active)))) -;; (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 -;; ;; when this is encountered the loop is broken because we are done -;; ;; (the last entry trumps all others) -;; (declare (indent 3)) -;; (let* ((allowed-statuscodes (-map #'car statuscode-tree)) -;; (trans-tbl (->> statuscode-tree -;; (--map (-let (((a . bs) it)) (--map (cons it a) bs))) -;; (-flatten-n 1))) -;; (breaker-status (-last-item allowed-statuscodes)) -;; (initial-status (car allowed-statuscodes))) -;; `(save-excursion -;; (let ((project-status ,initial-status) -;; (this-child nil) -;; (it-kw nil) -;; (new-status nil)) -;; ;; loop through tasks one level down until breaker-status found -;; (while (and children (not (eq project-status ,breaker-status))) -;; (setq this-child (car children) -;; it-kw (plist-get this-child :todo)) -;; ;; If project returns an allowed status then use that. Otherwise look -;; ;; up the value in the translation table and return error if not -;; ;; found. -;; (-if-let (cs (org-x-dag-node-get-headline-children dag this-child)) -;; (unless (member (setq new-status -;; (funcall ,callback-form -;; ,dag this-child cs)) -;; ',allowed-statuscodes) -;; (setq new-status (alist-get new-status ',trans-tbl))) -;; (goto-char (org-x-dag-key-get-point this-child)) -;; (setq new-status (nth ,get-task-status ',allowed-statuscodes))) -;; (when (org-x--compare-statuscodes ',allowed-statuscodes -;; new-status > project-status) -;; (setq project-status new-status)) -;; (!cdr children)) -;; 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 - task-form callback) - (declare (indent 3)) +(defmacro org-x-dag-descend-into-project (keys parent-tags codetree task-form + callback) + (declare (indent 2)) (let ((allowed-codes (-map #'car codetree)) (trans-tbl (--mapcat (-let (((a . bs) it)) (--map (cons it a) bs)) @@ -700,11 +462,9 @@ encountered will be returned." `(cl-flet ((get-project-or-task-status (key) - (-if-let (children (org-x-dag-node-get-headline-children ,dag key)) - (let* ((tags (-> (org-x-dag-id-lookup-prop key :tags) - (append ,parent-tags) - (org-x-dag-collapse-tags))) - (child-results (funcall ,callback ,dag key tags children)) + (-if-let (children (org-x-dag-id->headline-children key)) + (let* ((tags (org-x-dag-id->tags nil parent-tags key)) + (child-results (funcall ,callback key tags children)) ;; ASSUME the car of the results will be the toplevel ;; key/status pair for this (sub)project (top-status (plist-get (car child-results) :status)) @@ -712,7 +472,7 @@ encountered will be returned." top-status (alist-get top-status ',trans-tbl)))) (cons top-status* child-results)) - (let ((it-kw (org-x-dag-id-lookup-prop key :todo))) + (let ((it-kw (org-x-dag-id->todo key))) (org-x-dag-with-key key (-> ,task-form (nth ',allowed-codes) @@ -722,80 +482,81 @@ encountered will be returned." (org-x-dag-get-max-index ',allowed-codes)))) (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 (key tags children) ;; ASSUME children will always be at least 1 long - (goto-char (org-x-dag-key-get-point key)) - (let ((keyword (org-x-dag-id-lookup-prop key :todo))) - (-let (((status . child-results) - (cond - ((org-x-headline-is-scheduled nil) - (list :scheduled-project)) - ((equal keyword org-x-kw-hold) - (list (if (org-x-headline-is-inert-p) :inert :held))) - ((member keyword org-x--project-invalid-todostates) - (list :invalid-todostate)) - ((equal keyword org-x-kw-canc) - (list (if (org-x-headline-is-archivable-p) :archivable :complete))) - ((equal keyword org-x-kw-done) - (org-x-dag-descend-into-project dag children tags - ((:archivable) - (:complete) - (:done-incomplete :stuck :inert :held :wait :active - :scheduled-project :invalid-todostate - :undone-complete)) - (if (member it-kw org-x-done-keywords) - (if (org-x-headline-is-archivable-p) 0 1) - 2) - #'org-x-dag-headline-get-project-status)) - ((equal keyword org-x-kw-todo) - (org-x-dag-descend-into-project dag children tags - ((:undone-complete :complete :archivable) - (:stuck :scheduled-project :invalid-todostate :done-incomplete) - (:held) - (:wait) - (:inert) - (:active)) - (cond - ((and (not (member it-kw org-x-done-keywords)) - (org-x-headline-is-inert-p)) - 4) - ((equal it-kw org-x-kw-todo) - (if (org-x-headline-is-scheduled nil) 5 1)) - ((equal it-kw org-x-kw-hold) - 2) - ((equal it-kw org-x-kw-wait) - 3) - ((equal it-kw org-x-kw-next) - 5) - (t 0)) - #'org-x-dag-headline-get-project-status)) - (t (error "Invalid keyword detected: %s" keyword))))) - (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)) + (let ((keyword (org-x-dag-id->todo key))) + (-let (((status . child-results) + (cond + ((org-x-dag-headline-is-scheduled-p nil) + (list :scheduled-project)) + ((equal keyword org-x-kw-hold) + (list (if (org-x-headline-is-inert-p) :inert :held))) + ((member keyword org-x--project-invalid-todostates) + (list :invalid-todostate)) + ((equal keyword org-x-kw-canc) + (list (if (org-x-headline-is-archivable-p) :archivable :complete))) + ((equal keyword org-x-kw-done) + (org-x-dag-descend-into-project children tags + ((:archivable) + (:complete) + (:done-incomplete :stuck :inert :held :wait :active + :scheduled-project :invalid-todostate + :undone-complete)) + (if (member it-kw org-x-done-keywords) + (if (org-x-headline-is-archivable-p) 0 1) + 2) + #'org-x-dag-headline-get-project-status)) + ((equal keyword org-x-kw-todo) + (org-x-dag-descend-into-project children tags + ((:undone-complete :complete :archivable) + (:stuck :scheduled-project :invalid-todostate + :done-incomplete) + (:held) + (:wait) + (:inert) + (:active)) + (cond + ((and (not (member it-kw org-x-done-keywords)) + (org-x-headline-is-inert-p)) + 4) + ((equal it-kw org-x-kw-todo) + (if (org-x-dag-headline-is-scheduled-p nil) 5 1)) + ((equal it-kw org-x-kw-hold) + 2) + ((equal it-kw org-x-kw-wait) + 3) + ((equal it-kw org-x-kw-next) + 5) + (t 0)) + #'org-x-dag-headline-get-project-status)) + (t (error "Invalid keyword detected: %s" keyword))))) + (cons (list :key key :status status :tags tags) child-results))))) + +(defun org-x-dag-headline-get-iterator-project-status (key children) + (org-x-dag-with-key key + (let* ((kw (org-x-dag-id->todo key)) (status (cond ((or (member kw org-x--project-invalid-todostates) - (org-x-headline-is-scheduled nil)) + (org-x-dag-headline-is-scheduled-p 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 + (org-x-dag-descend-into-project 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 + (org-x-dag-descend-into-project children nil ((:unscheduled :project-error) (:empt) (:actv)) - (let ((ts (org-x-headline-is-scheduled t))) + (let ((ts (org-x-dag-headline-is-scheduled-p t))) (cond ((not ts) 0) ((> org-x-iterator-active-future-offset (- ts (float-time))) 1) @@ -806,34 +567,36 @@ encountered will be returned." (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))))) + (if (org-x-dag-id->is-done-p key) :empt + (-if-let (ts (or (org-x-dag-headline-is-scheduled-p t) + (org-x-dag-headline-is-deadlined-p t))) + (if (< org-x-iterator-active-future-offset (- ts (float-time))) + :actv + :empt) + :unscheduled)))) -(defun org-x-dag-headline-get-iterator-status (dag key) +(defun org-x-dag-headline-get-iterator-status (key) (cl-flet ((get-status (key) - (-if-let (children (org-x-dag-node-get-headline-children dag key)) + (-if-let (children (org-x-dag-id->headline-children key)) (->> children - (org-x-dag-headline-get-iterator-project-status dag key) + (org-x-dag-headline-get-iterator-project-status key) (car)) (org-x-dag-headline-get-iterator-task-status key)))) - (->> (org-x-dag-node-get-headline-children dag key) + (->> (org-x-dag-id->headline-children 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-key (key &rest body) (declare (indent 1)) - `(->> (-group-by #'org-x-dag-key-get-file ,keys) - (--mapcat (org-x-with-file (car it) - (--mapcat ,form (cdr it)))) - (-non-nil))) + `(progn + (goto-char (org-x-dag-id->point ,key)) + ,@body)) + +;;; SCANNERS +;; +;; Not sure what to call these, they convert the DAG to a list of agenda strings (defmacro org-x-dag-with-files (files pre-form form) (declare (indent 2)) @@ -850,12 +613,6 @@ encountered will be returned." (--mapcat ,form keys))))) (-non-nil (-mapcat #'proc-file ,files)))))) -(defmacro org-x-dag-with-key (key &rest body) - (declare (indent 1)) - `(progn - (goto-char (org-x-dag-key-get-point ,key)) - ,@body)) - (defun org-x-dag-scan-projects () (cl-flet* ((format-result @@ -866,65 +623,50 @@ encountered will be returned." (org-x-dag-with-key key (-> (org-x-dag-format-tag-node cat tags key) (org-add-props nil - 'x-toplevelp (org-x-dag-id-lookup-prop key :toplevelp) + 'x-toplevelp (org-x-dag-id->is-toplevel-p key) 'x-status status - 'x-priority priority))))))) - (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 + 'x-priority priority)))))) + (format-key + (key) + (let ((cat (org-get-category)) + (tags (org-x-dag-id->tags t org-file-tags key))) + ;; TODO don't hardcode these things + (org-x-dag-with-key key (unless (or (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)))) - (->> (org-x-dag-node-get-headline-children org-x-dag it) - (org-x-dag-headline-get-project-status org-x-dag it tags) - (--map (format-result cat it)))))))))) + (org-x-dag-headline-is-iterator-p)) + (-some->> (org-x-dag-id->headline-children key) + (org-x-dag-headline-get-project-status key tags) + (--map (format-result cat it)))))))) + (org-x-dag-with-files (org-x-get-action-files) + (and (org-x-dag-id->is-toplevel-p it) + (not (org-x-dag-id->is-done-p it))) + (format-key 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))) + (-let ((status (org-x-dag-headline-get-iterator-status 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 sloppy nonDRY hack -(defun org-x-dag-id->headline-children (id) - (org-x-dag-node-get-headline-children (plist-get org-x-dag :dag) id)) - + (org-x-dag-with-files (org-x-get-action-files) + (org-x-dag-id->is-toplevel-p it) + (let ((tags (org-x-dag-id->tags t org-file-tags it))) + (unless (member org-x-tag-incubated tags) + (let ((cat (org-get-category))) + (org-x-dag-with-key it + (when (org-x-dag-headline-is-iterator-p) + (list (format-result tags cat it)))))))))) + (defun org-x-dag-get-task-nodes (id) (declare (indent 2)) (cl-labels ((descend (children) ;; TODO don't hardcode this - (->> (--remove (member (org-x-dag-id-lookup-prop it :todo) + (->> (--remove (member (org-x-dag-id->todo it) (list org-x-kw-canc org-x-kw-hold)) children) (--mapcat (-if-let (cs (org-x-dag-id->headline-children it)) @@ -933,30 +675,17 @@ encountered will be returned." (-some-> (org-x-dag-id->headline-children id) (descend)))) -(defun org-x-dag-id->is-floating-p (id) - (-> (plist-get org-x-dag :dag) - (dag-get-floating-nodes) - (ht-get id))) - -(defun org-x-dag-id->is-toplevel-p (id) - (or (org-x-dag-id-lookup-prop id :toplevelp) - (org-x-dag-id->is-floating-p id))) - (defun org-x-dag-scan-tasks () (cl-flet ((format-key (category is-standalone key) - (let ((tags (->> (org-x-dag-get-inherited-tags org-file-tags - (plist-get org-x-dag :dag) - key) - (append (org-x-dag-id-lookup-prop key :tags)) - (org-x-dag-collapse-tags)))) + (let ((tags (org-x-dag-id->tags t org-file-tags key))) ;; filter out incubators (org-x-dag-with-key key (unless (or (member org-x-tag-incubated tags) - (org-x-headline-is-scheduled nil) - (org-x-headline-is-deadlined nil)) - (let* ((s (org-x-headline-get-task-status-0 (org-x-dag-id-lookup-prop key :todo))) + (org-x-dag-headline-is-scheduled-p nil) + (org-x-dag-headline-is-deadlined-p nil)) + (let* ((s (org-x-headline-get-task-status-0 (org-x-dag-id->todo key))) (p (alist-get s org-x-headline-task-status-priorities))) (unless (= p -1) (-> (org-x-dag-format-tag-node category tags key) @@ -972,32 +701,15 @@ encountered will be returned." (--map (format-key category nil it) project-tasks) (list (format-key category t it))))))) -;; (defun org-x-dag-partition-children (ids) -;; (cl-labels -;; ((descend -;; (acc children) -;; (-let (((projects tasks) acc)) -;; (->> (--remove (member (org-x-dag-id-lookup-prop it :todo) -;; (list org-x-kw-canc org-x-kw-hold)) -;; children) -;; (--mapcat (-if-let (cs (org-x-dag-id->headline-children it)) -;; (descend `((it ,@projects) (,@tasks)) cs) -;; `((,@projects) (it ,@tasks)))))))) -;; (-reduce-from #'descend nil ids))) - (defun org-x-dag-scan-incubated () (cl-flet ((format-key (category key) - (let ((tags (->> (org-x-dag-get-inherited-tags org-file-tags - (plist-get org-x-dag :dag) - key) - (append (org-x-dag-id-lookup-prop key :tags)) - (org-x-dag-collapse-tags)))) + (let ((tags (org-x-dag-id->tags t org-file-tags key))) (when (member org-x-tag-incubated tags) (org-x-dag-with-key key - (let* ((sch (org-x-headline-is-scheduled t)) - (dead (org-x-headline-is-deadlined t)) + (let* ((sch (org-x-dag-headline-is-scheduled-p t)) + (dead (org-x-dag-headline-is-deadlined-p t)) (is-project (org-x-dag-id->headline-children key))) (-> (org-x-dag-format-tag-node category tags key) (org-add-props nil @@ -1006,7 +718,7 @@ encountered will be returned." 'x-deadlined dead)))))))) (org-x-dag-with-files (org-x-get-action-and-incubator-files) (and (org-x-dag-id->is-toplevel-p it) - (not (member (org-x-dag-id-lookup-prop it :todo) org-x-done-keywords))) + (not (org-x-dag-id->is-done-p it))) (let ((category (org-get-category))) (list (format-key category it)))))) @@ -1014,11 +726,7 @@ encountered will be returned." (cl-flet ((format-key (category key) - (let ((tags (->> (org-x-dag-get-inherited-tags org-file-tags - (plist-get org-x-dag :dag) - key) - (append (org-x-dag-id-lookup-prop key :tags)) - (org-x-dag-collapse-tags)))) + (let ((tags (org-x-dag-id->tags t org-file-tags key))) (unless (member org-x-tag-incubated tags) (org-x-dag-with-key key (-let (((is-archivable is-project) @@ -1027,7 +735,7 @@ encountered will be returned." (alist-get org-x-project-status-priorities) (eq :archivable) (list t)) - (-> (org-x-headline-get-task-status-0 (org-x-dag-id-lookup-prop key :todo)) + (-> (org-x-headline-get-task-status-0 (org-x-dag-id->todo key)) (alist-get org-x-headline-task-status-priorities) (eq :archivable) (list t))))) @@ -1038,53 +746,21 @@ encountered will be returned." (org-x-dag-with-files (org-x-get-action-files) (org-x-dag-id->is-toplevel-p it) (let ((category (org-get-category))) - (if (org-x-dag-key-is-iterator it) - (--map (format-key category it) (org-x-dag-id->headline-children it)) - (list (format-key category it))))))) - -(defun org-x-dag-get-inherited-tags (init dag key) - (let* ((this-file (org-x-dag-key-get-file key))) - (cl-labels - ((ascend - (k tags) - (-if-let (parent (->> (dag-get-parents k dag) - (--first (equal (org-x-dag-key-get-file it) - this-file)))) - (->> (org-x-dag-id-lookup-prop parent :tags) - (append tags) - (ascend parent)) - tags))) - (org-x-dag-collapse-tags (append (ascend key nil) init))))) + (org-x-dag-with-key it + (if (org-x-dag-headline-is-iterator-p) + (--map (format-key category it) (org-x-dag-id->headline-children it)) + (list (format-key category it)))))))) ;;; AGENDA VIEWS -(defun org-x-dag-get-day-entries (_ date &rest args) - "Like `org-agenda-get-day-entries' but better." - ;; for now just return a list of standalone tasks - (->> (org-x-dag-get-standalone-task-nodes org-x-dag) - (org-x-dag-nodes-to-headlines))) - -(defun org-x-dag-agenda-list () - (let ((org-agenda-files (org-x-get-action-files))) - (nd/with-advice - (('org-agenda-get-day-entries :override #'org-x-dag-get-day-entries)) - (org-agenda-list)))) - -;; (defun org-x-dag-tags-view (_match) +;; (defun org-x-dag-show-tasks (_match) ;; (org-x-dag-sync t) -;; (let ((org-agenda-files (org-x-get-action-files))) +;; ;; hack to make the loop only run once +;; (let ((org-agenda-files (list (car (org-x-get-action-files))))) ;; (nd/with-advice -;; (('org-scan-tags :override (lambda (&rest _) (org-x-dag-scan-tags)))) +;; (('org-scan-tags :override (lambda (&rest _) (org-x-dag-scan-tasks)))) ;; (org-tags-view '(4) "TODO")))) -(defun org-x-dag-show-tasks (_match) - (org-x-dag-sync t) - ;; hack to make the loop only run once - (let ((org-agenda-files (list (car (org-x-get-action-files))))) - (nd/with-advice - (('org-scan-tags :override (lambda (&rest _) (org-x-dag-scan-tasks)))) - (org-tags-view '(4) "TODO")))) - (defun org-x-dag-show-nodes (get-nodes) (org-x-dag-sync) (let* ((org-tags-match-list-sublevels org-tags-match-list-sublevels)