ENH abuse new TCO optimization (and make algorithms less silly)
This commit is contained in:
parent
19077c72c9
commit
1b1f4d1353
|
@ -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)))))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue