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

View File

@ -615,8 +615,7 @@ used for optimization."
(defun org-x-dag-bs-error-kw (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
canc-bs-form
(defmacro org-x-dag-bs-with-closed (node-data type-name canc-bs-form
done-form open-form)
(declare (indent 2))
(let ((c (make-symbol "--closed")))
@ -645,24 +644,54 @@ used for optimization."
(t
,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
((new-proj
(status)
(either :right `(:sp-proj ,@status)))
(either :right `(:sp-proj ,status)))
(is-next
(task-data)
(-let (((&plist :todo :sched) task-data))
(or sched (equal todo org-x-kw-next)))))
;; rankings
;; *-active > proj-wait > proj-held > (proj-stuck == iter-empty) > *-complete
(org-x-dag-bs-action-with-closed node-data ancestry "projects"
(if child-bss
(org-x-dag-bs-action-with-closed node-data ancestry child-bss "projects"
(if it-children
`(:sp-proj :proj-complete ,it-comptime)
`(:sp-task :task-complete ,it-comptime))
;; 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
;; returned in this form and not the last
(->> (pcase `(,acc ,it)
@ -698,11 +727,11 @@ used for optimization."
(list :sp-task :task-active))))
(cond
((and child-bss (equal it-todo org-x-kw-hold))
(new-proj '(:proj-held)))
(new-proj :proj-held))
((and child-bss sched)
(either :left "Projects cannot be scheduled"))
((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)
(`((:sp-task :task-active ,a) (:sp-task :task-active ,b))
(and (not (is-next a)) (is-next b)))
@ -721,7 +750,7 @@ used for optimization."
`(:sp-proj :proj-wait)
`(:sp-proj :proj-held)
`(:sp-proj :proj-stuck)
`(:sp-iter :iter-active)
`(:sp-iter :iter-active, _)
`(:sp-iter :iter-empty)))
(not (is-next d)))
@ -761,20 +790,19 @@ used for optimization."
`(:sp-task :task-complete ,_)
`(:sp-iter :iter-complete ,_))
(either :left "Active projects must have at least one active child"))
(`(:sp-proj . ,s) (new-proj s))
(`(:sp-iter :iter-active ,_) (new-proj '(:proj-active)))
(`(:sp-iter :iter-empty) (new-proj '(:proj-stuck)))
(`(:sp-proj ,s) (new-proj s))
(`(:sp-iter :iter-active ,_) (new-proj :proj-active))
(`(:sp-iter :iter-empty) (new-proj :proj-stuck))
(`(:sp-task :task-active ,d)
(-let (((&plist :todo o :sched s) d))
(cond
((equal o org-x-kw-todo) (->> (if s :proj-active
:proj-stuck)
(list)
((equal o org-x-kw-todo) (->> (if s :proj-active :proj-stuck)
(new-proj)))
((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-hold) (new-proj '(:proj-hold)))
(t (org-x-dag-bs-error-kw "Task action" o))))))))
((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-hold) (new-proj :proj-hold))
(t (org-x-dag-bs-error-kw "Task action" o)))))
(e (error "Pattern fail: %s" e)))))
(child-bss
(org-x-dag-bs-error-kw "Project action" it-todo))
(t
@ -788,9 +816,9 @@ used for optimization."
;; 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
;; still needed in case there is only one child)
(defun org-x-dag-bs-action-subiter-complete-fold (child-bss _ comptime
type-name comp-key)
(declare (indent 3))
(defun org-x-dag-bs-action-subiter-complete-fold (child-bss comptime type-name
comp-key)
(declare (indent 2))
(org-x-dag-bs-fold-children child-bss `(,comp-key ,comptime)
(->> (pcase `(,acc ,it)
(`((:si-complete ,_) (:si-complete ,_)) nil)
@ -808,8 +836,9 @@ used for optimization."
(->> (format "Completed %s cannot have active children" type-name)
(either :left))))))
(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)
(declare (indent 1))
(org-x-dag-bs-fold-children child-bss default
(pcase `(,acc ,it)
(`((: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)))
(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)
(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)
(-let (((sched dead) (-some->> it-planning
(org-ml-get-properties '(:scheduled :deadline)))))
(cond
((and sched child-bss)
((and sched it-children)
(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"))
;; ((and (not child-bss) (not (xor sched dead)))
;; (either :left "Sub-iterators must either be deadlined or scheduled"))
((org-x-dag-node-data-is-iterator-p node-data)
(either :left "Iterators cannot be nested"))
((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
`(:si-active (:sched ,sched :dead ,dead))))
(t
(org-x-dag-bs-error-kw "Sub-iterator" it-todo))))))
(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)
(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)
(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"))
;; 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 ancestry
(org-x-dag-bs-action-subiter-todo-fold it-children
"iterator" :iter-active
'(:iter-empty)))
(t
(org-x-dag-bs-error-kw "Iterator" it-todo)))))
(defun org-x-dag-bs-epg-inner (node _ child-bss)
(org-x-dag-bs-action-with-closed node ancestry "endpoint goal"
(defun org-x-dag-bs-epg-inner (node ancestry child-bss)
(org-x-dag-bs-action-with-closed node ancestry child-bss "endpoint goal"
`(: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)
(`((:complete ,_) (:complete ,_)) nil)
(`(,_ (:complete ,_)) nil)
@ -910,7 +939,7 @@ used for optimization."
((-some->> it-planning (org-ml-get-property :scheduled))
(either :left "EPGs cannot be scheduled"))
((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)
(`((:active) (:active)) nil)
(`(,_ (:active)) t)
@ -1013,7 +1042,8 @@ used for optimization."
#'org-x-dag-bs-action-subiter
(lambda (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)
(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))
(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))))
(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))
(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)
(either :right `(:complete ,it-comptime))
(cond
@ -1108,7 +1138,7 @@ used for optimization."
(org-x-dag-bs-error-kw "QTP" it-todo)))))
(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)
(either :right `(:complete ,it-comptime))
(cond
@ -1122,7 +1152,7 @@ used for optimization."
(org-x-dag-bs-error-kw "WKP" it-todo)))))
(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)
(either :right `(:complete ,it-comptime))
(cond
@ -3922,13 +3952,13 @@ FUTURE-LIMIT in a list."
;; TODO this could show more detail if I wanted
(pcase bs-data
;; action
(`(:sp-proj :proj-active)
(`(:sp-proj :proj-active ,_)
"Active Project")
(`(:sp-proj :proj-wait)
(`(:sp-proj :proj-wait ,_)
"Waiting Project")
(`(:sp-proj :proj-hold)
(`(:sp-proj :proj-hold ,_)
"Held Project")
(`(:sp-proj :proj-stuck)
(`(:sp-proj :proj-stuck ,_)
"Stuck Project")
(`(:sp-proj :proj-complete ,comptime)
(format-comptime "project" comptime))