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

ADD propagate up/down steps in the network status stack

This commit is contained in:
Nathan Dwarshuis 2022-03-29 23:18:16 -04:00
parent 5199afe09e
commit b97d288555
1 changed files with 50 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2178,12 +2178,12 @@ used for optimization."
(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 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)
(org-x-dag-ht-add-links id ht-e :fulfilled e) (org-x-dag-ht-add-links id ht-e :fulfilled e)
(->> (--mapcat (org-x-dag-ht-get-maybe ht-e it :committed) e) (->> (--mapcat (org-x-dag-ht-get-maybe ht-e it :committed) e)
(org-x-dag-ht-add-links id ht-l :fulfilled)) (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 ;; TODO check that actions that are linked here are not linked to survival
@ -2216,7 +2216,7 @@ used for optimization."
(ht-set ht-d id))))))) (ht-set ht-d id)))))))
ns))) ns)))
(defun org-x-dag-ht-propagate-endpoint (adjlist ns) (defun org-x-dag-ht-propagate-down (adjlist h-key s-key ns)
(cl-labels (cl-labels
((get-children ((get-children
(adjlist id) (adjlist id)
@ -2226,52 +2226,54 @@ used for optimization."
(plist-get :buffer-parent) (plist-get :buffer-parent)
(equal id))))) (equal id)))))
(propagate (propagate
(adjlist htbl id to-set) (adjlist htbl id set-key to-set)
(--each (get-children adjlist id) (--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 :committed (org-x-dag-plist-map it set-key
(lambda (x) (append x to-set)))) (lambda (x) (append x to-set))))
(org-x-dag-bs :valid `(:committed ,to-set))) (org-x-dag-bs :valid `(,set-key ,to-set)))
(ht-set htbl it)) (ht-set htbl it))
(propagate adjlist htbl it to-set)))) (propagate adjlist htbl it set-key to-set))))
(-let (((&alist :endpoint ht-e) ns)) (let ((h (alist-get h-key ns)))
(-each (ht-keys ht-e) (-each (ht-keys h)
(lambda (id) (lambda (id)
(-when-let (committed (org-x-dag-ht-get-maybe ht-e id :committed)) (-when-let (xs (org-x-dag-ht-get-maybe h id s-key))
(--each (get-children adjlist id) (--each (get-children adjlist id)
(propagate adjlist ht-e it committed))))) (propagate adjlist h it s-key xs)))))
ns))) ns)))
;; (defun org-x-dag-ht-propagate-action (adjlist ns) (defun org-x-dag-ht-propagate-up (adjlist h-key s-key ns)
;; (cl-labels (cl-labels
;; ((get-children ((get-children
;; (adjlist id) (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 (propagate
;; (adjlist htbl id to-set) (htbl id)
;; (--each (get-children adjlist id) (-let* ((cs (get-children adjlist id))
;; (->> (-if-let (node (ht-get htbl it)) (rs (--map (propagate htbl it) cs))
;; (org-x-dag-bs-fmap node ;; TODO there isn't a better way to do this? (seems like I'm
;; (org-x-dag-plist-map it :committed ;; accessing either/maybe types too many times)
;; (lambda (x) (append x to-set)))) ((n* rs*) (-if-let (n (ht-get htbl id))
;; (org-x-dag-bs :valid `(:committed ,to-set))) (pcase n
;; (ht-set htbl it)) (`(:error ,_) (list n rs))
;; (propagate adjlist htbl it to-set)))) (`(:valid ,v)
;; (-let (((&alist :action ht-a) ns)) (let ((p (org-x-dag-plist-map v s-key
;; (-each (ht-keys ht-a) (lambda (x) (append x rs)))))
;; (lambda (id) (list (org-x-dag-bs :valid p)
;; (-when-let (committed (org-x-dag-ht-get-maybe ht-a id :committed)) (plist-get s-key p)))))
;; (--each (get-children adjlist id) (list (org-x-dag-bs :valid `(,s-key ,rs))
;; (propagate adjlist ht-a it committed))))) rs))))
;; (-when-let (committed (org-x-dag-ht-get-maybe ht-a id :planned)) (ht-set htbl id n*)
;; (--each (get-children adjlist id) rs*)))
;; (propagate adjlist ht-a it committed))))) (let ((h (alist-get h-key ns)))
;; ns))) (--each (ht-keys h)
(propagate h it )))
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)
@ -2304,7 +2306,13 @@ used for optimization."
(org-x-dag-ns-wkp adjlist w) (org-x-dag-ns-wkp adjlist w)
(org-x-dag-ns-action adjlist a) (org-x-dag-ns-action adjlist a)
(org-x-dag-ns-dlp adjlist d) (org-x-dag-ns-dlp adjlist d)
(org-x-dag-ht-propagate-endpoint adjlist)))) (org-x-dag-ht-propagate-down adjlist :action :planned)
(org-x-dag-ht-propagate-down adjlist :action :committed)
(org-x-dag-ht-propagate-down adjlist :endpoint :committed)
(org-x-dag-ht-propagate-up adjlist :lifetime :fulfilled)
(org-x-dag-ht-propagate-up adjlist :lifetime :planned)
(org-x-dag-ht-propagate-up adjlist :survival :planned)
(org-x-dag-ht-propagate-up adjlist :survival :fulfilled))))
;;; DAG SYNCHRONIZATION/CONSTRUCTION ;;; DAG SYNCHRONIZATION/CONSTRUCTION