ENH restructure action status to hold ancestry in sane way
This commit is contained in:
parent
12d17cc9f3
commit
e63f83b2a7
|
@ -615,8 +615,7 @@ 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")))
|
||||||
|
@ -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))
|
||||||
|
|
Loading…
Reference in New Issue