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

ENH distinguish actions that are linked between survival and lifetime/endpoint goals

This commit is contained in:
Nathan Dwarshuis 2022-03-29 19:32:33 -04:00
parent 8727df790b
commit 5199afe09e
1 changed files with 54 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2168,16 +2168,26 @@ used for optimization."
(org-x-dag-ns-with-valid ns adjlist :action links (org-x-dag-ns-with-valid ns adjlist :action links
'((:survival) (:endpoint) (:lifetime)) '((:survival) (:endpoint) (:lifetime))
(lambda (id this-h res) (lambda (id this-h res)
(-let (((&alist :survival s :endpoint e :lifetime l) res)) (-let* (((&alist :survival s :endpoint e :lifetime l) res)
(->> (org-x-dag-bs :valid `(:committed (,@e ,@l ,@s))) (this-ns
(ht-set this-h id)) (cond
(->> (--mapcat (org-x-dag-ht-get-maybe ht-e it :committed) e) ((and s (or e l))
(org-x-dag-ht-add-links id ht-l :fulfilled)) (->> "Action has both survival and endpoint/lifetime links"
(org-x-dag-ht-add-links id ht-e :fulfilled e) (org-x-dag-bs :error)))
(s
(org-x-dag-bs :valid `(:committed ,s :survivalp t)))
(t
(org-x-dag-bs :valid `(:committed `(,@e ,@l) :survivalp nil))))))
(ht-set this-h this-ns)
(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)
(->> (--mapcat (org-x-dag-ht-get-maybe ht-e it :committed) e)
(org-x-dag-ht-add-links id ht-l :fulfilled))
ns)) ns))
;; TODO check that actions that are linked here are not linked to survival
;; goals here (since those can't be planned)
(defun org-x-dag-ns-dlp (adjlist links ns) (defun org-x-dag-ns-dlp (adjlist links ns)
(cl-flet (cl-flet
((get-committed ((get-committed
@ -2218,19 +2228,51 @@ used for optimization."
(propagate (propagate
(adjlist htbl id to-set) (adjlist htbl id to-set)
(--each (get-children adjlist id) (--each (get-children adjlist id)
;; TODO this needs to treat the node value like a functor (->> (-if-let (node (ht-get htbl it))
(let ((node (ht-get htbl it))) (org-x-dag-bs-fmap node
(unless (org-x-dag-bs-error-p node) (org-x-dag-plist-map it :committed
(ht-set htbl it (org-x-dag-plist-map node :committed (lambda (x) (append x to-set))))
(lambda (x) (append x to-set))))))))) (org-x-dag-bs :valid `(:committed ,to-set)))
(ht-set htbl it))
(propagate adjlist htbl it to-set))))
(-let (((&alist :endpoint ht-e) ns)) (-let (((&alist :endpoint ht-e) ns))
(-each (ht-keys ht-e) (-each (ht-keys ht-e)
(lambda (id) (lambda (id)
(let ((committed (plist-get (ht-get ht-e id) :committed))) (-when-let (committed (org-x-dag-ht-get-maybe ht-e id :committed))
(--each (get-children adjlist id) (--each (get-children adjlist id)
(propagate adjlist ht-e it committed))))) (propagate adjlist ht-e it committed)))))
ns))) ns)))
;; (defun org-x-dag-ht-propagate-action (adjlist ns)
;; (cl-labels
;; ((get-children
;; (adjlist id)
;; (->> (plist-get (ht-get adjlist id) :children)
;; (--filter (-> (ht-get adjlist it)
;; (plist-get :node-meta)
;; (plist-get :buffer-parent)
;; (equal id)))))
;; (propagate
;; (adjlist htbl id to-set)
;; (--each (get-children adjlist id)
;; (->> (-if-let (node (ht-get htbl it))
;; (org-x-dag-bs-fmap node
;; (org-x-dag-plist-map it :committed
;; (lambda (x) (append x to-set))))
;; (org-x-dag-bs :valid `(:committed ,to-set)))
;; (ht-set htbl it))
;; (propagate adjlist htbl it to-set))))
;; (-let (((&alist :action ht-a) ns))
;; (-each (ht-keys ht-a)
;; (lambda (id)
;; (-when-let (committed (org-x-dag-ht-get-maybe ht-a id :committed))
;; (--each (get-children adjlist id)
;; (propagate adjlist ht-a it committed)))))
;; (-when-let (committed (org-x-dag-ht-get-maybe ht-a id :planned))
;; (--each (get-children adjlist id)
;; (propagate adjlist ht-a it committed)))))
;; ns)))
(defun org-x-dag-get-network-status (adjlist links) (defun org-x-dag-get-network-status (adjlist links)
(-let ((ns (->> '(:action :endpoint :lifetime :survival :quarterly :weekly :daily) (-let ((ns (->> '(:action :endpoint :lifetime :survival :quarterly :weekly :daily)
(--map (cons it (ht-create #'equal))))) (--map (cons it (ht-create #'equal)))))