ndwarshuis
/
emacs-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

generalized relation functions

This commit is contained in:
petrucci4prez 2018-05-04 22:13:10 -04:00
parent 17476fc0c1
commit a2925e5549
2 changed files with 72 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
conf.el
View File

@ -403,37 +403,44 @@ If it does not have a date, it will return nil."
keyword))) keyword)))
(defun nd/is-project-p () (defun nd/is-project-p ()
(and (nd/heading-has-children) (nd/is-todoitem-p))) (and (nd/heading-has-children 'nd/is-todoitem-p) (nd/is-todoitem-p)))
(defun nd/is-task-p () (defun nd/is-task-p ()
(and (not (nd/heading-has-children)) (nd/is-todoitem-p))) (and (not (nd/heading-has-children 'nd/is-todoitem-p)) (nd/is-todoitem-p)))
(defun nd/is-atomic-task-p () (defun nd/is-atomic-task-p ()
(and (not (nd/heading-has-parent)) (nd/is-task-p))) (and (not (nd/heading-has-parent 'nd/is-todoitem-p)) (nd/is-task-p)))
(defun nd/is-series-heading-p () (defun nd/is-periodical-heading-p ()
"return t if headline has property Project_Type=series" (equal "periodical" (org-entry-get nil "PARENT_TYPE" t)))
(equal "series" (org-entry-get nil "Project_Type" t)))
(defun nd/heading-has-children () (defun nd/is-iterator-heading-p ()
"returns t if heading has todoitems in its immediate subtree" (equal "iterator" (org-entry-get nil "PARENT_TYPE" t)))
(defun nd/heading-has-children (heading-test)
"returns t if heading has subheadings that return t when assessed with
heading-test function"
;; TODO make this more efficient (and accurate) by only testing ;; TODO make this more efficient (and accurate) by only testing
;; the level immediately below (if it exists) ;; the level immediately below (if it exists)
(let ((has-children) (let ((has-children)
(subtree-end (save-excursion (org-end-of-subtree t)))) (subtree-end (save-excursion (org-end-of-subtree t)))
(previous-point))
(save-excursion (save-excursion
(setq previous-point (point))
(outline-next-heading) (outline-next-heading)
(while (and (not has-children) (while (and (not has-children)
(< (point) subtree-end)) (< previous-point (point) subtree-end))
(when (nd/is-todoitem-p) (when (funcall heading-test)
(setq has-children t)) (setq has-children t))
;; (org-forward-heading-same-level 1 t))) (setq previous-point (point))
(outline-next-heading))) (org-forward-heading-same-level 1 t)))
;; (outline-next-heading)))
has-children)) has-children))
(defun nd/heading-has-parent () (defun nd/heading-has-parent (heading-test)
"returns parent keyword if heading is in the immediate subtree of a todoitem" "returns parent keyword if heading is in the immediate subtree of a heading
(save-excursion (and (org-up-heading-safe) (nd/is-todoitem-p)))) that evaluated to t with heading-test function"
(save-excursion (and (org-up-heading-safe) (funcall heading-test))))
(defun nd/has-discontinuous-parent () (defun nd/has-discontinuous-parent ()
"returns t if heading has a parent which is not a "returns t if heading has a parent which is not a
@ -500,7 +507,7 @@ down the list override higher items")
(let ((keyword (nd/is-todoitem-p))) (let ((keyword (nd/is-todoitem-p)))
(if keyword (if keyword
(let ((cur-state (let ((cur-state
(if (nd/heading-has-children) (if (nd/heading-has-children 'nd/is-todoitem-p)
(cond ((member keyword nd/project-invalid-todostates) :invalid-todostate) (cond ((member keyword nd/project-invalid-todostates) :invalid-todostate)
((nd/is-scheduled-heading-p) :scheduled-project) ((nd/is-scheduled-heading-p) :scheduled-project)
((equal keyword "CANC") (if (nd/is-archivable-heading-p) ((equal keyword "CANC") (if (nd/is-archivable-heading-p)
@ -598,7 +605,7 @@ Note that this assumes the headline being tested is a valid project"
(error "unknown statuscode"))))) (error "unknown statuscode")))))
;; helper functions ;; helper functions
(defun nd/skip-item () (defun nd/skip-heading ()
(save-excursion (or (outline-next-heading) (point-max)))) (save-excursion (or (outline-next-heading) (point-max))))
(defun nd/skip-subtree () (defun nd/skip-subtree ()
@ -622,7 +629,7 @@ test-fun return true"
(let ((keyword (,heading-fun))) (let ((keyword (,heading-fun)))
(message keyword) (message keyword)
(if (not (and keyword ,test-fun)) (if (not (and keyword ,test-fun))
(nd/skip-item))))) (nd/skip-heading)))))
;; stale headings ;; stale headings
;; For archiving headings with old timestamps ;; For archiving headings with old timestamps
@ -640,9 +647,9 @@ test-fun return true"
(if (not (if (not
(and (nd/is-stale-heading-p) (and (nd/is-stale-heading-p)
(not (member keyword org-done-keywords)) (not (member keyword org-done-keywords))
(not (nd/heading-has-children)) (not (nd/heading-has-children 'nd/is-todoitem-p))
(not (nd/heading-has-parent)))) (not (nd/heading-has-parent 'nd/is-todoitem-p))))
(nd/skip-item))))) (nd/skip-heading)))))
;; atomic tasks ;; atomic tasks
;; by definition these have no parents, so ;; by definition these have no parents, so
@ -683,19 +690,19 @@ test-fun return true"
(widen) (widen)
(let ((keyword (nd/is-todoitem-p))) (let ((keyword (nd/is-todoitem-p)))
(if keyword (if keyword
(if (nd/heading-has-children) (if (nd/heading-has-children 'nd/is-todoitem-p)
(if (member keyword nd/project-skip-todostates) (if (member keyword nd/project-skip-todostates)
(nd/skip-subtree) (nd/skip-subtree)
(nd/skip-item)) (nd/skip-heading))
(if (not (and (nd/heading-has-parent) (if (not (and (nd/heading-has-parent 'nd/is-todoitem-p)
(not (nd/is-timestamped-heading-p)) (not (nd/is-timestamped-heading-p))
(not (nd/is-scheduled-heading-p)) (not (nd/is-scheduled-heading-p))
(not (nd/is-deadlined-heading-p)) (not (nd/is-deadlined-heading-p))
(equal keyword skip-keyword))) (equal keyword skip-keyword)))
(nd/skip-item))) (nd/skip-heading)))
(nd/skip-item))))) (nd/skip-heading)))))
;; task-level errors ;; header-level errors
(defun nd/skip-non-discontinuous-project-tasks () (defun nd/skip-non-discontinuous-project-tasks ()
(nd/skip-heading-with (nd/skip-heading-with
nd/is-todoitem-p nd/is-todoitem-p
@ -713,10 +720,17 @@ test-fun return true"
(and (not (member keyword org-done-keywords)) (and (not (member keyword org-done-keywords))
(nd/is-closed-heading-p)))) (nd/is-closed-heading-p))))
(defun nd/skip-non-series-atomic-tasks () (defun nd/skip-non-untimestamped-periodical-headers ()
(save-restriction
(widen)
(if (not (and (nd/is-periodical-p)
(not (nd/is-timestamped-heading-p))))
(nd/skip-heading))))
(defun nd/skip-non-iterator-atomic-tasks ()
(nd/skip-heading-with (nd/skip-heading-with
nd/is-atomic-task-p nd/is-atomic-task-p
(nd/is-series-heading-p))) (nd/is-iterator-heading-p)))
;; projects ;; projects
(defun nd/skip-projects-without-statuscode (statuscode) (defun nd/skip-projects-without-statuscode (statuscode)
@ -725,11 +739,11 @@ test-fun return true"
(let ((keyword (nd/is-project-p))) (let ((keyword (nd/is-project-p)))
(if keyword (if keyword
(if (and nd/agenda-limit-project-toplevel (if (and nd/agenda-limit-project-toplevel
(nd/heading-has-parent)) (nd/heading-has-parent 'nd/is-todoitem-p))
(nd/skip-subtree) (nd/skip-subtree)
(if (not (nd/is-project-status-p statuscode)) (if (not (nd/is-project-status-p statuscode))
(nd/skip-item))) (nd/skip-heading)))
(nd/skip-item))))) (nd/skip-heading)))))
(defvar nd/agenda-limit-project-toplevel t (defvar nd/agenda-limit-project-toplevel t
"used to filter projects by all levels or top-level only") "used to filter projects by all levels or top-level only")
@ -792,7 +806,7 @@ test-fun return true"
,(nd/agenda-base-project-command series-view-match "Active Series" :active) ,(nd/agenda-base-project-command series-view-match "Active Series" :active)
,(nd/agenda-base-project-command series-view-match "Waiting Series" :waiting) ,(nd/agenda-base-project-command series-view-match "Waiting Series" :waiting)
,(nd/agenda-base-project-command series-view-match "Held Series" :held) ,(nd/agenda-base-project-command series-view-match "Held Series" :held)
,(nd/agenda-base-task-command series-view-match "Uninitialized Series" ''nd/skip-non-series-atomic-tasks))) ,(nd/agenda-base-task-command series-view-match "Uninitialized Series" ''nd/skip-non-iterator-atomic-tasks)))
("r" ("r"
"Refile and Critical Errors" "Refile and Critical Errors"
((tags "REFILE" ((tags "REFILE"

43
conf.org
View File

@ -593,13 +593,13 @@ Doubles as a way to further test the todostate in downstream functions
keyword))) keyword)))
(defun nd/is-project-p () (defun nd/is-project-p ()
(and (nd/heading-has-children) (nd/is-todoitem-p))) (and (nd/heading-has-children 'nd/is-todoitem-p) (nd/is-todoitem-p)))
(defun nd/is-task-p () (defun nd/is-task-p ()
(and (not (nd/heading-has-children)) (nd/is-todoitem-p))) (and (not (nd/heading-has-children 'nd/is-todoitem-p)) (nd/is-todoitem-p)))
(defun nd/is-atomic-task-p () (defun nd/is-atomic-task-p ()
(and (not (nd/heading-has-parent)) (nd/is-task-p))) (and (not (nd/heading-has-parent 'nd/is-todoitem-p)) (nd/is-task-p)))
#+END_SRC #+END_SRC
**** property testing **** property testing
Returns t is heading matches a certian set of properties Returns t is heading matches a certian set of properties
@ -613,25 +613,30 @@ Returns t is heading matches a certian set of properties
**** relational testing **** relational testing
Returns t if heading has certain relationship to other headings Returns t if heading has certain relationship to other headings
#+BEGIN_SRC emacs-lisp #+BEGIN_SRC emacs-lisp
(defun nd/heading-has-children () (defun nd/heading-has-children (heading-test)
"returns t if heading has todoitems in its immediate subtree" "returns t if heading has subheadings that return t when assessed with
heading-test function"
;; TODO make this more efficient (and accurate) by only testing ;; TODO make this more efficient (and accurate) by only testing
;; the level immediately below (if it exists) ;; the level immediately below (if it exists)
(let ((has-children) (let ((has-children)
(subtree-end (save-excursion (org-end-of-subtree t)))) (subtree-end (save-excursion (org-end-of-subtree t)))
(previous-point))
(save-excursion (save-excursion
(setq previous-point (point))
(outline-next-heading) (outline-next-heading)
(while (and (not has-children) (while (and (not has-children)
(< (point) subtree-end)) (< previous-point (point) subtree-end))
(when (nd/is-todoitem-p) (when (funcall heading-test)
(setq has-children t)) (setq has-children t))
;; (org-forward-heading-same-level 1 t))) (setq previous-point (point))
(outline-next-heading))) (org-forward-heading-same-level 1 t)))
;; (outline-next-heading)))
has-children)) has-children))
(defun nd/heading-has-parent () (defun nd/heading-has-parent (heading-test)
"returns parent keyword if heading is in the immediate subtree of a todoitem" "returns parent keyword if heading is in the immediate subtree of a heading
(save-excursion (and (org-up-heading-safe) (nd/is-todoitem-p)))) that evaluated to t with heading-test function"
(save-excursion (and (org-up-heading-safe) (funcall heading-test))))
(defun nd/has-discontinuous-parent () (defun nd/has-discontinuous-parent ()
"returns t if heading has a parent which is not a "returns t if heading has a parent which is not a
@ -700,7 +705,7 @@ Returns t if heading has certain relationship to other headings
(let ((keyword (nd/is-todoitem-p))) (let ((keyword (nd/is-todoitem-p)))
(if keyword (if keyword
(let ((cur-state (let ((cur-state
(if (nd/heading-has-children) (if (nd/heading-has-children 'nd/is-todoitem-p)
(cond ((member keyword nd/project-invalid-todostates) :invalid-todostate) (cond ((member keyword nd/project-invalid-todostates) :invalid-todostate)
((nd/is-scheduled-heading-p) :scheduled-project) ((nd/is-scheduled-heading-p) :scheduled-project)
((equal keyword "CANC") (if (nd/is-archivable-heading-p) ((equal keyword "CANC") (if (nd/is-archivable-heading-p)
@ -844,8 +849,8 @@ tags in the custom commands section but I find this easier to maintain and possi
(if (not (if (not
(and (nd/is-stale-heading-p) (and (nd/is-stale-heading-p)
(not (member keyword org-done-keywords)) (not (member keyword org-done-keywords))
(not (nd/heading-has-children)) (not (nd/heading-has-children 'nd/is-todoitem-p))
(not (nd/heading-has-parent)))) (not (nd/heading-has-parent 'nd/is-todoitem-p))))
(nd/skip-heading))))) (nd/skip-heading)))))
;; atomic tasks ;; atomic tasks
@ -887,11 +892,11 @@ tags in the custom commands section but I find this easier to maintain and possi
(widen) (widen)
(let ((keyword (nd/is-todoitem-p))) (let ((keyword (nd/is-todoitem-p)))
(if keyword (if keyword
(if (nd/heading-has-children) (if (nd/heading-has-children 'nd/is-todoitem-p)
(if (member keyword nd/project-skip-todostates) (if (member keyword nd/project-skip-todostates)
(nd/skip-subtree) (nd/skip-subtree)
(nd/skip-heading)) (nd/skip-heading))
(if (not (and (nd/heading-has-parent) (if (not (and (nd/heading-has-parent 'nd/is-todoitem-p)
(not (nd/is-timestamped-heading-p)) (not (nd/is-timestamped-heading-p))
(not (nd/is-scheduled-heading-p)) (not (nd/is-scheduled-heading-p))
(not (nd/is-deadlined-heading-p)) (not (nd/is-deadlined-heading-p))
@ -936,7 +941,7 @@ tags in the custom commands section but I find this easier to maintain and possi
(let ((keyword (nd/is-project-p))) (let ((keyword (nd/is-project-p)))
(if keyword (if keyword
(if (and nd/agenda-limit-project-toplevel (if (and nd/agenda-limit-project-toplevel
(nd/heading-has-parent)) (nd/heading-has-parent 'nd/is-todoitem-p))
(nd/skip-subtree) (nd/skip-subtree)
(if (not (nd/is-project-status-p statuscode)) (if (not (nd/is-project-status-p statuscode))
(nd/skip-heading))) (nd/skip-heading)))