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

ENH allow daily nodes to link to any action (not just leaves)

This commit is contained in:
Nathan Dwarshuis 2022-03-29 19:13:22 -04:00
parent 4441230a84
commit 8727df790b
1 changed files with 93 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2009,17 +2009,20 @@ used for optimization."
(lambda (xs) (lambda (xs)
(cons x xs)))) (cons x xs))))
(defmacro org-x-dag-each-links (links form) (defmacro org-x-dag-each-links (links &rest body)
(declare (indent 1)) (declare (indent 1))
`(--each links `(let (it it-targets)
(-let (((it . it-targets) it)) (while links
,form))) (setq it (car (car links))
it-targets (cdr (car links)))
,@body
(!cdr links))))
(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)
(ht-set ,parent-ht it-parent)))) ;; (ht-set ,parent-ht it-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)
@ -2078,58 +2081,58 @@ used for optimization."
(org-x-dag-bs :valid `(,key (,id)))) (org-x-dag-bs :valid `(,key (,id))))
(ht-set htbl it))))) (ht-set htbl it)))))
(defun org-x-dag-ns-with-valid (ns adjlist cur-key id targets keys valid-fun) (defun org-x-dag-ns-with-valid (ns adjlist cur-key links keypairs valid-fun)
(declare (indent 5)) (declare (indent 4))
(cl-flet* (cl-flet*
((key-group ((key-group
(id) (keys id)
(let ((g (org-x-dag-id-link-group adjlist id))) (let ((g (org-x-dag-id-link-group adjlist id)))
(if (member g keys) g :invalid))) (if (member g keys) g :invalid)))
(parent-group (parent-group
(h adjlist id) (h checkleafp adjlist id)
(cond (cond
((org-x-dag-bs-error-p (ht-get h id)) :error) ((org-x-dag-bs-error-p (ht-get h id))
((not (org-x-dag-id-is-buffer-leaf adjlist id)) :non-leaf) :error)
((and checkleafp (not (org-x-dag-id-is-buffer-leaf adjlist id)))
:non-leaf)
(t :valid))) (t :valid)))
(reduce-valid (reduce-valid
(grouped-targets acc key) (grouped-targets acc keypair)
(-let* (((acc-keyed acc-error acc-non-leaf) acc) (-let* (((key . checkleafp) keypair)
((acc-keyed acc-error acc-non-leaf) acc)
(h (alist-get key ns)) (h (alist-get key ns))
((&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 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)))))
(let ((grouped (-group-by #'key-group targets)) (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))) (cur-h (alist-get cur-key ns)))
(-if-let (invalid (alist-get :invalid grouped)) (-if-let (invalid (alist-get :invalid grouped))
(ht-set cur-h id (org-x-dag-bs-error-links "Invalid links" invalid)) (ht-set cur-h it (org-x-dag-bs-error-links "Invalid links" invalid))
(-let (((valid err non-leaf) (-let (((valid err non-leaf)
(--reduce-from (reduce-valid grouped acc it) nil keys))) (--reduce-from (reduce-valid grouped acc it) nil keypairs)))
(cond (cond
(err (err
(->> (org-x-dag-bs-error-links "Linked to invalid links" err) (->> (org-x-dag-bs-error-links "Linked to invalid links" err)
(ht-set cur-h id))) (ht-set cur-h it)))
(non-leaf (non-leaf
(->> (org-x-dag-bs-error-links "Linked to non-leaf nodes" non-leaf) (->> (org-x-dag-bs-error-links "Linked to non-leaf nodes" non-leaf)
(ht-set cur-h id))) (ht-set cur-h it)))
(t (t
(funcall valid-fun id cur-h valid)))))))) (funcall valid-fun it cur-h valid)))))))))
(defun org-x-dag-ns-epg (adjlist links ns) (defun org-x-dag-ns-epg (adjlist links ns)
(-let (((&alist :lifetime ht-l) ns)) (-let (((&alist :lifetime ht-l) ns))
(org-x-dag-each-links links (org-x-dag-ns-with-valid ns adjlist :endpoint links
(org-x-dag-ns-with-valid ns adjlist :endpoint it it-targets '((:lifetime))
'(:lifetime)
(lambda (id this-h res) (lambda (id this-h res)
(-let (((&alist :lifetime l) res)) (-let (((&alist :lifetime l) res))
(ht-set this-h id (org-x-dag-bs :valid `(:committed ,l))) (ht-set this-h id (org-x-dag-bs :valid `(:committed ,l)))
;; this function doesn't treat the value of the nstat hash table (org-x-dag-ht-add-links id ht-l :fulfilled l))))
;; as an either, but at this point in the code, we have already
;; ruled out the fact that these are all Rights since we use that
;; as a test of validity
(org-x-dag-ht-add-links id ht-l :fulfilled l)))))
ns)) ns))
(defun org-x-dag-ht-get-maybe (htbl id key) (defun org-x-dag-ht-get-maybe (htbl id key)
@ -2139,43 +2142,40 @@ used for optimization."
(defun org-x-dag-ns-qtp (adjlist links ns) (defun org-x-dag-ns-qtp (adjlist links ns)
(-let (((&alist :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-ns-with-valid ns adjlist :quarterly links
(org-x-dag-ns-with-valid ns adjlist :quarterly it it-targets '((:lifetime) (:endpoint))
'(:lifetime :endpoint)
(lambda (id this-h res) (lambda (id this-h res)
(-let (((&alist :lifetime l :endpoint e) res)) (-let (((&alist :lifetime l :endpoint e) res))
(ht-set this-h id (org-x-dag-bs :valid `(:committed (,@e ,@l)))) (ht-set this-h id (org-x-dag-bs :valid `(:committed (,@e ,@l))))
(->> (--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 :planned)) (org-x-dag-ht-add-links id ht-l :planned))
(org-x-dag-ht-add-links id ht-e :planned e) (org-x-dag-ht-add-links id ht-e :planned e)
(org-x-dag-ht-add-links id ht-l :planned l))))) (org-x-dag-ht-add-links id ht-l :planned l))))
ns)) ns))
(defun org-x-dag-ns-wkp (adjlist links ns) (defun org-x-dag-ns-wkp (adjlist links ns)
(-let (((&alist :quarterly ht-q) ns)) (-let (((&alist :quarterly ht-q) ns))
(org-x-dag-each-links links (org-x-dag-ns-with-valid ns adjlist :weekly links
(org-x-dag-ns-with-valid ns adjlist :weekly it it-targets '((:quarterly))
'(:quarterly)
(lambda (id this-h res) (lambda (id this-h res)
(-let (((&alist :quarterly q) res)) (-let (((&alist :quarterly q) res))
(ht-set this-h id (org-x-dag-bs :valid `(:committed ,q))) (ht-set this-h id (org-x-dag-bs :valid `(:committed ,q)))
(org-x-dag-ht-add-links id ht-q :planned q))))) (org-x-dag-ht-add-links id ht-q :planned q))))
ns)) ns))
(defun org-x-dag-ns-action (adjlist links ns) (defun org-x-dag-ns-action (adjlist links ns)
(-let (((&alist :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-ns-with-valid ns adjlist :action links
(org-x-dag-ns-with-valid ns adjlist :action it it-targets '((:survival) (:endpoint) (:lifetime))
'(:survival :endpoint :lifetime)
(lambda (id this-h res) (lambda (id this-h res)
(-let (((&alist :survival s :endpoint e :lifetime l) res)) (-let (((&alist :survival s :endpoint e :lifetime l) res))
(->> (org-x-dag-bs :valid `(:committed (,@e ,@l ,@s))) (->> (org-x-dag-bs :valid `(:committed (,@e ,@l ,@s)))
(ht-set this-h it)) (ht-set this-h id))
(->> (--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))
(org-x-dag-ht-add-links id ht-e :fulfilled e) (org-x-dag-ht-add-links id ht-e :fulfilled e)
(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))))
ns)) ns))
(defun org-x-dag-ns-dlp (adjlist links ns) (defun org-x-dag-ns-dlp (adjlist links ns)
@ -2184,11 +2184,8 @@ used for optimization."
(htbl ids) (htbl ids)
(--mapcat (org-x-dag-ht-get-maybe htbl it :committed) ids))) (--mapcat (org-x-dag-ht-get-maybe htbl it :committed) ids)))
(-let (((&alist :action ht-a :quarterly ht-q :weekly ht-w) ns)) (-let (((&alist :action ht-a :quarterly ht-q :weekly ht-w) ns))
(org-x-dag-each-links links (org-x-dag-ns-with-valid ns adjlist :daily links
(org-x-dag-ns-with-valid ns adjlist :daily it it-targets '((:action t) (:weekly))
'(:action :weekly)
;; TODO this won't allow links to project actions since those aren't
;; leaves
(lambda (id this-h res) (lambda (id this-h res)
(-let (((&alist :action a :weekly w) res)) (-let (((&alist :action a :weekly w) res))
(let ((qgoals (->> (get-committed ht-w w) (let ((qgoals (->> (get-committed ht-w w)
@ -2206,7 +2203,7 @@ used for optimization."
(org-x-dag-ht-add-links id ht-w :planned w) (org-x-dag-ht-add-links id ht-w :planned w)
(org-x-dag-ht-add-links id ht-a :planned a)) (org-x-dag-ht-add-links id ht-a :planned a))
(->> (org-x-dag-bs :error "Non overlapping goals") (->> (org-x-dag-bs :error "Non overlapping goals")
(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-endpoint (adjlist ns)