ENH don't map over children unless we need to
This commit is contained in:
parent
a94d51020f
commit
1a4c7e0bc6
|
@ -581,20 +581,18 @@ used for optimization."
|
||||||
|
|
||||||
;; buffer status
|
;; buffer status
|
||||||
|
|
||||||
(defun org-x-dag-bs-check-children (bss msg nochild-def child-def stop-fun)
|
(defun org-x-dag-bs-check-children (bss fail success nochild stop-fun)
|
||||||
(declare (indent 4))
|
(declare (indent 4))
|
||||||
;; this is almost like fold or foldM but I want to stop if `fun' returns nil
|
;; this is almost like fold or foldM but I want to stop if `fun' returns nil
|
||||||
(cl-labels
|
(cl-labels
|
||||||
;; hopefully the TCO native comp actually works :)
|
;; hopefully the TCO native comp actually works :)
|
||||||
((fold-while
|
((fold-while
|
||||||
(xs)
|
(xs)
|
||||||
(if (not xs) (either :right child-def)
|
(if (not xs) success
|
||||||
(pcase (car xs)
|
(pcase (car xs)
|
||||||
(`(:right ,r) (if (funcall stop-fun r)
|
(`(:right ,r) (if (funcall stop-fun r) (fold-while (cdr xs)) fail))
|
||||||
(either :left msg)
|
|
||||||
(fold-while (cdr xs))))
|
|
||||||
(_ (either :left "Child error"))))))
|
(_ (either :left "Child error"))))))
|
||||||
(if (not bss) (either :right nochild-def)
|
(if (not bss) (either :right nochild)
|
||||||
(fold-while bss))))
|
(fold-while bss))))
|
||||||
|
|
||||||
;; [Status a] -> b -> (a -> a -> Status Bool) -> (a -> Bool) -> (a -> Status b)
|
;; [Status a] -> b -> (a -> a -> Status Bool) -> (a -> Bool) -> (a -> Status b)
|
||||||
|
@ -680,14 +678,14 @@ used for optimization."
|
||||||
;; sake of some inner type, but if any of these are left then
|
;; sake of some inner type, but if any of these are left then
|
||||||
;; they should short circuit the fold/check functions embedded in here
|
;; they should short circuit the fold/check functions embedded in here
|
||||||
`(org-x-dag-bs-check-created ,node-data
|
`(org-x-dag-bs-check-created ,node-data
|
||||||
(-let ((it-children (--map (either>>= it
|
;; (-let ((it-children (--map (either>>= it
|
||||||
(->> (plist-get it :local)
|
;; (->> (plist-get it :local)
|
||||||
(either :right)))
|
;; (either :right)))
|
||||||
,child-bss)))
|
;; ,child-bss)))
|
||||||
(org-x-dag-bs-with-closed ,node-data ,type-name
|
(org-x-dag-bs-with-closed ,node-data ,type-name
|
||||||
,canc-bs-form*
|
,canc-bs-form*
|
||||||
,done-form*
|
,done-form*
|
||||||
,open-form*))))))
|
,open-form*)))))
|
||||||
|
|
||||||
(defun org-x-dag-bs-action-project-inner (node-data ancestry child-bss)
|
(defun org-x-dag-bs-action-project-inner (node-data ancestry child-bss)
|
||||||
(cl-flet
|
(cl-flet
|
||||||
|
@ -701,23 +699,22 @@ used for optimization."
|
||||||
;; 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 child-bss "projects"
|
(org-x-dag-bs-action-with-closed node-data ancestry child-bss "projects"
|
||||||
(if it-children
|
(if child-bss
|
||||||
`(: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
|
(org-x-dag-bs-check-children child-bss
|
||||||
(org-x-dag-bs-check-children it-children
|
(either :left "Completed projects cannot have active children")
|
||||||
"Completed projects cannot have active children"
|
(either :right `(:sp-proj :proj-complete ,it-comptime))
|
||||||
`(:sp-task :task-complete ,it-comptime)
|
`(:sp-task :task-complete ,it-comptime)
|
||||||
`(:sp-proj :proj-complete ,it-comptime)
|
|
||||||
(lambda (child-bs)
|
(lambda (child-bs)
|
||||||
(pcase child-bs
|
(-let (((&plist :local) child-bs))
|
||||||
(`(:sp-proj :proj-complete ,_) nil)
|
(pcase local
|
||||||
(`(:sp-iter :iter-complete ,_) nil)
|
(`(:sp-proj :proj-complete ,_) t)
|
||||||
(`(:sp-task :task-complete ,_) nil)
|
(`(:sp-iter :iter-complete ,_) t)
|
||||||
(_ t))))
|
(`(:sp-task :task-complete ,_) t)
|
||||||
|
(_ nil)))))
|
||||||
|
|
||||||
;; undone form
|
|
||||||
(-let* (((sched dead) (-some->> it-planning
|
(-let* (((sched dead) (-some->> it-planning
|
||||||
(org-ml-get-properties '(:scheduled :deadline))))
|
(org-ml-get-properties '(:scheduled :deadline))))
|
||||||
(task-default (->> (list :todo it-todo
|
(task-default (->> (list :todo it-todo
|
||||||
|
@ -730,9 +727,9 @@ used for optimization."
|
||||||
((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-rankfold-children it-children task-default
|
(org-x-dag-bs-rankfold-children child-bss task-default
|
||||||
(lambda (acc next)
|
(lambda (acc next)
|
||||||
(->> (pcase `(,acc ,next)
|
(->> (pcase `(,(plist-get :local acc) ,(plist-get :local next))
|
||||||
(`((: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)))
|
||||||
|
|
||||||
|
@ -778,17 +775,15 @@ used for optimization."
|
||||||
(`(,_ ,_) nil))
|
(`(,_ ,_) nil))
|
||||||
(either :right)))
|
(either :right)))
|
||||||
|
|
||||||
;; early stop
|
|
||||||
(lambda (next)
|
(lambda (next)
|
||||||
(pcase next
|
(pcase (plist-get :local next)
|
||||||
(`(:sp-proj :proj-active) t)
|
(`(:sp-proj :proj-active) t)
|
||||||
(`(:sp-iter :iter-active ,_) t)
|
(`(:sp-iter :iter-active ,_) t)
|
||||||
(`(:sp-task :task-active ,d) (is-next d))
|
(`(:sp-task :task-active ,d) (is-next d))
|
||||||
(_ nil)))
|
(_ nil)))
|
||||||
|
|
||||||
;; child -> parent translation
|
|
||||||
(lambda (acc)
|
(lambda (acc)
|
||||||
(pcase acc
|
(pcase (plist-get :local acc)
|
||||||
((or `(:sp-proj :proj-complete ,_)
|
((or `(:sp-proj :proj-complete ,_)
|
||||||
`(:sp-task :task-complete ,_)
|
`(:sp-task :task-complete ,_)
|
||||||
`(:sp-iter :iter-complete ,_))
|
`(:sp-iter :iter-complete ,_))
|
||||||
|
@ -825,20 +820,20 @@ used for optimization."
|
||||||
comp-key)
|
comp-key)
|
||||||
(declare (indent 2))
|
(declare (indent 2))
|
||||||
(org-x-dag-bs-check-children child-bss
|
(org-x-dag-bs-check-children child-bss
|
||||||
(format "Completed %s cannot have active children" type-name)
|
(org-x-dag-left "Completed %s cannot have active children" type-name)
|
||||||
`(,comp-key ,comptime)
|
(either :right `(,comp-key ,comptime))
|
||||||
`(,comp-key ,comptime)
|
`(,comp-key ,comptime)
|
||||||
(lambda (child-bs)
|
(lambda (child-bs)
|
||||||
(pcase child-bs
|
(pcase (plist-get :local child-bs)
|
||||||
(`(:si-complete ,_) nil)
|
(`(:si-complete ,_) t)
|
||||||
(_ t)))))
|
(_ nil)))))
|
||||||
|
|
||||||
(defun org-x-dag-bs-action-subiter-todo-fold (child-bss type-name active-key
|
(defun org-x-dag-bs-action-subiter-todo-fold (child-bss type-name active-key
|
||||||
default)
|
default)
|
||||||
(declare (indent 1))
|
(declare (indent 1))
|
||||||
(org-x-dag-bs-rankfold-children child-bss default
|
(org-x-dag-bs-rankfold-children child-bss default
|
||||||
(lambda (acc next)
|
(lambda (acc next)
|
||||||
(pcase `(,acc ,next)
|
(pcase `(,(plist-get :local acc) ,(plist-get :local next))
|
||||||
(`((:si-active ,a) (:si-active ,b))
|
(`((:si-active ,a) (:si-active ,b))
|
||||||
(-let (((&plist :sched as :dead ad) a)
|
(-let (((&plist :sched as :dead ad) a)
|
||||||
((&plist :sched bs :dead bd) b))
|
((&plist :sched bs :dead bd) b))
|
||||||
|
@ -866,11 +861,11 @@ used for optimization."
|
||||||
(`(,_ (:si-active ,_)) (either :right t))
|
(`(,_ (:si-active ,_)) (either :right t))
|
||||||
(`(,_ ,_) (either :right nil))))
|
(`(,_ ,_) (either :right nil))))
|
||||||
(lambda (next)
|
(lambda (next)
|
||||||
(pcase next
|
(pcase (plist-get :local next)
|
||||||
(`(:si-active ,_) t)
|
(`(:si-active ,_) t)
|
||||||
(_ nil)))
|
(_ nil)))
|
||||||
(lambda (acc)
|
(lambda (acc)
|
||||||
(pcase acc
|
(pcase (plist-get :local acc)
|
||||||
(`(:si-complete ,_)
|
(`(:si-complete ,_)
|
||||||
(->> type-name
|
(->> type-name
|
||||||
(org-x-dag-left "Active %s must have at least one active child")))
|
(org-x-dag-left "Active %s must have at least one active child")))
|
||||||
|
@ -883,21 +878,19 @@ used for optimization."
|
||||||
(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 child-bss "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 it-children it-comptime
|
(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)))))
|
||||||
(cond
|
(cond
|
||||||
((and sched it-children)
|
((and sched child-bss)
|
||||||
(either :left "Sub-iterators with children cannot be scheduled"))
|
(either :left "Sub-iterators with children cannot be scheduled"))
|
||||||
((and dead it-children)
|
((and dead child-bss)
|
||||||
(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)))
|
|
||||||
;; (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 it-children
|
(org-x-dag-bs-action-subiter-todo-fold child-bss
|
||||||
"sub-iterator" :si-active
|
"sub-iterator" :si-active
|
||||||
`(:si-active (:sched ,sched :dead ,dead))))
|
`(:si-active (:sched ,sched :dead ,dead))))
|
||||||
(t
|
(t
|
||||||
|
@ -906,44 +899,43 @@ used for optimization."
|
||||||
(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 child-bss "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 it-children it-comptime
|
(org-x-dag-bs-action-subiter-complete-fold child-bss it-comptime
|
||||||
"iterators" :iter-complete)
|
"iterators" :iter-complete)
|
||||||
(cond
|
(cond
|
||||||
((and it-children (-some->> it-planning (org-ml-get-property :scheduled)))
|
((and child-bss (-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 it-children
|
(org-x-dag-bs-action-subiter-todo-fold child-bss
|
||||||
"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 ancestry child-bss)
|
(defun org-x-dag-bs-epg-inner (node ancestry child-bss)
|
||||||
|
(let ((is-complete
|
||||||
|
(lambda (child-bs)
|
||||||
|
(pcase (plist-get :local child-bs)
|
||||||
|
(`(:complete ,_) t)
|
||||||
|
(_ nil)))))
|
||||||
(org-x-dag-bs-action-with-closed node ancestry child-bss "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-check-children it-children
|
(org-x-dag-bs-check-children child-bss
|
||||||
"Completed EPGs cannot have active children"
|
(either :left "Completed EPGs cannot have active children")
|
||||||
|
(either :right `(:complete ,it-comptime))
|
||||||
`(:complete ,it-comptime)
|
`(:complete ,it-comptime)
|
||||||
`(:complete ,it-comptime)
|
is-complete)
|
||||||
(lambda (child-bs)
|
|
||||||
(pcase child-bs
|
|
||||||
(`(:complete ,_) nil)
|
|
||||||
(_ t))))
|
|
||||||
(cond
|
(cond
|
||||||
((-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-check-children it-children
|
(org-x-dag-bs-check-children child-bss
|
||||||
"Active EPGs must have at least one active child"
|
(either :right '(:active))
|
||||||
|
(either :left "Active EPGs must have at least one active child")
|
||||||
'(:active)
|
'(:active)
|
||||||
'(:active)
|
is-complete))
|
||||||
(lambda (child-bs)
|
|
||||||
(pcase child-bs
|
|
||||||
('(:active) t)
|
|
||||||
(_ nil)))))
|
|
||||||
(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)
|
(defun org-x-dag-bs-with-treetop-error (tree)
|
||||||
(declare (indent 3))
|
(declare (indent 3))
|
||||||
|
|
Loading…
Reference in New Issue