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

ENH make iterator date logic simpler

This commit is contained in:
Nathan Dwarshuis 2022-06-11 22:56:07 -04:00
parent e4ae5ca4a1
commit dc7c134045
2 changed files with 86 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -155,7 +155,7 @@
(org-x-dag-datetime-to-date datetime1))) (org-x-dag-datetime-to-date datetime1)))
(defun org-x-dag-datetime-max (datetimes) (defun org-x-dag-datetime-max (datetimes)
(-max-by #'org-x-dag-datetime< datetimes)) (-max-by #'org-x-dag-datetime> datetimes))
(defun org-x-dag-date-max (datetimes) (defun org-x-dag-date-max (datetimes)
(-max-by #'org-x-dag-date< datetimes)) (-max-by #'org-x-dag-date< datetimes))
@ -1001,7 +1001,8 @@ deadline (eg via epoch time) or if it has a repeater."
((or `(:si-task :task-complete ,_) `(:si-proj :proj-complete ,_)) t) ((or `(:si-task :task-complete ,_) `(:si-proj :proj-complete ,_)) t)
(_ nil))))) (_ nil)))))
(defun org-x-dag-bs-action-subiter-todo-fold (child-bss default trans-fun) (defun org-x-dag-bs-action-subiter-todo-fold
(child-bss default complete-default new-active-fun)
(declare (indent 2)) (declare (indent 2))
(cl-flet* (cl-flet*
((fmt-left ((fmt-left
@ -1025,7 +1026,7 @@ deadline (eg via epoch time) or if it has a repeater."
(org-x-dag-with-datetimes (org-x-dag-with-datetimes
a b a b
(lambda (a b) (lambda (a b)
(either :right (org-x-dag-pts-compare a b))) (either :right (org-x-dag-datetime-compare a b)))
(-const (either :left 'length)))))) (-const (either :left 'length))))))
(comp2right (comp2right
(sched? comp) (sched? comp)
@ -1042,7 +1043,13 @@ deadline (eg via epoch time) or if it has a repeater."
(sym-left-2 (sym-left-2
(sched-sym dead-sym) (sched-sym dead-sym)
(if (eq sched-sym dead-sym) (fmt-left-both (left2err sched-sym)) (if (eq sched-sym dead-sym) (fmt-left-both (left2err sched-sym))
(fmt-left-2 (left2err sched-sym) (left2err dead-sym))))) (fmt-left-2 (left2err sched-sym) (left2err dead-sym))))
(new-active
(ts-data child-scheds)
(->> (list :dead (plist-get ts-data :dead)
:child-sched-dts child-scheds
:leading-sched-dt (org-x-dag-datetime-max child-scheds))
(funcall new-active-fun))))
(org-x-dag-bs-action-rankfold-children child-bss default (org-x-dag-bs-action-rankfold-children child-bss default
(lambda (acc next) (lambda (acc next)
(pcase `(,acc ,next) (pcase `(,acc ,next)
@ -1083,102 +1090,81 @@ deadline (eg via epoch time) or if it has a repeater."
(`(:si-proj :proj-active ,d) (plist-get d :child-scheds)) (`(:si-proj :proj-active ,d) (plist-get d :child-scheds))
(`(:si-task :task-active ,d) (-some-> (plist-get d :sched) (list))) (`(:si-task :task-active ,d) (-some-> (plist-get d :sched) (list)))
(_ nil))) (_ nil)))
trans-fun))) (lambda (acc cs)
(pcase acc
((or `(:si-task :task-complete ,_) `(:si-proj :proj-complete ,_))
complete-default)
(`(:si-proj :proj-active ,ts-data)
(new-active ts-data cs))
(`(:si-task :task-active ,ts-data)
(new-active ts-data cs))
(e (error "Invalid pattern: %s" e)))))))
(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)))
(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)
(cl-flet (org-x-dag-bs-action-with-closed node-data ancestry "sub-iterators"
((new-active-proj (if child-bss
(d s cs) `(:si-proj :proj-complete ,it-comptime)
(->> (list :dead d :child-scheds cs :leading-sched s) `(:si-task :task-complete ,it-comptime))
(list :si-proj :proj-active)
(either :right))))
(org-x-dag-bs-action-with-closed node-data ancestry "sub-iterators"
(if child-bss
`(:si-proj :proj-complete ,it-comptime)
`(:si-task :task-complete ,it-comptime))
(org-x-dag-bs-action-subiter-complete-fold child-bss it-comptime (org-x-dag-bs-action-subiter-complete-fold child-bss it-comptime
"sub-iterators" "sub-iterators"
(lambda (c) `(:si-proj :proj-complete ,c)) (lambda (c) `(:si-proj :proj-complete ,c))
(lambda (c) `(:si-task :task-complete ,c))) (lambda (c) `(:si-task :task-complete ,c)))
(-let* (((sched dead) (-some->> it-planning (-let* (((sched dead) (-some->> it-planning
(org-ml-get-properties '(:scheduled :deadline)))) (org-ml-get-properties '(:scheduled :deadline))))
(sp (-some-> sched (org-x-dag-partition-timestamp))) (sp (-some-> sched (org-x-dag-partition-timestamp)))
(dp (-some-> dead (org-x-dag-partition-timestamp)))) (dp (-some-> dead (org-x-dag-partition-timestamp))))
(cond (cond
((and sp child-bss) ((and sp child-bss)
(either :left "Project sub-iterators cannot be scheduled")) (either :left "Project sub-iterators cannot be scheduled"))
((and dp child-bss) ((and dp child-bss)
(either :left "Project sub-iterators cannot be deadlined")) (either :left "Project sub-iterators cannot be deadlined"))
((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"))
((org-x-dag-action-dead-after-parent-p ancestry dead) ((org-x-dag-action-dead-after-parent-p ancestry dead)
(either :left "Sub-iterator deadline must not start after parent")) (either :left "Sub-iterator deadline must not start after parent"))
((and sp (plist-get sp :repeater)) ((and sp (plist-get sp :repeater))
(either :left "Scheduled sub-iterators cannot repeat")) (either :left "Scheduled sub-iterators cannot repeat"))
((and dp (plist-get dp :repeater)) ((and dp (plist-get dp :repeater))
(either :left "Deadlined sub-iterators cannot repeat")) (either :left "Deadlined sub-iterators cannot repeat"))
((and sp (< 0 (plist-get sp :length))) ((and sp (< 0 (plist-get sp :length)))
(either :left "Scheduled sub-iterators cannot be ranged")) (either :left "Scheduled sub-iterators cannot be ranged"))
((and dp (< 0 (plist-get dp :length))) ((and dp (< 0 (plist-get dp :length)))
(either :left "Deadlined sub-iterators cannot be ranged")) (either :left "Deadlined sub-iterators cannot be ranged"))
((member it-todo (list org-x-kw-todo org-x-kw-wait)) ((member it-todo (list org-x-kw-todo org-x-kw-wait))
(org-x-dag-bs-action-subiter-todo-fold child-bss (org-x-dag-bs-action-subiter-todo-fold child-bss
`(:si-task :task-active (:sched ,sp :dead ,dp)) (->> (list :sched (plist-get sp :datetime)
(lambda (acc cs) :dead (plist-get dp :datetime))
(pcase acc (list :si-task :task-active))
((or `(:si-proj :proj-complete ,_) (->> "Active sub-iterator must have at least one active child"
`(:si-task :task-complete ,_)) (either :left))
(-> "Active sub-iterator must have at least one active child" (lambda (data)
(org-x-dag-left))) (either :right `(:si-proj :proj-active ,data)))))
(`(:si-proj :proj-active ,ts-data) (t
(-let (((&plist :dead d :leading-sched s) ts-data)) (org-x-dag-bs-error-kw "Sub-iterator" it-todo))))))
(new-active-proj d s cs)))
(`(:si-task :task-active ,ts-data)
(-let (((&plist :dead d) ts-data)
((&plist :datetime s) (org-x-dag-pts-max cs)))
(new-active-proj d s cs)))
(e (error "Invalid pattern: %s" e))))))
(t
(org-x-dag-bs-error-kw "Sub-iterator" it-todo)))))))
(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)
(cl-flet (org-x-dag-bs-action-with-closed node-data ancestry "iterators"
((new-active-iter `(:iter-empty :empty-complete ,it-comptime)
(d s cs) (org-x-dag-bs-action-subiter-complete-fold child-bss it-comptime "iterators"
(->> (list :dead d :child-scheds cs :leading-sched s) (lambda (c) `(:iter-nonempty :nonempty-complete ,c))
(list :iter-nonempty :nonempty-active) (lambda (c) `(:iter-empty :empty-complete ,c)))
(either :right)))) (cond
(org-x-dag-bs-action-with-closed node-data ancestry "iterators" (it-planning
`(:iter-empty :empty-complete ,it-comptime) (either :left "Iterators cannot be scheduled or deadlined"))
(org-x-dag-bs-action-subiter-complete-fold child-bss it-comptime "iterators" ;; TODO also check for timeshift and archive props
(lambda (c) `(:iter-nonempty :nonempty-complete ,c)) ((equal it-todo org-x-kw-todo)
(lambda (c) `(:iter-empty :empty-complete ,c))) (org-x-dag-bs-action-subiter-todo-fold child-bss
(cond '(:iter-empty :empty-active)
(it-planning (either :right '(:iter-nonempty :nonempty-complete))
(either :left "Iterators cannot be scheduled or deadlined")) (lambda (data)
;; TODO also check for timeshift and archive props (either :right `(:iter-nonempty :nonempty-active ,data)))))
((equal it-todo org-x-kw-todo) (t
(org-x-dag-bs-action-subiter-todo-fold child-bss '(:iter-empty :empty-active) (org-x-dag-bs-error-kw "Iterator" it-todo)))))
(lambda (acc cs)
(pcase acc
((or `(:si-task :task-complete ,_)
`(:si-proj :proj-complete ,_))
(either :right '(:iter-nonempty :nonempty-complete)))
(`(:si-task :task-active ,ts-data)
(-let* (((&plist :dead d) ts-data)
((&plist :datetime s) (org-x-dag-pts-max cs)))
(new-active-iter d s cs)))
(`(:si-proj :proj-active ,ts-data)
(-let (((&plist :dead d :leading-sched s) ts-data))
(new-active-iter d s cs)))
(e (error "Invalid pattern: %s" e))))))
(t
(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 (let ((is-complete

14
local/lib/org-x/test/org-x-dag-test.el
View File

@ -42,6 +42,10 @@
(->> (org-ml-from-string 'timestamp s) (->> (org-ml-from-string 'timestamp s)
(org-x-dag-partition-timestamp))) (org-x-dag-partition-timestamp)))
(defun timestamp-to-datetime (s)
(->> (org-ml-from-string 'timestamp s)
(org-ml-timestamp-get-start-time)))
(buttercup-define-matcher :to-be-left-with (a x) (buttercup-define-matcher :to-be-left-with (a x)
(cl-destructuring-bind (cl-destructuring-bind
((a-expr . a) (x-expr . x)) ((a-expr . a) (x-expr . x))
@ -280,13 +284,13 @@
(describe "Iterators" (describe "Iterators"
(it "Active non-empty" (it "Active non-empty"
(let ((s0 (partition-timestamp "<2022-06-07 Tue>")) (let ((s0 (timestamp-to-datetime "<2022-06-07 Tue>"))
(s1 (partition-timestamp "<2022-06-14 Tue>")) (s1 (timestamp-to-datetime "<2022-06-14 Tue>"))
(s2 (partition-timestamp "<2022-06-21 Tue>"))) (s2 (timestamp-to-datetime "<2022-06-21 Tue>")))
(expect "2711e9b9-f765-415d-930f-b7ff16b3140b" :id-to-be-action (expect "2711e9b9-f765-415d-930f-b7ff16b3140b" :id-to-be-action
nil nil nil :sp-iter '(:iter-nonempty :nonempty-active) nil nil nil :sp-iter '(:iter-nonempty :nonempty-active)
(list :child-scheds `(,s0 ,s1 ,s2) (list :child-sched-dts `(,s0 ,s1 ,s2)
:leading-sched (plist-get s2 :datetime) :leading-sched-dt s2
:dead nil))))))) :dead nil)))))))
(provide 'org-x-dag-test) (provide 'org-x-dag-test)