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

ENH don't map over children unless we need to

This commit is contained in:
Nathan Dwarshuis 2022-04-28 20:13:49 -04:00
parent a94d51020f
commit 1a4c7e0bc6
1 changed files with 61 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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)
(org-x-dag-bs-action-with-closed node ancestry child-bss "endpoint goal" (let ((is-complete
`(:complete ,it-comptime) (lambda (child-bs)
(org-x-dag-bs-check-children it-children (pcase (plist-get :local child-bs)
"Completed EPGs cannot have active children" (`(:complete ,_) t)
`(:complete ,it-comptime) (_ nil)))))
`(:complete ,it-comptime) (org-x-dag-bs-action-with-closed node ancestry child-bss "endpoint goal"
(lambda (child-bs) `(:complete ,it-comptime)
(pcase child-bs (org-x-dag-bs-check-children child-bss
(`(:complete ,_) nil) (either :left "Completed EPGs cannot have active children")
(_ t)))) (either :right `(:complete ,it-comptime))
(cond `(:complete ,it-comptime)
((-some->> it-planning (org-ml-get-property :scheduled)) is-complete)
(either :left "EPGs cannot be scheduled")) (cond
((equal it-todo org-x-kw-todo) ((-some->> it-planning (org-ml-get-property :scheduled))
(org-x-dag-bs-check-children it-children (either :left "EPGs cannot be scheduled"))
"Active EPGs must have at least one active child" ((equal it-todo org-x-kw-todo)
'(:active) (org-x-dag-bs-check-children child-bss
'(:active) (either :right '(:active))
(lambda (child-bs) (either :left "Active EPGs must have at least one active child")
(pcase child-bs '(:active)
('(:active) t) is-complete))
(_ 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))