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

ENH abuse new TCO optimization (and make algorithms less silly)

This commit is contained in:
Nathan Dwarshuis 2022-04-27 23:44:25 -04:00
parent 19077c72c9
commit 1b1f4d1353
1 changed files with 179 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -581,34 +581,45 @@ used for optimization."
;; buffer status ;; buffer status
(defun org-x-dag-bs-check-children (bss msg nochild-def child-def fun)
(declare (indent 4))
;; this is almost like fold or foldM but I want to stop if `fun' returns nil
(cl-labels
;; hopefully the TCO native comp actually works :)
((fold-while
(xs)
(cond
((not xs) (either :right child-def))
((either-is-left-p (car xs)) (either :left "Child error"))
(t (if (funcall fun (car xs))
(fold-while (cdr xs))
(either :left msg))))))
(if (not bss) (either :right nochild-def)
(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)
;; -> Status b ;; -> Status b
(defmacro org-x-dag-bs-fold-children (bss default rank-form stop-form trans-form) (defun org-x-dag-bs-rankfold-children (bss default rank-fun stop-fun trans-fun)
(declare (indent 2)) (declare (indent 2))
(let ((err (either :left "Child error"))) (let ((err (either :left "Child error")))
`(if ,bss (cl-labels
(-let (((x . xs) ,bss)) ((fold-rank
(if (either-is-left-p x) ',err (acc xs)
(let ((acc (cadr x)) r final it) (if (not xs) (either :right acc)
(while (and (not final) xs) (-let (((x . rest) xs))
(setq x (car xs)) (pcase x
(if (either-is-left-p x) (`(:right ,r)
(setq final ',err) (either>>= (funcall rank-fun acc r)
(setq it (cadr x) (if (not it) (fold-rank acc rest)
r ,rank-form) (if (funcall stop-fun r) x (fold-rank r rest)))))
(unless r (_ err))))))
(error "You forgot the difference between Maybe and Either")) (if (not bss) (either :right default)
(if (either-is-left-p r) (pcase (car bss)
(setq final r) (`(:right ,r)
(when (cadr r) (if (funcall stop-fun r) (funcall trans-fun r)
(setq acc (cadr x))) (either>>= (fold-rank r (cdr bss))
(if ,stop-form (funcall trans-fun it))))
(setq final (either :right acc)) (_ err))))))
(!cdr xs)))))
(when (not final)
(setq final (either :right acc)))
(either>>= final ,trans-form))))
(either :right ,default))))
(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)))
@ -665,6 +676,9 @@ used for optimization."
(let ((canc-bs-form* (wrap-ancestry canc-bs-form)) (let ((canc-bs-form* (wrap-ancestry canc-bs-form))
(done-form* (lift-form done-form)) (done-form* (lift-form done-form))
(open-form* (lift-form open-form))) (open-form* (lift-form open-form)))
;; TODO this seems excessive, I'm unwrapping some outer type for the
;; sake of some inner type, but if any of these are left then
;; 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)
@ -692,32 +706,16 @@ used for optimization."
`(:sp-task :task-complete ,it-comptime)) `(:sp-task :task-complete ,it-comptime))
;; done form ;; done form
(org-x-dag-bs-fold-children it-children `(:sp-task :task-complete ,it-comptime) (org-x-dag-bs-check-children it-children
;; TODO this could be slightly more efficient if the error type is "Completed projects cannot have active children"
;; returned in this form and not the last `(:sp-task :task-complete ,it-comptime)
(->> (pcase `(,acc ,it) `(:sp-proj :proj-complete ,it-comptime)
(`((:sp-proj :proj-complete ,_) (:sp-proj :proj-complete ,_)) nil) (lambda (child-bs)
(`((:sp-iter :iter-complete ,_) (:sp-iter :iter-complete ,_)) nil) (pcase child-bs
(`((:sp-task :task-complete ,_) (:sp-task :task-complete ,_)) nil) (`(:sp-proj :proj-complete ,_) nil)
(`((:sp-proj :proj-complete ,_) ,_) t) (`(:sp-iter :iter-complete ,_) nil)
(`((:sp-iter :iter-complete ,_) ,_) t) (`(:sp-task :task-complete ,_) nil)
(`((:sp-task :task-complete ,_) ,_) t) (_ t))))
(`(,_ (:sp-proj :proj-complete ,_)) nil)
(`(,_ (:sp-iter :iter-complete ,_)) nil)
(`(,_ (:sp-task :task-complete ,_)) nil)
(e (error "Unmatched pattern: %S" e)))
(either :right))
(pcase acc
(`(:sp-proj :proj-complete ,_) nil)
(`(:sp-iter :iter-complete ,_) nil)
(`(:sp-task :task-complete ,_) nil)
(_ t))
(pcase it
((or `(:sp-proj :proj-complete ,_)
`(:sp-iter :iter-complete ,_)
`(:sp-task :task-complete ,_))
(either :right `(:sp-proj :proj-complete ,it-comptime)))
(_ (either :left "Completed projects cannot have active children"))))
;; undone form ;; undone form
(-let* (((sched dead) (-some->> it-planning (-let* (((sched dead) (-some->> it-planning
@ -732,78 +730,84 @@ 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-fold-children it-children task-default (org-x-dag-bs-rankfold-children it-children task-default
(->> (pcase `(,acc ,it) (lambda (acc next)
(`((:sp-task :task-active ,a) (:sp-task :task-active ,b)) (->> (pcase `(,acc ,next)
(and (not (is-next a)) (is-next b))) (`((:sp-task :task-active ,a) (:sp-task :task-active ,b))
(and (not (is-next a)) (is-next b)))
(`(,(or `(:sp-proj :proj-active) (`(,(or `(:sp-proj :proj-active)
`(: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))
(:sp-task :task-active ,d)) (:sp-task :task-active ,d))
(is-next d)) (is-next d))
(`((:sp-task :task-active ,d) (`((:sp-task :task-active ,d)
,(or `(:sp-proj :proj-active) ,(or `(:sp-proj :proj-active)
`(: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)))
(`((:sp-iter :iter-active ,_) ,_) nil) (`((:sp-iter :iter-active ,_) ,_) nil)
(`((:sp-proj :proj-active) ,_) nil) (`((:sp-proj :proj-active) ,_) nil)
(`(,_ (:sp-proj :proj-active)) t) (`(,_ (:sp-proj :proj-active)) t)
(`(,_ (:sp-iter :iter-active ,_)) t) (`(,_ (:sp-iter :iter-active ,_)) t)
(`((:sp-proj :proj-wait) ,_) nil) (`((:sp-proj :proj-wait) ,_) nil)
(`(,_ (:sp-proj :proj-wait)) t) (`(,_ (:sp-proj :proj-wait)) t)
(`((:sp-proj :proj-held) ,_) nil) (`((:sp-proj :proj-held) ,_) nil)
(`(,_ (:sp-proj :proj-held)) t) (`(,_ (:sp-proj :proj-held)) t)
(`((:sp-proj :proj-stuck) ,_) nil) (`((:sp-proj :proj-stuck) ,_) nil)
(`((:sp-iter :iter-empty) ,_) nil) (`((:sp-iter :iter-empty) ,_) nil)
(`((:sp-task :task-active ,_) ,_) nil) (`((:sp-task :task-active ,_) ,_) nil)
(`(,_ (:sp-proj :proj-stuck)) t) (`(,_ (:sp-proj :proj-stuck)) t)
(`(,_ (:sp-iter :iter-empty)) t) (`(,_ (:sp-iter :iter-empty)) t)
(`(,_ (:sp-task :task-active ,_)) t) (`(,_ (:sp-task :task-active ,_)) t)
;; any pair that makes it this far is completed in both, which means ;; any pair that makes it this far is completed in both,
;; neither takes precedence, which means choose the left one ;; which means neither takes precedence, which means choose
(`(,_ ,_) nil)) ;; the left one
(either :right)) (`(,_ ,_) nil))
(either :right)))
;; early stop ;; early stop
(pcase acc (lambda (next)
(`(:sp-proj :proj-active) t) (pcase next
(`(:sp-iter :iter-active ,_) t) (`(:sp-proj :proj-active) t)
(`(:sp-task :task-active ,d) (is-next d)) (`(:sp-iter :iter-active ,_) t)
(_ nil)) (`(:sp-task :task-active ,d) (is-next d))
(_ nil)))
;; child -> parent translation ;; child -> parent translation
(pcase it (lambda (acc)
((or `(:sp-proj :proj-complete ,_) (pcase acc
`(:sp-task :task-complete ,_) ((or `(:sp-proj :proj-complete ,_)
`(:sp-iter :iter-complete ,_)) `(:sp-task :task-complete ,_)
(either :left "Active projects must have at least one active child")) `(:sp-iter :iter-complete ,_))
(`(:sp-proj ,s) (new-proj s)) (->> "Active projects must have at least one active child"
(`(:sp-iter :iter-active ,_) (new-proj :proj-active)) (either :left )))
(`(:sp-iter :iter-empty) (new-proj :proj-stuck)) (`(:sp-proj ,s) (new-proj s))
(`(:sp-task :task-active ,d) (`(:sp-iter :iter-active ,_) (new-proj :proj-active))
(-let (((&plist :todo o :sched s) d)) (`(:sp-iter :iter-empty) (new-proj :proj-stuck))
(cond (`(:sp-task :task-active ,d)
((equal o org-x-kw-todo) (->> (if s :proj-active :proj-stuck) (-let (((&plist :todo o :sched s) d))
(new-proj))) (cond
((equal o org-x-kw-next) (new-proj :proj-active)) ((equal o org-x-kw-todo) (->> (if s :proj-active
((equal o org-x-kw-wait) (new-proj :proj-wait)) :proj-stuck)
((equal o org-x-kw-hold) (new-proj :proj-hold)) (new-proj)))
(t (org-x-dag-bs-error-kw "Task action" o))))) ((equal o org-x-kw-next) (new-proj :proj-active))
(e (error "Pattern fail: %s" e))))) ((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 (child-bss
(org-x-dag-bs-error-kw "Project action" it-todo)) (org-x-dag-bs-error-kw "Project action" it-todo))
(t (t
@ -820,63 +824,58 @@ used for optimization."
(defun org-x-dag-bs-action-subiter-complete-fold (child-bss comptime type-name (defun org-x-dag-bs-action-subiter-complete-fold (child-bss comptime type-name
comp-key) comp-key)
(declare (indent 2)) (declare (indent 2))
(org-x-dag-bs-fold-children child-bss `(,comp-key ,comptime) (org-x-dag-bs-check-children child-bss
(->> (pcase `(,acc ,it) (format "Completed %s cannot have active children" type-name)
(`((:si-complete ,_) (:si-complete ,_)) nil) `(,comp-key ,comptime)
(`((:si-complete ,_) ,_) t) `(,comp-key ,comptime)
(`(,_ (:si-complete ,_)) nil) (lambda (child-bs)
(e (error "Unmatched pattern: %S" e))) (pcase child-bs
(either :right)) (`(:si-complete ,_) nil)
(pcase acc (_ t)))))
(`(:si-complete ,_) nil)
(_ t))
(pcase it
(`(:si-complete ,_)
(either :right `(,comp-key ,comptime)))
(_
(->> (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 (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-fold-children child-bss default (org-x-dag-bs-rankfold-children child-bss default
(pcase `(,acc ,it) (lambda (acc next)
(`((:si-active ,a) (:si-active ,b)) (pcase `(,acc ,next)
(-let (((&plist :sched as :dead ad) a) (`((:si-active ,a) (:si-active ,b))
((&plist :sched bs :dead bd) b)) (-let (((&plist :sched as :dead ad) a)
(cond ((&plist :sched bs :dead bd) b))
((or (xor as bs) (xor ad bd)) (cond
(->> "All sub-iters must have the same planning configuration" ((or (xor as bs) (xor ad bd))
(either :left))) (->> "All sub-iters must have the same planning configuration"
((and as bs (xor (org-ml-time-is-long as) (org-ml-time-is-long bs))) (either :left)))
(->> "Sub-iters must have scheduled timestamp with same length" ((and as bs (xor (org-ml-time-is-long as) (org-ml-time-is-long bs)))
(either :left))) (->> "Sub-iters must have scheduled timestamp with same length"
((and ad bd (xor (org-ml-time-is-long ad) (org-ml-time-is-long bd))) (either :left)))
(->> "Sub-iters must have deadline timestamp with same length" ((and ad bd (xor (org-ml-time-is-long ad) (org-ml-time-is-long bd)))
(either :left))) (->> "Sub-iters must have deadline timestamp with same length"
;; ASSUME this won't fail since the datetimes are assumed to be the (either :left)))
;; same length as per rules above ;; ASSUME this won't fail since the datetimes are assumed to be the
((and ad bd) ;; same length as per rules above
(->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time ad) ((and ad bd)
(org-ml-timestamp-get-start-time bd)) (->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time ad)
(either :right))) (org-ml-timestamp-get-start-time bd))
(t (either :right)))
(->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time as) (t
(org-ml-timestamp-get-start-time bs)) (->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time as)
(either :right)))))) (org-ml-timestamp-get-start-time bs))
(`((:si-active ,_) ,_) (either :right nil)) (either :right))))))
(`(,_ (:si-active ,_)) (either :right t)) (`((:si-active ,_) ,_) (either :right nil))
(`(,_ ,_) (either :right nil))) (`(,_ (:si-active ,_)) (either :right t))
(pcase acc (`(,_ ,_) (either :right nil))))
(`(:si-active ,_) t) (lambda (next)
(_ nil)) (pcase next
(pcase it (`(:si-active ,_) t)
(`(:si-complete ,_) (_ nil)))
(->> (format "Active %s must have at least one active child" type-name) (lambda (acc)
(either :left))) (pcase acc
(`(:si-active ,ts-data) (`(:si-complete ,_)
(either :right `(,active-key ,ts-data)))))) (->> type-name
(org-x-dag-left "Active %s must have at least one active child")))
(`(:si-active ,ts-data)
(either :right `(,active-key ,ts-data)))))))
(defun org-x-dag-node-is-iterator-p (node) (defun org-x-dag-node-is-iterator-p (node)
(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)))
@ -923,35 +922,26 @@ used for optimization."
(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" (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 it-children `(:complete ,it-comptime) (org-x-dag-bs-check-children it-children
(->> (pcase `(,acc ,it) "Completed EPGs cannot have active children"
(`((:complete ,_) (:complete ,_)) nil) `(:complete ,it-comptime)
(`(,_ (:complete ,_)) nil) `(:complete ,it-comptime)
(`((:complete ,_) ,_) t)) (lambda (child-bs)
(either :right)) (pcase child-bs
(pcase acc (`(:complete ,_) nil)
(`(:complete ,_) nil) (_ t))))
(_ t))
(pcase it
(`(:complete ,_)
(either :right `(:complete ,it-comptime)))
(_ (either :left "Completed EPGs cannot have active children"))))
(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-fold-children it-children `(:active) (org-x-dag-bs-check-children it-children
(->> (pcase `(,acc ,it) "Active EPGs must have at least one active child"
(`((:active) (:active)) nil) '(:active)
(`(,_ (:active)) t) '(:active)
(`((:active) ,_) nil)) (lambda (child-bs)
(either :right)) (pcase child-bs
nil ('(:active) t)
(pcase it (_ nil)))))
('(:active)
(either :right '(:active)))
(_
(either :left "Active EPGs must have at least one active child")))))
(t (t
(org-x-dag-bs-error-kw "Endpoint goal" it-todo))))) (org-x-dag-bs-error-kw "Endpoint goal" it-todo)))))