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

82
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,18 +1090,20 @@ 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
((new-active-proj
(d s cs)
(->> (list :dead d :child-scheds cs :leading-sched s)
(list :si-proj :proj-active)
(either :right))))
(org-x-dag-bs-action-with-closed node-data ancestry "sub-iterators" (org-x-dag-bs-action-with-closed node-data ancestry "sub-iterators"
(if child-bss (if child-bss
`(:si-proj :proj-complete ,it-comptime) `(:si-proj :proj-complete ,it-comptime)
@ -1128,31 +1137,17 @@ deadline (eg via epoch time) or if it has a repeater."
(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)
(-let (((&plist :dead d :leading-sched s) ts-data))
(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 (t
(org-x-dag-bs-error-kw "Sub-iterator" it-todo))))))) (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
((new-active-iter
(d s cs)
(->> (list :dead d :child-scheds cs :leading-sched s)
(list :iter-nonempty :nonempty-active)
(either :right))))
(org-x-dag-bs-action-with-closed node-data ancestry "iterators" (org-x-dag-bs-action-with-closed node-data ancestry "iterators"
`(:iter-empty :empty-complete ,it-comptime) `(:iter-empty :empty-complete ,it-comptime)
(org-x-dag-bs-action-subiter-complete-fold child-bss it-comptime "iterators" (org-x-dag-bs-action-subiter-complete-fold child-bss it-comptime "iterators"
@ -1163,22 +1158,13 @@ deadline (eg via epoch time) or if it has a repeater."
(either :left "Iterators cannot be scheduled or deadlined")) (either :left "Iterators cannot be scheduled or deadlined"))
;; 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 :empty-active) (org-x-dag-bs-action-subiter-todo-fold child-bss
(lambda (acc cs) '(:iter-empty :empty-active)
(pcase acc (either :right '(:iter-nonempty :nonempty-complete))
((or `(:si-task :task-complete ,_) (lambda (data)
`(:si-proj :proj-complete ,_)) (either :right `(:iter-nonempty :nonempty-active ,data)))))
(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 (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)
(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)