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

WIP use trees to compute buffer status for weekly plan

This commit is contained in:
Nathan Dwarshuis 2022-05-12 23:38:40 -04:00
parent 9a82ddc696
commit db518f8049
1 changed files with 62 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1056,6 +1056,8 @@ deadline (eg via epoch time) or if it has a repeater."
;; TODO this is super inefficient, make a plist mapper function ;; TODO this is super inefficient, make a plist mapper function
(-let* (((node . children) tree) (-let* (((node . children) tree)
((&plist :id i :parents ps :node-meta m) node) ((&plist :id i :parents ps :node-meta m) node)
;; TODO don't calculate this unless there are actually children
;; that need to use it
(new-ancestry (funcall ancestry-fun m ancestry)) (new-ancestry (funcall ancestry-fun m ancestry))
((shallow rest) (->> children ((shallow rest) (->> children
(--map (funcall child-fun it new-ancestry)) (--map (funcall child-fun it new-ancestry))
@ -1226,25 +1228,52 @@ deadline (eg via epoch time) or if it has a repeater."
(t (t
(org-x-dag-bs-error-kw "QTP" it-todo))))))) (org-x-dag-bs-error-kw "QTP" it-todo)))))))
(defun org-x-dag-bs-wkp-inner (node-data) (defun org-x-dag-bs-wkp-leaf-inner (node-data ancestry child-bss)
(-let* (((&plist :parent-tags (o d m y)) node-data) (if (child-bss) (either :left "Weekly plan nodes cannot have children")
(date-abs (->> (org-x-dag-tags-to-date y m d)
(org-x-dag-date-to-absolute)))
(offset (org-x-dag-tag-to-offset o))
(pair `(:date ,date-abs :offset ,offset)))
(org-x-dag-bs-with-closed node-data "weekly plan" (org-x-dag-bs-with-closed node-data "weekly plan"
`(:complete (,@it-comptime ,@pair)) `(:complete ,it-comptime)
(either :right `(:complete (,@it-comptime ,@pair))) (either :right `(:complete ,it-comptime))
(cond (cond
((-some->> it-planning (org-ml-get-properties :scheduled)) ((-some->> it-planning (org-ml-get-properties :scheduled))
(either :left "WKPs cannot be scheduled")) (either :left "WKPs cannot be scheduled"))
((-some->> it-planning (org-ml-get-properties :deadline)) ((-some->> it-planning (org-ml-get-properties :deadline))
(either :left "WKPs cannot be deadlined")) (either :left "WKPs cannot be deadlined"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(either :right `(:active ,pair))) (either :right `(:active)))
(t (t
(org-x-dag-bs-error-kw "WKP" it-todo)))))) (org-x-dag-bs-error-kw "WKP" it-todo))))))
(defun org-x-dag-bs-wkp-branch-inner (node-data ancestry child-bss)
(org-x-dag-bs-with-closed node-data "weekly plan"
`(:complete ,it-comptime)
(either :right `(:complete ,it-comptime))
(let ((sched (-some->> it-planning (org-ml-get-properties :scheduled))))
(cond
((or (not sched) (org-ml-time-is-long sched))
(either :left "WKP day nodes must be short scheduled"))
((-some->> it-planning (org-ml-get-properties :deadline))
(either :left "WKP day nodes cannot be deadlined"))
((equal it-todo org-x-kw-todo)
(either :right `(:active)))
(t
(org-x-dag-bs-error-kw "WKP day node" it-todo))))))
(defun org-x-dag-bs-wkp-root-inner (node-data ancestry child-bss)
(org-x-dag-bs-with-closed node-data "weekly plan"
`(:complete ,it-comptime)
;; TODO need to check the week length and the scheduled children
(either :right `(:complete ,it-comptime))
(let ((sched (-some->> it-planning (org-ml-get-properties :scheduled))))
(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-properties :deadline))
(either :left "WKP root nodes cannot be deadlined"))
((equal it-todo org-x-kw-todo)
(either :right `(:active)))
(t
(org-x-dag-bs-error-kw "WKP day node" it-todo))))))
(defun org-x-dag-bs-dlp-inner (node-data) (defun org-x-dag-bs-dlp-inner (node-data)
(org-x-dag-bs-with-closed node-data "daily metablock" (org-x-dag-bs-with-closed node-data "daily metablock"
`(:complete ,it-comptime) `(:complete ,it-comptime)
@ -1276,6 +1305,30 @@ deadline (eg via epoch time) or if it has a repeater."
(-let (((n ns) (org-x-dag-bs-with-treetop tree #'org-x-dag-bs-qtp-inner))) (-let (((n ns) (org-x-dag-bs-with-treetop tree #'org-x-dag-bs-qtp-inner)))
(org-x-dag-bs-prefix :quarterly `(,n ,@ns)))) (org-x-dag-bs-prefix :quarterly `(,n ,@ns))))
(defun org-x-dag-bs-wkp-leaf (tree ancestry)
(org-x-dag-bs-with-children-1
tree
ancestry
(lambda (_ _) nil)
#'org-x-dag-bs-wkp-leaf
#'org-x-dag-bs-wkp-leaf-inner))
(defun org-x-dag-bs-wkp-branch (tree ancestry)
(org-x-dag-bs-with-children-1
tree
ancestry
(lambda (_ _) nil)
#'org-x-dag-bs-wkp-leaf
#'org-x-dag-bs-wkp-branch-inner))
(defun org-x-dag-bs-wkp-root (tree ancestry)
(org-x-dag-bs-with-children-1
tree
ancestry
(lambda (_ _) nil)
#'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-with-treetop tree #'org-x-dag-bs-wkp-inner))) (-let (((n ns) (org-x-dag-bs-with-treetop tree #'org-x-dag-bs-wkp-inner)))
(org-x-dag-bs-prefix :weekly `(,n ,@ns)))) (org-x-dag-bs-prefix :weekly `(,n ,@ns))))