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

ENH properly handle action survival flag

This commit is contained in:
Nathan Dwarshuis 2022-03-30 18:10:32 -04:00
parent 1251050d54
commit 0d4b165914
1 changed files with 85 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2074,7 +2074,7 @@ used for optimization."
((&alist :valid v :error e :non-leaf n) ((&alist :valid v :error e :non-leaf n)
(->> (alist-get key grouped-targets) (->> (alist-get key grouped-targets)
(--group-by (parent-group h checkleafp adjlist it))))) (--group-by (parent-group h checkleafp adjlist it)))))
`(((,key ,v) ,@acc-keyed) `(((,key ,@v) ,@acc-keyed)
(,@e ,@acc-error) (,@e ,@acc-error)
(,@n ,@acc-non-leaf))))) (,@n ,@acc-non-leaf)))))
(org-x-dag-each-links links (org-x-dag-each-links links
@ -2147,7 +2147,7 @@ used for optimization."
(s (s
(org-x-dag-bs :valid `(:committed ,s :survivalp t))) (org-x-dag-bs :valid `(:committed ,s :survivalp t)))
(t (t
(org-x-dag-bs :valid `(:committed `(,@e ,@l) :survivalp nil)))))) (org-x-dag-bs :valid `(:committed (,@e ,@l) :survivalp nil))))))
(ht-set this-h id this-ns) (ht-set this-h id 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)
@ -2186,33 +2186,69 @@ used for optimization."
(ht-set ht-d id))))))) (ht-set ht-d id)))))))
ns))) ns)))
(defun org-x-dag-ht-propagate-down (adjlist h-key s-key ns) (defun org-x-dag-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)))))
(defun org-x-dag-ht-map-down (adjlist h-key ns get-fun set-fun def-fun)
(declare (indent 3))
(cl-labels (cl-labels
((get-children ((propagate
(adjlist id) (adjlist htbl id to-set)
(->> (plist-get (ht-get adjlist id) :children) (--each (org-x-dag-get-children adjlist id)
(--filter (-> (ht-get adjlist it)
(plist-get :node-meta)
(plist-get :buffer-parent)
(equal id)))))
(propagate
(adjlist htbl id set-key to-set)
(--each (get-children adjlist id)
(->> (-if-let (node (ht-get htbl it)) (->> (-if-let (node (ht-get htbl it))
(org-x-dag-bs-fmap node (org-x-dag-bs-fmap node
(org-x-dag-plist-map it set-key (funcall set-fun it to-set))
(lambda (x) (append x to-set)))) (org-x-dag-bs :valid (funcall def-fun to-set)))
(org-x-dag-bs :valid `(,set-key ,to-set)))
(ht-set htbl it)) (ht-set htbl it))
(propagate adjlist htbl it set-key to-set)))) (propagate adjlist htbl it to-set))))
(let ((h (alist-get h-key ns))) (let ((h (alist-get h-key ns)))
(-each (ht-keys h) (-each (ht-keys h)
(lambda (id) (lambda (id)
(-when-let (xs (org-x-dag-ht-get-maybe h id s-key)) (-when-let (xs (funcall get-fun h id))
(--each (get-children adjlist id) (--each (org-x-dag-get-children adjlist id)
(propagate adjlist h it s-key xs))))) (propagate adjlist h it xs)))))
ns))) ns)))
(defun org-x-dag-ht-propagate-down (adjlist h-key s-key ns)
(org-x-dag-ht-map-down adjlist h-key ns
(lambda (h id)
(org-x-dag-ht-get-maybe h id s-key))
(lambda (plist to-set)
(org-x-dag-plist-map plist s-key
(lambda (x) (append x to-set))))
(lambda (to-set)
(list s-key to-set))))
;; (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 set-key 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 set-key
;; (lambda (x) (append x to-set))))
;; (org-x-dag-bs :valid `(,set-key ,to-set)))
;; (ht-set htbl it))
;; (propagate adjlist htbl it set-key to-set))))
;; (let ((h (alist-get h-key ns)))
;; (-each (ht-keys h)
;; (lambda (id)
;; (-when-let (xs (org-x-dag-ht-get-maybe h id s-key))
;; (--each (get-children adjlist id)
;; (propagate adjlist h it s-key xs)))))
;; ns)))
(defun org-x-dag-ht-propagate-up (adjlist h-key s-key ns) (defun org-x-dag-ht-propagate-up (adjlist h-key s-key ns)
(cl-labels (cl-labels
((get-children ((get-children
@ -2259,30 +2295,35 @@ used for optimization."
(org-x-dag-plist-cons acc key link)) (org-x-dag-plist-cons acc key link))
nil nil
links))) links)))
;; TODO add propagate step at the end (org-x-dag-ns-ltg adjlist l ns)
;; (org-x-dag-ns-svg adjlist s ns)
;; actions: propogate down since these can be link at any point and (org-x-dag-ns-epg adjlist e ns)
;; can have daily links pointing anywhere (org-x-dag-ns-qtp adjlist q ns)
;; TODO not sure if I want to propagate the planning field up (org-x-dag-ns-wkp adjlist w ns)
;; (org-x-dag-ns-action adjlist a ns)
;; endpoint goals: propagate down since these can link up to ltgs (org-x-dag-ns-dlp adjlist d ns)
;; (org-x-dag-ht-propagate-down adjlist :action :planned ns)
;; toplevel (ltg and svg): propagate up since only leaves can be linked (org-x-dag-ht-map-down adjlist :action ns
;; but we care if a tree is linked to anything else (lambda (h id)
(->> (org-x-dag-ns-ltg adjlist l ns) (pcase (ht-get h id)
(org-x-dag-ns-svg adjlist s) (`(:error ,_) nil)
(org-x-dag-ns-epg adjlist e) (`(:valid ,c)
(org-x-dag-ns-qtp adjlist q) (-when-let (committed (plist-get c :committed))
(org-x-dag-ns-wkp adjlist w) (let ((survivalp (plist-get c :survivalp)))
(org-x-dag-ns-action adjlist a) (list committed survivalp))))))
(org-x-dag-ns-dlp adjlist d) (lambda (plist to-set)
(org-x-dag-ht-propagate-down adjlist :action :planned) (-let (((committed survivalp) to-set))
(org-x-dag-ht-propagate-down adjlist :action :committed) (-> (plist-put plist :survivalp survivalp)
(org-x-dag-ht-propagate-down adjlist :endpoint :committed) (org-x-dag-plist-map :committed
(org-x-dag-ht-propagate-up adjlist :lifetime :fulfilled) (lambda (x) (append x committed))))))
(org-x-dag-ht-propagate-up adjlist :lifetime :planned) (lambda (to-set)
(org-x-dag-ht-propagate-up adjlist :survival :planned) (-let (((committed survivalp) to-set))
(org-x-dag-ht-propagate-up adjlist :survival :fulfilled)))) `(:committed ,committed :survivalp ,survivalp))))
(org-x-dag-ht-propagate-down adjlist :endpoint :committed ns)
(org-x-dag-ht-propagate-up adjlist :lifetime :fulfilled ns)
(org-x-dag-ht-propagate-up adjlist :lifetime :planned ns)
(org-x-dag-ht-propagate-up adjlist :survival :planned ns)
(org-x-dag-ht-propagate-up adjlist :survival :fulfilled ns)))
;;; DAG SYNCHRONIZATION/CONSTRUCTION ;;; DAG SYNCHRONIZATION/CONSTRUCTION