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

ENH update iterator scanner

This commit is contained in:
Nathan Dwarshuis 2022-04-02 19:03:07 -04:00
parent 564b231e1c
commit 56436f7147
1 changed files with 176 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -249,17 +249,6 @@ 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-meta (file point level todo title tags planning props parent)
(list :file file
:point point
:level level
:todo todo
:title title
:tags tags
:planning planning
:props props
:buffer-parent parent))
;; state lookup functions ;; state lookup functions
;; ;;
;; all functions with `org-x-dag->' or `org-x-dag-id->' depend on the value of ;; all functions with `org-x-dag->' or `org-x-dag-id->' depend on the value of
@ -315,7 +304,7 @@ that file as it currently sits on disk.")
(plist-get :buffer-status))) (plist-get :buffer-status)))
(defun org-x-dag-id->buffer-parent (id) (defun org-x-dag-id->buffer-parent (id)
(-> (org-x-dag-id->node-meta id) (-> (org-x-dag-id->hl-meta id)
(plist-get :buffer-parent))) (plist-get :buffer-parent)))
(defun org-x-dag-id->ns (id) (defun org-x-dag-id->ns (id)
@ -375,7 +364,7 @@ highest in the tree."
(cl-labels (cl-labels
((ascend ((ascend
(id tags) (id tags)
(-if-let (parent (org-x-dag-id->hl-meta-prop id :buffer-parent)) (-if-let (parent (org-x-dag-id->buffer-parent id))
;; tags in the front of the list have precedence over latter tags, ;; tags in the front of the list have precedence over latter tags,
;; so putting parent tags at the end means child tags have ;; so putting parent tags at the end means child tags have
;; precedence ;; precedence
@ -1300,19 +1289,27 @@ used for optimization."
(when (and (< (point) prop-beg) (looking-at org-planning-line-re)) (when (and (< (point) prop-beg) (looking-at org-planning-line-re))
(org-element-planning-parser prop-beg)))) (org-element-planning-parser prop-beg))))
(defun org-x-dag-nreverse-tree (tree)
(--each tree
(setcdr it (org-x-dag-nreverse-tree (cdr it))))
(nreverse tree))
(defun org-x-dag-get-buffer-nodes (file-meta kws target-props) (defun org-x-dag-get-buffer-nodes (file-meta kws target-props)
(goto-char (point-min)) (goto-char (point-min))
(let* ((line-re (org-x-dag-line-regexp kws)) (let* ((line-re (org-x-dag-line-regexp kws))
(first-hl (org-x-dag-next-headline))
;; If not on a headline, check for a property drawer with links in it
(this-file-links (unless (= ?* (following-char))
(org-x-dag-get-parent-links nil first-hl)))
(pps (--map (cons it (org-re-property it nil t)) target-props)) (pps (--map (cons it (org-re-property it nil t)) target-props))
(id-prop (org-re-property "ID" nil t)) (id-prop (org-re-property "ID" nil t))
(first-hl (unless (= ?* (following-char))
(org-x-dag-next-headline)))
;; If not on a headline, check for a property drawer with links in it
(this-file-links (when first-hl
(org-x-dag-get-parent-links nil first-hl)))
;; stack vars ;; stack vars
bare-stack node-level bury-level bare-stack node-stack bury-level
;; data vars ;; data vars
this-id this-level this-todo this-tags this-links this-pblock pbeg pend this-id this-level this-todo this-tags this-links this-pblock
this-parent this-buffer-parent
pbeg pend
;; return ;; return
acc acc-links) acc acc-links)
(when first-hl (when first-hl
@ -1333,9 +1330,9 @@ used for optimization."
(unless (and bury-level (< bury-level this-level)) (unless (and bury-level (< bury-level this-level))
;; Adjust the stack so that the top headline is the parent of the ;; Adjust the stack so that the top headline is the parent of the
;; current headline ;; current headline
(when (and node-level (<= this-level node-level)) (while (and node-stack (<= this-level (nth 0 (car node-stack))))
(setq node-level nil)) (!cdr node-stack))
(unless node-level (unless node-stack
(while (and bare-stack (<= this-level (nth 0 (car bare-stack)))) (while (and bare-stack (<= this-level (nth 0 (car bare-stack))))
(!cdr bare-stack))) (!cdr bare-stack)))
;; Add the current headline to accumulator if it is a node, but only if ;; Add the current headline to accumulator if it is a node, but only if
@ -1347,41 +1344,50 @@ used for optimization."
pend (nth 2 this-pblock) pend (nth 2 this-pblock)
this-id (org-x-dag-get-local-property pbeg pend id-prop))) this-id (org-x-dag-get-local-property pbeg pend id-prop)))
(setq bury-level nil (setq bury-level nil
this-buffer-parent (nth 2 (car node-stack))
this-links (or (org-x-dag-get-parent-links (nth 3 this-pblock) this-links (or (org-x-dag-get-parent-links (nth 3 this-pblock)
next-pos) next-pos)
(unless node-level (unless node-stack
(nth 2 (car bare-stack))))) (nth 2 (car bare-stack)))))
(when this-tags (when this-tags
(setq this-tags (split-string this-tags ":"))) (setq this-tags (split-string this-tags ":")))
(when (and (not node-level) bare-stack) (when (and (not node-stack) bare-stack)
(setq this-tags (->> (car bare-stack) (setq this-tags (->> (car bare-stack)
(nth 1) (nth 1)
(append this-tags)))) (append this-tags))))
(-> (list (->> (list :point this-point
:id this-id :buffer-parent this-buffer-parent
:parents this-links :effort (when this-title
:node-meta
`(,@file-meta
:point ,this-point
:effort ,(when this-title
(get-text-property 0 'effort this-title)) (get-text-property 0 'effort this-title))
:level ,this-level :level this-level
:todo ,this-todo :todo this-todo
:title ,(if this-title (substring-no-properties this-title) "") :title (if this-title (substring-no-properties this-title) "")
:tags ,this-tags :tags this-tags
:planning ,(org-x-dag-parse-this-planning (nth 0 this-pblock)) :planning (org-x-dag-parse-this-planning (nth 0 this-pblock))
:props ,(org-x-dag-get-local-properties pbeg pend pps))) :props (org-x-dag-get-local-properties pbeg pend pps))
(!cons acc)) (append file-meta)
(list :id this-id
:parents (if this-buffer-parent
`(,this-buffer-parent ,@this-links)
this-links)
:node-meta)
(list)
(setq this-node))
(if node-stack
(-> (setq this-parent (nth 1 (car node-stack)))
(setcdr (cons this-node (cdr this-parent))))
(!cons this-node acc))
(!cons (list this-level this-node this-id) node-stack)
(when this-links (when this-links
(!cons (cons this-id this-links) acc-links)) (!cons (cons this-id this-links) acc-links)))
(setq node-level this-level))
;; Underneath a node but not on a node, therefore we are buried ;; Underneath a node but not on a node, therefore we are buried
(node-level (node-stack
(setq bury-level this-level)) (setq bury-level this-level))
;; Anything else means we are on a bare headline above any nodes ;; Anything else means we are on a bare headline above any nodes
(t (t
(setq bury-level nil (setq bury-level nil
node-level nil) ;; node-level nil)
node-stack nil)
(when this-tags (when this-tags
(setq this-tags (split-string this-tags ":"))) (setq this-tags (split-string this-tags ":")))
(-> (list this-level (-> (list this-level
@ -1391,7 +1397,7 @@ used for optimization."
this-file-links)) this-file-links))
(!cons bare-stack))))) (!cons bare-stack)))))
(goto-char next-pos)) (goto-char next-pos))
(list (nreverse acc) acc-links))) (list (org-x-dag-nreverse-tree acc) acc-links)))
(defun org-x-dag-buffer-nodes-to-tree (nodes) (defun org-x-dag-buffer-nodes-to-tree (nodes)
(cl-labels (cl-labels
@ -1449,27 +1455,27 @@ used for optimization."
(declare (indent 2)) (declare (indent 2))
(let ((err (org-x-dag-bs :error "Child error"))) (let ((err (org-x-dag-bs :error "Child error")))
`(-if-let ((x . xs) ,bss) `(-if-let ((x . xs) ,bss)
;; (if (org-x-dag-bs-error-p x) (progn (print x) ',err)
(if (org-x-dag-bs-error-p x) ',err (if (org-x-dag-bs-error-p x) ',err
(let ((acc x) r) (let ((acc (cadr x)) r final)
(while xs (while (and (not final) xs)
(setq x (car xs)) (setq x (car xs))
(if (org-x-dag-bs-error-p x) (if (org-x-dag-bs-error-p x)
(setq acc ',err (setq final ',err)
xs nil) (setq it (cadr x)
(setq it x
r ,rank-form) r ,rank-form)
(unless r (unless r
(error "You forgot the difference between Maybe and Either")) (error "You forgot the difference between Maybe and Either"))
(if (org-x-dag-bs-error-p r) (if (org-x-dag-bs-error-p r)
(setq acc r (setq final r)
xs nil) (when (cadr r)
(when r (setq acc (cadr x)))
(setq acc x))
(if ,stop-form (if ,stop-form
(setq acc (org-x-dag-bs :valid acc) (setq final (org-x-dag-bs :valid acc))
xs nil)
(!cdr xs))))) (!cdr xs)))))
(org-x-dag-bs>>= acc ,trans-form))) (when (not final)
(setq final (org-x-dag-bs :valid acc)))
(org-x-dag-bs>>= final ,trans-form)))
(org-x-dag-bs :valid ,default)))) (org-x-dag-bs :valid ,default))))
(defun org-x-dag-bs-error-kw (type-name kw) (defun org-x-dag-bs-error-kw (type-name kw)
@ -1529,7 +1535,8 @@ used for optimization."
(`((:sp-task :task-complete ,_) ,_) t) (`((:sp-task :task-complete ,_) ,_) t)
(`(,_ (:sp-proj :proj-complete ,_)) nil) (`(,_ (:sp-proj :proj-complete ,_)) nil)
(`(,_ (:sp-iter :iter-complete ,_)) nil) (`(,_ (:sp-iter :iter-complete ,_)) nil)
(`(,_ (:sp-task :task-complete ,_)) nil)) (`(,_ (:sp-task :task-complete ,_)) nil)
(e (error "Unmatched pattern: %S" e)))
(org-x-dag-bs :valid)) (org-x-dag-bs :valid))
(pcase acc (pcase acc
(`(:sp-proj :proj-complete ,_) nil) (`(:sp-proj :proj-complete ,_) nil)
@ -1617,43 +1624,54 @@ used for optimization."
;; TODO these next two could be made more efficient by cutting out the ;; TODO these next two could be made more efficient by cutting out the
;; earlystop form and returning error in the rank form (the trans form is ;; earlystop form and returning error in the rank form (the trans form is
;; still needed in case there is only one child) ;; still needed in case there is only one child)
(defun org-x-dag-bs-action-subiter-complete-fold (child-bss type-name comp-key) (defun org-x-dag-bs-action-subiter-complete-fold (child-bss comptime type-name comp-key)
(declare (indent 1)) (declare (indent 2))
(org-x-dag-bs-fold-children child-bss `(,comp-key ,it-comptime) (org-x-dag-bs-fold-children child-bss `(,comp-key ,comptime)
(->> (pcase `(,si-a ,si-b) (->> (pcase `(,acc ,it)
(`((:si-complete ,_) (:si-complete ,_)) nil) (`((:si-complete ,_) (:si-complete ,_)) nil)
(`((:si-complete ,_) ,_) t) (`((:si-complete ,_) ,_) t)
(`(,_ (:si-complete ,_)) nil)) (`(,_ (:si-complete ,_)) nil)
(e (error "Unmatched pattern: %S" e)))
(org-x-dag-bs :valid)) (org-x-dag-bs :valid))
(pcase acc (pcase acc
(`(:si-complete ,_) nil) (`(:si-complete ,_) nil)
(_ t)) (_ t))
(pcase it (pcase it
(`(:si-complete ,_) (`(:si-complete ,_)
(org-x-dag-bs :valid `(,comp-key ,it-comptime))) (org-x-dag-bs :valid `(,comp-key ,comptime)))
(_ (_
(->> (format "Completed %s cannot have active children" type-name) (->> (format "Completed %s cannot have active children" type-name)
(org-x-dag-bs :error)))))) (org-x-dag-bs :error))))))
(defun org-x-dag-bs-action-subiter-todo-fold (child-bss type-name active-key default) (defun org-x-dag-bs-action-subiter-todo-fold (child-bss type-name active-key default)
(org-x-dag-bs-fold-children child-bss default (org-x-dag-bs-fold-children child-bss default
(pcase `(,si-a ,si-b) (pcase `(,acc ,it)
(`((:si-active (,ts-a ,dead-a)) (:si-active (,ts-b ,dead-b))) (`((:si-active ,a) (:si-active ,b))
(let ((dt-a (org-ml-timestamp-get-start-time ts-a)) (-let (((&plist :sched as :dead ad) a)
(dt-b (org-ml-timestamp-get-start-time ts-b))) ((&plist :sched bs :dead bd) b))
(cond (cond
((not (eq dead-a dead-b)) ((or (xor as bs) (xor ad bd))
(->> "All sub-iter timestamps must be scheduled or deadlined" (->> "All sub-iters must have the same planning configuration"
(org-x-dag-bs :error))) (org-x-dag-bs :error)))
((xor (org-ml-time-is-long dt-a) (org-ml-time-is-long dt-b)) ((and as bs (xor (org-ml-time-is-long as) (org-ml-time-is-long bs)))
(->> "All sub-iter timestamps must be long or short" (->> "Sub-iters must have scheduled timestamp with same length"
(org-x-dag-bs :error)))
((and ad bd (xor (org-ml-time-is-long ad) (org-ml-time-is-long bd)))
(->> "Sub-iters must have deadline timestamp with same length"
(org-x-dag-bs :error))) (org-x-dag-bs :error)))
(t
;; ASSUME this won't fail since the datetimes are assumed to be the ;; ASSUME this won't fail since the datetimes are assumed to be the
;; same length as per rules above ;; same length as per rules above
(org-x-dag-bs :valid (org-x-dag-datetime< dt-a dt-b)))))) ((and ad bd)
(->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time ad)
(org-ml-timestamp-get-start-time bd))
(org-x-dag-bs :valid)))
(t
(->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time as)
(org-ml-timestamp-get-start-time bs))
(org-x-dag-bs :valid))))))
(`((:si-active ,_) ,_) (org-x-dag-bs :valid nil)) (`((:si-active ,_) ,_) (org-x-dag-bs :valid nil))
(`(,_ (:si-active ,_)) (org-x-dag-bs :valid t))) (`(,_ (:si-active ,_)) (org-x-dag-bs :valid t))
(`(,_ ,_) (org-x-dag-bs :valid nil)))
(pcase acc (pcase acc
(`(:si-active ,_) t) (`(:si-active ,_) t)
(_ nil)) (_ nil))
@ -1665,12 +1683,12 @@ used for optimization."
(org-x-dag-bs :valid `(,active-key ,ts-data)))))) (org-x-dag-bs :valid `(,active-key ,ts-data))))))
(defun org-x-dag-node-is-iterator-p (node) (defun org-x-dag-node-is-iterator-p (node)
(org-x-dag-node-data-is-iterator-p (plist-get node :node-data))) (org-x-dag-node-data-is-iterator-p (plist-get node :node-meta)))
(defun org-x-dag-bs-action-subiter-inner (node-data child-bss) (defun org-x-dag-bs-action-subiter-inner (node-data child-bss)
(org-x-dag-bs-action-with-closed node "sub-iterators" (org-x-dag-bs-action-with-closed node-data "sub-iterators"
`(:si-complete ,it-comptime) `(:si-complete ,it-comptime)
(org-x-dag-bs-action-subiter-complete-fold child-bss (org-x-dag-bs-action-subiter-complete-fold child-bss it-comptime
"sub-iterators" :si-complete) "sub-iterators" :si-complete)
(-let (((sched dead) (-some->> it-planning (-let (((sched dead) (-some->> it-planning
(org-ml-get-properties '(:scheduled :deadline))))) (org-ml-get-properties '(:scheduled :deadline)))))
@ -1679,21 +1697,21 @@ used for optimization."
(org-x-dag-bs :error "Sub-iterators with children cannot be scheduled")) (org-x-dag-bs :error "Sub-iterators with children cannot be scheduled"))
((and dead child-bss) ((and dead child-bss)
(org-x-dag-bs :error "Sub-iterators with children cannot be deadlined")) (org-x-dag-bs :error "Sub-iterators with children cannot be deadlined"))
((and (not child-bss) (not (xor sched dead))) ;; ((and (not child-bss) (not (xor sched dead)))
(org-x-dag-bs :error "Sub-iterators must either be deadlined or scheduled")) ;; (org-x-dag-bs :error "Sub-iterators must either be deadlined or scheduled"))
((org-x-dag-node-data-is-iterator-p node-data) ((org-x-dag-node-data-is-iterator-p node-data)
(org-x-dag-bs :error "Iterators cannot be nested")) (org-x-dag-bs :error "Iterators cannot be nested"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(org-x-dag-bs-action-subiter-todo-fold child-bss (org-x-dag-bs-action-subiter-todo-fold child-bss
"sub-iterator" :si-active "sub-iterator" :si-active
`(:si-active ,(or sched dead) ,(and dead t)))) `(:si-active (:sched ,sched :dead ,dead))))
(t (t
(org-x-dag-bs-error-kw "Sub-iterator" it-todo)))))) (org-x-dag-bs-error-kw "Sub-iterator" it-todo))))))
(defun org-x-dag-bs-action-iter-inner (node-data child-bss) (defun org-x-dag-bs-action-iter-inner (node-data child-bss)
(org-x-dag-bs-action-with-closed node-data "iterators" (org-x-dag-bs-action-with-closed node-data "iterators"
`(:iter-complete ,it-comptime) `(:iter-complete ,it-comptime)
(org-x-dag-bs-action-subiter-complete-fold child-bss (org-x-dag-bs-action-subiter-complete-fold child-bss it-comptime
"iterators" :iter-complete) "iterators" :iter-complete)
(cond (cond
((and child-bss (-some->> it-planning (org-ml-get-property :scheduled))) ((and child-bss (-some->> it-planning (org-ml-get-property :scheduled)))
@ -1756,28 +1774,26 @@ used for optimization."
(t (t
(org-x-dag-bs-error-kw "Endpoint goal" it-todo))))) (org-x-dag-bs-error-kw "Endpoint goal" it-todo)))))
(defun org-x-dag-bs-with-treetop-error (tree parent-id) (defun org-x-dag-bs-with-treetop-error (tree)
(declare (indent 3)) (declare (indent 3))
(-let* (((node . children) tree) (-let* (((node . children) tree)
((&plist :id i :parents links :node-meta m) node) ((&plist :id i :parents ps :node-meta m) node)
(ps (cons parent-id links))
(this (->> (org-x-dag-bs :error "Children not allowed") (this (->> (org-x-dag-bs :error "Children not allowed")
(org-x-dag-node i ps parent-id m)))) (org-x-dag-node i ps m))))
(cons this (--mapcat (org-x-dag-bs-with-treetop-error it i) children)))) (cons this (--mapcat (org-x-dag-bs-with-treetop-error it) children))))
(defun org-x-dag-bs-with-treetop (tree node-fun) (defun org-x-dag-bs-with-treetop (tree node-fun)
(declare (indent 3)) (declare (indent 3))
(-let* ((((&plist :id i :parents links :node-meta m) . children) tree) (-let* ((((&plist :id i :parents ps :node-meta m) . children) tree)
(bs (if children (org-x-dag-bs :error "Children not allowed") (bs (if children (org-x-dag-bs :error "Children not allowed")
(funcall node-fun m))) (funcall node-fun m)))
(top (org-x-dag-node i links nil m bs))) (top (org-x-dag-node i ps m bs)))
(cons top (--mapcat (org-x-dag-bs-with-treetop-error it i) children)))) (cons top (--mapcat (org-x-dag-bs-with-treetop-error it) children))))
(defun org-x-dag-node (id parents buffer-parent node-meta bs) (defun org-x-dag-node (id parents node-meta bs)
(list :id id (list :id id
:parents parents :parents parents
:node-meta (list :hl-meta node-meta :node-meta (list :hl-meta node-meta
:buffer-parent buffer-parent
:buffer-status bs))) :buffer-status bs)))
(defmacro org-x-dag-node-fmap (node form) (defmacro org-x-dag-node-fmap (node form)
@ -1786,34 +1802,32 @@ used for optimization."
`(-let (((&plist :id i `(-let (((&plist :id i
:parents ps :parents ps
:node-meta (&plist :hl-meta h :node-meta (&plist :hl-meta h
:buffer-parent p
:buffer-status it)) :buffer-status it))
,node)) ,node))
(org-x-dag-node i ps p h ,form))) (org-x-dag-node i ps h ,form)))
(defun org-x-dag-bs-with-children (tree parent child-fun node-fun concat-fun) (defun org-x-dag-bs-with-children (tree child-fun node-fun concat-fun)
(declare (indent 3)) (declare (indent 3))
;; TODO this is super inefficient, make a plist mapper function ;; TODO this is super inefficient, make a plist mapper function
(-let* (((node . children) tree) (-let* (((node . children) tree)
((&plist :id i :parents links :node-meta m) node) ((&plist :id i :parents ps :node-meta m) node)
((shallow rest) (->> (--map (funcall child-fun it i) children) ((shallow rest) (->> (--map (funcall child-fun it) children)
(apply #'-zip-lists))) (apply #'-zip-lists))))
(ps (if parent (cons parent links) links)))
(list (->> shallow (list (->> shallow
(--map (plist-get (plist-get it :node-meta) :buffer-status)) (--map (plist-get (plist-get it :node-meta) :buffer-status))
(funcall node-fun m) (funcall node-fun m)
(org-x-dag-node i ps parent m)) (org-x-dag-node i ps m))
(funcall concat-fun shallow rest)))) (funcall concat-fun shallow rest))))
;; Tree a -> (Tree a -> (b, [d])) -> (a -> [b] -> c) -> (c, [d]) ;; Tree a -> (Tree a -> (b, [d])) -> (a -> [b] -> c) -> (c, [d])
(defun org-x-dag-bs-with-children-1 (tree parent child-fun node-fun) (defun org-x-dag-bs-with-children-1 (tree child-fun node-fun)
(org-x-dag-bs-with-children tree parent child-fun node-fun (org-x-dag-bs-with-children tree child-fun node-fun
(lambda (shallow deep) (lambda (shallow deep)
(append shallow (-flatten-n 1 deep))))) (append shallow (-flatten-n 1 deep)))))
;; Tree a -> (Tree a -> (b, ([d], [e]))) -> (a -> [b] -> c) -> (c, ([d], [e])) ;; Tree a -> (Tree a -> (b, ([d], [e]))) -> (a -> [b] -> c) -> (c, ([d], [e]))
(defun org-x-dag-bs-with-children-2 (tree parent child-fun node-fun) (defun org-x-dag-bs-with-children-2 (tree child-fun node-fun)
(org-x-dag-bs-with-children tree parent child-fun node-fun (org-x-dag-bs-with-children tree child-fun node-fun
(lambda (shallow deep) (lambda (shallow deep)
(--reduce-from (-let (((a b) acc) (--reduce-from (-let (((a b) acc)
((as bs) it)) ((as bs) it))
@ -1821,43 +1835,43 @@ used for optimization."
`(,shallow nil) `(,shallow nil)
deep)))) deep))))
(defun org-x-dag-bs-action-subiter (tree parent) (defun org-x-dag-bs-action-subiter (tree)
(org-x-dag-bs-with-children-1 (org-x-dag-bs-with-children-1
tree tree
parent
#'org-x-dag-bs-action-subiter #'org-x-dag-bs-action-subiter
#'org-x-dag-bs-action-subiter-inner)) #'org-x-dag-bs-action-subiter-inner))
(defun org-x-dag-bs-action-iter (tree parent) (defun org-x-dag-bs-action-iter (tree)
(org-x-dag-bs-with-children-1 (org-x-dag-bs-with-children-1
tree tree
parent
#'org-x-dag-bs-action-subiter #'org-x-dag-bs-action-subiter
(lambda (node child-bss) (lambda (node-data child-bss)
(org-x-dag-node-fmap node (org-x-dag-bs-fmap (org-x-dag-bs-action-iter-inner node-data child-bss)
(org-x-dag-bs-fmap (org-x-dag-bs-action-iter-inner it child-bss) (cons :sp-proj it)))))
`(:sp-proj it))))))
(defun org-x-dag-bs-action-project (tree parent) (defun org-x-dag-bs-action-project (tree)
(if (org-x-dag-node-is-iterator-p (car tree)) (if (org-x-dag-node-is-iterator-p (car tree))
(-let (((iter subiters) (org-x-dag-bs-action-iter tree nil))) (-let (((iter subiters) (org-x-dag-bs-action-iter tree)))
`(,iter (nil ,subiters))) `(,iter (nil ,subiters)))
(org-x-dag-bs-with-children-2 (org-x-dag-bs-with-children-2
tree tree
parent
#'org-x-dag-bs-action-project #'org-x-dag-bs-action-project
#'org-x-dag-bs-action-project-inner))) #'org-x-dag-bs-action-project-inner)))
;; TODO need to check for created timestamps ;; TODO need to check for created timestamps
(defun org-x-dag-bs-action (node-tree) (defun org-x-dag-bs-action (node-tree)
;; TODO these types might not line up properly (cl-flet
(-let (((p (ps is)) (org-x-dag-bs-action-project node-tree nil))) ((lift-subiter
`(,p ,@ps ,@is))) (node)
(org-x-dag-node-fmap node
(org-x-dag-bs-fmap it
(cons :sp-subiter it)))))
(-let (((p (ps is)) (org-x-dag-bs-action-project node-tree)))
`(,p ,@ps ,@(-map #'lift-subiter is)))))
(defun org-x-dag-bs-epg-outer (tree parent) (defun org-x-dag-bs-epg-outer (tree)
(org-x-dag-bs-with-children-1 (org-x-dag-bs-with-children-1
tree tree
parent
#'org-x-dag-bs-epg-outer #'org-x-dag-bs-epg-outer
#'org-x-dag-bs-epg-inner)) #'org-x-dag-bs-epg-inner))
@ -1865,7 +1879,7 @@ used for optimization."
(--map (org-x-dag-node-fmap it (org-x-dag-bs-fmap it `(,key ,it))) nodes)) (--map (org-x-dag-node-fmap it (org-x-dag-bs-fmap it `(,key ,it))) nodes))
(defun org-x-dag-bs-epg (tree) (defun org-x-dag-bs-epg (tree)
(-let (((n ns) (org-x-dag-bs-epg-outer tree nil))) (-let (((n ns) (org-x-dag-bs-epg-outer tree)))
(org-x-dag-bs-prefix :endpoint `(,n ,@ns)))) (org-x-dag-bs-prefix :endpoint `(,n ,@ns))))
(defun org-x-dag-bs-toplevel-goal-inner (type-name node-data child-bss) (defun org-x-dag-bs-toplevel-goal-inner (type-name node-data child-bss)
@ -1881,17 +1895,16 @@ used for optimization."
(t (t
(org-x-dag-bs-error-kw type-name todo))))) (org-x-dag-bs-error-kw type-name todo)))))
(defun org-x-dag-bs-toplevel-goal-outer (type-name tree parent) (defun org-x-dag-bs-toplevel-goal-outer (type-name tree)
(org-x-dag-bs-with-children-1 (org-x-dag-bs-with-children-1
tree tree
parent (lambda (tree)
(lambda (tree parent) (org-x-dag-bs-toplevel-goal-outer type-name tree))
(org-x-dag-bs-toplevel-goal-outer type-name tree parent))
(lambda (node-data child-bss) (lambda (node-data child-bss)
(org-x-dag-bs-toplevel-goal-inner type-name node-data child-bss)))) (org-x-dag-bs-toplevel-goal-inner type-name node-data child-bss))))
(defun org-x-dag-bs-toplevel-goal (type-name type-key tree) (defun org-x-dag-bs-toplevel-goal (type-name type-key tree)
(-let (((n ns) (org-x-dag-bs-toplevel-goal-outer type-name tree nil))) (-let (((n ns) (org-x-dag-bs-toplevel-goal-outer type-name tree)))
(org-x-dag-bs-prefix type-key `(,n ,@ns)))) (org-x-dag-bs-prefix type-key `(,n ,@ns))))
(defun org-x-dag-bs-ltg (tree) (defun org-x-dag-bs-ltg (tree)
@ -1994,9 +2007,7 @@ used for optimization."
((nodes links) ((nodes links)
(org-x-with-file file (org-x-with-file file
(org-x-dag-get-buffer-nodes meta org-todo-keywords-1 props)))) (org-x-dag-get-buffer-nodes meta org-todo-keywords-1 props))))
(list (->> (org-x-dag-buffer-nodes-to-tree nodes) `(,(-mapcat bs-fun nodes) ,links)))
(-mapcat bs-fun))
links)))
;; network status ;; network status
@ -2037,13 +2048,6 @@ used for optimization."
(format "%s: %s" msg) (format "%s: %s" msg)
(org-x-dag-bs :error))) (org-x-dag-bs :error)))
(defun org-x-dag-id-is-buffer-leaf (adjlist id)
(->> (plist-get (ht-get adjlist id) :children)
(--none-p (-> (ht-get adjlist it)
(plist-get :node-meta)
(plist-get :buffer-parent)
(equal id)))))
(defun org-x-dag-ns-toplevel (tbl adjlist links ns) (defun org-x-dag-ns-toplevel (tbl adjlist links ns)
(let ((h (alist-get tbl ns))) (let ((h (alist-get tbl ns)))
(org-x-dag-each-links links (org-x-dag-each-links links
@ -2077,7 +2081,7 @@ used for optimization."
(cond (cond
((org-x-dag-bs-error-p (ht-get h id)) ((org-x-dag-bs-error-p (ht-get h id))
:error) :error)
((and checkleafp (not (org-x-dag-id-is-buffer-leaf adjlist id))) ((and checkleafp (not (org-x-dag-get-children adjlist id)))
:non-leaf) :non-leaf)
(t :valid))) (t :valid)))
(reduce-valid (reduce-valid
@ -2204,6 +2208,7 @@ used for optimization."
(->> (plist-get (ht-get adjlist id) :children) (->> (plist-get (ht-get adjlist id) :children)
(--filter (-> (ht-get adjlist it) (--filter (-> (ht-get adjlist it)
(plist-get :node-meta) (plist-get :node-meta)
(plist-get :hl-meta)
(plist-get :buffer-parent) (plist-get :buffer-parent)
(equal id))))) (equal id)))))
@ -2239,16 +2244,9 @@ used for optimization."
(defun org-x-dag-ht-propagate-up (adjlist h-key s-key ns) (defun org-x-dag-ht-propagate-up (adjlist h-key s-key ns)
(cl-labels (cl-labels
((get-children ((propagate
(adjlist id)
(->> (plist-get (ht-get adjlist id) :children)
(--filter (-> (ht-get adjlist it)
(plist-get :node-meta)
(plist-get :buffer-parent)
(equal id)))))
(propagate
(htbl id) (htbl id)
(-let* ((cs (get-children adjlist id)) (-let* ((cs (org-x-dag-get-children adjlist id))
(rs (--map (propagate htbl it) cs)) (rs (--map (propagate htbl it) cs))
;; TODO there isn't a better way to do this? (seems like I'm ;; TODO there isn't a better way to do this? (seems like I'm
;; accessing either/maybe types too many times) ;; accessing either/maybe types too many times)
@ -3194,20 +3192,22 @@ except it ignores inactive timestamps."
(-mapcat #'split-parent-goals)))) (-mapcat #'split-parent-goals))))
(defun org-x-dag-scan-iterators () (defun org-x-dag-scan-iterators ()
(cl-flet* (cl-flet
((format-result ((format-id
(tags cat key) (id status-data)
(-let ((status (org-x-dag-headline-get-iterator-status key))) (let ((status (car status-data)))
(-> (org-x-dag-format-tag-node cat tags key) (when (memq status '(:iter-empty :iter-active))
(let ((tags (org-x-dag-id->tags nil id)))
(-> (org-x-dag-format-tag-node tags id)
(org-add-props nil (org-add-props nil
'x-status status))))) 'x-status status)))))))
;; TODO this will only scan toplevel iterators (with-temp-buffer
(org-x-dag-with-files (org-x-dag->action-files) (org-mode)
(org-x-dag-id->is-toplevel-p it) (->> (org-x-dag->action-files)
(let ((tags (org-x-dag-id->tags nil it))) (org-x-dag-files->ids)
(when (eq (cadr (org-x-dag-id->goal-status 'current id)) :planned) (--map (pcase (org-x-dag-id->bs it)
(when (org-x-dag-id->is-iterator-p it) (`(:valid (:sp-proj . ,s)) (format-id it s))))
(list (format-result tags it-category it)))))))) (-non-nil)))))
(defun org-x-dag-get-task-nodes (pred id) (defun org-x-dag-get-task-nodes (pred id)
(declare (indent 2)) (declare (indent 2))
@ -3375,30 +3375,24 @@ except it ignores inactive timestamps."
(defun org-x-dag-scan-archived () (defun org-x-dag-scan-archived ()
(cl-flet (cl-flet
((format-key ((format-key
(category key) (id bs)
(let ((tags (org-x-dag-id->tags nil key))) (-when-let ((comptime is-project)
;; TODO is this what I actually want? (pcase bs
(when (memq (cadr (org-x-dag-id->goal-status 'current key)) '(:planned :committed)) (`(:sp-proj :proj-complete ,c) `(,c t))
(-let (((is-archivable is-project) (`(:sp-task :task-complete ,c) `(,c nil))))
(-if-let (children (org-x-dag-id->buffer-children key)) (-let ((epoch (plist-get comptime :epoch)))
(-> (org-x-dag-headline-get-project-status key tags children) (when (org-x-dag-time-is-archivable-p epoch)
(alist-get org-x-project-status-priorities) (let ((tags (org-x-dag-id->tags nil id)))
(eq :archivable) (-> (org-x-dag-format-tag-node tags id)
(list t))
(-> (org-x-dag-id->task-status id)
(alist-get org-x-headline-task-status-priorities)
(eq :archivable)
(list t)))))
(when is-archivable
(-> (org-x-dag-format-tag-node category tags key)
(org-add-props nil (org-add-props nil
'x-project-p is-project)))))))) 'x-project-p is-project))))))))
(org-x-dag-with-files (org-x-get-action-files) (with-temp-buffer
(org-x-dag-id->is-toplevel-p it) (org-mode)
(if (org-x-dag->is-iterator-p it) (->> (org-x-dag->action-files)
(->> (org-x-dag-id->buffer-children it) (org-x-dag-files->ids)
(--map (format-key it-category it))) (--map (pcase (org-x-dag-id->bs it)
(list (format-key it-category it)))))) (`(:valid ,v) (format-key it v))))
(-non-nil)))))
(defun org-x-dag--classify-goal-link (which which-goal id) (defun org-x-dag--classify-goal-link (which which-goal id)
(let ((f (org-x-dag-id->file id))) (let ((f (org-x-dag-id->file id)))