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

FIX a bunch of network status errors

This commit is contained in:
Nathan Dwarshuis 2022-03-29 18:50:08 -04:00
parent d2ac2212ea
commit 4441230a84
1 changed files with 224 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1359,7 +1359,8 @@ used for optimization."
:planning ,(org-x-dag-parse-this-planning (nth 0 this-pblock)) :planning ,(org-x-dag-parse-this-planning (nth 0 this-pblock))
:props ,(org-x-dag-get-local-properties pbeg pend pps))) :props ,(org-x-dag-get-local-properties pbeg pend pps)))
(!cons acc)) (!cons acc))
(!cons (cons this-id this-links) acc-links) (when this-links
(!cons (cons this-id this-links) acc-links))
(setq node-level this-level)) (setq node-level this-level))
;; Underneath a node but not on a node, therefore we are buried ;; Underneath a node but not on a node, therefore we are buried
(node-level (node-level
@ -1985,6 +1986,13 @@ used for optimization."
;; network status ;; network status
;; terminology
;; - committed: x -> goal
;; - fulfilled: action -> x
;; - planned: plan -> x
;; - scheduled: x -> plan
;; - active: x -> action
(defun org-x-dag-id-link-group (adjlist id) (defun org-x-dag-id-link-group (adjlist id)
(-> (ht-get adjlist id) (-> (ht-get adjlist id)
(plist-get :node-meta) (plist-get :node-meta)
@ -1993,7 +2001,7 @@ used for optimization."
(defun org-x-dag-plist-map (plist key fun) (defun org-x-dag-plist-map (plist key fun)
(declare (indent 2)) (declare (indent 2))
(plist-set (funcall fun (plist-get plist key)) key)) (plist-put plist key (funcall fun (plist-get plist key))))
(defun org-x-dag-plist-cons (plist key x) (defun org-x-dag-plist-cons (plist key x)
(declare (indent 2)) (declare (indent 2))
@ -2009,18 +2017,48 @@ used for optimization."
(defmacro org-x-dag-each-link-parent (parent-ht links form) (defmacro org-x-dag-each-link-parent (parent-ht links form)
(declare (indent 2)) (declare (indent 2))
`(-each links `(-each ,links
(lambda (it-parent) (lambda (it-parent)
(->> (org-x-dag-bs-fmap (ht-get parent-ht it-parent) ,form) (ht-set ,parent-ht it-parent))))
(ht-set ht-parent parent)))))
(defun org-x-dag-bs-error-links (msg links) (defun org-x-dag-bs-error-links (msg links)
(->> (s-join ", " links) (->> (s-join ", " links)
(format "%s: %s" msg) (format "%s: %s" msg)
(org-x-dag-bs :error))) (org-x-dag-bs :error)))
;; ;; TODO need to make two versions of this, one to propogogate the entire
;; ;; status, and another to propogate the entire key
;; ;; both cases will need to stop when they encounted a child that is already
;; ;; 'filled' (eg either already an error or already has the key)
;; (defun org-x-dag-ht-propagate-status (adjlist htbl ids)
;; (cl-labels
;; ((get-children
;; (adjlist id)
;; (->> (plist-get (ht-get adjlist id) :childre)
;; (--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)
;; (unless (ht-get htbl id)
;; (ht-set htbl id to-set)))))
;; (-each ids
;; (lambda (id)
;; (--each (get-children adjlist id)
;; (propagate adjlist htbl it id))))
;; htbl))
(defun org-x-dag-id-is-buffer-leaf (adjlist id)
(->> (plist-get (ht-get adjlist id) :children)
(--none-p (-> (ht-get adjlist it)
(plist-get :node-meta)
(plist-get :buffer-parent)
(equal id)))))
(defun org-x-dag-ns-toplevel (tbl adjlist links ns) (defun org-x-dag-ns-toplevel (tbl adjlist links ns)
(let ((h (plist-get ns tbl))) (let ((h (alist-get tbl ns)))
(org-x-dag-each-links links (org-x-dag-each-links links
(ht-set h it (org-x-dag-bs-error-links "Invalid links" it-targets))) (ht-set h it (org-x-dag-bs-error-links "Invalid links" it-targets)))
ns)) ns))
@ -2031,164 +2069,174 @@ used for optimization."
(defun org-x-dag-ns-svg (adjlist links ns) (defun org-x-dag-ns-svg (adjlist links ns)
(org-x-dag-ns-toplevel :survival adjlist links ns)) (org-x-dag-ns-toplevel :survival adjlist links ns))
(defun org-x-dag-ht-add-links (id htbl key targets)
(let (r)
(--each targets
(->> (if (setq r (ht-get htbl it))
(org-x-dag-bs-fmap r
(org-x-dag-plist-cons it key id))
(org-x-dag-bs :valid `(,key (,id))))
(ht-set htbl it)))))
(defun org-x-dag-ns-with-valid (ns adjlist cur-key id targets keys valid-fun)
(declare (indent 5))
(cl-flet*
((key-group
(id)
(let ((g (org-x-dag-id-link-group adjlist id)))
(if (member g keys) g :invalid)))
(parent-group
(h adjlist id)
(cond
((org-x-dag-bs-error-p (ht-get h id)) :error)
((not (org-x-dag-id-is-buffer-leaf adjlist id)) :non-leaf)
(t :valid)))
(reduce-valid
(grouped-targets acc key)
(-let* (((acc-keyed acc-error acc-non-leaf) acc)
(h (alist-get key ns))
((&alist :valid v :error e :non-leaf n)
(->> (alist-get key grouped-targets)
(--group-by (parent-group h adjlist it)))))
`(((,key ,v) ,@acc-keyed)
(,@e ,@acc-error)
(,@n ,@acc-non-leaf)))))
(let ((grouped (-group-by #'key-group targets))
(cur-h (alist-get cur-key ns)))
(-if-let (invalid (alist-get :invalid grouped))
(ht-set cur-h id (org-x-dag-bs-error-links "Invalid links" invalid))
(-let (((valid err non-leaf)
(--reduce-from (reduce-valid grouped acc it) nil keys)))
(cond
(err
(->> (org-x-dag-bs-error-links "Linked to invalid links" err)
(ht-set cur-h id)))
(non-leaf
(->> (org-x-dag-bs-error-links "Linked to non-leaf nodes" non-leaf)
(ht-set cur-h id)))
(t
(funcall valid-fun id cur-h valid))))))))
(defun org-x-dag-ns-epg (adjlist links ns) (defun org-x-dag-ns-epg (adjlist links ns)
(-let (((&plist :lifetime ht-l :endpoint ht-e) ns)) (-let (((&alist :lifetime ht-l) ns))
(org-x-dag-each-links links (org-x-dag-each-links links
(-let (((valid invalid) (org-x-dag-ns-with-valid ns adjlist :endpoint it it-targets
(--split-with (eq :lifetime (org-x-dag-id-link-group it)) it-targets))) '(:lifetime)
(if invalid (lambda (id this-h res)
(ht-set ht-e it (org-x-dag-bs-error-links "Invalid links" invalid)) (-let (((&alist :lifetime l) res))
(-let (((invalid valid) (ht-set this-h id (org-x-dag-bs :valid `(:committed ,l)))
(--split-with (org-x-dag-bs-error-p (ht-get ht-l it)) valid))) ;; this function doesn't treat the value of the nstat hash table
(if invalid ;; as an either, but at this point in the code, we have already
(->> invalid ;; ruled out the fact that these are all Rights since we use that
(org-x-dag-bs-error-links "Linked to invalid links") ;; as a test of validity
(ht-set ht-e it)) (org-x-dag-ht-add-links id ht-l :fulfilled l)))))
(->> (list :committed valid
:fulfilled nil
:planned nil)
(org-x-dag-bs :valid)
(ht-set ht-e it))
(org-x-dag-each-link-parent ht-l valid
(org-x-dag-plist-cons it :fulfilled parent)))))))
;; TODO propagate links downward
ns)) ns))
(defun org-x-dag-ht-get-maybe (htbl id key)
(pcase (ht-get htbl id)
(`(:error ,_) nil)
(`(:valid ,c) (plist-get c key))))
(defun org-x-dag-ns-qtp (adjlist links ns) (defun org-x-dag-ns-qtp (adjlist links ns)
(-let (((&plist :lifetime ht-l :endpoint ht-e :quarterly ht-q) ns)) (-let (((&alist :lifetime ht-l :endpoint ht-e :quarterly ht-q) ns))
(org-x-dag-each-links links (org-x-dag-each-links links
(-let (((&plist :endpoint pe :lifetime pl :invalid i) (org-x-dag-ns-with-valid ns adjlist :quarterly it it-targets
(--group-by (let ((g (org-x-dag-id-link-group it))) '(:lifetime :endpoint)
(if (member g '(:endpoint :lifetime)) g :invalid)) (lambda (id this-h res)
it-targets))) (-let (((&alist :lifetime l :endpoint e) res))
(if i (ht-set ht-q it (org-x-dag-bs-error-links "Invalid links" i)) (ht-set this-h id (org-x-dag-bs :valid `(:committed (,@e ,@l))))
(-let (((e- e+) (--split-with (org-x-dag-bs-error-p (ht-get ht-e it)) pe)) (->> (--mapcat (org-x-dag-ht-get-maybe ht-e it :committed) e)
((l- l+) (--split-with (org-x-dag-bs-error-p (ht-get ht-l it)) pl))) (org-x-dag-ht-add-links id ht-l :planned))
(if (or e- l-) (org-x-dag-ht-add-links id ht-e :planned e)
(->> `(,@e- ,@l-) (org-x-dag-ht-add-links id ht-l :planned l)))))
(org-x-dag-bs-error-links "Linked to invalid links")
(ht-set ht-e it))
(->> (list :committed `(,@e+ ,@l+) :planned nil)
(org-x-dag-bs :valid)
(ht-set ht-e it))
(org-x-dag-each-link-parent ht-e e+
(progn
(org-x-dag-each-link-parent ht-l (plist it :committed)
(org-x-dag-plist-cons it :planned parent))
(org-x-dag-plist-cons it :planned parent)))
(org-x-dag-each-link-parent ht-l l+
(org-x-dag-plist-cons it :planned parent)))))))
;; TODO propagate links downward
ns)) ns))
(defun org-x-dag-ns-wkp (adjlist links ns) (defun org-x-dag-ns-wkp (adjlist links ns)
(-let (((&plist :weekly ht-w :quarterly ht-q) ns)) (-let (((&alist :quarterly ht-q) ns))
(org-x-dag-each-links links (org-x-dag-each-links links
(-let (((valid invalid) (org-x-dag-ns-with-valid ns adjlist :weekly it it-targets
(--split-with (eq :quarterly (org-x-dag-id-link-group it)) '(:quarterly)
it-targets))) (lambda (id this-h res)
(if invalid (-let (((&alist :quarterly q) res))
(ht-set ht-w it (org-x-dag-bs-error-links "Invalid links" invalid)) (ht-set this-h id (org-x-dag-bs :valid `(:committed ,q)))
(-let (((invalid valid) (org-x-dag-ht-add-links id ht-q :planned q)))))
(--split-with (org-x-dag-bs-error-p (ht-get ht-w it)) valid))
(if invalid
(->> invalid
(org-x-dag-bs-error-links "Linked to invalid links")
(ht-set ht-w it))
(->> (list :committed valid :planned nil)
(org-x-dag-bs :valid)
(ht-set ht-w it))
(org-x-dag-each-link-parent ht-q valid
(org-x-dag-plist-cons it :planned parent))))))))
;; TODO propagate links downward
ns)) ns))
(defun org-x-dag-ns-action (adjlist links ns) (defun org-x-dag-ns-action (adjlist links ns)
(-let (((&plist :action ht-a :endpoint ht-e :lifetime ht-l :survival ht-s) ns)) (-let (((&alist :endpoint ht-e :lifetime ht-l :survival ht-s) ns))
(org-x-dag-each-links links (org-x-dag-each-links links
(-let (((&plist :endpoint pe :lifetime pl :survival ps :invalid i) (org-x-dag-ns-with-valid ns adjlist :action it it-targets
(--group-by (let ((g (org-x-dag-id-link-group it))) '(:survival :endpoint :lifetime)
(if (member g '(:endpoint :lifetime :survival)) (lambda (id this-h res)
g :invalid)) (-let (((&alist :survival s :endpoint e :lifetime l) res))
it-targets))) (->> (org-x-dag-bs :valid `(:committed (,@e ,@l ,@s)))
(if i (ht-set ht-w it (org-x-dag-bs-error-links "Invalid links" i)) (ht-set this-h it))
(-let (((e- e+) (--split-with (org-x-dag-bs-error-p (ht-get ht-e it)) pe)) (->> (--mapcat (org-x-dag-ht-get-maybe ht-e it :committed) e)
((l- l+) (--split-with (org-x-dag-bs-error-p (ht-get ht-l it)) pl)) (org-x-dag-ht-add-links id ht-l :fulfilled))
((s- s+) (--split-with (org-x-dag-bs-error-p (ht-get ht-s it)) ps))) (org-x-dag-ht-add-links id ht-e :fulfilled e)
(if (or e- l- s-) (org-x-dag-ht-add-links id ht-l :fulfilled l)
(->> `(,@e- ,@l- ,@s-) (org-x-dag-ht-add-links id ht-s :fulfilled s)))))
(org-x-dag-bs-error-links "Linked to invalid links")
(ht-set ht-w it))
(->> (list :scheduled `(,@e+ ,@l+ ,@s+) :planned nil)
(org-x-dag-bs :valid)
(ht-set ht-w it))
(org-x-dag-each-link-parent ht-e e+
(progn
(org-x-dag-each-link-parent ht-l (plist it :committed)
(org-x-dag-plist-cons it :planned parent))
(org-x-dag-plist-cons it :planned parent)))
(org-x-dag-each-link-parent ht-l l+
(org-x-dag-plist-cons it :fulfilled parent))
(org-x-dag-each-link-parent ht-s s+
(org-x-dag-plist-cons it :fulfilled parent)))))))
;; TODO propagate links downward
ns)) ns))
(defun org-x-dag-ns-daily (adjlist links ns) (defun org-x-dag-ns-dlp (adjlist links ns)
(-let (((&plist :daily ht-d (cl-flet
:action ht-a ((get-committed
:quarterly ht-q (htbl ids)
:weekly ht-w) (--mapcat (org-x-dag-ht-get-maybe htbl it :committed) ids)))
ns)) (-let (((&alist :action ht-a :quarterly ht-q :weekly ht-w) ns))
(org-x-dag-each-links links (org-x-dag-each-links links
(-let (((&plist :action pa :weekly pw :invalid i) (org-x-dag-ns-with-valid ns adjlist :daily it it-targets
(--group-by (let ((g (org-x-dag-id-link-group it))) '(:action :weekly)
(if (member g '(:action :weekly)) ;; TODO this won't allow links to project actions since those aren't
g :invalid)) ;; leaves
it-targets))) (lambda (id this-h res)
(if i (ht-set ht-d it (org-x-dag-bs-error-links "Invalid links" i)) (-let (((&alist :action a :weekly w) res))
(-let* ((as (ht-get ht-a it)) (let ((qgoals (->> (get-committed ht-w w)
(ws (ht-get ht-w it)) (get-commited ht-q)))
((w- w+) (-split-with #'org-x-dag-bs-error-p ws)) (agoals (get-committed ht-a a)))
((a- a+) (-split-with #'org-x-dag-bs-error-p as)))
(if (or a- w-)
(->> `(,@a- ,@w-)
(org-x-dag-bs-error-links "Linked to invalid links")
(ht-set ht-d it))
(let ((qgoals (--mapcat (plist-get (ht-get ht-q it) :committed) w+))
(agoals (--mapcat (plist-get (ht-get ht-a it) :committed) a+)))
(-if-let (gs (-intesection qgoals agoals)) (-if-let (gs (-intesection qgoals agoals))
(progn (progn
(->> (list :scheduled w+ (->> (list :scheduled w
:committed gs :committed (-uniq gs)
:active a+) :active a)
(org-x-dag-bs :valid) (org-x-dag-bs :valid)
(ht-set ht-d it)) (ht-set this-h id))
;; TODO add the goals to their goal links? (this might be ;; TODO add the goals to their goal links? (this might be
;; useful later when displaying) ;; useful later when displaying)
(org-x-dag-each-link-parent ht-w w+ (org-x-dag-ht-add-links id ht-w :planned w)
(org-x-dag-plist-cons it :planned parent)) (org-x-dag-ht-add-links id ht-a :planned a))
(org-x-dag-each-link-parent ht-a a+ (->> (org-x-dag-bs :error "Non overlapping goals")
(org-x-dag-plist-cons it :planned parent))) (ht-set ht-d id))))))))
(ht-set ht-d it (org-x-dag-bs :error "Non overlapping goals"))))))))) ns)))
;; TODO propagate links downward
ns)) (defun org-x-dag-ht-propagate-endpoint (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)
;; TODO this needs to treat the node value like a functor
(let ((node (ht-get htbl it)))
(unless (org-x-dag-bs-error-p node)
(ht-set htbl it (org-x-dag-plist-map node :committed
(lambda (x) (append x to-set)))))))))
(-let (((&alist :endpoint ht-e) ns))
(-each (ht-keys ht-e)
(lambda (id)
(let ((committed (plist-get (ht-get ht-e id) :committed)))
(--each (get-children adjlist id)
(propagate adjlist ht-e it committed)))))
ns)))
(defun org-x-dag-get-network-status (adjlist links) (defun org-x-dag-get-network-status (adjlist links)
(cl-flet (-let ((ns (->> '(:action :endpoint :lifetime :survival :quarterly :weekly :daily)
((link-group (--map (cons it (ht-create #'equal)))))
(adjlist link)
(-> (ht-get adjlist (car id))
(plist-get :node-meta)
(plist-get :hl-meta)
(plist-get :group))))
(-let ((ns (--map (cons it (ht-create #'equal)) (list :action
:endpoint
:lifetime
:survival
:quarterly
:weekly
:daily)))
((&plist :action a ((&plist :action a
:endpoint e :endpoint e
:lifetime l :lifetime l
@ -2196,14 +2244,29 @@ used for optimization."
:quarterly q :quarterly q
:weekly w :weekly w
:daily d) :daily d)
links)) (--reduce-from (-let (((key . link) it))
(org-x-dag-plist-cons acc key link))
nil
links)))
;; TODO add propagate step at the end
;;
;; actions: propogate down since these can be link at any point and
;; can have daily links pointing anywhere
;; TODO not sure if I want to propagate the planning field up
;;
;; endpoint goals: propagate down since these can link up to ltgs
;;
;; toplevel (ltg and svg): propagate up since only leaves can be linked
;; but we care if a tree is linked to anything else
(->> (org-x-dag-ns-ltg adjlist l ns) (->> (org-x-dag-ns-ltg adjlist l ns)
(org-x-dag-ns-svg adjlist s ns) (org-x-dag-ns-svg adjlist s)
(org-x-dag-ns-epg adjlist e ns) (org-x-dag-ns-epg adjlist e)
(org-x-dag-ns-qtp adjlist q ns) (org-x-dag-ns-qtp adjlist q)
(org-x-dag-ns-wkp adjlist w ns) (org-x-dag-ns-wkp adjlist w)
(org-x-dag-ns-action adjlist a ns) (org-x-dag-ns-action adjlist a)
(org-x-dag-ns-dlp adjlist d ns))))) (org-x-dag-ns-dlp adjlist d)
(org-x-dag-ht-propagate-endpoint adjlist))))
;;; DAG SYNCHRONIZATION/CONSTRUCTION ;;; DAG SYNCHRONIZATION/CONSTRUCTION
@ -2366,7 +2429,11 @@ plist holding the files to be used in the DAG."
;; (org-x-dag-update-ht ids2rem meta2ins id->meta) ;; (org-x-dag-update-ht ids2rem meta2ins id->meta)
;; (org-x-dag-update-ht files2rem fms2ins file->ids) ;; (org-x-dag-update-ht files2rem fms2ins file->ids)
(org-x-dag-update-dag ids2ins ids2rem) (org-x-dag-update-dag ids2ins ids2rem)
(plist-put org-x-dag :files file-state))) (plist-put org-x-dag :files file-state)
;; TODO not sure where to put this
(let ((adjlist (dag-get-adjacency-list (plist-get org-x-dag :dag))))
(->> (org-x-dag-get-network-status adjlist links2ins)
(plist-put org-x-dag :netstat)))))
;; update illegal links after updating the adjlist, since we need that to ;; update illegal links after updating the adjlist, since we need that to
;; figure out which links are illegal ;; figure out which links are illegal
;; (-let (((illegal-foreign illegal-local) (org-x-dag-filter-links links2ins))) ;; (-let (((illegal-foreign illegal-local) (org-x-dag-filter-links links2ins)))