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

ENH restructure action status to hold ancestry in sane way

This commit is contained in:
Nathan Dwarshuis 2022-04-24 23:39:36 -04:00
parent 12d17cc9f3
commit e63f83b2a7
1 changed files with 78 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -615,9 +615,8 @@ used for optimization."
(defun org-x-dag-bs-error-kw (type-name kw) (defun org-x-dag-bs-error-kw (type-name kw)
(either :left (format "%ss cannot have keyword '%s" type-name kw))) (either :left (format "%ss cannot have keyword '%s" type-name kw)))
(defmacro org-x-dag-bs-action-with-closed (node-data _ type-name (defmacro org-x-dag-bs-with-closed (node-data type-name canc-bs-form
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")))
`(cl-flet `(cl-flet
@ -645,24 +644,54 @@ used for optimization."
(t (t
,open-form))))))) ,open-form)))))))
(defun org-x-dag-bs-action-project-inner (node-data _ child-bss) (defmacro org-x-dag-bs-action-with-closed (node-data ancestry child-bss type-name
canc-bs-form
done-form open-form)
(declare (indent 4))
(cl-flet*
((wrap-ancestry
(form)
`(list :ancestry ,ancestry :status ,form))
(lift-form
(form)
;; `(let ((r ,form))
;; (unless r
;; (print 'hi))
;; (either<$> ,form (list :ancestry ancestry :status it)))))
`(either<$> ,form ,(wrap-ancestry 'it))))
(let ((canc-bs-form* (wrap-ancestry canc-bs-form))
(done-form* (lift-form done-form))
(open-form* (lift-form open-form)))
`(-let ((it-children (--map (either>>= it
(->> (plist-get it :status)
(either :right)))
,child-bss)))
;; (print "----")
;; (print child-bss)
;; (print it-children)
(org-x-dag-bs-with-closed ,node-data ,type-name
,canc-bs-form*
,done-form*
,open-form*)))))
(defun org-x-dag-bs-action-project-inner (node-data ancestry child-bss)
(cl-flet (cl-flet
((new-proj ((new-proj
(status) (status)
(either :right `(:sp-proj ,@status))) (either :right `(:sp-proj ,status)))
(is-next (is-next
(task-data) (task-data)
(-let (((&plist :todo :sched) task-data)) (-let (((&plist :todo :sched) task-data))
(or sched (equal todo org-x-kw-next))))) (or sched (equal todo org-x-kw-next)))))
;; rankings ;; rankings
;; *-active > proj-wait > proj-held > (proj-stuck == iter-empty) > *-complete ;; *-active > proj-wait > proj-held > (proj-stuck == iter-empty) > *-complete
(org-x-dag-bs-action-with-closed node-data ancestry "projects" (org-x-dag-bs-action-with-closed node-data ancestry child-bss "projects"
(if child-bss (if it-children
`(:sp-proj :proj-complete ,it-comptime) `(:sp-proj :proj-complete ,it-comptime)
`(:sp-task :task-complete ,it-comptime)) `(:sp-task :task-complete ,it-comptime))
;; done form ;; done form
(org-x-dag-bs-fold-children child-bss `(:sp-task :task-complete ,it-comptime) (org-x-dag-bs-fold-children it-children `(: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)
@ -698,11 +727,11 @@ used for optimization."
(list :sp-task :task-active)))) (list :sp-task :task-active))))
(cond (cond
((and child-bss (equal it-todo org-x-kw-hold)) ((and child-bss (equal it-todo org-x-kw-hold))
(new-proj '(:proj-held))) (new-proj :proj-held))
((and child-bss sched) ((and child-bss sched)
(either :left "Projects cannot be scheduled")) (either :left "Projects cannot be scheduled"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(org-x-dag-bs-fold-children child-bss task-default (org-x-dag-bs-fold-children it-children task-default
(->> (pcase `(,acc ,it) (->> (pcase `(,acc ,it)
(`((:sp-task :task-active ,a) (:sp-task :task-active ,b)) (`((:sp-task :task-active ,a) (:sp-task :task-active ,b))
(and (not (is-next a)) (is-next b))) (and (not (is-next a)) (is-next b)))
@ -721,7 +750,7 @@ used for optimization."
`(:sp-proj :proj-wait) `(:sp-proj :proj-wait)
`(:sp-proj :proj-held) `(:sp-proj :proj-held)
`(:sp-proj :proj-stuck) `(:sp-proj :proj-stuck)
`(:sp-iter :iter-active) `(:sp-iter :iter-active, _)
`(:sp-iter :iter-empty))) `(:sp-iter :iter-empty)))
(not (is-next d))) (not (is-next d)))
@ -761,20 +790,19 @@ used for optimization."
`(:sp-task :task-complete ,_) `(:sp-task :task-complete ,_)
`(:sp-iter :iter-complete ,_)) `(:sp-iter :iter-complete ,_))
(either :left "Active projects must have at least one active child")) (either :left "Active projects must have at least one active child"))
(`(:sp-proj . ,s) (new-proj s)) (`(:sp-proj ,s) (new-proj s))
(`(:sp-iter :iter-active ,_) (new-proj '(:proj-active))) (`(:sp-iter :iter-active ,_) (new-proj :proj-active))
(`(:sp-iter :iter-empty) (new-proj '(:proj-stuck))) (`(:sp-iter :iter-empty) (new-proj :proj-stuck))
(`(:sp-task :task-active ,d) (`(:sp-task :task-active ,d)
(-let (((&plist :todo o :sched s) d)) (-let (((&plist :todo o :sched s) d))
(cond (cond
((equal o org-x-kw-todo) (->> (if s :proj-active ((equal o org-x-kw-todo) (->> (if s :proj-active :proj-stuck)
:proj-stuck)
(list)
(new-proj))) (new-proj)))
((equal o org-x-kw-next) (new-proj '(:proj-active))) ((equal o org-x-kw-next) (new-proj :proj-active))
((equal o org-x-kw-wait) (new-proj '(:proj-wait))) ((equal o org-x-kw-wait) (new-proj :proj-wait))
((equal o org-x-kw-hold) (new-proj '(:proj-hold))) ((equal o org-x-kw-hold) (new-proj :proj-hold))
(t (org-x-dag-bs-error-kw "Task action" o)))))))) (t (org-x-dag-bs-error-kw "Task action" o)))))
(e (error "Pattern fail: %s" e)))))
(child-bss (child-bss
(org-x-dag-bs-error-kw "Project action" it-todo)) (org-x-dag-bs-error-kw "Project action" it-todo))
(t (t
@ -788,9 +816,9 @@ 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 _ comptime (defun org-x-dag-bs-action-subiter-complete-fold (child-bss comptime type-name
type-name comp-key) comp-key)
(declare (indent 3)) (declare (indent 2))
(org-x-dag-bs-fold-children child-bss `(,comp-key ,comptime) (org-x-dag-bs-fold-children child-bss `(,comp-key ,comptime)
(->> (pcase `(,acc ,it) (->> (pcase `(,acc ,it)
(`((:si-complete ,_) (:si-complete ,_)) nil) (`((:si-complete ,_) (:si-complete ,_)) nil)
@ -808,8 +836,9 @@ used for optimization."
(->> (format "Completed %s cannot have active children" type-name) (->> (format "Completed %s cannot have active children" type-name)
(either :left)))))) (either :left))))))
(defun org-x-dag-bs-action-subiter-todo-fold (child-bss _ type-name (defun org-x-dag-bs-action-subiter-todo-fold (child-bss type-name active-key
active-key default) default)
(declare (indent 1))
(org-x-dag-bs-fold-children child-bss default (org-x-dag-bs-fold-children child-bss default
(pcase `(,acc ,it) (pcase `(,acc ,it)
(`((:si-active ,a) (:si-active ,b)) (`((:si-active ,a) (:si-active ,b))
@ -852,48 +881,48 @@ used for optimization."
(org-x-dag-node-data-is-iterator-p (plist-get node :node-meta))) (org-x-dag-node-data-is-iterator-p (plist-get node :node-meta)))
(defun org-x-dag-bs-action-subiter-inner (node-data ancestry child-bss) (defun org-x-dag-bs-action-subiter-inner (node-data ancestry child-bss)
(org-x-dag-bs-action-with-closed node-data ancestry "sub-iterators" (org-x-dag-bs-action-with-closed node-data ancestry child-bss "sub-iterators"
`(:si-complete ,it-comptime) `(:si-complete ,it-comptime)
(org-x-dag-bs-action-subiter-complete-fold child-bss ancestry it-comptime (org-x-dag-bs-action-subiter-complete-fold it-children 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)))))
(cond (cond
((and sched child-bss) ((and sched it-children)
(either :left "Sub-iterators with children cannot be scheduled")) (either :left "Sub-iterators with children cannot be scheduled"))
((and dead child-bss) ((and dead it-children)
(either :left "Sub-iterators with children cannot be deadlined")) (either :left "Sub-iterators with children cannot be deadlined"))
;; ((and (not child-bss) (not (xor sched dead))) ;; ((and (not child-bss) (not (xor sched dead)))
;; (either :left "Sub-iterators must either be deadlined or scheduled")) ;; (either :left "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)
(either :left "Iterators cannot be nested")) (either :left "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 ancestry (org-x-dag-bs-action-subiter-todo-fold it-children
"sub-iterator" :si-active "sub-iterator" :si-active
`(:si-active (:sched ,sched :dead ,dead)))) `(: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 ancestry child-bss) (defun org-x-dag-bs-action-iter-inner (node-data ancestry child-bss)
(org-x-dag-bs-action-with-closed node-data ancestry "iterators" (org-x-dag-bs-action-with-closed node-data ancestry child-bss "iterators"
`(:iter-complete ,it-comptime) `(:iter-complete ,it-comptime)
(org-x-dag-bs-action-subiter-complete-fold child-bss ancestry it-comptime (org-x-dag-bs-action-subiter-complete-fold it-children it-comptime
"iterators" :iter-complete) "iterators" :iter-complete)
(cond (cond
((and child-bss (-some->> it-planning (org-ml-get-property :scheduled))) ((and it-children (-some->> it-planning (org-ml-get-property :scheduled)))
(either :left "Iterators cannot be scheduled")) (either :left "Iterators cannot be scheduled"))
;; TODO also check for timeshift and archive props ;; TODO also check for timeshift and archive props
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(org-x-dag-bs-action-subiter-todo-fold child-bss ancestry (org-x-dag-bs-action-subiter-todo-fold it-children
"iterator" :iter-active "iterator" :iter-active
'(:iter-empty))) '(:iter-empty)))
(t (t
(org-x-dag-bs-error-kw "Iterator" it-todo))))) (org-x-dag-bs-error-kw "Iterator" it-todo)))))
(defun org-x-dag-bs-epg-inner (node _ child-bss) (defun org-x-dag-bs-epg-inner (node ancestry child-bss)
(org-x-dag-bs-action-with-closed node ancestry "endpoint goal" (org-x-dag-bs-action-with-closed node ancestry child-bss "endpoint goal"
`(:complete ,it-comptime) `(:complete ,it-comptime)
(org-x-dag-bs-fold-children child-bss `(:complete ,it-comptime) (org-x-dag-bs-fold-children it-children `(:complete ,it-comptime)
(->> (pcase `(,acc ,it) (->> (pcase `(,acc ,it)
(`((:complete ,_) (:complete ,_)) nil) (`((:complete ,_) (:complete ,_)) nil)
(`(,_ (:complete ,_)) nil) (`(,_ (:complete ,_)) nil)
@ -910,7 +939,7 @@ used for optimization."
((-some->> it-planning (org-ml-get-property :scheduled)) ((-some->> it-planning (org-ml-get-property :scheduled))
(either :left "EPGs cannot be scheduled")) (either :left "EPGs cannot be scheduled"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(org-x-dag-bs-fold-children child-bss `(:active) (org-x-dag-bs-fold-children it-children `(:active)
(->> (pcase `(,acc ,it) (->> (pcase `(,acc ,it)
(`((:active) (:active)) nil) (`((:active) (:active)) nil)
(`(,_ (:active)) t) (`(,_ (:active)) t)
@ -1013,7 +1042,8 @@ used for optimization."
#'org-x-dag-bs-action-subiter #'org-x-dag-bs-action-subiter
(lambda (node-data ancestry child-bss) (lambda (node-data ancestry child-bss)
(either<$> (org-x-dag-bs-action-iter-inner node-data ancestry child-bss) (either<$> (org-x-dag-bs-action-iter-inner node-data ancestry child-bss)
(cons :sp-iter it))))) (-let (((&plist :ancestry a :status s) it))
(list :ancestry a :status (cons :sp-iter s)))))))
(defun org-x-dag-bs-action-project (tree ancestry) (defun org-x-dag-bs-action-project (tree ancestry)
(if (org-x-dag-node-is-iterator-p (car tree)) (if (org-x-dag-node-is-iterator-p (car tree))
@ -1049,7 +1079,7 @@ used for optimization."
(--map (org-x-dag-node-fmap it (either<$> it `(,key ,@it))) nodes)) (--map (org-x-dag-node-fmap it (either<$> 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 '(:canceled-parent-p nil))))
(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)
@ -1084,7 +1114,7 @@ used for optimization."
(org-x-dag-bs-toplevel-goal "SVG" :survival tree)) (org-x-dag-bs-toplevel-goal "SVG" :survival tree))
(defun org-x-dag-bs-qtp-inner (node-data) (defun org-x-dag-bs-qtp-inner (node-data)
(org-x-dag-bs-action-with-closed node-data nil "quarterly plan" (org-x-dag-bs-with-closed node-data "quarterly plan"
`(:complete ,it-comptime) `(:complete ,it-comptime)
(either :right `(:complete ,it-comptime)) (either :right `(:complete ,it-comptime))
(cond (cond
@ -1108,7 +1138,7 @@ used for optimization."
(org-x-dag-bs-error-kw "QTP" it-todo))))) (org-x-dag-bs-error-kw "QTP" it-todo)))))
(defun org-x-dag-bs-wkp-inner (node-data) (defun org-x-dag-bs-wkp-inner (node-data)
(org-x-dag-bs-action-with-closed node-data nil "weekly plan" (org-x-dag-bs-with-closed node-data "weekly plan"
`(:complete ,it-comptime) `(:complete ,it-comptime)
(either :right `(:complete ,it-comptime)) (either :right `(:complete ,it-comptime))
(cond (cond
@ -1122,7 +1152,7 @@ used for optimization."
(org-x-dag-bs-error-kw "WKP" it-todo))))) (org-x-dag-bs-error-kw "WKP" it-todo)))))
(defun org-x-dag-bs-dlp-inner (node-data) (defun org-x-dag-bs-dlp-inner (node-data)
(org-x-dag-bs-action-with-closed node-data nil "daily metablock" (org-x-dag-bs-with-closed node-data "daily metablock"
`(:complete ,it-comptime) `(:complete ,it-comptime)
(either :right `(:complete ,it-comptime)) (either :right `(:complete ,it-comptime))
(cond (cond
@ -3922,13 +3952,13 @@ FUTURE-LIMIT in a list."
;; TODO this could show more detail if I wanted ;; TODO this could show more detail if I wanted
(pcase bs-data (pcase bs-data
;; action ;; action
(`(:sp-proj :proj-active) (`(:sp-proj :proj-active ,_)
"Active Project") "Active Project")
(`(:sp-proj :proj-wait) (`(:sp-proj :proj-wait ,_)
"Waiting Project") "Waiting Project")
(`(:sp-proj :proj-hold) (`(:sp-proj :proj-hold ,_)
"Held Project") "Held Project")
(`(:sp-proj :proj-stuck) (`(:sp-proj :proj-stuck ,_)
"Stuck Project") "Stuck Project")
(`(:sp-proj :proj-complete ,comptime) (`(:sp-proj :proj-complete ,comptime)
(format-comptime "project" comptime)) (format-comptime "project" comptime))