diff --git a/local/lib/org-x/org-x-dag.el b/local/lib/org-x/org-x-dag.el index 6215c1d..695ed88 100644 --- a/local/lib/org-x/org-x-dag.el +++ b/local/lib/org-x/org-x-dag.el @@ -88,14 +88,21 @@ ;; datetime operations -(defmacro org-x-dag-with-times (datetime0 datetime1 form) +(defun org-x-dag-datetimes-same-length-p (datetime0 datetime1) ;; ASSUME all digits in this comparison are on the calendar/clock (eg day 32 ;; does not 'rollover' to day 1 on the next month) + (not (xor (org-ml-time-is-long datetime0) (org-ml-time-is-long datetime1)))) + +;; Maybe a -> Maybe a -> (a -> a -> b) -> b -> Maybe b +(defun org-x-dag-with-datetimes (a b fun alt) + (when (and a b) + (if (org-x-dag-datetimes-same-length-p a b) + (funcall fun a b) + (funcall alt)))) + +(defmacro org-x-dag-with-times (datetime0 datetime1 form) (declare (indent 2)) - `(if (or (and (org-ml-time-is-long ,datetime0) - (org-ml-time-is-long ,datetime1)) - (not (or (org-ml-time-is-long ,datetime0) - (org-ml-time-is-long ,datetime1)))) + `(if (org-x-dag-datetimes-same-length-p datetime0 datetime1) ,form (error "Datetimes are invalid lengths: %S and %S" ,datetime0 ,datetime1))) @@ -126,6 +133,12 @@ (--drop-while (= (car it) (cdr it))) (not)))) +(defun org-x-dag-datetime-compare (a b) + (cond + ((org-x-dag-datetime= a b) 'eq) + ((org-x-dag-datetime< a b) 'gt) + (t 'lt))) + (defun org-x-dag-date< (datetime0 datetime1) (org-x-dag-datetime< (org-x-dag-datetime-to-date datetime0) (org-x-dag-datetime-to-date datetime1))) @@ -141,6 +154,12 @@ (org-x-dag-datetime= (org-x-dag-datetime-to-date datetime0) (org-x-dag-datetime-to-date datetime1))) +(defun org-x-dag-datetime-max (datetimes) + (-max-by #'org-x-dag-datetime< datetimes)) + +(defun org-x-dag-date-max (datetimes) + (-max-by #'org-x-dag-date< datetimes)) + (defun org-x-dag-datetime-shift (datetime shift unit) (cl-flet* ((enc-dec-long @@ -173,6 +192,9 @@ ;; date <-> epoch +(defun org-x-dag-datetime-to-epoch (date) + (float-time (encode-time `(0 ,@(reverse date) nil -1 nil)))) + (defun org-x-dag-date-to-epoch (date) (float-time (encode-time `(0 0 0 ,@(reverse date) nil -1 nil)))) @@ -375,6 +397,36 @@ relative shift in days from ABS." ;; (org-x-dag-format-month-tag m) ;; (org-x-dag-format-day-tag d)))) +;; timestamps <-> datetime + +(defun org-x-dag-partition-timestamp (ts) + (list :datetime (org-ml-timestamp-get-start-time ts) + :length (org-ml-timestamp-get-range ts) + :pos (org-ml-get-property :begin ts) + :repeater (org-ml-timestamp-extract-modulus 'repeater ts) + :warning (org-ml-timestamp-extract-modulus 'warning ts))) + +(defun org-x--dag-pts-compare (fun a b) + (funcall (-on fun (lambda (ts) (plist-get ts :datetime))) a b)) + +(defun org-x-dag-pts-compare (a b) + (org-x--dag-pts-compare #'org-x-dag-datetime-compare a b)) + +(defun org-x-dag-pts= (a b) + (org-x--dag-pts-compare #'org-x-dag-datetime= a b)) + +(defun org-x-dag-pts< (a b) + (org-x--dag-pts-compare #'org-x-dag-datetime< a b)) + +(defun org-x-dag-pts> (a b) + (org-x--dag-pts-compare #'org-x-dag-datetime> a b)) + +(defun org-x-dag-pts-max (ps) + (-max-by #'org-x-dag-pts> ps)) + +(defun org-x-dag-pts-is-long-p (pts) + (org-ml-time-is-long (plist-get pts :datetime))) + ;; allocation (pcase-defmacro regexp (capture regexp) @@ -699,7 +751,8 @@ used for optimization." (pcase (car bss) (`(:right ,r) (if (funcall stop-fun r) - (->> (funcall acc-fun r) + (->> (either-rights bss) + (--mapcat (funcall acc-fun it)) (funcall trans-fun r)) (either>>= (fold-rank (list r nil) (cdr bss)) (-let (((cur as) it)) @@ -708,8 +761,11 @@ used for optimization." (defun org-x-dag-bs-action-rankfold-children (bss default rank-fun stop-fun acc-fun trans-fun) - (cl-flet ((get-local (x) (plist-get x :local))) - (declare (indent 2)) + (declare (indent 2)) + (cl-flet + ((get-local + (x) + (plist-get x :local))) (org-x-dag-bs-rankfold-children bss default (-on rank-fun #'get-local) (-compose stop-fun #'get-local) @@ -947,51 +1003,87 @@ deadline (eg via epoch time) or if it has a repeater." (defun org-x-dag-bs-action-subiter-todo-fold (child-bss default trans-fun) (declare (indent 2)) - (org-x-dag-bs-action-rankfold-children child-bss default - (lambda (acc next) - (pcase `(,acc ,next) - ;; for active tasks, the furthest in the future is ranked the highest - (`((:si-task :task-active ,a) (:si-task :task-active ,b)) - (-let (((&plist :sched as :dead ad) a) - ((&plist :sched bs :dead bd) b)) - (cond - ((or (xor as bs) (xor ad bd)) - (->> "All sub-iters must have the same planning configuration" - (either :left))) - ((and as bs (xor (org-ml-time-is-long as) (org-ml-time-is-long bs))) - (->> "Sub-iters must have scheduled timestamp with same length" - (either :left))) - ((and ad bd (xor (org-ml-time-is-long ad) (org-ml-time-is-long bd))) - (->> "Sub-iters must have deadline timestamp with same length" - (either :left))) - ;; ASSUME this won't fail since the datetimes are assumed to be the - ;; same length as per rules above - ((and ad bd) - (->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time ad) - (org-ml-timestamp-get-start-time bd)) - (either :right))) - (t - (->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time as) - (org-ml-timestamp-get-start-time bs)) - (either :right)))))) - ((or `((:si-task . ,_) (:si-proj . ,_)) - `((:si-proj . ,_) (:si-task . ,_))) - (either :left "Sub-iterators must have same project structure")) - (`(,(or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_)) ,_) - (either :right nil)) - (`(,_ ,(or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_))) - (either :right t)) - (`(,_ ,_) (either :right nil)))) - (lambda (next) - (pcase next - ((or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_)) t) - (_ nil))) - (lambda (next) - (pcase next - (`(:si-proj :proj-active ,d) (plist-get d :child-scheds)) - (`(:si-task :task-active ,d) (list (plist-get d :sched))) - (_ nil))) - trans-fun)) + (cl-flet* + ((fmt-left + (sched? wrong) + (let ((what (if sched? "scheduled" "deadlined"))) + (org-x-dag-left "Sub-iter %s timestamps %s" what wrong))) + (fmt-left-both + (wrong) + (org-x-dag-left "Sub-iter scheduled/deadlined timestamps %s" wrong)) + (fmt-left-2 + (sched-wrong dead-wrong) + (org-x-dag-left + "Sub-iter scheduled timestamps %s and deadlined timestamps %s" + sched-wrong dead-wrong)) + (compare + (a b) + (cond + ((not (or a b)) (either :left nil)) + ((xor a b) (either :left 'presence)) + (t + (org-x-dag-with-datetimes + a b + (lambda (a b) + (either :right (org-x-dag-pts-compare a b))) + (-const (either :left 'length)))))) + (comp2right + (sched? comp) + (if (eq comp 'eq) (fmt-left sched? "should be different") + (either :right (eq comp 'gt)))) + (left2err + (sym) + (pcase sym + (`presence "should be on all or none") + (`length "must have same length"))) + (sym-left + (sched? sym) + (fmt-left sched? (left2err sym))) + (sym-left-2 + (sched-sym dead-sym) + (if (eq sched-sym dead-sym) (fmt-left-both (left2err sched-sym)) + (fmt-left-2 (left2err sched-sym) (left2err dead-sym))))) + (org-x-dag-bs-action-rankfold-children child-bss default + (lambda (acc next) + (pcase `(,acc ,next) + ;; for active tasks, the furthest in the future is ranked the highest + (`((:si-task :task-active ,a) (:si-task :task-active ,b)) + (-let (((&plist :sched as :dead ad) a) + ((&plist :sched bs :dead bd) b)) + (pcase `(,(compare as bs) ,(compare ad bd)) + (`((:left ,s) (:right ,d)) (if s (sym-left t s) (comp2right nil d))) + (`((:right ,s) (:left ,d)) (if d (sym-left nil d) (comp2right t s))) + (`((:right ,s) (:right ,d)) + (pcase `(,s ,d) + (`(gt gt) (either :right t)) + (`(lt lt) (either :right nil)) + ((or `(gt lt) `(lt gt)) (fmt-left-both "should not cross")) + (`(eq eq) (fmt-left-both "should be different")) + (`(eq ,_) (fmt-left t "should be different")) + (`(,_ eq) (fmt-left nil "should be different")))) + (`((:left ,s) (:left ,d)) + (cond + ((and s d) (sym-left-2 s d)) + (s (sym-left t s)) + (d (sym-left nil d))))))) + ((or `((:si-task . ,_) (:si-proj . ,_)) + `((:si-proj . ,_) (:si-task . ,_))) + (either :left "Sub-iterators must have same project structure")) + (`(,(or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_)) ,_) + (either :right nil)) + (`(,_ ,(or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_))) + (either :right t)) + (`(,_ ,_) (either :right nil)))) + (lambda (next) + (pcase next + ((or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_)) t) + (_ nil))) + (lambda (next) + (pcase next + (`(:si-proj :proj-active ,d) (plist-get d :child-scheds)) + (`(:si-task :task-active ,d) (-some-> (plist-get d :sched) (list))) + (_ nil))) + trans-fun))) (defun org-x-dag-node-is-iterator-p (node) (org-x-dag-node-data-is-iterator-p (plist-get node :node-meta))) @@ -1013,20 +1105,30 @@ deadline (eg via epoch time) or if it has a repeater." (lambda (c) `(:si-proj :proj-complete ,c)) (lambda (c) `(:si-task :task-complete ,c))) - (-let (((sched dead) (-some->> it-planning - (org-ml-get-properties '(:scheduled :deadline))))) + (-let* (((sched dead) (-some->> it-planning + (org-ml-get-properties '(:scheduled :deadline)))) + (sp (-some-> sched (org-x-dag-partition-timestamp))) + (dp (-some-> dead (org-x-dag-partition-timestamp)))) (cond - ((and sched child-bss) + ((and sp child-bss) (either :left "Project sub-iterators cannot be scheduled")) - ((and dead child-bss) + ((and dp child-bss) (either :left "Project sub-iterators cannot be deadlined")) ((org-x-dag-node-data-is-iterator-p node-data) (either :left "Iterators cannot be nested")) ((org-x-dag-action-dead-after-parent-p ancestry dead) (either :left "Sub-iterator deadline must not start after parent")) - ((equal it-todo org-x-kw-todo) + ((and sp (plist-get sp :repeater)) + (either :left "Scheduled sub-iterators cannot repeat")) + ((and dp (plist-get dp :repeater)) + (either :left "Deadlined sub-iterators cannot repeat")) + ((and sp (< 0 (plist-get sp :length))) + (either :left "Scheduled sub-iterators cannot be ranged")) + ((and dp (< 0 (plist-get dp :length))) + (either :left "Deadlined sub-iterators cannot be ranged")) + ((member it-todo (list org-x-kw-todo org-x-kw-wait)) (org-x-dag-bs-action-subiter-todo-fold child-bss - `(:si-task :task-active (:sched ,sched :dead ,dead)) + `(:si-task :task-active (:sched ,sp :dead ,dp)) (lambda (acc cs) (pcase acc ((or `(:si-proj :proj-complete ,_) @@ -1037,7 +1139,8 @@ deadline (eg via epoch time) or if it has a repeater." (-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 :sched s) 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 @@ -1067,7 +1170,8 @@ deadline (eg via epoch time) or if it has a repeater." `(:si-proj :proj-complete ,_)) (either :right '(:iter-nonempty :nonempty-complete))) (`(:si-task :task-active ,ts-data) - (-let (((&plist :dead d :sched s) 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)) @@ -2775,12 +2879,6 @@ encountered will be returned." (u (convert-unit unit))) `(,v ,u ,type)))))) -(defun org-x-dag-partition-timestamp (ts) - (list :datetime (org-ml-timestamp-get-start-time ts) - :pos (org-ml-get-property :begin ts) - :repeater (org-ml-timestamp-extract-modulus 'repeater ts) - :warning (org-ml-timestamp-extract-modulus 'warning ts))) - (defun org-x-dag-repeater-get-next (sel-datetime datetime shift shifttype reptype) "Return the next timestamp repeater of DATETIME." (pcase reptype @@ -3127,8 +3225,8 @@ FUTURE-LIMIT in a list." (`(:iter-empty :empty-active ,_) :empty) (`(:iter-nonempty :nonempty-active ,data) (-let* (((&plist :dead d :leading-sched s) data) - (d* (-some->> d (org-x-dag-timestamp-to-epoch))) - (s* (-some->> s (org-x-dag-timestamp-to-epoch)))) + (d* (-some->> d (org-x-dag-datetime-to-epoch))) + (s* (-some->> s (org-x-dag-datetime-to-epoch)))) (-if-let (epoch (if (and d* s*) (min d* s*) (or s* d*))) (if (< (+ (float-time) org-x-iterator-active-future-offset) epoch) diff --git a/local/lib/org-x/test/org-x-dag-test.el b/local/lib/org-x/test/org-x-dag-test.el index 8c56a14..e03aa14 100644 --- a/local/lib/org-x/test/org-x-dag-test.el +++ b/local/lib/org-x/test/org-x-dag-test.el @@ -38,6 +38,10 @@ org-x-weekly-plan-file "weekly.org" org-x-quarterly-plan-file "quarterly.org")) +(defun partition-timestamp (s) + (->> (org-ml-from-string 'timestamp s) + (org-x-dag-partition-timestamp))) + (buttercup-define-matcher :to-be-left-with (a x) (cl-destructuring-bind ((a-expr . a) (x-expr . x)) @@ -64,25 +68,65 @@ `(nil . ,(format "Expected %s right with %s, but got right with %s" a-expr x r))))))) -(defun split-plists (a b) - (let* ((a* (-partition 2 a)) - (b* (-partition 2 b)) - (a- (-difference a* b*)) - (b- (-difference b* a*))) - `(,(-flatten-n 1 a-) ,(-flatten-n 1 b-)))) +(defun split-plists (eq-funs a b) + (cl-flet + ((get-keys + (x) + (->> (-partition 2 x) + (-map #'car))) + (key-eq + (k) + (let ((av (plist-get a k)) + (bv (plist-get b k)) + (f (or (plist-get eq-funs k) #'equal))) + (funcall f av bv)))) + (let* ((a* (get-keys a)) + (b* (get-keys b)) + (a- (-difference a* b*)) + (b- (-difference b* a*)) + (common (->> (-intersection a* b*) + (--reduce-from (if (key-eq it) acc + (cons (list it + (plist-get a it) + (plist-get b it)) + acc)) + nil)))) + `(,a- ,b- ,common)))) -(defun plist-diff-msg (expr a b) - (-let (((a-diff b-diff) (split-plists a b))) +(defun plists-equal-p (a b) + (equal (split-plists nil a b) '(nil nil nil))) + +(defun element-equal-p (a b) + ;; NOTE this does not compare children of elements/objects + (cl-flet + ((get-useful-props + (node) + (->> (org-ml-get-all-properties node) + (-partition 2) + (--remove (memq (car it) '(:parent :begin :end :contents-begin :contents-end))) + (-flatten-n 1)))) + (and (eq (org-ml-get-type a) (org-ml-get-type b)) + (plists-equal-p (get-useful-props a) (get-useful-props b))))) + +(defun plist-diff-msg (eq-funs expr a b) + (-let (((a-diff b-diff common-diffs) (split-plists eq-funs a b))) (cond ((and a-diff b-diff) - (format "Expected %s to have pairs '%s' and not to have pairs '%s'" + (format "Expected %s to have keys '%s' and not to have keys '%s'" expr b-diff a-diff)) (a-diff - (format "Expected %s not to have pairs '%s'" expr a-diff)) + (format "Expected %s not to have keys '%s'" expr a-diff)) (b-diff - (format "Expected %s to have pairs '%s'" expr b-diff))))) + (format "Expected %s to have keys '%s'" expr b-diff)) + (common-diffs + (-let (((as bs) + (->> common-diffs + (--map `((,(car it) ,(nth 1 it)) (,(car it) ,(nth 2 it)))) + (apply #'-zip-lists)))) + (format "Expected %s to have key/value pairs '%s' but instead had '%s'" + expr as bs)))))) -(defun status-diff-msg (expr type subtype data to-test) +(defun status-diff-msg (eq-funs expr type subtype data to-test) (-let* (((type* . rest) to-test) ((subtype* last) (-split-at (length subtype) rest)) (data* (car last))) @@ -94,12 +138,12 @@ (format "Expected %s to have subtype '%s' but instead had subtype '%s'" expr subtype subtype*)) (t - (plist-diff-msg expr data data*))))) + (plist-diff-msg eq-funs expr data data*))))) -(defun ancestry-diff-msg (expr ancestry inner-fun to-test) +(defun ancestry-diff-msg (eq-funs expr ancestry inner-fun to-test) (declare (indent 3)) (-let* (((&plist :ancestry A :local L) to-test)) - (or (plist-diff-msg expr A ancestry) + (or (plist-diff-msg eq-funs expr A ancestry) (funcall inner-fun L)))) (defun buffer-status-diff-msg (expr type inner-fun to-test) @@ -125,8 +169,14 @@ (let* ((ancestry (list :canceled-parent-p c :held-parent-p h :parent-deadline e)) - (f (->> (-partial #'status-diff-msg test-expr y s d) - (-partial #'ancestry-diff-msg test-expr ancestry) + (ancestry-eq-funs (list :parent-deadline #'element-equal-p)) + (local-eq-funs (list :sched #'element-equal-p + ;; TODO this is wrong + :child-scheds (lambda (a b) + (seq-set-equal-p + a b #'element-equal-p)))) + (f (->> (-partial #'status-diff-msg local-eq-funs test-expr y s d) + (-partial #'ancestry-diff-msg ancestry-eq-funs test-expr ancestry) (-partial #'buffer-status-diff-msg test-expr :action) (-partial #'right-diff-msg test-expr)))) (-if-let (m (funcall f (org-x-dag-id->bs test))) @@ -170,15 +220,11 @@ (expect "a98df83f-bc98-4767-b2bc-f1054dbf89f9" :id-to-be-action nil nil nil :sp-proj '(:proj-active) '(:child-scheds nil))) - ;; TODO these tests are broken because I don't have a robust way - ;; to compare the equality of org elements here (likely will need to - ;; steal something from the org-ml code, and then tell the plist - ;; checker which equality tests to use) - ;; (it "Active (scheduled)" - ;; (let ((sched (org-ml-from-string 'timestamp "<2022-06-10 Fri>"))) - ;; (expect "3788c7bc-390e-4caf-af8e-06831ff3276b" :id-to-be-action - ;; nil nil nil :sp-proj '(:proj-active) - ;; `(:child-scheds (,sched))))) + (it "Active (scheduled)" + (let ((sched (org-ml-from-string 'timestamp "<2022-06-10 Fri>"))) + (expect "3788c7bc-390e-4caf-af8e-06831ff3276b" :id-to-be-action + nil nil nil :sp-proj '(:proj-active) + `(:child-scheds (,sched))))) (it "Wait" (expect "26586b4d-7fc7-4a9f-b86f-e3c26a83a507" :id-to-be-action @@ -230,7 +276,18 @@ (it "Canceled" (expect "322af50a-f431-4940-8caf-cc5acdf5a555" :id-to-be-action nil nil nil :sp-task '(:task-complete) - '(:canceledp t :epoch 1654903560)))))) + '(:canceledp t :epoch 1654903560)))) + + (describe "Iterators" + (it "Active non-empty" + (let ((s0 (partition-timestamp "<2022-06-07 Tue>")) + (s1 (partition-timestamp "<2022-06-14 Tue>")) + (s2 (partition-timestamp "<2022-06-21 Tue>"))) + (expect "2711e9b9-f765-415d-930f-b7ff16b3140b" :id-to-be-action + nil nil nil :sp-iter '(:iter-nonempty :nonempty-active) + (list :child-scheds `(,s0 ,s1 ,s2) + :leading-sched (plist-get s2 :datetime) + :dead nil))))))) (provide 'org-x-dag-test) ;;; org-x-dag-test.el ends here