ENH make daily node network status more nuanced
This commit is contained in:
parent
15217aa752
commit
fdb76e6e43
|
|
@ -23,6 +23,8 @@
|
|||
|
||||
(require 'dash)
|
||||
|
||||
;; type constructor
|
||||
|
||||
(defmacro either (key data)
|
||||
"Make an either type.
|
||||
|
||||
|
|
@ -32,6 +34,8 @@ left/right slot."
|
|||
((or :left :right) `(list ,key ,data))
|
||||
(_ (error "Invalid status key: %s" key))))
|
||||
|
||||
;; monad-y things
|
||||
|
||||
(defmacro either>>= (either form)
|
||||
"Bind EITHER to FORM where the right slot is bound to 'it'."
|
||||
(declare (indent 1))
|
||||
|
|
@ -40,6 +44,23 @@ left/right slot."
|
|||
(`(:right ,it) ,form)
|
||||
(e (error "Learn to use monads, dummy; this isn't one: %s" e))))
|
||||
|
||||
(defun either-foldM (fun init xs)
|
||||
"Mondically apply FUN to XS (a list).
|
||||
|
||||
INIT is the starting value to use for FUN, which takes two
|
||||
arguments (the accumulator and the next value) and returns an
|
||||
either."
|
||||
(let ((acc (either :right init)))
|
||||
(while (and xs (either-is-right-p acc))
|
||||
(setq acc (funcall fun (cadr acc) (car xs)))
|
||||
(!cdr xs))
|
||||
acc))
|
||||
|
||||
(defmacro either-foldM* (form init xs)
|
||||
`(either-foldM (lambda (acc it) ,form) ,init ,xs))
|
||||
|
||||
;; Data.Either ripoff things
|
||||
|
||||
(defun either-is-left-p (either)
|
||||
"Return t if EITHER is a left."
|
||||
(eq (car either) :left))
|
||||
|
|
|
|||
|
|
@ -1196,6 +1196,78 @@ used for optimization."
|
|||
(either :right `(,key (,id))))
|
||||
(ht-set htbl it)))))
|
||||
|
||||
(defun org-x-dag-adjlist-id-node-meta (adjlist id)
|
||||
(-> (ht-get adjlist id)
|
||||
(plist-get :node-meta)))
|
||||
|
||||
(defun org-x-dag-adjlist-id-hl-meta (adjlist id)
|
||||
(-> (org-x-dag-adjlist-id-node-meta adjlist id)
|
||||
(plist-get :hl-meta)))
|
||||
|
||||
(defun org-x-dag-adjlist-id-hl-meta-prop (adjlist prop id)
|
||||
(-> (org-x-dag-adjlist-id-hl-meta adjlist id)
|
||||
(plist-get prop)))
|
||||
|
||||
(defun org-x-dag-adjlist-id-tags (adjlist id)
|
||||
(org-x-dag-adjlist-id-hl-meta-prop adjlist :tags id))
|
||||
|
||||
(defun org-x-dag-get-children (adjlist id)
|
||||
(->> (plist-get (ht-get adjlist id) :children)
|
||||
(--filter (-> (org-x-dag-adjlist-id-hl-meta adjlist it)
|
||||
(plist-get :buffer-parent)
|
||||
(equal id)))))
|
||||
|
||||
;; (defun org-x-dag-ns-with-valid (ns adjlist cur-key links keypairs valid-fun)
|
||||
;; (declare (indent 4))
|
||||
;; (cl-flet*
|
||||
;; ((key-group
|
||||
;; (keys id)
|
||||
;; (let ((g (org-x-dag-id-link-group adjlist id)))
|
||||
;; (if (member g keys) g :invalid)))
|
||||
;; (parent-group
|
||||
;; (h permitleafp adjlist id)
|
||||
;; (cond
|
||||
;; ((either-is-left-p (ht-get h id))
|
||||
;; :error)
|
||||
;; ((and (not permitleafp) (org-x-dag-get-children adjlist id))
|
||||
;; :non-leaf)
|
||||
;; (t :valid)))
|
||||
;; (reduce-valid
|
||||
;; (grouped-targets acc keypair)
|
||||
;; (-let* (((key . permitleafp) keypair)
|
||||
;; ((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 permitleafp adjlist it)))))
|
||||
;; `(((,key ,@v) ,@acc-keyed)
|
||||
;; (,@e ,@acc-error)
|
||||
;; (,@n ,@acc-non-leaf)))))
|
||||
;; (org-x-dag-each-links links
|
||||
;; (let* ((keys (-map #'car keypairs))
|
||||
;; (grouped (--group-by (key-group keys it) it-targets))
|
||||
;; (cur-h (alist-get cur-key ns)))
|
||||
;; (-if-let (invalid (alist-get :invalid grouped))
|
||||
;; (ht-set cur-h it (org-x-dag-bs-error-links "Invalid links" invalid))
|
||||
;; (-let (((valid err non-leaf)
|
||||
;; ;; TODO this could be more efficient if we break early when
|
||||
;; ;; encountering an error/non-leaf node
|
||||
;; (--reduce-from (reduce-valid grouped acc it) nil keypairs)))
|
||||
;; (cond
|
||||
;; (err
|
||||
;; (->> (org-x-dag-bs-error-links "Linked to invalid links" err)
|
||||
;; (ht-set cur-h it)))
|
||||
;; (non-leaf
|
||||
;; (->> (org-x-dag-bs-error-links "Linked to non-leaf nodes" non-leaf)
|
||||
;; (ht-set cur-h it)))
|
||||
;; (t
|
||||
;; (funcall valid-fun it cur-h valid)))))))))
|
||||
|
||||
(defun org-x-dag-ns-is-leaf-p (adjlist id)
|
||||
(if (org-x-dag-get-children adjlist id)
|
||||
(either :left "Linked to non-leaf node")
|
||||
(either :right id)))
|
||||
|
||||
(defun org-x-dag-ns-with-valid (ns adjlist cur-key links keypairs valid-fun)
|
||||
(declare (indent 4))
|
||||
(cl-flet*
|
||||
|
|
@ -1203,42 +1275,38 @@ used for optimization."
|
|||
(keys id)
|
||||
(let ((g (org-x-dag-id-link-group adjlist id)))
|
||||
(if (member g keys) g :invalid)))
|
||||
(parent-group
|
||||
(h permitleafp adjlist id)
|
||||
(id-is-valid
|
||||
(h valid-fun acc id)
|
||||
(cond
|
||||
((either-is-left-p (ht-get h id))
|
||||
:error)
|
||||
((and (not permitleafp) (org-x-dag-get-children adjlist id))
|
||||
:non-leaf)
|
||||
(t :valid)))
|
||||
(either :left "Linked to invalid links"))
|
||||
(valid-fun
|
||||
;; NOTE this valid-fun doesn't just have to return a Right ID upon
|
||||
;; success, it can return a Right anything which might be useful
|
||||
;; downstream
|
||||
(-> (funcall valid-fun adjlist id)
|
||||
(either<$> (cons it acc))))
|
||||
(t
|
||||
(either :right (cons id acc)))))
|
||||
(reduce-valid
|
||||
(grouped-targets acc keypair)
|
||||
(-let* (((key . permitleafp) keypair)
|
||||
((acc-keyed acc-error acc-non-leaf) acc)
|
||||
(-let* (((key valid-fun) keypair)
|
||||
(h (alist-get key ns))
|
||||
((&alist :valid v :error e :non-leaf n)
|
||||
(->> (alist-get key grouped-targets)
|
||||
(--group-by (parent-group h permitleafp adjlist it)))))
|
||||
`(((,key ,@v) ,@acc-keyed)
|
||||
(,@e ,@acc-error)
|
||||
(,@n ,@acc-non-leaf)))))
|
||||
(new (->> (alist-get key grouped-targets)
|
||||
(either-foldM* (id-is-valid h valid-fun acc it) nil))))
|
||||
(either<$> new `((,key ,@it) ,@acc)))))
|
||||
(org-x-dag-each-links links
|
||||
(let* ((keys (-map #'car keypairs))
|
||||
(grouped (--group-by (key-group keys it) it-targets))
|
||||
(cur-h (alist-get cur-key ns)))
|
||||
(-if-let (invalid (alist-get :invalid grouped))
|
||||
(ht-set cur-h it (org-x-dag-bs-error-links "Invalid links" invalid))
|
||||
(-let (((valid err non-leaf)
|
||||
(--reduce-from (reduce-valid grouped acc it) nil keypairs)))
|
||||
(cond
|
||||
(err
|
||||
(->> (org-x-dag-bs-error-links "Linked to invalid links" err)
|
||||
(ht-set cur-h it)))
|
||||
(non-leaf
|
||||
(->> (org-x-dag-bs-error-links "Linked to non-leaf nodes" non-leaf)
|
||||
(ht-set cur-h it)))
|
||||
(t
|
||||
(funcall valid-fun it cur-h valid)))))))))
|
||||
(let ((x (either-foldM* (reduce-valid grouped acc it) nil keypairs)))
|
||||
(either-from x
|
||||
(lambda (_)
|
||||
(ht-set cur-h it x))
|
||||
(lambda (valid-ids)
|
||||
(funcall valid-fun it cur-h valid-ids)))))))))
|
||||
|
||||
;; TODO this needs to eventually propagate deadlines; I want to be able to
|
||||
;; link epgs to other epgs, which means I won't be able to check deadline
|
||||
|
|
@ -1246,7 +1314,7 @@ used for optimization."
|
|||
(defun org-x-dag-ns-epg (adjlist links ns)
|
||||
(-let (((&alist :lifetime ht-l) ns))
|
||||
(org-x-dag-ns-with-valid ns adjlist :endpoint links
|
||||
'((:lifetime))
|
||||
'((:lifetime org-x-dag-ns-is-leaf-p))
|
||||
(lambda (id this-h res)
|
||||
(-let (((&alist :lifetime l) res))
|
||||
(ht-set this-h id (either :right `(:committed ,l)))
|
||||
|
|
@ -1260,7 +1328,8 @@ used for optimization."
|
|||
(defun org-x-dag-ns-qtp (adjlist links ns)
|
||||
(-let (((&alist :lifetime ht-l :endpoint ht-e) ns))
|
||||
(org-x-dag-ns-with-valid ns adjlist :quarterly links
|
||||
'((:lifetime) (:endpoint))
|
||||
'((:lifetime org-x-dag-ns-is-leaf-p)
|
||||
(:endpoint org-x-dag-ns-is-leaf-p))
|
||||
(lambda (id this-h res)
|
||||
(-let (((&alist :lifetime l :endpoint e) res))
|
||||
(ht-set this-h id (either :right `(:committed (,@e ,@l))))
|
||||
|
|
@ -1273,7 +1342,7 @@ used for optimization."
|
|||
(defun org-x-dag-ns-wkp (adjlist links ns)
|
||||
(-let (((&alist :quarterly ht-q) ns))
|
||||
(org-x-dag-ns-with-valid ns adjlist :weekly links
|
||||
'((:quarterly))
|
||||
'((:quarterly org-x-dag-ns-is-leaf-p))
|
||||
(lambda (id this-h res)
|
||||
(-let (((&alist :quarterly q) res))
|
||||
(ht-set this-h id (either :right `(:committed ,q)))
|
||||
|
|
@ -1291,7 +1360,9 @@ used for optimization."
|
|||
:quarterly ht-q)
|
||||
ns))
|
||||
(org-x-dag-ns-with-valid ns adjlist :action links
|
||||
'((:survival) (:endpoint) (:lifetime))
|
||||
'((:survival org-x-dag-ns-is-leaf-p)
|
||||
(:endpoint org-x-dag-ns-is-leaf-p)
|
||||
(:lifetime org-x-dag-ns-is-leaf-p))
|
||||
(lambda (id this-h res)
|
||||
(-let* (((&alist :survival s :endpoint e :lifetime l) res)
|
||||
(this-ns
|
||||
|
|
@ -1314,44 +1385,64 @@ used for optimization."
|
|||
(org-x-dag-ht-add-links id ht-l :fulfilled)))))
|
||||
ns)))
|
||||
|
||||
(defun org-x-dag-ns-dlp (adjlist links ns)
|
||||
(defun org-x-dag-ns-dlp (sel-date adjlist links ns)
|
||||
(cl-flet
|
||||
((get-committed
|
||||
(htbl ids)
|
||||
(--mapcat (org-x-dag-ht-get-maybe htbl it :committed) ids)))
|
||||
(-let (((&alist :action ht-a :quarterly ht-q :weekly ht-w) ns))
|
||||
((add-planned
|
||||
(id htbl res)
|
||||
(->> (--mapcat (nth 1) res)
|
||||
(-uniq)
|
||||
;; TODO ':planned' might not be the best name for these
|
||||
(org-x-dag-ht-add-links id htbl :planned))))
|
||||
(-let* (((&alist :lifetime ht-l
|
||||
:endpoint ht-e
|
||||
:survival ht-s
|
||||
:action ht-a
|
||||
:quarterly ht-q
|
||||
:weekly ht-w)
|
||||
ns)
|
||||
(get-planned
|
||||
(lambda (id)
|
||||
(let* ((c (org-x-dag-ht-get-maybe ht-a id :committed))
|
||||
;; TODO this is lame
|
||||
(e (--mapcat (org-x-dag-ht-get-maybe ht-e it :planned) c))
|
||||
(l (--mapcat (org-x-dag-ht-get-maybe ht-l it :planned) c)))
|
||||
(-union e l))))
|
||||
(is-valid-action
|
||||
(lambda (adjlist id)
|
||||
(-if-let (sched (-some->> (org-x-dag-adjlist-id-hl-meta-prop adjlist :planning id)
|
||||
(org-ml-get-property :scheduled)
|
||||
(org-ml-timestamp-get-start-time)))
|
||||
;; ASSUME if the node's timestamp does not coincide with the
|
||||
;; actual day in the plan it will be reflected in the buffer
|
||||
;; status
|
||||
(-let (((_ time) (org-x-dag-datetime-split sched)))
|
||||
(if time
|
||||
(either :left "Linked to action with HH:MM timestamp")
|
||||
(if (org-x-dag-ht-get-maybe ht-a id :survivalp)
|
||||
;; ASSUME (for now) that if survival flag is t
|
||||
;; then there will be at least one goal (which
|
||||
;; means this action is committed)
|
||||
(let ((s (org-x-dag-ht-get-maybe ht-a id :committed)))
|
||||
(either :right `(,id :survival ,s)))
|
||||
(-if-let (q (funcall get-planned id))
|
||||
(either :right `(,id :quarterly ,q))
|
||||
(->> "Linked to scheduled action that isn't on QTP"
|
||||
(either :left))))))
|
||||
(-if-let (w (->> (funcall get-planned id)
|
||||
(--mapcat (org-x-dag-ht-get-maybe ht-q it :planned))))
|
||||
(either :right `(,id :weekly ,w))
|
||||
(->> "Linked to unscheduled action that isn't on WKP"
|
||||
(either :left)))))))
|
||||
(org-x-dag-ns-with-valid ns adjlist :daily links
|
||||
'((:action t) (:weekly))
|
||||
`((:action ,is-valid-action))
|
||||
(lambda (id this-h res)
|
||||
(-let (((&alist :action a :weekly w) res))
|
||||
(let ((qgoals (->> (get-committed ht-w w)
|
||||
(get-committed ht-q)))
|
||||
(agoals (get-committed ht-a a)))
|
||||
;; TODO this check doesn't matter for survival goals since
|
||||
;; those won't be on the quarterly plan
|
||||
;; (-if-let (gs (-intersection qgoals agoals))
|
||||
(progn
|
||||
(->> (list :scheduled w
|
||||
;; :committed (-uniq gs)
|
||||
:committed (-uniq (append qgoals agoals))
|
||||
:active a)
|
||||
(either :right)
|
||||
(ht-set this-h id))
|
||||
;; TODO add the goals to their goal links? (this might be
|
||||
;; useful later when displaying)
|
||||
(org-x-dag-ht-add-links id ht-w :planned w)
|
||||
(org-x-dag-ht-add-links id ht-a :planned a))))))
|
||||
;; (->> (either :left "Non overlapping goals")
|
||||
;; (ht-set this-h id)))))))
|
||||
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 :hl-meta)
|
||||
(plist-get :buffer-parent)
|
||||
(equal id)))))
|
||||
(-let (((&alist :action a) res))
|
||||
(org-x-dag-ht-add-links id ht-a :planned (-map #'car a))
|
||||
(-let (((&alist :weekly w :quarterly q :survival s)
|
||||
(--group-by (nth 1 it) a)))
|
||||
(add-planned id ht-w w)
|
||||
(add-planned id ht-q q)
|
||||
(add-planned id ht-s s))))))))
|
||||
|
||||
(defun org-x-dag-ht-map-down (adjlist h-key ns get-fun set-fun def-fun)
|
||||
(declare (indent 3))
|
||||
|
|
@ -1406,8 +1497,18 @@ used for optimization."
|
|||
(propagate h it )))
|
||||
ns))
|
||||
|
||||
(defun org-x-dag-get-network-status (adjlist links)
|
||||
(-let ((ns (->> (list :action
|
||||
(defun org-x-dag-adjlist-ids-filter-tags (adjlist tag-getter date ids)
|
||||
(--filter (equal date (funcall tag-getter (org-x-dag-adjlist-id-tags it))) ids))
|
||||
|
||||
(defun org-x-dag-get-network-status (sel-date adjlist links)
|
||||
(cl-flet
|
||||
((cur-links
|
||||
(tag-fun links)
|
||||
(--filter (equal sel-date (->> (car it)
|
||||
(org-x-dag-adjlist-id-tags adjlist)
|
||||
(funcall tag-fun)))
|
||||
links)))
|
||||
(-let* ((ns (->> (list :action
|
||||
:endpoint
|
||||
:lifetime
|
||||
:survival
|
||||
|
|
@ -1426,7 +1527,15 @@ used for optimization."
|
|||
(acc-links (plist-get acc group)))
|
||||
(plist-put acc group (append acc-links links)))
|
||||
nil
|
||||
links)))
|
||||
links))
|
||||
;; Filter all planning nodes to be on/within the current date. After
|
||||
;; this I can assume that any time a planning node shows up anywhere
|
||||
;; it is on the current plan, and I don't need to do any downstream
|
||||
;; processing to distinguish between current and not current. Bonus,
|
||||
;; this is much faster (less stuff to deal with)
|
||||
(cur-q (cur-links #'org-x-dag-quarter-tags-to-date q))
|
||||
(cur-w (cur-links #'org-x-dag-weekly-tags-to-date w))
|
||||
(cur-d (cur-links #'org-x-dag-daily-tags-to-date d)))
|
||||
;; add all links to the network status object (ew side effects)
|
||||
(org-x-dag-ns-ltg l ns)
|
||||
(org-x-dag-ns-svg s ns)
|
||||
|
|
@ -1434,18 +1543,15 @@ used for optimization."
|
|||
(org-x-dag-ns-epg adjlist e ns)
|
||||
(org-x-dag-ht-propagate-down adjlist :endpoint :committed ns)
|
||||
|
||||
(org-x-dag-ns-qtp adjlist q ns)
|
||||
(org-x-dag-ns-qtp adjlist cur-q ns)
|
||||
(org-x-dag-ht-propagate-up adjlist :lifetime :planned ns)
|
||||
(org-x-dag-ht-propagate-up adjlist :survival :planned ns)
|
||||
|
||||
(org-x-dag-ns-wkp adjlist w ns)
|
||||
(org-x-dag-ns-wkp adjlist cur-w ns)
|
||||
|
||||
(org-x-dag-ns-action adjlist a ns)
|
||||
(org-x-dag-ht-propagate-up adjlist :lifetime :fulfilled ns)
|
||||
(org-x-dag-ht-propagate-up adjlist :survival :fulfilled ns)
|
||||
|
||||
(org-x-dag-ns-dlp adjlist d ns)
|
||||
(org-x-dag-ht-propagate-down adjlist :action :planned ns)
|
||||
(org-x-dag-ht-map-down adjlist :action ns
|
||||
(lambda (h id)
|
||||
(either-from* (ht-get h id)
|
||||
|
|
@ -1462,7 +1568,10 @@ used for optimization."
|
|||
(lambda (x) (append x committed))))))
|
||||
(lambda (to-set)
|
||||
(-let (((committed survivalp) to-set))
|
||||
`(:committed ,committed :survivalp ,survivalp))))))
|
||||
`(:committed ,committed :survivalp ,survivalp))))
|
||||
|
||||
(org-x-dag-ns-dlp sel-date adjlist cur-d ns)
|
||||
(org-x-dag-ht-propagate-down adjlist :action :planned ns))))
|
||||
|
||||
;; global pipeline control
|
||||
|
||||
|
|
@ -1587,7 +1696,7 @@ removed from, added to, or edited within the DAG respectively."
|
|||
TO-REMOVE, TO-INSERT, and TO-UPDATE are lists of files to remove
|
||||
from, add to, and update with the DAG. FILE-STATE is a nested
|
||||
plist holding the files to be used in the DAG."
|
||||
(-let* (((&plist :dag :file->ids :file->links) org-x-dag)
|
||||
(-let* (((&plist :dag :file->ids :file->links :selected-date) org-x-dag)
|
||||
(files2rem (append to-update to-remove))
|
||||
(files2ins (append to-update to-insert))
|
||||
(ids2rem (org-x-dag-files->ids files2rem))
|
||||
|
|
@ -1601,7 +1710,7 @@ plist holding the files to be used in the DAG."
|
|||
(let ((adjlist (dag-get-adjacency-list (plist-get org-x-dag :dag))))
|
||||
(->> (plist-get org-x-dag :file->links)
|
||||
(ht-values)
|
||||
(org-x-dag-get-network-status adjlist)
|
||||
(org-x-dag-get-network-status selected-date adjlist)
|
||||
(plist-put org-x-dag :netstat)))))
|
||||
|
||||
(defun org-x-dag-sync (&optional force)
|
||||
|
|
|
|||
Loading…
Reference in New Issue