ENH properly handle action survival flag
This commit is contained in:
parent
1251050d54
commit
0d4b165914
|
@ -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)
|
||||||
(cl-labels
|
|
||||||
((get-children
|
|
||||||
(adjlist id)
|
|
||||||
(->> (plist-get (ht-get adjlist id) :children)
|
(->> (plist-get (ht-get adjlist id) :children)
|
||||||
(--filter (-> (ht-get adjlist it)
|
(--filter (-> (ht-get adjlist it)
|
||||||
(plist-get :node-meta)
|
(plist-get :node-meta)
|
||||||
(plist-get :buffer-parent)
|
(plist-get :buffer-parent)
|
||||||
(equal id)))))
|
(equal id)))))
|
||||||
(propagate
|
|
||||||
(adjlist htbl id set-key to-set)
|
(defun org-x-dag-ht-map-down (adjlist h-key ns get-fun set-fun def-fun)
|
||||||
(--each (get-children adjlist id)
|
(declare (indent 3))
|
||||||
|
(cl-labels
|
||||||
|
((propagate
|
||||||
|
(adjlist htbl id to-set)
|
||||||
|
(--each (org-x-dag-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
|
||||||
|
|
Loading…
Reference in New Issue