From fdde5fefc8045a4f3dbe85d64fc92b7463c33d3d Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 10 Apr 2021 23:45:59 -0400 Subject: [PATCH] ENH move iterator/periodical functions to org-x --- etc/conf.org | 130 +--------------------------- local/lib/org-x/org-x.el | 178 ++++++++++++++++++++++++++++++++------- 2 files changed, 149 insertions(+), 159 deletions(-) diff --git a/etc/conf.org b/etc/conf.org index f7f56da..346ec06 100644 --- a/etc/conf.org +++ b/etc/conf.org @@ -3013,132 +3013,6 @@ These are functions and variables exclusively for agenda block manipulation with (defconst org-clone-peri-statuscodes '(:uninit :empt :actv :unscheduled)) #+END_SRC -***** task helper functions -These are the building blocks for skip functions. -****** repeater testing -:PROPERTIES: -:ID: 44657755-b47e-4b2a-85c4-5f82d830618a -:END: -Iterators and periodicals are tested similarly to projects in that they have statuscodes. -#+BEGIN_SRC emacs-lisp -(defun org-clone-get-iterator-project-status (kw) - (cond - ((or (org-x-is-scheduled-heading-p) - (member kw org-x-project-invalid-todostates)) :project-error) - - ;; canceled tasks add nothing - ((equal kw "CANC") :empt) - - ;; - ;; these require descending into the project subtasks - ;; - - ;; done projects either add nothing (empty) or are not actually - ;; done (project error) - ((equal kw "DONE") - (org-x-descend-into-project - '(:empt :project-error) - '((:unscheduled . 1) - (:actv . 1)) - (lambda (k) - (if (member k org-done-keywords) 0 1)) - #'org-clone-get-iterator-project-status)) - - ;; project with TODO states could be basically any status - ((equal kw "TODO") - (org-x-descend-into-project - '(:unscheduled :empt :actv) - '(:project-error . 0) - (lambda (k) - (let ((ts (org-x-is-scheduled-heading-p))) - (cond - ((not ts) 0) - ((> org-clone-iter-future-time (- ts (float-time))) 1) - (t 2)))) - #'org-clone-get-iterator-project-status)) - - (t (error (concat "invalid keyword detected: " kw))))) - -(defun org-clone-get-iterator-status () - "Get the status of an iterator where allowed statuscodes are in list - `nd/get-iter-statuscodes.' where latter codes in the list trump -earlier ones." - (let ((cur-status (first org-clone-iter-statuscodes)) - (breaker-status (-last-item org-clone-iter-statuscodes)) - (subtree-end (save-excursion (org-end-of-subtree t))) - (prev-point (point))) - (save-excursion - (outline-next-heading) - (while (and (not (eq cur-status breaker-status)) - (< prev-point (point) subtree-end)) - (let ((kw (org-x-is-todoitem-p)) - (new-status)) - (when kw - ;; test if project of atomic task - ;; assume that there are no todoitems above this headline - ;; to make checking easier - (setq - new-status - (if (org-x-headline-has-children 'org-x-is-todoitem-p) - (org-clone-get-iterator-project-status kw) - (let ((ts (or (org-x-is-scheduled-heading-p) - (org-x-is-deadlined-heading-p)))) - (cond - ((member kw org-done-keywords) :empt) - ((not ts) :unscheduled) - ((< org-clone-iter-future-time (- ts (float-time))) :actv) - (t :empt))))) - (when (org-x-compare-statuscodes > new-status cur-status org-clone-iter-statuscodes) - (setq cur-status new-status)))) - (setq prev-point (point)) - (org-forward-heading-same-level 1 t))) - cur-status)) - -(defun org-clone-get-periodical-status () - "Get the status of a periodical where allowed statuscodes are in list - `nd/get-peri-statuscodes.' where latter codes in the list trump -earlier ones." - (letrec - ((max-ts - (lambda () - (-some--> - (org-ml-parse-this-headline) - (org-element-map it 'timestamp #'identity) - (--filter - (memq (org-element-property :type it) '(active active-range)) - it) - (--map - (--> it - (org-timestamp-split-range it t) - (org-element-property :raw-value it) - (org-2ft it)) - it) - (-max it)))) - (compare - (lambda (s1 s2) - (if (org-x-compare-statuscodes > s1 s2 org-clone-peri-statuscodes) s1 s2))) - (new-status - (lambda (ts) - (--> - ts - (cond - ((not it) :unscheduled) - ((< org-clone-peri-future-time (- it (float-time))) :actv) - (t :empt)) - (funcall compare it cur-status)))) - (cur-status (first org-clone-peri-statuscodes)) - (breaker-status (-last-item org-clone-peri-statuscodes)) - (subtree-end (save-excursion (org-end-of-subtree t))) - (prev-point (point))) - (save-excursion - (outline-next-heading) - (while (and (not (eq cur-status breaker-status)) - (< prev-point (point) subtree-end)) - (setq cur-status (->> (funcall max-ts) (funcall new-status))) - (setq prev-point (point)) - (org-forward-heading-same-level 1 t))) - cur-status)) -#+END_SRC **** super agenda :PROPERTIES: :ID: 6bd2a7c9-2104-4b18-9f56-c1581ed86d82 @@ -3398,7 +3272,7 @@ original org entry before executing BODY." (org-super-agenda-groups `((:auto-map ,(nd/org-x-mk-super-agenda-pred - (cl-case (org-clone-get-periodical-status) + (cl-case (org-x-get-periodical-status) (:uninit "0. Uninitialized") (:unscheduled "0. Unscheduled") (:empt "1. Empty") @@ -3421,7 +3295,7 @@ original org entry before executing BODY." (org-super-agenda-groups `((:auto-map ,(nd/org-x-mk-super-agenda-pred - (cl-case (org-clone-get-iterator-status) + (cl-case (org-x-get-iterator-status) (:uninit "0. Uninitialized") (:project-error "0. Project Error") (:unscheduled "0. Unscheduled") diff --git a/local/lib/org-x/org-x.el b/local/lib/org-x/org-x.el index 527867f..ac399ab 100644 --- a/local/lib/org-x/org-x.el +++ b/local/lib/org-x/org-x.el @@ -269,40 +269,40 @@ compared to REF-TIME. Returns nil if no timestamp is found." ;; relational testing -;; ;; TODO this function seems slow -;; (defun org-x-headline-has-children (heading-test) -;; "Return t if heading has a child for whom HEADING-TEST is t." -;; (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) +;; TODO this function seems slow +(defun org-x-headline-has-children (heading-test) + "Return t if heading has a child for whom HEADING-TEST is t." + (let ((subtree-end (save-excursion (org-end-of-subtree t))) + has-children previous-point) (save-excursion - (while (and (<= level cur-level) - (re-search-forward org-outline-regexp-bol nil t)) - ;; it's actually more efficient to scan every headline and check its - ;; level rather than using a regexp to match the target depth - (setq cur-level (- (match-end 0) (match-beginning 0) 1)) - (when (and (= cur-level level) (funcall test-fun)) - (setq has-children t)))) + (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 +;; (while (and (<= level cur-level) +;; (re-search-forward org-outline-regexp-bol nil t)) +;; ;; it's actually more efficient to scan every headline and check its +;; ;; level rather than using a regexp to match the target depth +;; (setq cur-level (- (match-end 0) (match-beginning 0) 1)) +;; (when (and (= cur-level level) (funcall test-fun)) +;; (setq has-children t)))) +;; has-children)) + (defun org-x-headline-has-parent (heading-test) "Return t if heading has parent for whom HEADING-TEST is t." (save-excursion (and (org-up-heading-safe) (funcall heading-test)))) @@ -451,6 +451,122 @@ should be this function again)." (t (error (concat "invalid keyword detected: " keyword))))))) +(defun org-x--clone-get-iterator-project-status (kw) + (cond + ((or (org-x-is-scheduled-heading-p) + (member kw org-x-project-invalid-todostates)) :project-error) + + ;; canceled tasks add nothing + ((equal kw "CANC") :empt) + + ;; + ;; these require descending into the project subtasks + ;; + + ;; done projects either add nothing (empty) or are not actually + ;; done (project error) + ((equal kw "DONE") + (org-x-descend-into-project + ((:empt) + (:project-error :unscheduled :actv)) + (if (member it-kw org-done-keywords) 0 1) + #'org-x--clone-get-iterator-project-status)) + + ;; project with TODO states could be basically any status + ((equal kw "TODO") + (org-x-descend-into-project + ((:unscheduled :project-error) + (:empt) + (:actv)) + (let ((ts (org-x-is-scheduled-heading-p))) + (cond + ((not ts) 0) + ((> org-clone-iter-future-time (- ts (float-time))) 1) + (t 2))) + org-x--clone-get-iterator-project-status)) + + (t (error (concat "invalid keyword detected: " kw))))) + +(defun org-x-get-iterator-status () + "Get the status of an iterator. +Allowed statuscodes are in list `nd/get-iter-statuscodes.' where + latter codes in the list trump earlier ones." + (let ((cur-status (first org-clone-iter-statuscodes)) + (breaker-status (-last-item org-clone-iter-statuscodes)) + (subtree-end (save-excursion (org-end-of-subtree t))) + (prev-point (point))) + (save-excursion + (outline-next-heading) + (while (and (not (eq cur-status breaker-status)) + (< prev-point (point) subtree-end)) + (let ((kw (org-x-is-todoitem-p)) + (new-status)) + (when kw + ;; test if project of atomic task + ;; assume that there are no todoitems above this headline + ;; to make checking easier + (setq + new-status + (if (org-x-headline-has-children 'org-x-is-todoitem-p) + (org-x--clone-get-iterator-project-status kw) + (let ((ts (or (org-x-is-scheduled-heading-p) + (org-x-is-deadlined-heading-p)))) + (cond + ((member kw org-done-keywords) :empt) + ((not ts) :unscheduled) + ((< org-clone-iter-future-time (- ts (float-time))) :actv) + (t :empt))))) + (when (org-x-compare-statuscodes > new-status cur-status org-clone-iter-statuscodes) + (setq cur-status new-status)))) + (setq prev-point (point)) + (org-forward-heading-same-level 1 t))) + cur-status)) + +(defun org-x-get-periodical-status () + "Get the status of a periodical. +Allowed statuscodes are in list `nd/get-peri-statuscodes.' where +latter codes in the list trump earlier ones." + (letrec + ((max-ts + (lambda () + (-some--> + (org-ml-parse-this-headline) + (org-element-map it 'timestamp #'identity) + (--filter + (memq (org-element-property :type it) '(active active-range)) + it) + (--map + (--> it + (org-timestamp-split-range it t) + (org-element-property :raw-value it) + (org-2ft it)) + it) + (-max it)))) + (compare + (lambda (s1 s2) + (if (org-x-compare-statuscodes > s1 s2 org-clone-peri-statuscodes) s1 s2))) + (new-status + (lambda (ts) + (--> + ts + (cond + ((not it) :unscheduled) + ((< org-clone-peri-future-time (- it (float-time))) :actv) + (t :empt)) + (funcall compare it cur-status)))) + (cur-status (first org-clone-peri-statuscodes)) + (breaker-status (-last-item org-clone-peri-statuscodes)) + (subtree-end (save-excursion (org-end-of-subtree t))) + (prev-point (point))) + (save-excursion + (outline-next-heading) + (while (and (not (eq cur-status breaker-status)) + (< prev-point (point) subtree-end)) + (setq cur-status (->> (funcall max-ts) (funcall new-status))) + (setq prev-point (point)) + (org-forward-heading-same-level 1 t))) + cur-status)) + ;; skip functions (defun org-x-skip-heading ()