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

189
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
(cur-h (alist-get cur-key ns))) (let* ((keys (-map #'car keypairs))
(-if-let (invalid (alist-get :invalid grouped)) (grouped (--group-by (key-group keys it) it-targets))
(ht-set cur-h id (org-x-dag-bs-error-links "Invalid links" invalid)) (cur-h (alist-get cur-key ns)))
(-let (((valid err non-leaf) (-if-let (invalid (alist-get :invalid grouped))
(--reduce-from (reduce-valid grouped acc it) nil keys))) (ht-set cur-h it (org-x-dag-bs-error-links "Invalid links" invalid))
(cond (-let (((valid err non-leaf)
(err (--reduce-from (reduce-valid grouped acc it) nil keypairs)))
(->> (org-x-dag-bs-error-links "Linked to invalid links" err) (cond
(ht-set cur-h id))) (err
(non-leaf (->> (org-x-dag-bs-error-links "Linked to invalid links" err)
(->> (org-x-dag-bs-error-links "Linked to non-leaf nodes" non-leaf) (ht-set cur-h it)))
(ht-set cur-h id))) (non-leaf
(t (->> (org-x-dag-bs-error-links "Linked to non-leaf nodes" non-leaf)
(funcall valid-fun id cur-h valid)))))))) (ht-set cur-h it)))
(t
(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))) (org-x-dag-ht-add-links id ht-l :fulfilled l))))
;; this function doesn't treat the value of the nstat hash table
;; 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 id))
(ht-set this-h it)) (->> (--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,29 +2184,26 @@ 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) (lambda (id this-h res)
;; TODO this won't allow links to project actions since those aren't (-let (((&alist :action a :weekly w) res))
;; leaves (let ((qgoals (->> (get-committed ht-w w)
(lambda (id this-h res) (get-commited ht-q)))
(-let (((&alist :action a :weekly w) res)) (agoals (get-committed ht-a a)))
(let ((qgoals (->> (get-committed ht-w w) (-if-let (gs (-intesection qgoals agoals))
(get-commited ht-q))) (progn
(agoals (get-committed ht-a a))) (->> (list :scheduled w
(-if-let (gs (-intesection qgoals agoals)) :committed (-uniq gs)
(progn :active a)
(->> (list :scheduled w (org-x-dag-bs :valid)
:committed (-uniq gs) (ht-set this-h id))
:active a) ;; TODO add the goals to their goal links? (this might be
(org-x-dag-bs :valid) ;; useful later when displaying)
(ht-set this-h id)) (org-x-dag-ht-add-links id ht-w :planned w)
;; TODO add the goals to their goal links? (this might be (org-x-dag-ht-add-links id ht-a :planned a))
;; useful later when displaying) (->> (org-x-dag-bs :error "Non overlapping goals")
(org-x-dag-ht-add-links id ht-w :planned w) (ht-set ht-d id)))))))
(org-x-dag-ht-add-links id ht-a :planned a))
(->> (org-x-dag-bs :error "Non overlapping goals")
(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)