ENH only add scheduled actions if scheduled within the current week
This commit is contained in:
parent
dc4e160e12
commit
8bcefb4718
|
@ -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-filter-weekly-ids (adjlist sel-date ids)
|
(defun org-x-dag-annotate-weekly-ids (adjlist sel-date ids)
|
||||||
(let ((id2date
|
(cl-flet
|
||||||
(lambda (id)
|
((id2date
|
||||||
|
(id)
|
||||||
(-let* (((o d m y)
|
(-let* (((o d m y)
|
||||||
(org-x-dag-adjlist-id-hl-meta-prop adjlist :parent-tags id))
|
(org-x-dag-adjlist-id-hl-meta-prop adjlist :parent-tags id))
|
||||||
(this-date (list (org-x-dag-tag-to-year y)
|
(this-date (list (org-x-dag-tag-to-year y)
|
||||||
(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)))
|
||||||
(offset (org-x-dag-tag-to-offset o)))
|
(offset (org-x-dag-tag-to-offset o)))
|
||||||
`(,this-date offset)))))
|
`(,id ,this-date ,offset))))
|
||||||
(org-x-dag-filter-weekly id2date sel-date ids)))
|
(-map #'id2date ids)))
|
||||||
|
|
||||||
|
(defun org-x-dag-filter-weekly-ids (adjlist sel-date ids)
|
||||||
|
(->> (org-x-dag-annotate-weekly-ids adjlist sel-date ids)
|
||||||
|
(org-x-dag-filter-weekly #'cdr sel-date)
|
||||||
|
(-map #'car)))
|
||||||
|
|
||||||
|
(defun org-x-dag-filter-and-span-weekly-ids (adjlist sel-date ids)
|
||||||
|
(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)
|
(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)
|
||||||
|
|
Loading…
Reference in New Issue