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

ENH only add scheduled actions if scheduled within the current week

This commit is contained in:
Nathan Dwarshuis 2022-05-09 22:09:59 -04:00
parent dc4e160e12
commit 8bcefb4718
1 changed files with 70 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1329,6 +1329,10 @@ used for optimization."
(-some->> (org-x-dag-adjlist-id-hl-meta-prop adjlist :planning id) (-some->> (org-x-dag-adjlist-id-hl-meta-prop adjlist :planning id)
(org-ml-get-property which))) (org-ml-get-property which)))
(defun org-x-dag-adjlist-id-planning-datetime (adjlist which id)
(-some->> (org-x-dag-adjlist-id-planning adjlist which id)
(org-ml-timestamp-get-start-time)))
(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)
@ -1480,7 +1484,7 @@ used for optimization."
(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 ns) (defun org-x-dag-ns-action (adjlist links weekly-span ns)
(cl-flet (cl-flet
((ns-overlaps ((ns-overlaps
(ids key ns) (ids key ns)
@ -1501,7 +1505,19 @@ used for optimization."
(if (org-x-dag-ht-get-maybe ht-e id :committed) (if (org-x-dag-ht-get-maybe ht-e id :committed)
(org-x-dag-ns-is-leaf-p adjlist id) (org-x-dag-ns-is-leaf-p adjlist id)
(->> (list "Linked to non-committed endpoint node" id) (->> (list "Linked to non-committed endpoint node" id)
(either :left)))))) (either :left)))))
((week-start week-end) weekly-span)
(put-scheduled-action-maybe
(lambda (id committed-ids)
(-when-let (sched (org-x-dag-adjlist-id-planning-datetime
adjlist :scheduled id))
(when (and (not (or (org-x-dag-date< sched week-start)
(org-x-dag-date< week-start sched)))
committed-ids)
(->> q-committed
(--filter (-intersection committed-ids (cdr it)))
(-map #'car)
(org-x-dag-ht-add-links id ht-q :scheduled-actions)))))))
(org-x-dag-ns-with-valid ns adjlist :action links (org-x-dag-ns-with-valid ns adjlist :action links
`((:survival (lambda (id) (org-x-dag-ns-is-leaf-p ,adjlist id))) `((:survival (lambda (id) (org-x-dag-ns-is-leaf-p ,adjlist id)))
(:endpoint ,is-committed-leaf-p) (:endpoint ,is-committed-leaf-p)
@ -1521,12 +1537,7 @@ used for optimization."
(ht-set this-h id)) (ht-set this-h id))
;; TODO add additional restriction that these must be scheduled ;; TODO add additional restriction that these must be scheduled
;; within the current week ;; within the current week
(when (org-x-dag-adjlist-id-planning adjlist :scheduled id) (funcall put-scheduled-action-maybe id (-union e l))
(-when-let (committed-ids (-union e l))
(->> q-committed
(--filter (-intersection committed-ids (cdr it)))
(-map #'car)
(org-x-dag-ht-add-links id ht-q :scheduled-actions))))
(org-x-dag-ht-add-links id ht-l :fulfilled l) (org-x-dag-ht-add-links id ht-l :fulfilled l)
(org-x-dag-ht-add-links id ht-s :fulfilled s) (org-x-dag-ht-add-links id ht-s :fulfilled s)
(org-x-dag-ht-add-links id ht-e :fulfilled e) (org-x-dag-ht-add-links id ht-e :fulfilled e)
@ -1721,17 +1732,49 @@ 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)
(cl-flet
((id2date
(id)
(-let* (((o d m y)
(org-x-dag-adjlist-id-hl-meta-prop adjlist :parent-tags id))
(this-date (list (org-x-dag-tag-to-year y)
(org-x-dag-tag-to-month m)
(org-x-dag-tag-to-day d)))
(offset (org-x-dag-tag-to-offset o)))
`(,id ,this-date ,offset))))
(-map #'id2date ids)))
(defun org-x-dag-filter-weekly-ids (adjlist sel-date ids) (defun org-x-dag-filter-weekly-ids (adjlist sel-date ids)
(let ((id2date (->> (org-x-dag-annotate-weekly-ids adjlist sel-date ids)
(lambda (id) (org-x-dag-filter-weekly #'cdr sel-date)
(-let* (((o d m y) (-map #'car)))
(org-x-dag-adjlist-id-hl-meta-prop adjlist :parent-tags id))
(this-date (list (org-x-dag-tag-to-year y) (defun org-x-dag-filter-and-span-weekly-ids (adjlist sel-date ids)
(org-x-dag-tag-to-month m) (cl-flet*
(org-x-dag-tag-to-day d))) ((shift
(offset (org-x-dag-tag-to-offset o))) (fun group)
`(,this-date offset))))) (-let* (((datetime . filtered) group)
(org-x-dag-filter-weekly id2date sel-date ids))) (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) (defun org-x-dag-get-network-status (sel-date adjlist links)
(cl-flet* (cl-flet*
@ -1768,8 +1811,9 @@ DEF-FUN and the output from GET-FUN (type :: a -> NS)."
;; 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)) (q-date (org-x-dag-date-to-quarter-start sel-date))
(cur-q (cur-links #'org-x-dag-quarter-tags-to-date q-date q)) (cur-q (cur-links #'org-x-dag-quarter-tags-to-date q-date q))
(cur-w (->> (-map #'car w) ((cur-w span-w)
(org-x-dag-filter-weekly-ids adjlist sel-date))) (->> (-map #'car w)
(org-x-dag-filter-and-span-weekly-ids adjlist sel-date)))
(cur-d (cur-links #'org-x-dag-daily-tags-to-date sel-date d))) (cur-d (cur-links #'org-x-dag-daily-tags-to-date sel-date 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)
@ -1786,7 +1830,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 ns) (org-x-dag-ns-action adjlist a span-w 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)
@ -2881,21 +2925,7 @@ FUTURE-LIMIT in a list."
(defun org-x-dag-itemize-qtp (files) (defun org-x-dag-itemize-qtp (files)
(let* ((wkp-ids (org-x-dag->current-wkp-ids)) (let* ((wkp-ids (org-x-dag->current-wkp-ids))
(sel-date (org-x-dag->selected-date)) (sel-date (org-x-dag->selected-date))
(q-date (org-x-dag-date-to-quarter-start sel-date)) (q-date (org-x-dag-date-to-quarter-start sel-date)))
;; TODO this time range is meant to figure out which nodes are
;; "scheduled" which also intersect with the qtp, but it has a fixed
;; range of 7 days; this may not always be true now that my weekly plan
;; is fuzzier
(week-start (org-x-dag-date-to-week-start sel-date))
(week-end (org-x-dag-datetime-shift week-start 7 'submonth)))
(cl-flet
((is-scheduled-current
(id)
(-when-let (d (-some->> (org-x-dag-id->planning-datetime :scheduled id)
(org-x-dag-datetime-split)
(car)))
(and (not (org-x-dag-datetime< d week-start))
(org-x-dag-datetime< d week-end)))))
(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)
(`(:quarterly :active ,dead) (`(:quarterly :active ,dead)
@ -2903,16 +2933,16 @@ FUTURE-LIMIT in a list."
(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)
(-when-let (ns (org-x-dag-id->ns it)) (-when-let (ns (org-x-dag-id->ns it))
(-let (((&plist :planned p :committed c :scheduled-actions a) (-let (((&plist :planned p :committed c :scheduled-actions s)
(either-from-right ns nil))) (either-from-right ns nil)))
;; TODO actually handle deadlines ;; TODO actually handle deadlines
(-> (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-deadline dead 'x-deadline dead
'x-scheduled (-any-p #'is-scheduled-current a) 'x-scheduled s
'x-plannedp (-intersection p wkp-ids) 'x-plannedp (-intersection p wkp-ids)
'x-committedp c) 'x-committedp c)
(list)))))))))))) (list)))))))))))
;; TODO not DRY ;; TODO not DRY
;; TODO this can be made way simpler by just pulling the current weekly ids ;; TODO this can be made way simpler by just pulling the current weekly ids
@ -4489,7 +4519,7 @@ FUTURE-LIMIT in a list."
(add-text-properties (add-text-properties
(point-min) (point-max) (point-min) (point-max)
`(org-agenda-type agenda `(org-agenda-type agenda
org-last-args (,arg ,start-day ,span) org-last-args (,arg ,start-day* ,span)
org-redo-cmd ,org-agenda-redo-command org-redo-cmd ,org-agenda-redo-command
org-series-cmd ,org-cmd)) org-series-cmd ,org-cmd))
(org-agenda-finalize) (org-agenda-finalize)