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

ENH only add a scheduled action if an action and qtp point to the same goal node

This commit is contained in:
Nathan Dwarshuis 2022-05-08 20:03:37 -04:00
parent c8be4f52f9
commit f77967681d
1 changed files with 17 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1482,14 +1482,20 @@ used for optimization."
(defun org-x-dag-ns-action (adjlist links ns) (defun org-x-dag-ns-action (adjlist links ns)
(cl-flet (cl-flet
((get-planned ((ns-overlaps
(htbl ids) (ids key ns)
(--mapcat (org-x-dag-ht-get-maybe htbl it :planned) ids))) (-intersection (plist-get (either-from-right ns nil) key) ids)))
(-let* (((&alist :endpoint ht-e (-let* (((&alist :endpoint ht-e
:lifetime ht-l :lifetime ht-l
:survival ht-s :survival ht-s
:quarterly ht-q) :quarterly ht-q)
ns) ns)
(q-committed
(->> (ht->alist ht-q)
(--map (cons (car it)
(-> (either-from-right (cdr it) nil)
(plist-get :committed))))
(-filter #'cdr)))
(is-committed-leaf-p (is-committed-leaf-p
(lambda (id) (lambda (id)
(if (org-x-dag-ht-get-maybe ht-e id :committed) (if (org-x-dag-ht-get-maybe ht-e id :committed)
@ -1513,10 +1519,14 @@ used for optimization."
(t (t
(either :right `(:committed (,@e ,@l) :survivalp nil)))) (either :right `(:committed (,@e ,@l) :survivalp nil))))
(ht-set this-h id)) (ht-set this-h id))
(when (-some->> (org-x-dag-adjlist-id-hl-meta-prop adjlist :planning id) ;; TODO add additional restriction that these must be scheduled
(org-ml-get-property :scheduled)) ;; within the current week
(->> (-union (get-planned ht-e e) (get-planned ht-l l)) (when (org-x-dag-adjlist-id-planning adjlist :scheduled id)
(org-x-dag-ht-add-links id ht-q :scheduled-actions))) (-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)