ENH abuse new TCO optimization (and make algorithms less silly)

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

@@ -581,34 +581,45 @@ used for optimization."
 
 ;; buffer status
 
+(defun org-x-dag-bs-check-children (bss msg nochild-def child-def fun)
+  (declare (indent 4))
+  ;; this is almost like fold or foldM but I want to stop if `fun' returns nil
+  (cl-labels
+      ;; hopefully the TCO native comp actually works :)
+      ((fold-while
+        (xs)
+        (cond
+         ((not xs) (either :right child-def))
+         ((either-is-left-p (car xs)) (either :left "Child error"))
+         (t (if (funcall fun (car xs))
+                (fold-while (cdr xs))
+              (either :left msg))))))
+    (if (not bss) (either :right nochild-def)
+      (fold-while bss))))
+
 ;; [Status a] -> b -> (a -> a -> Status Bool) -> (a -> Bool) -> (a -> Status b)
 ;; -> Status b
-(defmacro org-x-dag-bs-fold-children (bss default rank-form stop-form trans-form)
+(defun org-x-dag-bs-rankfold-children (bss default rank-fun stop-fun trans-fun)
   (declare (indent 2))
   (let ((err (either :left "Child error")))
-    `(if ,bss
+    (cl-labels
-         (-let (((x . xs) ,bss))
+        ((fold-rank
-           (if (either-is-left-p x) ',err
+          (acc xs)
-             (let ((acc (cadr x)) r final it)
+          (if (not xs) (either :right acc)
-               (while (and (not final) xs)
+            (-let (((x . rest) xs))
-                 (setq x (car xs))
+              (pcase x
-                 (if (either-is-left-p x)
+                (`(:right ,r)
-                     (setq final ',err)
+                 (either>>= (funcall rank-fun acc r)
-                   (setq it (cadr x)
+                   (if (not it) (fold-rank acc rest)
-                         r ,rank-form)
+                     (if (funcall stop-fun r) x (fold-rank r rest)))))
-                   (unless r
+                (_ err))))))
-                     (error "You forgot the difference between Maybe and Either"))
+      (if (not bss) (either :right default)
-                   (if (either-is-left-p r)
+        (pcase (car bss)
-                       (setq final r)
+          (`(:right ,r)
-                     (when (cadr r)
+           (if (funcall stop-fun r) (funcall trans-fun r)
-                       (setq acc (cadr x)))
+             (either>>= (fold-rank r (cdr bss))
-                     (if ,stop-form
+               (funcall trans-fun it))))
-                         (setq final (either :right acc))
+          (_ err))))))
-                       (!cdr xs)))))
-               (when (not final)
-                 (setq final (either :right acc)))
-               (either>>= final ,trans-form))))
-       (either :right ,default))))
 
 (defmacro org-x-dag-left (fmt &rest args)
   `(either :left (format ,fmt ,@args)))
@@ -665,6 +676,9 @@ used for optimization."
     (let ((canc-bs-form* (wrap-ancestry canc-bs-form))
           (done-form* (lift-form done-form))
           (open-form* (lift-form open-form)))
+      ;; TODO this seems excessive, I'm unwrapping some outer type for the
+      ;; sake of some inner type, but if any of these are left then
+      ;; they should short circuit the fold/check functions embedded in here
       `(org-x-dag-bs-check-created ,node-data
          (-let ((it-children (--map (either>>= it
                                       (->> (plist-get it :local)
@@ -692,32 +706,16 @@ used for optimization."
         `(:sp-task :task-complete ,it-comptime))
 
       ;; done form
-      (org-x-dag-bs-fold-children it-children `(:sp-task :task-complete ,it-comptime)
+      (org-x-dag-bs-check-children it-children
-        ;; TODO this could be slightly more efficient if the error type is
+          "Completed projects cannot have active children"
-        ;; returned in this form and not the last
+          `(:sp-task :task-complete ,it-comptime)
-        (->> (pcase `(,acc ,it)
+          `(:sp-proj :proj-complete ,it-comptime)
-               (`((:sp-proj :proj-complete ,_) (:sp-proj :proj-complete ,_)) nil)
+        (lambda (child-bs)
-               (`((:sp-iter :iter-complete ,_) (:sp-iter :iter-complete ,_)) nil)
+          (pcase child-bs
-               (`((:sp-task :task-complete ,_) (:sp-task :task-complete ,_)) nil)
-               (`((:sp-proj :proj-complete ,_) ,_) t)
-               (`((:sp-iter :iter-complete ,_) ,_) t)
-               (`((:sp-task :task-complete ,_) ,_) t)
-               (`(,_ (:sp-proj :proj-complete ,_)) nil)
-               (`(,_ (:sp-iter :iter-complete ,_)) nil)
-               (`(,_ (:sp-task :task-complete ,_)) nil)
-               (e (error "Unmatched pattern: %S" e)))
-             (either :right))
-        (pcase acc
             (`(:sp-proj :proj-complete ,_) nil)
             (`(:sp-iter :iter-complete ,_) nil)
             (`(:sp-task :task-complete ,_) nil)
-          (_ t))
+            (_ t))))
-        (pcase it
-          ((or `(:sp-proj :proj-complete ,_)
-               `(:sp-iter :iter-complete ,_)
-               `(:sp-task :task-complete ,_))
-           (either :right `(:sp-proj :proj-complete ,it-comptime)))
-          (_ (either :left "Completed projects cannot have active children"))))
 
       ;; undone form
       (-let* (((sched dead) (-some->> it-planning
@@ -732,8 +730,9 @@ used for optimization."
          ((and child-bss sched)
           (either :left "Projects cannot be scheduled"))
          ((equal it-todo org-x-kw-todo)
-          (org-x-dag-bs-fold-children it-children task-default
+          (org-x-dag-bs-rankfold-children it-children task-default
-            (->> (pcase `(,acc ,it)
+            (lambda (acc next)
+              (->> (pcase `(,acc ,next)
                      (`((:sp-task :task-active ,a) (:sp-task :task-active ,b))
                       (and (not (is-next a)) (is-next b)))
 
@@ -773,37 +772,42 @@ used for optimization."
                      (`(,_ (:sp-iter :iter-empty)) t)
                      (`(,_ (:sp-task :task-active ,_)) t)
 
-                   ;; any pair that makes it this far is completed in both, which means
+                     ;; any pair that makes it this far is completed in both,
-                   ;; neither takes precedence, which means choose the left one
+                     ;; which means neither takes precedence, which means choose
+                     ;; the left one
                      (`(,_ ,_) nil))
-                 (either :right))
+                   (either :right)))
 
             ;; early stop
-            (pcase acc
+            (lambda (next)
+              (pcase next
                 (`(:sp-proj :proj-active) t)
                 (`(:sp-iter :iter-active ,_) t)
                 (`(:sp-task :task-active ,d) (is-next d))
-              (_ nil))
+                (_ nil)))
 
             ;; child -> parent translation
-            (pcase it
+            (lambda (acc)
+              (pcase acc
                 ((or `(:sp-proj :proj-complete ,_)
                      `(:sp-task :task-complete ,_)
                      `(:sp-iter :iter-complete ,_))
-               (either :left "Active projects must have at least one active child"))
+                 (->> "Active projects must have at least one active child"
+                      (either :left )))
                 (`(:sp-proj ,s) (new-proj s))
                 (`(:sp-iter :iter-active ,_) (new-proj :proj-active))
                 (`(:sp-iter :iter-empty) (new-proj :proj-stuck))
                 (`(:sp-task :task-active ,d)
                  (-let (((&plist :todo o :sched s) d))
                    (cond
-                  ((equal o org-x-kw-todo) (->> (if s :proj-active :proj-stuck)
+                    ((equal o org-x-kw-todo) (->> (if s :proj-active
+                                                    :proj-stuck)
                                                   (new-proj)))
                     ((equal o org-x-kw-next) (new-proj :proj-active))
                     ((equal o org-x-kw-wait) (new-proj :proj-wait))
                     ((equal o org-x-kw-hold) (new-proj :proj-hold))
                     (t (org-x-dag-bs-error-kw "Task action" o)))))
-              (e (error "Pattern fail: %s" e)))))
+                (e (error "Pattern fail: %s" e))))))
          (child-bss
           (org-x-dag-bs-error-kw "Project action" it-todo))
          (t
@@ -820,28 +824,21 @@ used for optimization."
 (defun org-x-dag-bs-action-subiter-complete-fold (child-bss comptime type-name
                                                             comp-key)
   (declare (indent 2))
-  (org-x-dag-bs-fold-children child-bss `(,comp-key ,comptime)
+  (org-x-dag-bs-check-children child-bss
-    (->> (pcase `(,acc ,it)
+      (format "Completed %s cannot have active children" type-name)
-           (`((:si-complete ,_) (:si-complete ,_)) nil)
+      `(,comp-key ,comptime)
-           (`((:si-complete ,_) ,_) t)
+      `(,comp-key ,comptime)
-           (`(,_ (:si-complete ,_)) nil)
+    (lambda (child-bs)
-           (e (error "Unmatched pattern: %S" e)))
+      (pcase child-bs
-         (either :right))
-    (pcase acc
         (`(:si-complete ,_) nil)
-      (_ t))
+        (_ t)))))
-    (pcase it
-      (`(:si-complete ,_)
-       (either :right `(,comp-key ,comptime)))
-      (_
-       (->> (format "Completed %s cannot have active children" type-name)
-            (either :left))))))
 
 (defun org-x-dag-bs-action-subiter-todo-fold (child-bss type-name active-key
                                                         default)
   (declare (indent 1))
-  (org-x-dag-bs-fold-children child-bss default
+  (org-x-dag-bs-rankfold-children child-bss default
-    (pcase `(,acc ,it)
+    (lambda (acc next)
+      (pcase `(,acc ,next)
         (`((:si-active ,a) (:si-active ,b))
          (-let (((&plist :sched as :dead ad) a)
                 ((&plist :sched bs :dead bd) b))
@@ -867,16 +864,18 @@ used for optimization."
                   (either :right))))))
         (`((:si-active ,_) ,_) (either :right nil))
         (`(,_ (:si-active ,_)) (either :right t))
-      (`(,_ ,_) (either :right nil)))
+        (`(,_ ,_) (either :right nil))))
-    (pcase acc
+    (lambda (next)
+      (pcase next
         (`(:si-active ,_) t)
-      (_ nil))
+        (_ nil)))
-    (pcase it
+    (lambda (acc)
+      (pcase acc
         (`(:si-complete ,_)
-       (->> (format "Active %s must have at least one active child" type-name)
+         (->> type-name
-            (either :left)))
+              (org-x-dag-left "Active %s must have at least one active child")))
         (`(:si-active ,ts-data)
-       (either :right `(,active-key ,ts-data))))))
+         (either :right `(,active-key ,ts-data)))))))
 
 (defun org-x-dag-node-is-iterator-p (node)
   (org-x-dag-node-data-is-iterator-p (plist-get node :node-meta)))
@@ -923,35 +922,26 @@ used for optimization."
 (defun org-x-dag-bs-epg-inner (node ancestry child-bss)
   (org-x-dag-bs-action-with-closed node ancestry child-bss "endpoint goal"
     `(:complete ,it-comptime)
-    (org-x-dag-bs-fold-children it-children `(:complete ,it-comptime)
+    (org-x-dag-bs-check-children it-children
-      (->> (pcase `(,acc ,it)
+        "Completed EPGs cannot have active children"
-             (`((:complete ,_) (:complete ,_)) nil)
+        `(:complete ,it-comptime)
-             (`(,_ (:complete ,_)) nil)
+        `(:complete ,it-comptime)
-             (`((:complete ,_) ,_) t))
+      (lambda (child-bs)
-           (either :right))
+        (pcase child-bs
-      (pcase acc
           (`(:complete ,_) nil)
-        (_ t))
+          (_ t))))
-      (pcase it
-        (`(:complete ,_)
-         (either :right `(:complete ,it-comptime)))
-        (_ (either :left "Completed EPGs cannot have active children"))))
     (cond
      ((-some->> it-planning (org-ml-get-property :scheduled))
       (either :left "EPGs cannot be scheduled"))
      ((equal it-todo org-x-kw-todo)
-      (org-x-dag-bs-fold-children it-children `(:active)
+      (org-x-dag-bs-check-children it-children
-        (->> (pcase `(,acc ,it)
+          "Active EPGs must have at least one active child"
-               (`((:active) (:active)) nil)
+          '(:active)
-               (`(,_ (:active)) t)
+          '(:active)
-               (`((:active) ,_) nil))
+        (lambda (child-bs)
-             (either :right))
+          (pcase child-bs
-        nil
+            ('(:active) t)
-        (pcase it
+            (_ nil)))))
-          ('(:active)
-           (either :right '(:active)))
-          (_
-           (either :left "Active EPGs must have at least one active child")))))
      (t
       (org-x-dag-bs-error-kw "Endpoint goal" it-todo)))))