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

REF clean up buffer status functions

This commit is contained in:
Nathan Dwarshuis 2022-03-25 19:17:53 -04:00
parent 9f75fd1905
commit 42758a7f43
1 changed files with 315 additions and 319 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1294,6 +1294,17 @@ 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-node (id parents node-meta)
(list :id id
:parents parents
:node-meta node-meta))
(defmacro org-x-dag-node-fmap (node form)
(declare (indent 1))
;; TODO not efficient (may or may not matter)
`(-let (((&plist :id i :parents ps :node-meta it) ,node))
(org-x-dag-node i ps ,form)))
(defun org-x-dag-get-buffer-nodes (file-meta kws target-props) (defun org-x-dag-get-buffer-nodes (file-meta kws target-props)
(let ((more t) (let ((more t)
(line-re (org-x-dag-line-regexp kws)) (line-re (org-x-dag-line-regexp kws))
@ -1418,12 +1429,9 @@ used for optimization."
(defun org-x-dag-bs-error-p (bs) (defun org-x-dag-bs-error-p (bs)
(eq (car bs) :error)) (eq (car bs) :error))
(defun org-x-dag-complete-time (epoch canceledp)
(list epoch canceledp))
;; [Status a] -> b -> (a -> a -> Status Bool) -> (a -> Bool) -> (a -> Status b) ;; [Status a] -> b -> (a -> a -> Status Bool) -> (a -> Bool) -> (a -> Status b)
;; -> Status b ;; -> Status b
(defmacro org-x-dag-fold-child-bss (bss default rank-form stop-form trans-form) (defmacro org-x-dag-bs-fold-children (bss default rank-form stop-form trans-form)
(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)
@ -1450,33 +1458,41 @@ used for optimization."
(org-x-dag-bs>>= acc ,trans-form))) (org-x-dag-bs>>= acc ,trans-form)))
(org-x-dag-bs :valid ,default)))) (org-x-dag-bs :valid ,default))))
(defun org-x-dag-bs-error-kw (type-name kw)
(->> (format "%ss cannot have keyword '%s" type-name kw)
(org-x-dag-bs :error)))
(defmacro org-x-dag-bs-action-with-closed (node-data type-name canc-bs-form (defmacro org-x-dag-bs-action-with-closed (node-data type-name canc-bs-form
done-form open-form) done-form open-form)
(declare (indent 2)) (declare (indent 2))
(let ((c (make-symbol "--closed"))) (let ((c (make-symbol "--closed")))
`(-let (((&plist :todo it-todo :planning it-planning) ,node-data)) `(cl-flet
(-if-let (,c (-some->> it-planning ((complete-time
(org-ml-get-property :closed) (epoch canceledp)
(org-ml-timestamp-get-start-time) (list :epoch epoch :canceledp canceledp)))
(org-ml-time-to-unixtime))) (-let (((&plist :todo it-todo :planning it-planning) ,node-data))
(-if-let (,c (-some->> it-planning
(org-ml-get-property :closed)
(org-ml-timestamp-get-start-time)
(org-ml-time-to-unixtime)))
(cond
((equal it-todo org-x-kw-canc)
(let ((it-comptime (complete-time ,c t)))
(org-x-dag-bs :valid ,canc-bs-form)))
((equal it-todo org-x-kw-done)
(let ((it-comptime (complete-time ,c nil)))
,done-form))
(t
(->> (format "Closed %s must be marked CANC/DONE" ,type-name)
(org-x-dag-bs :error))))
(cond (cond
((equal it-todo org-x-kw-canc) ((member it-todo org-x-done-keywords)
(let ((it-comptime (org-x-dag-complete-time ,c t))) (->> (format "DONE/CANC %s must be closed" ,type-name)
(org-x-dag-bs :valid ,canc-bs-form))) (org-x-dag-bs :error)))
((equal it-todo org-x-kw-done)
(let ((it-comptime (org-x-dag-complete-time ,c nil)))
,done-form))
(t (t
(->> (format "Closed %s must be marked CANC/DONE" ,type-name) ,open-form)))))))
(org-x-dag-bs :error))))
(cond
((member it-todo org-x-done-keywords)
(->> (format "DONE/CANC %s must be closed" ,type-name)
(org-x-dag-bs :error)))
(t
,open-form))))))
(defun org-x-dag-action-project-bs-inner (node-data child-bss) (defun org-x-dag-bs-action-project-inner (node-data child-bss)
(cl-flet (cl-flet
((new-proj ((new-proj
(status) (status)
@ -1487,7 +1503,7 @@ used for optimization."
`(:sp-proj :proj-complete ,it-comptime) `(:sp-proj :proj-complete ,it-comptime)
;; done form ;; done form
(org-x-dag-fold-child-bss child-bss `(:sp-task :task-complete ,it-comptime) (org-x-dag-bs-fold-children child-bss `(:sp-task :task-complete ,it-comptime)
;; TODO this could be slightly more efficient if the error type is ;; TODO this could be slightly more efficient if the error type is
;; returned in this form and not the last ;; returned in this form and not the last
(->> (pcase `(,acc ,it) (->> (pcase `(,acc ,it)
@ -1514,8 +1530,8 @@ used for optimization."
(_ (org-x-dag-bs :error "Completed projects cannot have active children")))) (_ (org-x-dag-bs :error "Completed projects cannot have active children"))))
;; undone form ;; undone form
(-let* ((sched (-some->> it-planning (org-ml-get-property :scheduled))) (-let* (((sched dead) (-some->> it-planning
(dead (-some->> it-planning (org-ml-get-property :deadline))) (org-ml-get-properties '(:scheduled :deadline))))
(task-default `(:sp-task :task-active (,it-todo ,sched ,dead)))) (task-default `(:sp-task :task-active (,it-todo ,sched ,dead))))
(cond (cond
((equal it-todo org-x-kw-hold) ((equal it-todo org-x-kw-hold)
@ -1523,7 +1539,7 @@ used for optimization."
((and sched child-bss) ((and sched child-bss)
(org-x-dag-bs :error "Projects cannot be scheduled")) (org-x-dag-bs :error "Projects cannot be scheduled"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(org-x-dag-fold-child-bss child-bss task-default (org-x-dag-bs-fold-children child-bss task-default
(->> (pcase `(,acc ,it) (->> (pcase `(,acc ,it)
(`((:sp-proj :proj-active) ,_) nil) (`((:sp-proj :proj-active) ,_) nil)
(`((:sp-iter :iter-active ,_) ,_) nil) (`((:sp-iter :iter-active ,_) ,_) nil)
@ -1572,15 +1588,13 @@ used for optimization."
((equal c-todo org-x-kw-next) (new-proj :proj-active)) ((equal c-todo org-x-kw-next) (new-proj :proj-active))
((equal c-todo org-x-kw-wait) (new-proj :proj-wait)) ((equal c-todo org-x-kw-wait) (new-proj :proj-wait))
((equal c-todo org-x-kw-hold) (new-proj :proj-hold)) ((equal c-todo org-x-kw-hold) (new-proj :proj-hold))
(t (->> (format "Undefined keyword: %s" c-todo) (t (org-x-dag-bs-error-kw "Task action" c-todo)))))))
(org-x-dag-bs :error))))))))
(child-bss (child-bss
(->> (format "Projects cannot have keyword '%s'" it-todo) (org-x-dag-bs-error-kw "Project action" it-todo))
(org-x-dag-bs :error)))
(t (t
task-default)))))) task-default))))))
(defun org-x-dag-action-subiter-rank (si-a si-b) (defun org-x-dag-bs-action-subiter-todo-rank (si-a si-b)
(pcase `(,si-a ,si-b) (pcase `(,si-a ,si-b)
(`((:si-active (,ts-a ,dead-a)) (:si-active (,ts-b ,dead-b))) (`((:si-active (,ts-a ,dead-a)) (:si-active (,ts-b ,dead-b)))
(let ((dt-a (org-ml-timestamp-get-start-time ts-a)) (let ((dt-a (org-ml-timestamp-get-start-time ts-a))
@ -1599,28 +1613,75 @@ used for optimization."
(`((: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))))
(defun org-x-dag-action-subiter-bs-inner (node-data child-bss) (defun org-x-dag-bs-action-subiter-complete-rank (si-a si-b)
(->> (pcase `(,si-a ,si-b)
(`((:si-complete ,_) (:si-complete ,_)) nil)
(`((:si-complete ,_) ,_) t)
(`(,_ (:si-complete ,_)) nil))
(org-x-dag-bs :valid)))
(defun org-x-dag-node-data-is-iterator-p (node-data)
(-let (((&plist :props) node-data))
(-when-let (p (alist-get org-x-prop-parent-type props nil nil #'equal))
(equal p org-x-prop-parent-type-iterator))))
(defun org-x-dag-bs-action-subiter-complete-fold (child-bss type-name comp-key)
(declare (indent 1))
(org-x-dag-bs-fold-children child-bss `(,comp-key ,it-comptime)
(->> (pcase `(,si-a ,si-b)
(`((:si-complete ,_) (:si-complete ,_)) nil)
(`((:si-complete ,_) ,_) t)
(`(,_ (:si-complete ,_)) nil))
(org-x-dag-bs :valid))
(pcase acc
(`(:si-complete ,_) nil)
(_ t))
(pcase it
(`(:si-complete ,_)
(org-x-dag-bs :valid `(,comp-key ,it-comptime)))
(_
(->> (format "Completed %s cannot have active children" type-name)
(org-x-dag-bs :error))))))
(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
(pcase `(,si-a ,si-b)
(`((:si-active (,ts-a ,dead-a)) (:si-active (,ts-b ,dead-b)))
(let ((dt-a (org-ml-timestamp-get-start-time ts-a))
(dt-b (org-ml-timestamp-get-start-time ts-b)))
(cond
((not (eq dead-a dead-b))
(->> "All sub-iter timestamps must be scheduled or deadlined"
(org-x-dag-bs :error)))
((xor (org-ml-time-is-long dt-a) (org-ml-time-is-long dt-b))
(->> "All sub-iter timestamps must be long or short"
(org-x-dag-bs :error)))
(t
;; ASSUME this won't fail since the datetimes are assumed to be the
;; same length as per rules above
(org-x-dag-bs :valid (org-x-dag-datetime< dt-a dt-b))))))
(`((:si-active ,_) ,_) (org-x-dag-bs :valid nil))
(`(,_ (:si-active ,_)) (org-x-dag-bs :valid t)))
(pcase acc
(`(:si-active ,_) t)
(_ nil))
(pcase it
(`(:si-complete ,_)
(->> (format "Active %s must have at least one active child" type-name)
(org-x-dag-bs :error)))
(`(:si-active ,ts-data)
(org-x-dag-bs :valid `(,active-key ,ts-data))))))
(defun org-x-dag-node-is-iterator-p (node)
(org-x-dag-node-data-is-iterator-p (plist-get node :node-data)))
(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 "sub-iterators"
`(:si-complete ,it-comptime) `(:si-complete ,it-comptime)
(org-x-dag-bs-action-subiter-complete-fold child-bss
;; done form "sub-iterators" :si-complete)
(org-x-dag-fold-child-bss child-bss `(:si-complete ,it-comptime) (-let (((sched dead) (-some->> it-planning
(->> (pcase `(,acc ,it) (org-ml-get-properties '(:scheduled :deadline)))))
(`((:si-complete ,_) (:si-complete ,_)) nil)
(`((:si-complete ,_) ,_) t)
(`(,_ (:si-complete ,_)) nil))
(org-x-dag-bs :valid))
(pcase acc
(`(:si-complete ,_) nil)
(_ t))
(pcase it
(`(:si-complete ,_)
(org-x-dag-bs :valid `(:si-complete ,it-comptime)))
(_ (org-x-dag-bs :error "Completed sub-iterators cannot have active children"))))
;; undone form
(-let* ((sched (org-ml-get-property :scheduled it-planning))
(dead (org-ml-get-property :dead ti-planning)))
(cond (cond
((and sched child-bss) ((and sched child-bss)
(org-x-dag-bs :error "Sub-iterators with children cannot be scheduled")) (org-x-dag-bs :error "Sub-iterators with children cannot be scheduled"))
@ -1628,146 +1689,35 @@ used for optimization."
(org-x-dag-bs :error "Sub-iterators with children cannot be deadlined")) (org-x-dag-bs :error "Sub-iterators with children cannot be deadlined"))
((not (xor sched dead)) ((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"))
;; todo test for iterator property here ((org-x-dag-node-data-is-iterator-p node-data)
(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-fold-child-bss child-bss (->> `(,(or sched dead) ,(and dead t)) (org-x-dag-bs-action-subiter-todo-fold child-bss
(list :si-active)) "sub-iterator" :si-active
(org-x-dag-action-subiter-rank acc it) `(:si-active ,(or sched dead) ,(and dead t))))
(pcase acc
(`(:si-active ,_) t)
(_ nil))
(pcase it
(`(:si-complete ,_)
(->> "Active iterators must have at least one active child"
(org-x-dag-bs :error)))
(`(:si-active ,ts-data)
(org-x-dag-bs :valid `(:si-active ,ts-data))))))
(t (t
(->> (format "Sub-iterators cannot have keyword '%s'" it-todo) (org-x-dag-bs-error-kw "Sub-iterator" it-todo))))))
(org-x-dag-bs :error)))))))
(defun org-x-dag-action-iter-bs-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
"iterators" :iter-complete)
(cond
((and child-bss (-some->> it-planning (org-ml-get-property :scheduled)))
(org-x-dag-bs :error "Iterators cannot be scheduled"))
;; TODO also check for timeshift and archive props
((equal it-todo org-x-kw-todo)
(org-x-dag-bs-action-subiter-todo-fold child-bss
"iterator" :iter-active
'(:iter-empty)))
(t
(org-x-dag-bs-error-kw "Iterator" it-todo)))))
;; done form (defun org-x-dag-bs-epg-inner (node child-bss)
(org-x-dag-fold-child-bss child-bss `(:iter-complete ,it-comptime)
(->> (pcase `(,acc ,it)
(`((:si-complete ,_) (:si-complete ,_)) nil)
(`((:si-complete ,_) ,_) t)
(`(,_ (:si-complete ,_)) nil))
(org-x-dag-bs :valid))
(pcase acc
(`(:si-complete ,_) nil)
(_ t))
(pcase it
(`(:si-complete ,_)
(org-x-dag-bs :valid `(:iter-complete ,it-comptime)))
(_ (org-x-dag-bs :error "Completed iterators cannot have active children"))))
;; undone form
(-let* ((sched (org-ml-get-property :scheduled it-planning)))
(cond
((and sched child-bss)
(org-x-dag-bs :error "Iterators cannot be scheduled"))
((equal it-todo org-x-kw-todo)
(org-x-dag-fold-child-bss child-bss '(:iter-empty)
(org-x-dag-action-subiter-rank acc it)
(pcase acc
(`(:si-active ,_) t)
(_ nil))
(pcase it
(`(:si-complete ,_)
(->> "Active iterators must have at least one active child"
(org-x-dag-bs :error)))
(`(:si-active ,ts-data)
(org-x-dag-bs :valid `(:iter-active ,ts-data))))))
(t
(->> (format "Iterators cannot have keyword '%s'" it-todo)
(org-x-dag-bs :error)))))))
(defun org-x-dag-node (id parents node-meta)
(list :id id
:parents parents
:node-meta node-meta))
(defmacro org-x-dag-node-fmap (node form)
(declare (indent 1))
;; TODO not efficient (may or may not matter)
`(-let (((&plist :id i :parents ps :node-meta it) ,node))
(org-x-dag-node i ps ,form)))
;; TODO add a slot for the buffer parent (so that we know which are toplevel and not)
(defun org-x-dag-with-children (tree child-fun node-fun concat-fun)
(declare (indent 3))
;; TODO this is super inefficient, make a plist mapper function
(-let* (((node . children) tree)
((&plist :id n :parents ps :node-meta m) node)
((shallow rest) (->> (-map child-fun children)
(apply #'-zip-lists)))
(shallow*
(--map (-let (((&plist :id ci :parents cps :node-meta cm) it))
(list :id ci :parents (cons n cps) :node-meta cm))
shallow)))
(list (->> (--map (plist-get it :node-meta) shallow)
(funcall node-fun m)
(org-x-dag-node n ps))
(funcall concat-fun shallow* rest))))
;; Tree a -> (Tree a -> (b, [d])) -> (a -> [b] -> c) -> (c, [d])
(defun org-x-dag-with-children-1 (tree child-fun node-fun)
(org-x-dag-with-children tree child-fun node-fun
(lambda (shallow deep)
(append shallow (-flatten-n 1 deep)))))
;; Tree a -> (Tree a -> (b, ([d], [e]))) -> (a -> [b] -> c) -> (c, ([d], [e]))
(defun org-x-dag-with-children-2 (tree child-fun node-fun)
(org-x-dag-with-children tree child-fun node-fun
(lambda (shallow deep)
(--reduce-from (-let (((a b) acc)
((as bs) it))
`((,@as ,@a) (,@bs ,@b)))
`(,shallow nil)
deep))))
(defun org-x-dag-action-subiter-bs (tree)
(org-x-dag-with-children-1
tree
#'org-x-dag-action-subiter-bs
#'org-x-dag-action-subiter-bs-inner))
(defun org-x-dag-action-iter-bs (tree)
(org-x-dag-with-children-1
tree
#'org-x-dag-action-subiter-bs
;; TODO this doesn't map deep enough
(lambda (node child-bss)
(org-x-dag-node-fmap node
(org-x-dag-bs-fmap (org-x-dag-action-iter-bs-inner it child-bss)
`(:sp-proj it))))))
(defun org-x-dag-action-project-bs (tree)
(-let* (((node . children) tree)
((&plist :props) node)
(pt (alist-get org-x-prop-parent-type props nil nil #'equal)))
(if (equal pt org-x-prop-parent-type-iterator)
(-let (((iter subiters) (org-x-dag-action-iter-bs tree)))
`(,iter (nil ,subiters)))
(org-x-dag-with-children-2
tree
#'org-x-dag-action-project-bs
#'org-x-dag-action-project-bs-inner))))
;; TODO need to check for created timestamps
(defun org-x-dag-action-bs (node-tree)
;; TODO these types might not line up properly
(-let (((p (ps is)) (org-x-dag-action-project-bs node-tree)))
`(,p ,@ps ,@is)))
(defun org-x-dag-epg-bs-inner (node child-bss)
(org-x-dag-bs-action-with-closed node "endpoint goal" (org-x-dag-bs-action-with-closed node "endpoint goal"
`(:complete ,comp-time) `(:complete ,comp-time)
(org-x-dag-fold-child-bss child-bss `(:complete ,comp-time) (org-x-dag-bs-fold-children child-bss `(:complete ,comp-time)
(->> (pcase `(,acc ,it) (->> (pcase `(,acc ,it)
(`((:complete ,_) (:complete ,_)) nil) (`((:complete ,_) (:complete ,_)) nil)
(`(,_ (:complete ,_)) nil) (`(,_ (:complete ,_)) nil)
@ -1780,13 +1730,12 @@ used for optimization."
(`(:complete ,_) (`(:complete ,_)
(org-x-dag-bs :valid `(:complete ,it-comptime))) (org-x-dag-bs :valid `(:complete ,it-comptime)))
(_ (org-x-dag-bs :error "Completed EPGs cannot have active children")))) (_ (org-x-dag-bs :error "Completed EPGs cannot have active children"))))
(let ((sched (-some->> it-planning (org-ml-get-property :scheduled))) (cond
(dead (-some->> it-planning (org-ml-get-property :deadline)))) ((-some->> it-planning (org-ml-get-property :scheduled))
(cond (org-x-dag-bs :error "EPGs cannot be scheduled"))
(sched ((equal it-todo org-x-kw-todo)
(org-x-dag-bs :error "EPGs cannot be scheduled")) (let ((dead (-some->> it-planning (org-ml-get-property :deadline))))
((equal it-todo org-x-kw-todo) (org-x-dag-bs-fold-children child-bss `(:active ,dead)
(org-x-dag-fold-child-bss child-bss `(:active ,dead)
(->> (pcase `(,acc ,it) (->> (pcase `(,acc ,it)
(`((:active ,_) (:active ,_)) nil) (`((:active ,_) (:active ,_)) nil)
(`(,_ (:active ,_)) t) (`(,_ (:active ,_)) t)
@ -1811,74 +1760,145 @@ used for optimization."
(t (t
(org-x-dag-bs :error "Child deadlines must be before parent deadlines"))))) (org-x-dag-bs :error "Child deadlines must be before parent deadlines")))))
(_ (_
(org-x-dag-bs :error "Active EPGs must have at least one active child"))))) (org-x-dag-bs :error "Active EPGs must have at least one active child"))))))
(t (t
(->> (format "EPG with invalid keyword: %s" it-todo) (org-x-dag-bs-error-kw "Endpoint goal" it-todo)))))
(org-x-dag-bs :error)))))))
(defun org-x-dag-epg-bs-outer (tree) (defun org-x-dag-bs-with-treetop-error (tree parent-node)
(org-x-dag-with-children-1 (declare (indent 3))
(-let* (((node . children) tree)
((&plist :id i :parents ps) node)
((&plist :id pi) parent-node)
(this (->> (org-x-dag-bs :error "Children not allowed")
(org-x-dag-node i (cons i ps)))))
(cons this (--mapcat (org-x-dag-bs-with-treetop-error it node) children))))
(defun org-x-dag-bs-with-treetop (tree node-fun)
(declare (indent 3))
(-let* (((top . children) tree)
(top* (org-x-dag-node-fmap top
(if children (org-x-dag-bs :error "Children not allowed")
(funcall node-fun it)))))
(cons top* (--mapcat (org-x-dag-bs-with-treetop-error it top) children))))
;; TODO add a slot for the buffer parent (so that we know which are toplevel and not)
(defun org-x-dag-bs-with-children (tree child-fun node-fun concat-fun)
(declare (indent 3))
;; TODO this is super inefficient, make a plist mapper function
(-let* (((node . children) tree)
((&plist :id i :parents ps :node-meta m) node)
((shallow rest) (->> (-map child-fun children)
(apply #'-zip-lists)))
(shallow*
(--map (-let (((&plist :id ci :parents cps :node-meta cm) it))
(list :id ci :parents (cons i cps) :node-meta cm))
shallow)))
(list (->> (--map (plist-get it :node-meta) shallow)
(funcall node-fun m)
(org-x-dag-node i ps))
(funcall concat-fun shallow* rest))))
;; Tree a -> (Tree a -> (b, [d])) -> (a -> [b] -> c) -> (c, [d])
(defun org-x-dag-bs-with-children-1 (tree child-fun node-fun)
(org-x-dag-bs-with-children tree child-fun node-fun
(lambda (shallow deep)
(append shallow (-flatten-n 1 deep)))))
;; Tree a -> (Tree a -> (b, ([d], [e]))) -> (a -> [b] -> c) -> (c, ([d], [e]))
(defun org-x-dag-bs-with-children-2 (tree child-fun node-fun)
(org-x-dag-bs-with-children tree child-fun node-fun
(lambda (shallow deep)
(--reduce-from (-let (((a b) acc)
((as bs) it))
`((,@as ,@a) (,@bs ,@b)))
`(,shallow nil)
deep))))
(defun org-x-dag-bs-action-subiter (tree)
(org-x-dag-bs-with-children-1
tree tree
#'org-x-dag-epg-bs-outer #'org-x-dag-bs-action-subiter
#'org-x-dag-epg-bs-inner)) #'org-x-dag-bs-action-subiter-inner))
(defun org-x-dag-epg-bs (tree) (defun org-x-dag-bs-action-iter (tree)
(-let (((n ns) (org-x-dag-epg-bs-outer tree))) (org-x-dag-bs-with-children-1
(--map (org-x-dag-node-fmap it tree
(org-x-dag-bs-fmap it #'org-x-dag-bs-action-subiter
`(:endpoint ,it))) (lambda (node child-bss)
`(,n ,@ns)))) (org-x-dag-node-fmap node
(org-x-dag-bs-fmap (org-x-dag-bs-action-iter-inner it child-bss)
`(:sp-proj it))))))
(defun org-x-dag-toplevel-goal-bs-inner (type-name node child-bss) (defun org-x-dag-bs-action-project (tree)
(-let (((&plist :node-meta (&plist :planning :todo)) node)) (if (org-x-dag-node-is-iterator-p (car tree))
(-let (((iter subiters) (org-x-dag-bs-action-iter tree)))
`(,iter (nil ,subiters)))
(org-x-dag-bs-with-children-2
tree
#'org-x-dag-bs-action-project
#'org-x-dag-bs-action-project-inner)))
;; TODO need to check for created timestamps
(defun org-x-dag-bs-action (node-tree)
;; TODO these types might not line up properly
(-let (((p (ps is)) (org-x-dag-bs-action-project node-tree)))
`(,p ,@ps ,@is)))
(defun org-x-dag-bs-epg-outer (tree)
(org-x-dag-bs-with-children-1
tree
#'org-x-dag-bs-epg-outer
#'org-x-dag-bs-epg-inner))
(defun org-x-dag-bs-prefix (key nodes)
(--map (org-x-dag-node-fmap it (org-x-dag-bs-fmap it `(,key ,it))) nodes))
(defun org-x-dag-bs-epg (tree)
(-let (((n ns) (org-x-dag-bs-epg-outer tree)))
(org-x-dag-bs-prefix :endpoint `(,n ,@ns))))
(defun org-x-dag-bs-toplevel-goal-inner (type-name node-data child-bss)
(-let (((&plist :planning :todo) node-data))
(cond (cond
((not (equal todo org-x-kw-todo))
(->> (format "%ss can only be TODO" type-name)
(org-x-dag-bs :error)))
(planning (planning
(->> (format "%ss cannot have planning elements" type-name) (->> (format "%ss cannot have planning elements" type-name)
(org-x-dag-bs :error))) (org-x-dag-bs :error)))
((-any #'org-x-dag-bs-error-p child-bss) ((-any #'org-x-dag-bs-error-p child-bss)
(org-x-dag-bs :error "Child error")) (org-x-dag-bs :error "Child error"))
((equal todo org-x-kw-todo)
(org-x-dag-bs :valid '(:active)))
(t (t
(org-x-dag-bs :valid '(:active)))))) (org-x-dag-bs-error-kw type-name todo)))))
(defun org-x-dag-toplevel-goal-bs-outer (type-name tree) (defun org-x-dag-bs-toplevel-goal-outer (type-name tree)
(org-x-dag-with-children-1 (org-x-dag-bs-with-children-1
tree tree
(lambda (tree) (lambda (tree)
(org-x-dag-toplevel-goal-bs-outer type-name tree)) (org-x-dag-bs-toplevel-goal-outer type-name tree))
(lambda (node child-bss) (lambda (node-data child-bss)
(org-x-dag-toplevel-goal-bs-inner type-name node child-bss)))) (org-x-dag-bs-toplevel-goal-inner type-name node-data child-bss))))
(defun org-x-dag-toplevel-goal-bs (type-name type-key tree) (defun org-x-dag-bs-toplevel-goal (type-name type-key tree)
(-let (((n ns) (org-x-dag-toplevel-goal-bs-outer type-name tree))) (-let (((n ns) (org-x-dag-bs-toplevel-goal-outer type-name tree)))
(--map (org-x-dag-node-fmap it (org-x-dag-bs-prefix type-key `(,n ,@ns))))
(org-x-dag-bs-fmap it
`(,type-key ,it)))
`(,n ,@ns))))
(defun org-x-dag-ltg-bs (tree) (defun org-x-dag-bs-ltg (tree)
(org-x-dag-toplevel-goal-bs "LTG" :lifetime tree)) (org-x-dag-bs-toplevel-goal "LTG" :lifetime tree))
(defun org-x-dag-svg-bs (tree) (defun org-x-dag-bs-svg (tree)
(org-x-dag-toplevel-goal-bs "SVG" :survival tree)) (org-x-dag-bs-toplevel-goal "SVG" :survival tree))
(defun org-x-dag-bs-error-kw (type-name kw) ;; planning
(->> (format "%ss cannot have keyword '%s" type-name kw)
(org-x-dag-bs :error)))
(defun org-x-dag-qtp-bs-inner (node-data) (defun org-x-dag-bs-qtp-inner (node-data)
(org-x-dag-bs-action-with-closed node-data "quarterly plan" (org-x-dag-bs-action-with-closed node-data "quarterly plan"
`(:complete ,it-comptime) `(:complete ,it-comptime)
(org-x-dag-bs :valid `(:complete ,it-comptime)) (org-x-dag-bs :valid `(:complete ,it-comptime))
(-let (((sched dead) (-some->> it-planning (cond
(org-ml-get-properties '(:scheduled :deadline))))) ((-some->> it-planning (org-ml-get-properties :scheduled))
(cond (org-x-dag-bs :error "QTPs cannot be scheduled"))
(sched ((equal it-todo org-x-kw-todo)
(org-x-dag-bs :error "QTPs cannot be scheduled")) (-if-let (dead (-some->> it-planning (org-ml-get-properties :deadline)))
((equal it-todo org-x-kw-todo)
(if (not dead) (org-x-dag-bs :valid '(:active nil))
(-let* (((&plist :tags) node-data) (-let* (((&plist :tags) node-data)
(tag-dt (org-x-dag-quarter-tags-to-date tags)) (tag-dt (org-x-dag-quarter-tags-to-date tags))
(dead-dt (->> (org-ml-timestamp-get-start-time dead) (dead-dt (->> (org-ml-timestamp-get-start-time dead)
@ -1886,94 +1906,60 @@ used for optimization."
(car)))) (car))))
(if (org-x-dag-datetime< tag-date dead-dt) (if (org-x-dag-datetime< tag-date dead-dt)
(org-x-dag-bs :valid `(:active ,dead)) (org-x-dag-bs :valid `(:active ,dead))
(org-x-dag-bs :error "QTP deadlines must be due after the quarter starts"))))) (->> "QTP deadlines must be due after the quarter starts"
(t (org-x-dag-bs :error))))
(org-x-dag-bs-error-kw "QTP" it-todo)))))) (org-x-dag-bs :valid '(:active nil))))
(t
(org-x-dag-bs-error-kw "QTP" it-todo)))))
(defun org-x-dag-wkp-bs-inner (node-data) (defun org-x-dag-bs-wkp-inner (node-data)
(org-x-dag-bs-action-with-closed node-data "weekly plan" (org-x-dag-bs-action-with-closed node-data "weekly plan"
`(:complete ,it-comptime) `(:complete ,it-comptime)
(org-x-dag-bs :valid `(:complete ,it-comptime)) (org-x-dag-bs :valid `(:complete ,it-comptime))
(-let (((sched dead) (-some->> it-planning (cond
(org-ml-get-properties '(:scheduled :deadline))))) ((-some->> it-planning (org-ml-get-properties :scheduled))
(cond (org-x-dag-bs :error "WKPs cannot be scheduled"))
(sched ((-some->> it-planning (org-ml-get-properties :deadline))
(org-x-dag-bs :error "WKPs cannot be scheduled")) (org-x-dag-bs :error "WKPs cannot be deadlined"))
(dead ((equal it-todo org-x-kw-todo)
(org-x-dag-bs :error "WKPs cannot be deadlined")) (org-x-dag-bs :valid `(:active)))
((equal it-todo org-x-kw-todo) (t
(org-x-dag-bs :valid `(:active))) (org-x-dag-bs-error-kw "WKP" it-todo)))))
(t
(org-x-dag-bs-error-kw "WKP" it-todo))))))
(defun org-x-dag-dlp-bs-inner (node-data) (defun org-x-dag-bs-dlp-inner (node-data)
(org-x-dag-bs-action-with-closed node-data "daily metablock" (org-x-dag-bs-action-with-closed node-data "daily metablock"
`(:complete ,it-comptime) `(:complete ,it-comptime)
(org-x-dag-bs :valid `(:complete ,it-comptime)) (org-x-dag-bs :valid `(:complete ,it-comptime))
(-let (((sched dead) (-some->> it-planning (cond
(org-ml-get-properties '(:scheduled :deadline))))) ((-some->> it-planning (org-ml-get-properties :deadline))
(cond (org-x-dag-bs :error "Daily metablocks cannot be deadlined"))
(dead ((equal it-todo org-x-kw-todo)
(org-x-dag-bs :error "Daily metablocks cannot be deadlined")) (-if-let ((sched-date sched-time) (-some->> it-planning
((equal it-todo org-x-kw-todo) (org-ml-get-property :scheduled)
(-if-let ((sched-date sched-time) (-some->> it-planning (org-ml-timestamp-get-start-time)
(org-ml-get-property :scheduled) (org-x-dag-datetime-split)))
(org-ml-timestamp-get-start-time) (if (not sched-time)
(org-x-dag-datetime-split))) (org-x-dag-bs :error "Daily metablocks must have scheduled time")
(if (not sched-time) (-let* (((&plist :tags) node-data)
(org-x-dag-bs :error "Daily metablocks must have scheduled time") (tag-date (org-x-dag-daily-tags-to-date tags)))
(-let* (((&plist :tags) node-data) (if (org-x-dag-datetime= tag-date sched-date)
(tag-date (org-x-dag-daily-tags-to-date tags))) (org-x-dag-bs :valid `(:active))
(if (org-x-dag-datetime= tag-date sched-date) (org-x-dag-bs :error "Daily metablocks must be scheduled within their date"))))
(org-x-dag-bs :valid `(:active)) (org-x-dag-bs :error "Daily metablocks must be scheduled")))
(org-x-dag-bs :error "Daily metablocks must be scheduled within their date")))) (t
(org-x-dag-bs :error "Daily metablocks must be scheduled"))) (org-x-dag-bs-error-kw "Daily metablock" it-todo)))))
(t
(org-x-dag-bs-error-kw "Daily metablock" it-todo))))))
(defun org-x-dag-with-treetop-error (tree) (defun org-x-dag-bs-qtp (tree)
(declare (indent 3)) (-let (((n ns) (org-x-dag-bs-with-treetop tree #'org-x-dag-bs-qtp-inner)))
(-let* (((node . children) tree) (org-x-dag-bs-prefix :quarterly `(,n ,@ns))))
((&plist :id n :parents ps :node-meta m) node)
((shallow rest) (->> (-map #'org-x-dag-with-treetop-error children)
(apply #'-zip-lists)))
(shallow*
(--map (-let (((&plist :id ci :parents cps :node-meta cm) it))
(org-x-dag-node ci (cons n cps) cm))
shallow)))
(list
(org-x-dag-node n ps (org-x-dag-bs :error "Children not allowed"))
,@shallow*
,@(-flatten-n 1 rest))))
(defun org-x-dag-with-treetop (tree node-fun) (defun org-x-dag-bs-wkp (tree)
(declare (indent 3)) (-let (((n ns) (org-x-dag-bs-with-treetop tree #'org-x-dag-bs-wkp-inner)))
(-let* (((top . children) tree) (org-x-dag-bs-prefix :weekly `(,n ,@ns))))
(top* (org-x-dag-node-fmap top
(if children (org-x-dag-bs :error "Children not allowed")
(funcall node-fun it)))))
`(,top* ,@(-map #'org-x-dag-with-treetop-error children))))
(defun org-x-dag-qtp-bs (tree) (defun org-x-dag-bs-dlp (tree)
(-let (((n ns) (org-x-dag-with-treetop tree #'org-x-dag-qtp-bs-inner))) (-let (((n ns) (org-x-dag-bs-with-treetop tree #'org-x-dag-bs-dlp-inner)))
(--map (org-x-dag-node-fmap it (org-x-dag-bs-prefix :daily `(,n ,@ns))))
(org-x-dag-bs-fmap it
`(:weekly ,it)))
`(,n ,@ns))))
(defun org-x-dag-wkp-bs (tree)
(-let (((n ns) (org-x-dag-with-treetop tree #'org-x-dag-wkp-bs-inner)))
(--map (org-x-dag-node-fmap it
(org-x-dag-bs-fmap it
`(:quarterly ,it)))
`(,n ,@ns))))
(defun org-x-dag-dlp-bs (tree)
(-let (((n ns) (org-x-dag-with-treetop tree #'org-x-dag-dlp-bs-inner)))
(--map (org-x-dag-node-fmap it
(org-x-dag-bs-fmap it
`(:daily ,it)))
`(,n ,@ns))))
(defun org-x-dag-get-file-nodes (file group) (defun org-x-dag-get-file-nodes (file group)
(let* ((meta (list :file file (let* ((meta (list :file file
@ -1984,10 +1970,20 @@ used for optimization."
(:action (list org-x-prop-parent-type (:action (list org-x-prop-parent-type
org-x-prop-time-shift org-x-prop-time-shift
"ARCHIVE"))) "ARCHIVE")))
(append def-props)))) (append def-props)))
;; TODO use group to determine which properties we need (bs-fun (pcase group
(org-x-with-file file (:action #'org-x-dag-bs-action)
(org-x-dag-get-buffer-nodes meta org-todo-keywords-1 props)))) (:lifetime #'org-x-dag-bs-ltg)
(:survival #'org-x-dag-bs-svg)
(:endpoint #'org-x-dag-bs-epg)
(:quarterly #'org-x-dag-bs-qtp)
(:weekly #'org-x-dag-bs-wkp)
(:daily #'org-x-dag-bs-dlp)))
(nodes
(org-x-with-file file
(org-x-dag-get-buffer-nodes meta org-todo-keywords-1 props))))
(->> (org-x-dag-buffer-nodes-to-tree nodes)
(-mapcat bs-fun))))
;;; DAG SYNCHRONIZATION/CONSTRUCTION ;;; DAG SYNCHRONIZATION/CONSTRUCTION