WIP pass the weekly date down the tree

This commit is contained in:
Nathan Dwarshuis 2022-05-16 01:01:05 -04:00
parent ffc3875c10
commit 1e917c0cee
2 changed files with 64 additions and 34 deletions

View File

@ -151,5 +151,9 @@ left/right slots."
(!cons (cadr it) acc-left))) (!cons (cadr it) acc-left)))
`(,(nreverse acc-left) ,(nreverse acc-right)))) `(,(nreverse acc-left) ,(nreverse acc-right))))
(defun either-maybe (fun either)
"Return nil if EITHER is left and apply FUN otherwise."
(either-from either (-const nil) fun))
(provide 'either) (provide 'either)
;;; either.el ends here ;;; either.el ends here

View File

@ -1260,28 +1260,16 @@ deadline (eg via epoch time) or if it has a repeater."
(org-x-dag-bs-error-kw "WKP day node" it-todo)))))) (org-x-dag-bs-error-kw "WKP day node" it-todo))))))
(defun org-x-dag-bs-wkp-root-inner (node-data ancestry child-bss) (defun org-x-dag-bs-wkp-root-inner (node-data ancestry child-bss)
(org-x-dag-bs-with-closed node-data "weekly plan" (either<$> ancestry
`(:root :complete ,it-comptime) (org-x-dag-bs-with-closed node-data "weekly plan"
;; TODO need to check the week length and the scheduled children `(:root :complete ,it-comptime)
(either :right `(:root :complete ,it-comptime)) ;; TODO need to check the week length and the scheduled children
(let ((sched (-some->> it-planning (org-ml-get-property :scheduled))) (either :right `(:root :complete ,it-comptime))
;; ASSUME anything that isn't actually a number will be converted to
;; a zero and will fail the test below
(offset (->> (alist-get org-x-prop-week-len
(plist-get node-data :props)
nil nil #'equal)
(string-to-number))))
(cond (cond
((or (not sched) (org-ml-time-is-long sched))
(either :left "WKP root nodes must be short scheduled"))
((-some->> it-planning (org-ml-get-property :deadline)) ((-some->> it-planning (org-ml-get-property :deadline))
(either :left "WKP root nodes cannot be deadlined")) (either :left "WKP root nodes cannot be deadlined"))
((< offset 1)
(either :left "WKP root week length must be an int >= 1"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(let ((date (->> (org-ml-timestamp-get-start-time sched) (either :right `(:root :active ,it)))
(org-x-dag-date-to-absolute))))
(either :right `(:root :active (:date ,date :offset ,offset)))))
(t (t
(org-x-dag-bs-error-kw "WKP day node" it-todo)))))) (org-x-dag-bs-error-kw "WKP day node" it-todo))))))
@ -1332,16 +1320,42 @@ deadline (eg via epoch time) or if it has a repeater."
#'org-x-dag-bs-wkp-leaf #'org-x-dag-bs-wkp-leaf
#'org-x-dag-bs-wkp-branch-inner)) #'org-x-dag-bs-wkp-branch-inner))
(defun org-x-dag-bs-wkp-root (tree ancestry) (defun org-x-dag-bs-wkp-root (tree)
(org-x-dag-bs-with-children-1 (-let* (((&plist :node-meta m) (car tree))
tree (datetime (->> (plist-get m :planning)
ancestry (org-ml-get-property :scheduled)
(lambda (_ _) nil) (org-ml-timestamp-get-start-time)))
#'org-x-dag-bs-wkp-branch (props (plist-get m :props))
#'org-x-dag-bs-wkp-root-inner)) ;; ASSUME anything that isn't actually a number will be converted to
;; a zero and will fail the test below
(offset (->> (alist-get org-x-prop-week-len props nil nil #'equal)
(string-to-number)))
(ancestry (cond
((or (not datetime) (org-ml-time-is-long datetime))
(either :left "WKP root nodes must be short scheduled"))
((< offset 1)
(either :left "WKP root week length must be an int >= 1"))
(t
(let ((date (org-x-dag-date-to-absolute datetime)))
(either :right `(:date ,date :offset ,offset)))))))
(org-x-dag-bs-with-children-1
tree
ancestry
(lambda (node-meta ancestry)
(either>>= ancestry
(-if-let (sched (-some->> (plist-get node-meta :planning)
(org-ml-get-property :scheduled)
(org-ml-timestamp-get-start-time)))
(if (org-ml-time-is-long sched)
(either :left "WKP branch node must be short scheduled")
;; TODO test if this is in bounds
(either :right (org-x-dag-date-to-absolute sched)))
(either :left "WKP branch node must be scheduled"))))
#'org-x-dag-bs-wkp-branch
#'org-x-dag-bs-wkp-root-inner)))
(defun org-x-dag-bs-wkp (tree) (defun org-x-dag-bs-wkp (tree)
(-let (((n ns) (org-x-dag-bs-wkp-root tree nil))) (-let (((n ns) (org-x-dag-bs-wkp-root tree)))
(org-x-dag-bs-prefix :weekly `(,n ,@ns)))) (org-x-dag-bs-prefix :weekly `(,n ,@ns))))
(defun org-x-dag-bs-dlp (tree) (defun org-x-dag-bs-dlp (tree)
@ -1443,6 +1457,7 @@ deadline (eg via epoch time) or if it has a repeater."
(either-from (org-x-dag-adjlist-id-bs adjlist id) (either-from (org-x-dag-adjlist-id-bs adjlist id)
(-const nil) (-const nil)
(lambda (r) (lambda (r)
(print r)
(-let (((_ _ (&plist :date d :offset o)) r)) (-let (((_ _ (&plist :date d :offset o)) r))
(+ d o))))) (+ d o)))))
@ -1591,13 +1606,23 @@ denoted by CUR-KEY with any errors that are found."
(org-x-dag-ht-add-links id ht-l :planned l)))))) (org-x-dag-ht-add-links id ht-l :planned l))))))
(defun org-x-dag-ns-wkp (adjlist links ns) (defun org-x-dag-ns-wkp (adjlist links ns)
(-let (((&alist :quarterly ht-q) ns)) (cl-flet
(org-x-dag-ns-with-valid ns adjlist :weekly links ((is-valid-leaf-p
`((:quarterly ,(-partial #'org-x-dag-ns-is-leaf-p adjlist))) (id)
(lambda (id this-h res) (-when-let (bs (-> (org-x-dag-adjlist-id-bs adjlist id)
(-let (((&alist :quarterly q) res)) (either-from-right nil)))
(ht-set this-h id (either :right `(:committed ,q))) (eq (nth bs 1) :leaf))))
(org-x-dag-ht-add-links id ht-q :planned q)))))) (-let (((&alist :quarterly ht-q) ns))
(org-x-dag-ns-with-valid ns adjlist :weekly links
`((:quarterly ,(-partial #'org-x-dag-ns-is-leaf-p adjlist)))
(lambda (id this-h res)
(-let (((&alist :quarterly q) res))
(->> (if (is-valid-leaf-p id)
(either :right `(:committed ,q))
(-> "WKP links can only originate from leaves"
(org-x-dag--ns-err)))
(ht-set this-h id))
(org-x-dag-ht-add-links id ht-q :planned q)))))))
(defun org-x-dag-ns-action (adjlist links ns) (defun org-x-dag-ns-action (adjlist links ns)
(cl-flet (cl-flet
@ -1848,6 +1873,7 @@ DEF-FUN and the output from GET-FUN (type :: a -> NS)."
(propagate h it ))))) (propagate h it )))))
(defun org-x-dag-get-network-status (sel-date spans adjlist links) (defun org-x-dag-get-network-status (sel-date spans adjlist links)
(print spans)
(cl-flet (cl-flet
((d-cur-p ((d-cur-p
(link) (link)
@ -1895,7 +1921,7 @@ DEF-FUN and the output from GET-FUN (type :: a -> NS)."
(q-cur-p (-partial #'cur-p #'org-x-dag-adjlist-id-qtp-abs qspan)) (q-cur-p (-partial #'cur-p #'org-x-dag-adjlist-id-qtp-abs qspan))
(w-cur-p (-partial #'cur-p #'org-x-dag-adjlist-id-wkp-abs wspan)) (w-cur-p (-partial #'cur-p #'org-x-dag-adjlist-id-wkp-abs wspan))
(cur-q (-filter q-cur-p q)) (cur-q (-filter q-cur-p q))
(cur-w (-filter w-cur-p w)) (cur-w (when wspan (-filter w-cur-p w)))
(cur-d (-filter #'d-cur-p d))) (cur-d (-filter #'d-cur-p d)))
;; add all links to the network status object (ew side effects) ;; add all links to the network status object (ew side effects)
(org-x-dag-ns-ltg adjlist l ns) (org-x-dag-ns-ltg adjlist l ns)