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

ENH make rankfold function accumulate "stuff" in parallel

This commit is contained in:
Nathan Dwarshuis 2022-06-02 18:09:24 -04:00
parent fb3b8f997d
commit edf2480b6f
1 changed files with 27 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -668,28 +668,39 @@ used for optimization."
(lambda (child-bs) (lambda (child-bs)
(funcall stop-fun (plist-get child-bs :local))))) (funcall stop-fun (plist-get child-bs :local)))))
;; [Status a] -> b -> (a -> a -> Status Bool) -> (a -> Bool) -> (a -> Status b) ;; [Status a] -> b -> (a -> a -> Status Bool) -> (a -> Bool) -> (a -> Maybe c)
;; -> Status b ;; -> (a -> [c] -> Status b) -> Status b
(defun org-x-dag-bs-rankfold-children (bss default rank-fun stop-fun trans-fun) (defun org-x-dag-bs-rankfold-children (bss default rank-fun stop-fun acc-fun trans-fun)
(declare (indent 2)) (declare (indent 2))
(let ((err (either :left "Child error"))) (let ((err (either :left "Child error")))
(cl-labels (cl-labels
((fold-rank ((cons-maybe
(x xs)
(if x (cons x xs) xs))
(fold-rank
(acc xs) (acc xs)
(if (not xs) (either :right acc) (if (not xs) (either :right acc)
(-let (((x . rest) xs)) (-let (((x . rest) xs))
(pcase x (pcase x
(`(:right ,r) (`(:right ,r)
(either>>= (funcall rank-fun acc r) (-let (((cur as) acc))
(if (not it) (fold-rank acc rest) (either>>= (funcall rank-fun cur r)
(if (funcall stop-fun r) x (fold-rank r rest))))) (let ((as* (cons-maybe (funcall acc-fun it) as)))
(if (not it) (fold-rank `(,cur ,as*) rest)
(if (funcall stop-fun r)
(either :right `(,r ,as*))
(fold-rank `(,r ,as*) rest)))))))
(_ err)))))) (_ err))))))
(if (not bss) (either :right default) (if (not bss) (either :right default)
(pcase (car bss) (pcase (car bss)
(`(:right ,r) (`(:right ,r)
(if (funcall stop-fun r) (funcall trans-fun r) (if (funcall stop-fun r)
(either>>= (fold-rank r (cdr bss)) (->> (funcall acc-fun r)
(funcall trans-fun it)))) (list)
(funcall trans-fun r))
(either>>= (fold-rank (list r nil) (cdr bss))
(-let (((cur as) it))
(funcall trans-fun cur as)))))
(_ err)))))) (_ err))))))
(defun org-x-dag-bs-action-rankfold-children (bss default rank-fun stop-fun (defun org-x-dag-bs-action-rankfold-children (bss default rank-fun stop-fun
@ -699,7 +710,9 @@ used for optimization."
(org-x-dag-bs-rankfold-children bss default (org-x-dag-bs-rankfold-children bss default
(-on rank-fun #'get-local) (-on rank-fun #'get-local)
(-compose stop-fun #'get-local) (-compose stop-fun #'get-local)
(-compose trans-fun #'get-local)))) (-const nil)
(lambda (x as)
(funcall trans-fun (get-local x) as)))))
(defmacro org-x-dag-left (fmt &rest args) (defmacro org-x-dag-left (fmt &rest args)
`(either :left (format ,fmt ,@args))) `(either :left (format ,fmt ,@args)))
@ -875,7 +888,7 @@ deadline (eg via epoch time) or if it has a repeater."
(`(:sp-task :task-active ,d) (is-next d)) (`(:sp-task :task-active ,d) (is-next d))
(_ nil))) (_ nil)))
(lambda (acc) (lambda (acc _)
(pcase acc (pcase acc
((or `(:sp-proj :proj-complete ,_) ((or `(:sp-proj :proj-complete ,_)
`(:sp-task :task-complete ,_) `(:sp-task :task-complete ,_)
@ -980,7 +993,7 @@ deadline (eg via epoch time) or if it has a repeater."
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(org-x-dag-bs-action-subiter-todo-fold child-bss (org-x-dag-bs-action-subiter-todo-fold child-bss
`(:si-active (:sched ,sched :dead ,dead)) `(:si-active (:sched ,sched :dead ,dead))
(lambda (acc) (lambda (acc _)
(pcase acc (pcase acc
(`(:si-complete ,_) (`(:si-complete ,_)
(org-x-dag-left "Active sub-iterator must have at least one active child")) (org-x-dag-left "Active sub-iterator must have at least one active child"))
@ -1001,7 +1014,7 @@ deadline (eg via epoch time) or if it has a repeater."
;; 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 '(:iter-empty) (org-x-dag-bs-action-subiter-todo-fold child-bss '(:iter-empty)
(lambda (acc) (lambda (acc _)
(pcase acc (pcase acc
(`(:si-complete ,_) (either :right '(:iter-empty))) (`(:si-complete ,_) (either :right '(:iter-empty)))
(`(:si-active ,ts-data) (`(:si-active ,ts-data)