ENH optimize org-x-headline-has-children

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

@@ -98,8 +98,7 @@ entire subtrees to save time and ignore tasks")
 (defun org-x-get-date-property (timestamp-property)
   "Get TIMESTAMP-PROPERTY on current heading and convert to a number.
 If it does not have a date, it will return nil."
-  (let ((ts (org-entry-get nil timestamp-property)))
+  (-some-> (org-entry-get nil timestamp-property) (org-2ft)))
-        (when ts (org-2ft ts))))
 
 ;; TODO I don't like this function...it perplexes me
 (defun org-x-heading-compare-timestamp (timestamp-fun &optional ref-time future)
@@ -270,19 +269,38 @@ compared to REF-TIME. Returns nil if no timestamp is found."
 
 ;; relational testing
 
-(defun org-x-headline-has-children (heading-test)
+;; ;; TODO this function seems slow
-  "Return t if heading has a child for whom HEADING-TEST is t."
+;; (defun org-x-headline-has-children (heading-test)
-  (let ((subtree-end (save-excursion (org-end-of-subtree t)))
+;;   "Return t if heading has a child for whom HEADING-TEST is t."
-        has-children previous-point)
+;;   (let ((subtree-end (save-excursion (org-end-of-subtree t)))
+;;         has-children previous-point)
+;;     (save-excursion
+;;       (setq previous-point (point))
+;;       (outline-next-heading)
+;;       (while (and (not has-children)
+;;                   (< previous-point (point) subtree-end))
+;;         (when (funcall heading-test)
+;;           (setq has-children t))
+;;         (setq previous-point (point))
+;;         (org-forward-heading-same-level 1 t)))
+;;     has-children))
+
+(defun org-x-headline-has-children (test-fun)
+  "Return t if heading has a child for whom TEST-FUN is t."
+  ;; assume that point is at the beginning of a headline
+  (let* ((level (1+ (org-current-level)))
+         (has-children nil)
+         (cur-level level))
+    ;; skip over the current headline
+    (re-search-forward org-outline-regexp-bol nil t)
     (save-excursion
-      (setq previous-point (point))
+      (while (and (<= level cur-level)
-      (outline-next-heading)
+                  (re-search-forward org-outline-regexp-bol nil t))
-      (while (and (not has-children)
+        ;; it's actually more efficient to scan every headline and check its
-                  (< previous-point (point) subtree-end))
+        ;; level rather than using a regexp to match the target depth
-        (when (funcall heading-test)
+        (setq cur-level (- (match-end 0) (match-beginning 0) 1))
-          (setq has-children t))
+        (when (and (= cur-level level) (funcall test-fun))
-        (setq previous-point (point))
+          (setq has-children t))))
-        (org-forward-heading-same-level 1 t)))
     has-children))
 
 (defun org-x-headline-has-parent (heading-test)
@@ -317,9 +335,7 @@ compared to REF-TIME. Returns nil if no timestamp is found."
   `(,op (cl-position ,sc1 ,sc-list) (cl-position ,sc2 ,sc-list)))
 
 ;; TODO there is likely a better way to handle this
-(defun org-x-descend-into-project (allowed-statuscodes trans-tbl
+(defmacro org-x-descend-into-project (statuscode-tree get-task-status callback-fun)
-                                                       get-task-status
-                                                       callback-fun)
   "Loop through (sub)project and return overall statuscode.
 
 The returned statuscode is chosen from list ALLOWED-STATUSCODES where
@@ -341,50 +357,50 @@ should be this function again)."
   ;; define "breaker-status" as the last of the allowed-statuscodes
   ;; when this is encountered the loop is broken because we are done
   ;; (the last entry trumps all others)
-  (let ((project-status (cl-first allowed-statuscodes))
+  (let* ((allowed-statuscodes (-map #'car statuscode-tree))
+         (trans-tbl (->> statuscode-tree
+                      (--map (-let (((a . bs) it)) (--map (cons it a) bs)))
+                      (-flatten-n 1)))
          (breaker-status (-last-item allowed-statuscodes))
-        (previous-point))
+         (initial-status (car allowed-statuscodes)))
+    `(let ((project-status ,initial-status)
+           (previous-point nil)
+           (new-status nil)
+           (it-kw nil))
        (save-excursion
          (setq previous-point (point))
          (outline-next-heading)
          ;; loop through subproject tasks until breaker-status found
-      (while (and (not (eq project-status breaker-status))
+         (while (and (not (eq project-status ,breaker-status))
                      (> (point) previous-point))
-        (let ((keyword (org-x-is-todoitem-p)))
+           (setq it-kw (org-get-todo-state))
-          (if keyword
+           (when it-kw
-              (let ((new-status
+             (if (org-x-headline-has-children #'org-x-is-todoitem-p)
-                     ;; if project then descend recursively
+                 (progn
-                     (if (org-x-headline-has-children 'org-x-is-todoitem-p)
+                   ;; If project returns an allowed status then use that.
-                         (let ((n (funcall callback-fun)))
+                   ;; Otherwise look up the value in the translation table and
-                           ;; if project returns an allowed status
+                   ;; return error if not found.
-                           ;; then use that
+                   (setq new-status (,callback-fun))
-                           (or (and (member n allowed-statuscodes) n)
+                   (unless (member new-status ',allowed-statuscodes)
-                               ;; otherwise look up the value in the
+                     (setq new-status (alist-get new-status ',trans-tbl))))
-                               ;; translation table and return error
-                               ;; if not found
-                               (nth (or (alist-get n trans-tbl)
-                                        (error (concat "status not found: " n)))
-                                    allowed-statuscodes)))
                ;; if tasks then use get-task-status to obtain status
-                       (nth (funcall get-task-status keyword)
+               (setq new-status (nth ,get-task-status ',allowed-statuscodes)))
-                            allowed-statuscodes))))
+             (when (org-x-compare-statuscodes > new-status project-status ',allowed-statuscodes)
-                (if (org-x-compare-statuscodes > new-status project-status allowed-statuscodes)
+               (setq project-status new-status)))
-                    (setq project-status new-status)))))
            (setq previous-point (point))
            (org-forward-heading-same-level 1 t)))
-    project-status))
+       project-status)))
 
 (defun org-x-get-project-status ()
   "Return project heading statuscode (assumes it is indeed a project)."
-  (let ((keyword (org-x-is-todoitem-p)))
   ;;
   ;; these first three are easy because they only require
   ;; testing the project headline and nothing underneath
   ;;
-    (cond
   ;; it does not make sense for projects to be scheduled
-     ((org-x-is-scheduled-heading-p) :scheduled-project)
+  (if (org-x-is-scheduled-heading-p) :scheduled-project
-
+    (-when-let (keyword (org-get-todo-state))
+      (cond
        ;; held projects do not care what is underneath them
        ;; only need to test if they are inert
        ((equal keyword "HOLD") (if (org-x-is-inert-p) :inert :held))
@@ -405,41 +421,35 @@ should be this function again)."
        ;; done projects are like canceled projects but can also be incomplete
        ((equal keyword "DONE")
         (org-x-descend-into-project
-       '(:archivable :complete :done-incomplete)
+         ((:archivable)
-       '((:stuck . 2)
+          (:complete)
-         (:inert . 2)
+          (:done-incomplete :stuck :inert :held :wait :active
-         (:held . 2)
+                            :scheduled-project :invalid-todostate
-         (:wait . 2)
+                            :undone-complete))
-         (:active . 2)
+         (if (member it-kw org-done-keywords)
-         (:scheduled-project . 2)
-         (:invalid-todostate . 2)
-         (:undone-complete . 2))
-       (lambda (k)
-         (if (member k org-done-keywords)
              (if (org-x-is-archivable-heading-p) 0 1)
-           2))
+           2)
-       #'org-x-get-project-status))
+         org-x-get-project-status))
        
        ;; project with TODO states could be basically any status
        ((equal keyword "TODO")
         (org-x-descend-into-project
-       '(:undone-complete :stuck :held :wait :inert :active)
+         ((:undone-complete :complete :archivable)
-       '((:complete . 0)
+          (:stuck :scheduled-project :invalid-todostate :done-incomplete)
-         (:archivable . 0)
+          (:held)
-         (:scheduled-project . 1)
+          (:wait)
-         (:invalid-todostate . 1)
+          (:inert)
-         (:done-incomplete . 1))
+          (:active))
-       (lambda (k)
+         (cond
-         (cond ((and (not (member k org-done-keywords))
+          ((and (not (member it-kw org-done-keywords)) (org-x-is-inert-p)) 4)
-                     (org-x-is-inert-p)) 4)
+          ((equal it-kw "TODO") (if (org-x-is-scheduled-heading-p) 5 1))
-               ((equal k "TODO") (if (org-x-is-scheduled-heading-p) 5 1))
+          ((equal it-kw "HOLD") 2)
-               ((equal k "HOLD") 2)
+          ((equal it-kw "WAIT") 3)
-               ((equal k "WAIT") 3)
+          ((equal it-kw "NEXT") 5)
-               ((equal k "NEXT") 5)
+          (t 0))
-               (t 0)))
+         org-x-get-project-status))
-       #'org-x-get-project-status))
        
-     (t (error (concat "invalid keyword detected: " keyword))))))
+       (t (error (concat "invalid keyword detected: " keyword)))))))
 
 ;; skip functions