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

ENH don't base weekly plan on fixed week intervals

This commit is contained in:
Nathan Dwarshuis 2022-05-12 00:03:17 -04:00
parent 96d9f84df0
commit 45aed1a3d3
3 changed files with 308 additions and 219 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
etc/conf.org
View File

@ -4759,6 +4759,7 @@ The function keys are nice because they are almost (not always) free in every mo
("b" #'org-x-dag-agenda-timeblock) ("b" #'org-x-dag-agenda-timeblock)
("q" #'org-x-dag-agenda-quarterly-plan) ("q" #'org-x-dag-agenda-quarterly-plan)
("w" #'org-x-dag-agenda-weekly-plan)
;; ("d" #'org-x-dag-agenda-daily) ;; ("d" #'org-x-dag-agenda-daily)
("g" #'org-x-dag-agenda-goals) ("g" #'org-x-dag-agenda-goals)
("r" #'nd/org-agenda-refile) ("r" #'nd/org-agenda-refile)

38
local/lib/interval/interval.el
View File

@ -41,6 +41,11 @@ and they have the same start time."
"Test if A comes before B or is the same as B." "Test if A comes before B or is the same as B."
(not (interval< b a))) (not (interval< b a)))
(defun interval-contains-p (x int)
"Return t if X is in INT (inclusive)."
(-let (((a b) int))
(and (<= a x) (< x b))))
(defun interval-bimap (fun int) (defun interval-bimap (fun int)
"Apply FUN to both numbers in INT." "Apply FUN to both numbers in INT."
`(,(funcall fun (car int)) ,(funcall fun (cadr int)))) `(,(funcall fun (car int)) ,(funcall fun (cadr int))))
@ -100,6 +105,39 @@ O(N) in case there are no conflicts."
(get-overlaps nil)))) (get-overlaps nil))))
(list (nreverse over) (nreverse non-over))))) (list (nreverse over) (nreverse non-over)))))
(defun interval-overlaps (ints)
"Return all pairs of INTS that overlap.
Assume that INTS is sorted according to `interval-sort'.
Complexity is O(N^2) in case all in INTS overlap with each other,
and O(N) in case there are no overlaps."
;; TODO not dry but making it more general seems like it would unnecessarily
;; slow it down, a I would need to add accessor functions that allow this
;; function to be put in terms of the annotated version above. If the compiler
;; is good enough to inline `identity' this might work.
;;
;; Would also have to deal with sorting, as this function isn't necessary to
;; force a sort.
(cl-labels
((get-overlaps
(acc ss)
(-if-let (s0 (car ss))
(-let* (((acc+ acc-) acc)
(s0-end (cadr s0))
(rest (cdr ss))
;; add members while if the starting value is less than the
;; ending value of the current member
(over (->> (--take-while (< (car it) s0-end) rest)
(--map `(,s0 ,it))
(reverse))))
(-> (if over `((,@over ,@acc+) ,acc-) `(,acc+ (,s0 ,@acc-)))
(get-overlaps rest)))
acc)))
(-let (((over non-over) (get-overlaps nil ints)))
(list (nreverse over) (nreverse non-over)))))
(defun interval-sort (ints) (defun interval-sort (ints)
"Sort INTS according to `interval-rank'." "Sort INTS according to `interval-rank'."
(-sort #'interval< ints)) (-sort #'interval< ints))

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

@ -107,6 +107,13 @@
(car))) (car)))
(< (car next) (cdr next))))) (< (car next) (cdr next)))))
(defun org-x-dag-datetime> (datetime0 datetime1)
(org-x-dag-datetime< datetime1 datetime0))
(defalias 'org-x-dag-datetime<= 'org-x-dag-datetime>)
(defalias 'org-x-dag-datetime>= 'org-x-dag-datetime<)
(defun org-x-dag-datetime= (datetime0 datetime1) (defun org-x-dag-datetime= (datetime0 datetime1)
(org-x-dag-with-times datetime0 datetime1 (org-x-dag-with-times datetime0 datetime1
(->> (-zip-with #'cons datetime0 datetime1) (->> (-zip-with #'cons datetime0 datetime1)
@ -117,6 +124,13 @@
(org-x-dag-datetime< (org-x-dag-datetime-to-date datetime0) (org-x-dag-datetime< (org-x-dag-datetime-to-date datetime0)
(org-x-dag-datetime-to-date datetime1))) (org-x-dag-datetime-to-date datetime1)))
(defun org-x-dag-date> (datetime0 datetime1)
(org-x-dag-date< datetime1 datetime0))
(defalias 'org-x-dag-date<= 'org-x-dag-date>)
(defalias 'org-x-dag-date>= 'org-x-dag-date<)
(defun org-x-dag-date= (datetime0 datetime1) (defun org-x-dag-date= (datetime0 datetime1)
(org-x-dag-datetime= (org-x-dag-datetime-to-date datetime0) (org-x-dag-datetime= (org-x-dag-datetime-to-date datetime0)
(org-x-dag-datetime-to-date datetime1))) (org-x-dag-datetime-to-date datetime1)))
@ -202,31 +216,23 @@ Must be an integer from 0 - 6, with 0 = Sunday.")
(->> (org-x-dag-date-to-gregorian date) (->> (org-x-dag-date-to-gregorian date)
(calendar-day-number))) (calendar-day-number)))
(defconst org-x-dag-weekly-offset-limit 11) (defun org-x-dag-weekly-intervals (date-offsets)
"Convert DATE-OFFSETS to a list of intervals.
(defun org-x-dag-filter-weekly (get-date-fun sel-date xs) DATE-OFFSETS is a list of lists like (ABS OFFSET) where ABS is an
absolute date and OFFSET is a positive integer representing a
relative shift in days from ABS."
(cl-flet (cl-flet
((from-tags ((to-interval
(start-date acc x) (acc date-offset)
(-let (((this-date offset) (funcall get-date-fun x))) (-let (((abs offset) date-offset))
(if (and (org-x-dag-datetime< start-date this-date) (-if-let (grp (assoc abs acc))
(not (org-x-dag-datetime< sel-date this-date))) (let ((grp-offset (cdr grp)))
(-if-let (grp (assoc this-date acc)) (setcdr grp (if (< grp-offset offset) offset grp-offset))
(-let (((_ grp-offset grp-xs) grp))
(setcdr grp `(,(if (< grp-offset offset) offset grp-offset)
,(cons x grp-xs)))
acc) acc)
(cons `(,this-date ,offset (,x)) acc)) `((,abs . ,offset) ,@acc)))))
acc))) (->> (-reduce-from #'to-interval nil date-offsets)
(collect-xs (--map `(,(car it) ,(+ 1 (car it) (cdr it)))))))
(acc group)
(-let* (((start-date offset xs) group)
(end-date (org-x-dag-datetime-shift start-date offset 'submonth)))
(if (org-x-dag-datetime< end-date sel-date) acc (append xs acc)))))
(let* ((shift (- org-x-dag-weekly-offset-limit))
(start-date (org-x-dag-datetime-shift sel-date shift 'submonth)))
(->> (--reduce-from (from-tags start-date acc it) nil xs)
(-reduce-from #'collect-xs nil)))))
;; date <-> quarter ;; date <-> quarter
@ -287,9 +293,6 @@ Must be an integer from 0 - 6, with 0 = Sunday.")
(defun org-x-dag-tag-to-week (tag) (defun org-x-dag-tag-to-week (tag)
(org-x-dag--parse-date-tag "W" tag)) (org-x-dag--parse-date-tag "W" tag))
;; (defun org-x-dag-tag-to-day-of-week (tag)
;; (car (rassoc tag org-x-dag-weekly-tags)))
(defun org-x-dag-tag-to-month (tag) (defun org-x-dag-tag-to-month (tag)
(org-x-dag--parse-date-tag "M" tag)) (org-x-dag--parse-date-tag "M" tag))
@ -311,9 +314,6 @@ Must be an integer from 0 - 6, with 0 = Sunday.")
(defun org-x-dag-format-week-tag (week) (defun org-x-dag-format-week-tag (week)
(format "W%02d" week)) (format "W%02d" week))
;; (defun org-x-dag-format-day-of-week-tag (daynum)
;; (alist-get daynum org-x-dag-weekly-tags))
(defun org-x-dag-format-day-tag (day) (defun org-x-dag-format-day-tag (day)
(format "D%02d" day)) (format "D%02d" day))
@ -325,11 +325,10 @@ Must be an integer from 0 - 6, with 0 = Sunday.")
(org-x-dag-quarter-to-date (list (org-x-dag-tag-to-year y) (org-x-dag-quarter-to-date (list (org-x-dag-tag-to-year y)
(org-x-dag-tag-to-quarter q))))) (org-x-dag-tag-to-quarter q)))))
(defun org-x-dag-weekly-tags-to-date (tags) (defun org-x-dag-tags-to-date (y m d)
(-let (((y m d o) (reverse tags)) (list (org-x-dag-tag-to-year y)
(this-date (org-x-dag-daily-tags-to-date (list y m d))) (org-x-dag-tag-to-month m)
(offset (org-x-dag-tag-to-offset o))) (org-x-dag-tag-to-day d)))
(org-x-dag-datetime-shift this-date offset 'submonth)))
(defun org-x-dag-daily-tags-to-date (tags) (defun org-x-dag-daily-tags-to-date (tags)
(-let (((y m d) (reverse tags))) (-let (((y m d) (reverse tags)))
@ -337,6 +336,13 @@ Must be an integer from 0 - 6, with 0 = Sunday.")
(org-x-dag-tag-to-month m) (org-x-dag-tag-to-month m)
(org-x-dag-tag-to-day d)))) (org-x-dag-tag-to-day d))))
(defun org-x-dag-weekly-tags-to-absolute (tags)
(-let* (((y m d o) (reverse tags))
(abs (->> (org-x-dag-tags-to-date y m d)
(org-x-dag-date-to-absolute)))
(offset (org-x-dag-tag-to-offset o)))
(+ abs offset)))
;; (defun org-x-dag-date-to-quarter-tags (date) ;; (defun org-x-dag-date-to-quarter-tags (date)
;; (-let (((y q) (org-x-dag-date-to-quarter date))) ;; (-let (((y q) (org-x-dag-date-to-quarter date)))
;; (list (org-x-dag-format-year-tag y) ;; (list (org-x-dag-format-year-tag y)
@ -397,6 +403,7 @@ Must be an integer from 0 - 6, with 0 = Sunday.")
:file->ids fis :file->ids fis
:file->links fls :file->links fls
:current-date c :current-date c
:selected-spans nil
:selected-date s)) :selected-date s))
(defun org-x-dag-empty () (defun org-x-dag-empty ()
@ -1188,42 +1195,55 @@ deadline (eg via epoch time) or if it has a repeater."
(org-x-dag-bs-toplevel-goal "SVG" :survival tree)) (org-x-dag-bs-toplevel-goal "SVG" :survival tree))
(defun org-x-dag-bs-qtp-inner (node-data) (defun org-x-dag-bs-qtp-inner (node-data)
;; ASSUME :parent-tags will contain the date tags as the level of the
;; plan will never exceed one
(-let* (((&plist :parent-tags) node-data)
(date (org-x-dag-quarter-tags-to-date parent-tags))
(date-abs (org-x-dag-date-to-absolute date)))
(cl-flet
((mk-right
(dead date)
(either :right `(:active (:deadline ,dead :date ,date-abs)))))
(org-x-dag-bs-with-closed node-data "quarterly plan" (org-x-dag-bs-with-closed node-data "quarterly plan"
`(:complete ,it-comptime) `(:complete (,@it-comptime :date ,date-abs))
(either :right `(:complete ,it-comptime)) (either :right `(:complete (,@it-comptime :date ,date-abs)))
(cond (cond
((-some->> it-planning (org-ml-get-properties :scheduled)) ((-some->> it-planning (org-ml-get-properties :scheduled))
(either :left "QTPs cannot be scheduled")) (either :left "QTPs cannot be scheduled"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(-if-let (dead (-some->> it-planning (org-ml-get-properties :deadline))) (-if-let (dead (-some->> it-planning
;; ASSUME :parent-tags will contain the date tags as the level of the (org-ml-get-properties :deadline)))
;; plan will never exceed one ;; ASSUME :parent-tags will contain the date tags as the level of
(-let* (((&plist :parent-tags) node-data) ;; the plan will never exceed one
(tag-dt (org-x-dag-quarter-tags-to-date parent-tags)) (let ((dead-dt (->> (org-ml-timestamp-get-start-time dead)
(dead-dt (->> (org-ml-timestamp-get-start-time dead)
(org-x-dag-datetime-split) (org-x-dag-datetime-split)
(car)))) (car))))
(if (org-x-dag-datetime< tag-dt dead-dt) (if (org-x-dag-datetime< date dead-dt)
(either :right `(:active ,dead)) (mk-right dead date-abs)
(->> "QTP deadlines must be due after the quarter starts" (->> "QTP deadlines must be due after the quarter starts"
(either :left)))) (either :left))))
(either :right '(:active nil)))) (mk-right nil date-abs)))
(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-inner (node-data)
(-let* (((&plist :parent-tags (o d m y)) node-data)
(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) `(:complete (,@it-comptime ,@pair))
(either :right `(:complete ,it-comptime)) (either :right `(:complete (,@it-comptime ,@pair)))
(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))) (either :right `(:active ,pair)))
(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-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"
@ -1246,7 +1266,8 @@ deadline (eg via epoch time) or if it has a repeater."
(tag-date (org-x-dag-daily-tags-to-date parent-tags))) (tag-date (org-x-dag-daily-tags-to-date parent-tags)))
(if (org-x-dag-datetime= tag-date sched-date) (if (org-x-dag-datetime= tag-date sched-date)
(either :right `(:active (:sched ,sched))) (either :right `(:active (:sched ,sched)))
(either :left "Daily metablocks must be scheduled within their date"))))) (->> "Daily metablocks must be scheduled within their date"
(either :left))))))
(either :left "Daily metablocks must be scheduled"))) (either :left "Daily metablocks must be scheduled")))
(t (t
(org-x-dag-bs-error-kw "Daily metablock" it-todo))))) (org-x-dag-bs-error-kw "Daily metablock" it-todo)))))
@ -1319,6 +1340,10 @@ deadline (eg via epoch time) or if it has a repeater."
(-> (ht-get adjlist id) (-> (ht-get adjlist id)
(plist-get :node-meta))) (plist-get :node-meta)))
(defun org-x-dag-adjlist-id-bs (adjlist id)
(-> (org-x-dag-adjlist-id-node-meta adjlist id)
(plist-get :buffer-status)))
(defun org-x-dag-adjlist-id-hl-meta (adjlist id) (defun org-x-dag-adjlist-id-hl-meta (adjlist id)
(-> (org-x-dag-adjlist-id-node-meta adjlist id) (-> (org-x-dag-adjlist-id-node-meta adjlist id)
(plist-get :hl-meta))) (plist-get :hl-meta)))
@ -1335,6 +1360,28 @@ deadline (eg via epoch time) or if it has a repeater."
(-some->> (org-x-dag-adjlist-id-planning adjlist which id) (-some->> (org-x-dag-adjlist-id-planning adjlist which id)
(org-ml-timestamp-get-start-time))) (org-ml-timestamp-get-start-time)))
(defun org-x-dag-adjlist-id-todo (adjlist id)
(org-x-dag-adjlist-id-hl-meta-prop adjlist :todo id))
(defun org-x-dag-adjlist-id-parent-tags (adjlist id)
(org-x-dag-adjlist-id-hl-meta-prop adjlist :parent-tags id))
(defun org-x-dag-adjlist-id-done-p (adjlist id)
(member (org-x-dag-adjlist-id-todo adjlist id) org-x-done-keywords))
(defun org-x-dag-adjlist-id-qtp-abs (adjlist id)
(either-from (org-x-dag-adjlist-id-bs adjlist id)
(-const nil)
(lambda (r)
(plist-get (nth 2 r) :date))))
(defun org-x-dag-adjlist-id-wkp-abs (adjlist id)
(either-from (org-x-dag-adjlist-id-bs adjlist id)
(-const nil)
(lambda (r)
(-let (((_ _ (&plist :date d :offset o)) r))
(+ d o)))))
(defun org-x-dag-get-children (adjlist id) (defun org-x-dag-get-children (adjlist id)
(->> (plist-get (ht-get adjlist id) :children) (->> (plist-get (ht-get adjlist id) :children)
(--filter (-> (org-x-dag-adjlist-id-hl-meta adjlist it) (--filter (-> (org-x-dag-adjlist-id-hl-meta adjlist it)
@ -1488,7 +1535,7 @@ denoted by CUR-KEY with any errors that are found."
(ht-set this-h id (either :right `(:committed ,q))) (ht-set this-h id (either :right `(:committed ,q)))
(org-x-dag-ht-add-links id ht-q :planned q)))))) (org-x-dag-ht-add-links id ht-q :planned q))))))
(defun org-x-dag-ns-action (adjlist links weekly-span ns) (defun org-x-dag-ns-action (adjlist links ns)
(cl-flet (cl-flet
((ns-overlaps ((ns-overlaps
(ids key ns) (ids key ns)
@ -1511,14 +1558,14 @@ denoted by CUR-KEY with any errors that are found."
(org-x-dag-ns-is-leaf-p adjlist id) (org-x-dag-ns-is-leaf-p adjlist id)
(-> "Linked to non-committed endpoint node" (-> "Linked to non-committed endpoint node"
(org-x-dag--link-err id))))) (org-x-dag--link-err id)))))
((week-start week-end) weekly-span)
(put-scheduled-action-maybe (put-scheduled-action-maybe
(lambda (id committed-ids) (lambda (id committed-ids)
;; TODO what about repeaters? ;; TODO what about repeaters?
(-when-let (sched (org-x-dag-adjlist-id-planning-datetime (-when-let (sched (org-x-dag-adjlist-id-planning-datetime
adjlist :scheduled id)) adjlist :scheduled id))
(when (and (not (or (org-x-dag-date< sched week-start) (when (and ;;(org-x-dag-date<= week-start sched)
(org-x-dag-date< week-start sched))) ;;(org-x-dag-date<= sched week-end)
(not (org-x-dag-adjlist-id-done-p adjlist id))
committed-ids) committed-ids)
(->> q-committed (->> q-committed
(--filter (-intersection committed-ids (cdr it))) (--filter (-intersection committed-ids (cdr it)))
@ -1533,7 +1580,7 @@ denoted by CUR-KEY with any errors that are found."
(->> (cond (->> (cond
((and s (or e l)) ((and s (or e l))
(-> "Action has SVG and EPG/LTG links" (-> "Action has SVG and EPG/LTG links"
(org-x-dag--ns-error (append s e l)))) (org-x-dag--ns-err (append s e l))))
(s (s
(either :right `(:committed ,s :survivalp t))) (either :right `(:committed ,s :survivalp t)))
(t (t
@ -1736,58 +1783,25 @@ DEF-FUN and the output from GET-FUN (type :: a -> NS)."
(--each (ht-keys h) (--each (ht-keys h)
(propagate h it ))))) (propagate h it )))))
(defun org-x-dag-annotate-weekly-ids (adjlist sel-date ids) (defun org-x-dag-get-network-status (sel-date spans adjlist links)
(cl-flet (cl-flet
((id2date ((d-cur-p
(id) (link)
(-let* (((o d m y) (-let* ((id (car link))
(org-x-dag-adjlist-id-hl-meta-prop adjlist :parent-tags id)) (bs (org-x-dag-adjlist-id-bs adjlist id)))
(this-date (list (org-x-dag-tag-to-year y) (when (either-is-right-p bs)
(org-x-dag-tag-to-month m) ;; TODO this makes some assumptions that might be cleaner to
(org-x-dag-tag-to-day d))) ;; code out
(offset (org-x-dag-tag-to-offset o))) (->> (org-x-dag-adjlist-id-planning adjlist :scheduled id)
`(,id ,this-date ,offset)))) (org-ml-timestamp-get-start-time)
(-map #'id2date ids))) (org-x-dag-datetime-split)
(car)
(defun org-x-dag-filter-weekly-ids (adjlist sel-date ids) (org-x-dag-datetime= sel-date)))))
(->> (org-x-dag-annotate-weekly-ids adjlist sel-date ids) (cur-p
(org-x-dag-filter-weekly #'cdr sel-date) (get-abs span link)
(-map #'car))) (let ((id (car link)))
(-when-let (abs (funcall get-abs adjlist id))
(defun org-x-dag-filter-and-span-weekly-ids (adjlist sel-date ids) (interval-contains-p abs span)))))
(cl-flet*
((shift
(fun group)
(-let* (((datetime . filtered) group)
(shift (funcall fun (-map #'cadr filtered))))
(org-x-dag-datetime-shift datetime shift 'submonth)))
(get-span
(groups)
(cond
((null groups) nil)
;; TODO this could be better (like actually label the nodes that
;; overlap
((< 1 (length groups)) (warn "Overlapping weeks found"))
(t (let ((start (shift #'-min (car groups)))
(end (shift #'-max (-last-item groups))))
`(,start ,end))))))
(let* ((filtered (->> (org-x-dag-annotate-weekly-ids adjlist sel-date ids)
(org-x-dag-filter-weekly #'cdr sel-date)))
(filtered-ids (-map #'car filtered))
(span (->> (-map #'cdr filtered)
(-group-by #'car)
(--sort (org-x-dag-date< (car it) (car other)))
(get-span))))
`(,filtered-ids ,span))))
(defun org-x-dag-get-network-status (sel-date adjlist links)
(cl-flet*
((plan-tags
(id)
(org-x-dag-adjlist-id-hl-meta-prop adjlist :parent-tags id))
(cur-links
(tag-fun date links)
(--filter (equal date (funcall tag-fun (plan-tags (car it)))) links)))
(-let* ((ns (->> (list :action (-let* ((ns (->> (list :action
:endpoint :endpoint
:lifetime :lifetime
@ -1813,12 +1827,12 @@ DEF-FUN and the output from GET-FUN (type :: a -> NS)."
;; it is on the current plan, and I don't need to do any downstream ;; it is on the current plan, and I don't need to do any downstream
;; processing to distinguish between current and not current. Bonus, ;; processing to distinguish between current and not current. Bonus,
;; this is much faster (less stuff to deal with) ;; this is much faster (less stuff to deal with)
(q-date (org-x-dag-date-to-quarter-start sel-date)) ((&plist :quarterly qspan :weekly wspan) spans)
(cur-q (cur-links #'org-x-dag-quarter-tags-to-date q-date q)) (q-cur-p (-partial #'cur-p #'org-x-dag-adjlist-id-qtp-abs qspan))
((cur-w span-w) (w-cur-p (-partial #'cur-p #'org-x-dag-adjlist-id-wkp-abs wspan))
(->> (-map #'car w) (cur-q (-filter q-cur-p q))
(org-x-dag-filter-and-span-weekly-ids adjlist sel-date))) (cur-w (-filter w-cur-p w))
(cur-d (cur-links #'org-x-dag-daily-tags-to-date sel-date 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)
(org-x-dag-ns-svg adjlist s ns) (org-x-dag-ns-svg adjlist s ns)
@ -1834,7 +1848,7 @@ DEF-FUN and the output from GET-FUN (type :: a -> NS)."
(org-x-dag-ns-wkp adjlist cur-w ns) (org-x-dag-ns-wkp adjlist cur-w ns)
(org-x-dag-ns-action adjlist a span-w ns) (org-x-dag-ns-action adjlist a ns)
(org-x-dag-ht-propagate-up adjlist :lifetime :fulfilled ns) (org-x-dag-ht-propagate-up adjlist :lifetime :fulfilled ns)
(org-x-dag-ht-propagate-up adjlist :survival :fulfilled ns) (org-x-dag-ht-propagate-up adjlist :survival :fulfilled ns)
(org-x-dag-ht-propagate-action-down adjlist ns) (org-x-dag-ht-propagate-action-down adjlist ns)
@ -1984,12 +1998,47 @@ removed from, added to, or edited within the DAG respectively."
(--each to-insert (--each to-insert
(ht-set h (car it) (cdr it))))) (ht-set h (car it) (cdr it)))))
(defun org-x-dag-quarter-span ()
(-let* (((&plist :selected-date s) org-x-dag)
(start (org-x-dag-date-to-quarter-start s))
(end (org-x-dag-datetime-shift start 3 'month)))
(list (org-x-dag-date-to-absolute start)
(1- (org-x-dag-date-to-absolute end)))))
(defun org-x-dag-weekly-span (date)
(cl-flet
((bs2date-offset
(bs)
(-let (((_ _ (&plist :date d :offset o)) bs))
`(,d ,o))))
(-let* (((&plist :dag d :file->ids f) org-x-dag)
(adjlist (dag-get-adjacency-list d))
(weekly-file (-> (plist-get org-x-dag-files :plan-files)
(plist-get :weekly)))
(abs (org-x-dag-date-to-absolute date))
(ints (->> (ht-get f weekly-file)
(--map (org-x-dag-adjlist-id-bs adjlist it))
(either-rights)
(-map #'bs2date-offset)
(org-x-dag-weekly-intervals)
(interval-sort))))
(-when-let (overlaps (nth 0 (interval-overlaps ints)))
(warn "Overlapping weeks detected: %s" overlaps))
(--find (interval-contains-p abs it) ints))))
(defun org-x-dag-update-spans ()
(-let* (((&plist :selected-date s) org-x-dag)
(q (org-x-dag-quarter-span))
(w (org-x-dag-weekly-span s)))
(plist-put org-x-dag :selected-spans `(:weekly ,w :quarterly ,q))))
(defun org-x-dag-build-network-status () (defun org-x-dag-build-network-status ()
(-let* (((&plist :selected-date :file->links :dag) org-x-dag) (-let* (((&plist :selected-date sd :selected-spans s :file->links f :dag d)
(adjlist (dag-get-adjacency-list dag)) org-x-dag)
(new (if (dag-is-valid-p dag) (adjlist (dag-get-adjacency-list d))
(->> (ht-values file->links) (new (if (dag-is-valid-p d)
(org-x-dag-get-network-status selected-date adjlist)) (->> (ht-values f)
(org-x-dag-get-network-status sd s adjlist))
(warn "Cycle detected: network status cannot be constructed") (warn "Cycle detected: network status cannot be constructed")
nil))) nil)))
(plist-put org-x-dag :netstat new))) (plist-put org-x-dag :netstat new)))
@ -2010,6 +2059,7 @@ from, add to, and update with the DAG."
(org-x-dag-update-dag ids2rem ids2ins) (org-x-dag-update-dag ids2rem ids2ins)
(org-x-dag-update-ht files2rem fms2ins :file->ids) (org-x-dag-update-ht files2rem fms2ins :file->ids)
(org-x-dag-update-ht files2rem links2ins :file->links) (org-x-dag-update-ht files2rem links2ins :file->links)
(org-x-dag-update-spans)
(org-x-dag-build-network-status))) (org-x-dag-build-network-status)))
(defun org-x-dag-update-files () (defun org-x-dag-update-files ()
@ -2054,6 +2104,17 @@ If FORCE is non-nil, sync no matter what."
(defun org-x-dag->selected-date () (defun org-x-dag->selected-date ()
(plist-get org-x-dag :selected-date)) (plist-get org-x-dag :selected-date))
(defun org-x-dag->selected-spans ()
(plist-get org-x-dag :selected-spans))
(defun org-x-dag->quarterly-span ()
(-> (org-x-dag->selected-spans)
(plist-get :quarterly)))
(defun org-x-dag->weekly-span ()
(-> (org-x-dag->selected-spans)
(plist-get :weekly)))
(defun org-x-dag->file-state () (defun org-x-dag->file-state ()
org-x-dag-files) org-x-dag-files)
@ -2382,11 +2443,6 @@ Return value is a list like (BUFFER NON-BUFFER)."
#'org-x-dag-quarter-tags-to-date #'org-x-dag-quarter-tags-to-date
date)) date))
(defun org-x-dag-date->wkp-ids (date)
(let ((adjlist (org-x-dag->adjacency-list)))
(->> (org-x-dag->wkp-ids)
(org-x-dag-filter-weekly-ids adjlist date))))
(defun org-x-dag-date->dlp-ids (date) (defun org-x-dag-date->dlp-ids (date)
(org-x-dag-date->tagged-ids (org-x-dag-date->tagged-ids
(org-x-dag->dlp-ids) (org-x-dag->dlp-ids)
@ -2399,8 +2455,15 @@ Return value is a list like (BUFFER NON-BUFFER)."
(org-x-dag-date->qtp-ids))) (org-x-dag-date->qtp-ids)))
(defun org-x-dag->current-wkp-ids () (defun org-x-dag->current-wkp-ids ()
(-> (org-x-dag->selected-date) (let ((span (org-x-dag->weekly-span)))
(org-x-dag-date->wkp-ids))) (cl-flet
((in-span
(id)
(-when-let (bs (either-from-right (org-x-dag-id->bs id) id))
(-let (((_ _ (&plist :date d :offset o)) bs))
(interval-contains-p (+ d o) span)))))
(->> (org-x-dag->wkp-ids)
(-filter #'in-span)))))
(defun org-x-dag->current-dlp-ids () (defun org-x-dag->current-dlp-ids ()
(-> (org-x-dag->selected-date) (-> (org-x-dag->selected-date)
@ -2562,12 +2625,11 @@ FUTURE-LIMIT in a list."
(defun org-x-dag-get-scheduled-at (sel-date pts) (defun org-x-dag-get-scheduled-at (sel-date pts)
(-let* (((&plist :datetime d :repeater r) pts) (-let* (((&plist :datetime d :repeater r) pts)
(islongp (org-ml-time-is-long d)) (islongp (org-ml-time-is-long d))
((future-limit sel-datetime cur) ((future-limit cur)
(if islongp (if islongp
`((,@sel-date 23 59) `((,@sel-date 23 59)
,(org-x-dag-date-at-current-time sel-date)
,(org-x-dag-current-datetime)) ,(org-x-dag-current-datetime))
`(,sel-date ,sel-date ,(org-x-dag-current-date))))) `(,sel-date ,(org-x-dag-current-date)))))
(org-x-dag-unfold-timestamp cur d r future-limit))) (org-x-dag-unfold-timestamp cur d r future-limit)))
(defun org-x-dag-get-deadlines-at (sel-date pts) (defun org-x-dag-get-deadlines-at (sel-date pts)
@ -2585,7 +2647,6 @@ FUTURE-LIMIT in a list."
(future-limit (org-x-dag-datetime-shift sel-datetime warn-shift warn-shifttype))) (future-limit (org-x-dag-datetime-shift sel-datetime warn-shift warn-shifttype)))
(org-x-dag-unfold-timestamp cur d r future-limit))) (org-x-dag-unfold-timestamp cur d r future-limit)))
(defun org-x-dag-id->marker (id &optional point) (defun org-x-dag-id->marker (id &optional point)
(let* ((f (org-x-dag-id->file id)) (let* ((f (org-x-dag-id->file id))
(p (or point (org-x-dag-id->point id))) (p (or point (org-x-dag-id->point id)))
@ -2940,6 +3001,10 @@ FUTURE-LIMIT in a list."
(let* ((tags (org-x-dag-id->tags it)) (let* ((tags (org-x-dag-id->tags it))
(date (org-x-dag-quarter-tags-to-date tags))) (date (org-x-dag-quarter-tags-to-date tags)))
(when (org-x-dag-datetime= q-date date) (when (org-x-dag-datetime= q-date date)
;; TODO this network status thing should probably be a feature
;; in all planning nodes, since we are guaranteed to have a
;; set of relevant nodes for any given day but some of this
;; might not have links (which is generally bad)
(let ((ns (-some-> (org-x-dag-id->ns it) (let ((ns (-some-> (org-x-dag-id->ns it)
(either-from (-const nil) #'map-ns)))) (either-from (-const nil) #'map-ns))))
;; TODO actually handle deadlines ;; TODO actually handle deadlines
@ -2954,24 +3019,23 @@ FUTURE-LIMIT in a list."
;; and not doing these convoluted date checks (which won't work in all cases ;; and not doing these convoluted date checks (which won't work in all cases
;; anyways because they assume the week start will never change) ;; anyways because they assume the week start will never change)
(defun org-x-dag-itemize-wkp (files) (defun org-x-dag-itemize-wkp (files)
(let ((sel-date (->> (org-x-dag->selected-date) (let ((span (org-x-dag->weekly-span)))
(org-x-dag-date-to-week-start))))
(org-x-dag-with-ids files (org-x-dag-with-ids files
(pcase (either-from-right (org-x-dag-id->bs it) nil) (pcase (either-from-right (org-x-dag-id->bs it) nil)
(`(:weekly :active) (`(:weekly :active ,p)
(let* ((tags (org-x-dag-id->tags it)) (-let* (((&plist :date d :offset o) p)
(date (org-x-dag-weekly-tags-to-date tags)) (abs (+ d o))
(day (nth 2 (reverse tags)))) (day (->> (calendar-gregorian-from-absolute abs)
(when (org-x-dag-datetime= sel-date date) (calendar-day-of-week))))
(-when-let (ns (org-x-dag-id->ns it)) (when (interval-contains-p abs span)
(-let (((&plist :planned p :committed c) (let ((ns (-some-> (org-x-dag-id->ns it)
(either-from-right ns nil))) (either-from (-const nil) #'identity)))
(tags (org-x-dag-id->tags it)))
(-> (org-x-dag-format-tag-node tags it) (-> (org-x-dag-format-tag-node tags it)
(org-add-props nil (org-add-props nil
'x-day day 'x-day day
'x-plannedp p 'x-network-status ns)
'x-committedp c) (list))))))))))
(list)))))))))))
(defun org-x-dag--item-add-goal-ids (item ids) (defun org-x-dag--item-add-goal-ids (item ids)
(if ids (if ids
@ -3330,6 +3394,10 @@ FUTURE-LIMIT in a list."
(-> (org-x-dag-format-day-tag day) (-> (org-x-dag-format-day-tag day)
(org-x-dag-headlines-find-tag headlines))) (org-x-dag-headlines-find-tag headlines)))
(defun org-x-dag-headlines-find-offset (offset headlines)
(-> (org-x-dag-format-offset-tag offset)
(org-x-dag-headlines-find-tag headlines)))
;; headline builders ;; headline builders
(defun org-x-dag-build-planning-headline (title tag level section subheadlines) (defun org-x-dag-build-planning-headline (title tag level section subheadlines)
@ -3602,52 +3670,32 @@ FUTURE-LIMIT in a list."
;; (org-x-dag-build-day-of-week-headline daynum hls)) ;; (org-x-dag-build-day-of-week-headline daynum hls))
;; plan)) ;; plan))
(defun org-x-dag-wkp-get-day-headline (date) (defun org-x-dag-wkp-get-headline-inner (y m d)
(cl-labels
((get-tag
(re hl)
(-when-let (tag (car (org-ml-get-property :tags hl)))
(when (s-matches? re tag) tag)))
(flatten-subtrees
(regexps st)
(-let (((re0 . reN) regexps))
(if (not re0)
(-when-let (tag (get-tag "d[0-9]\\{1,2\\}" st))
`((,st (,tag))))
(-when-let (tag (get-tag re0 st))
(->> (org-ml-headline-get-subheadlines st)
(--mapcat (flatten-subtrees reN it))
(--map (-let (((hl tags) it))
`(,hl (,tag ,@tags)))))))))
(convert-tags
(x)
(-let* (((st (yt mt dt ot)) x)
(parent-date (list (org-x-dag-tag-to-year yt)
(org-x-dag-tag-to-month mt)
(org-x-dag-tag-to-day dt)))
(offset (org-x-dag-tag-to-offset ot)))
`(,st (,parent-date ,offset))))
(date=
(x)
(-let* (((hl (parent-date offset)) x)
(this-date (org-x-dag-datetime-shift parent-date offset 'submonth)))
(org-x-dag-date= date this-date))))
(org-x-with-file (org-x-dag->planning-file :weekly) (org-x-with-file (org-x-dag->planning-file :weekly)
(let ((regexps '("Y[0-9]\\{2\\}" "M[0-9]\\{2\\}" "D[0-9]\\{2\\}")))
(->> (org-ml-parse-subtrees 'all) (->> (org-ml-parse-subtrees 'all)
(--mapcat (flatten-subtrees regexps it)) (org-x-dag-headlines-find-year y)
(-map #'convert-tags) (org-ml-headline-get-subheadlines)
(org-x-dag-filter-weekly #'cadr date) (org-x-dag-headlines-find-month m)
(-filter #'date=) (org-ml-headline-get-subheadlines)
(-map #'car)))))) (org-x-dag-headlines-find-day d))))
(defun org-x-dag-wkp-get-week-headline (date) (defun org-x-dag-wkp-get-week-headline (date)
(-some->> (org-x-dag-wkp-get-day-headline date) (-let (((y m d) (->> (org-x-dag-weekly-span date)
(car) (car)
(org-ml-get-property :parent))) (org-x-dag-absolute-to-date))))
(org-x-dag-wkp-get-headline-inner y m d)))
(defun org-x-dag-wkp-get-day-headline (date)
(-let ((abs (car (org-x-dag-weekly-span date)))
((y m d) (org-x-dag-absolute-to-date abs))
(offset (- (org-x-dag-date-to-absolute date) abs)))
(->> (org-x-dag-wkp-get-headline-inner y m d)
(org-x-dag-headlines-find-offset o))))
(defun org-x-dag-wkp-set-headlines (date headlines) (defun org-x-dag-wkp-set-headlines (date headlines)
(-let* (((y m d) (org-x-dag-date-to-week-start date)) (-let* (((y m d) (->> (org-x-dag->weekly-span)
(car)
(org-x-dag-absolute-to-date)))
(path (org-x-dag->planning-file :weekly)) (path (org-x-dag->planning-file :weekly))
(find-year (-partial #'org-x-dag-headlines-find-year y)) (find-year (-partial #'org-x-dag-headlines-find-year y))
(find-month (-partial #'org-x-dag-headlines-find-month m)) (find-month (-partial #'org-x-dag-headlines-find-month m))
@ -3775,6 +3823,7 @@ FUTURE-LIMIT in a list."
(-take 3) (-take 3)
(reverse)))) (reverse))))
(plist-put org-x-dag :selected-date date) (plist-put org-x-dag :selected-date date)
(org-x-dag-update-spans)
(apply #'message "Org-DAG date set to %d-%02d-%02d" date))) (apply #'message "Org-DAG date set to %d-%02d-%02d" date)))
(defun org-x-dag-show-date () (defun org-x-dag-show-date ()
@ -4751,12 +4800,13 @@ In the order of display
(org-super-agenda-groups (org-super-agenda-groups
'((:auto-map '((:auto-map
(lambda (line) (lambda (line)
(-let* ((c (get-text-property 1 'x-committedp line)) (-let* ((ns (get-text-property 1 'x-network-status line))
(p (get-text-property 1 'x-plannedp line))
(day (get-text-property 1 'x-day line)) (day (get-text-property 1 'x-day line))
;; TODO not sure if this will work anymore ;; TODO not sure if this will work anymore
(n (car (rassoc day org-x-dag-weekly-tags))) ;; (n (car (rassoc day org-x-dag-weekly-tags)))
((rank text) ((rank text)
(if (not ns) '(0 "No Netowrk Status")
(-let (((&plist :planned p :committed c) ns))
(cond (cond
((and p c) ((and p c)
'(4 "Committed | Planned")) '(4 "Committed | Planned"))
@ -4765,8 +4815,8 @@ In the order of display
((and p (not c)) ((and p (not c))
'(2 "Uncommitted | Planned")) '(2 "Uncommitted | Planned"))
(t (t
'(1 "Unfulfilled | Unplanned"))))) '(1 "Unfulfilled | Unplanned")))))))
(format "%d.%d %s (%s)" n rank day text)))))))))) (format "%d.%d %s (%s)" day rank day text))))))))))
(defun org-x-dag-agenda-tasks () (defun org-x-dag-agenda-tasks ()
"Show the tasks agenda view. "Show the tasks agenda view.