ENH make daily node network status more nuanced

local/lib/either/either.el

@@ -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))

local/lib/org-x/org-x-dag.el

@@ -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
+       (id-is-valid
-        (h permitleafp adjlist id)
+        (h valid-fun acc id)
         (cond
          ((either-is-left-p (ht-get h id))
-          :error)
+          (either :left "Linked to invalid links"))
-         ((and (not permitleafp) (org-x-dag-get-children adjlist id))
+         (valid-fun
-          :non-leaf)
+          ;; NOTE this valid-fun doesn't just have to return a Right ID upon
-         (t :valid)))
+          ;; 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)
+        (-let* (((key valid-fun) keypair)
-                ((acc-keyed acc-error acc-non-leaf) acc)
                 (h (alist-get key ns))
-                ((&alist :valid v :error e :non-leaf n)
+                (new (->> (alist-get key grouped-targets)
-                 (->> (alist-get key grouped-targets)
+                          (either-foldM* (id-is-valid h valid-fun acc it) nil))))
-                      (--group-by (parent-group h permitleafp adjlist it)))))
+          (either<$> new `((,key ,@it) ,@acc)))))
-          `(((,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)
+          (let ((x (either-foldM* (reduce-valid grouped acc it) nil keypairs)))
-                  (--reduce-from (reduce-valid grouped acc it) nil keypairs)))
+            (either-from x
-            (cond
+              (lambda (_)
-             (err
+                (ht-set cur-h it x))
-              (->> (org-x-dag-bs-error-links "Linked to invalid links" err)
+              (lambda (valid-ids)
-                   (ht-set cur-h it)))
+                (funcall valid-fun it cur-h valid-ids)))))))))
-             (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)))))))))
 
 ;; 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
+      ((add-planned
-        (htbl ids)
+        (id htbl res)
-        (--mapcat (org-x-dag-ht-get-maybe htbl it :committed) ids)))
+        (->> (--mapcat (nth 1) res)
-    (-let (((&alist :action ht-a :quarterly ht-q :weekly ht-w) ns))
+             (-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 (((&alist :action a) res))
-            (let ((qgoals (->> (get-committed ht-w w)
+            (org-x-dag-ht-add-links id ht-a :planned (-map #'car a))
-                               (get-committed ht-q)))
+            (-let (((&alist :weekly w :quarterly q :survival s)
-                  (agoals (get-committed ht-a a)))
+                    (--group-by (nth 1 it) a)))
-              ;; TODO this check doesn't matter for survival goals since
+              (add-planned id ht-w w)
-              ;; those won't be on the quarterly plan
+              (add-planned id ht-q q)
-              ;; (-if-let (gs (-intersection qgoals agoals))
+              (add-planned id ht-s s))))))))
-                  (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)))))
 
 (defun org-x-dag-ht-map-down (adjlist h-key ns get-fun set-fun def-fun)
   (declare (indent 3))
@@ -1406,63 +1497,81 @@ used for optimization."
         (propagate h it )))
     ns))
 
-(defun org-x-dag-get-network-status (adjlist links)
+(defun org-x-dag-adjlist-ids-filter-tags (adjlist tag-getter date ids)
-  (-let ((ns (->> (list :action
+  (--filter (equal date (funcall tag-getter (org-x-dag-adjlist-id-tags it))) ids))
-                        :endpoint
-                        :lifetime
-                        :survival
-                        :quarterly
-                        :weekly
-                        :daily)
-                  (--map (cons it (ht-create #'equal)))))
-         ((&plist :action a
-                  :endpoint e
-                  :lifetime l
-                  :survival s
-                  :quarterly q
-                  :weekly w
-                  :daily d)
-          (--reduce-from (-let* (((group . links) it)
-                                 (acc-links (plist-get acc group)))
-                           (plist-put acc group (append acc-links links)))
-                         nil
-                         links)))
-    ;; 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)
 
-    (org-x-dag-ns-epg adjlist e ns)
+(defun org-x-dag-get-network-status (sel-date adjlist links)
-    (org-x-dag-ht-propagate-down adjlist :endpoint :committed ns)
+  (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
+                           :quarterly
+                           :weekly
+                           :daily)
+                     (--map (cons it (ht-create #'equal)))))
+            ((&plist :action a
+                     :endpoint e
+                     :lifetime l
+                     :survival s
+                     :quarterly q
+                     :weekly w
+                     :daily d)
+             (--reduce-from (-let* (((group . links) it)
+                                    (acc-links (plist-get acc group)))
+                              (plist-put acc group (append acc-links links)))
+                            nil
+                            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)
 
-    (org-x-dag-ns-qtp adjlist q ns)
+      (org-x-dag-ns-epg adjlist e ns)
-    (org-x-dag-ht-propagate-up adjlist :lifetime :planned ns)
+      (org-x-dag-ht-propagate-down adjlist :endpoint :committed ns)
-    (org-x-dag-ht-propagate-up adjlist :survival :planned ns)
 
-    (org-x-dag-ns-wkp adjlist w 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-action adjlist a ns)
+      (org-x-dag-ns-wkp adjlist cur-w 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-ns-action adjlist a ns)
-    (org-x-dag-ht-propagate-down adjlist :action :planned ns)
+      (org-x-dag-ht-propagate-up adjlist :lifetime :fulfilled ns)
-    (org-x-dag-ht-map-down adjlist :action ns
+      (org-x-dag-ht-propagate-up adjlist :survival :fulfilled ns)
-      (lambda (h id)
+      (org-x-dag-ht-map-down adjlist :action ns
-        (either-from* (ht-get h id)
+        (lambda (h id)
-          nil
+          (either-from* (ht-get h id)
-          (-when-let (committed (plist-get it :committed))
+            nil
-            `(,committed ,(plist-get it :survivalp)))))
+            (-when-let (committed (plist-get it :committed))
-      (lambda (plist to-set)
+              `(,committed ,(plist-get it :survivalp)))))
-        (-let (((committed survivalp) to-set))
+        (lambda (plist to-set)
-          ;; copy is needed here for some reason, otherwise other parts of the
+          (-let (((committed survivalp) to-set))
-          ;; hash table are affected
+            ;; copy is needed here for some reason, otherwise other parts of the
-          (-> (-copy plist)
+            ;; hash table are affected
-              (plist-put :survivalp survivalp)
+            (-> (-copy plist)
-              (org-x-dag-plist-map :committed
+                (plist-put :survivalp survivalp)
-                  (lambda (x) (append x committed))))))
+                (org-x-dag-plist-map :committed
-      (lambda (to-set)
+                    (lambda (x) (append x committed))))))
-        (-let (((committed survivalp) to-set))
+        (lambda (to-set)
-          `(:committed ,committed :survivalp ,survivalp))))))
+          (-let (((committed survivalp) to-set))
+            `(: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)