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

REF headline planning buffer functions

This commit is contained in:
Nathan Dwarshuis 2022-02-14 19:55:28 -05:00
parent cc03fa14eb
commit ee969077b4
1 changed files with 174 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

293
local/lib/org-x/org-x-dag.el
View File

@ -281,15 +281,134 @@ A date like (YEAR MONTH DAY).")
;;; PLANNING ;;; PLANNING
(defun org-x--qtp-headline-get-year (headline) ;; planning buffer tags
(let ((rt (org-ml-get-property :raw-value headline))) ;;
(if (s-matches-p "[0-9]\\{4\\}" rt) (string-to-number rt) ;; use tags to encode date/time information in the buffer since it is really
(error "Invalid year headline in quarterly plan: %s" rt)))) ;; easy to look up tags in the DAG
(defun org-x--qtp-headline-get-quarter (headline) (defconst org-x-dag-weekly-tags
(let ((rt (org-ml-get-property :raw-value headline))) '((0 . "SUN")
(-if-let ((_ qt) (s-match "Q\\([0-9]\\)" rt)) (string-to-number qt) (1 . "MON")
(error "Invalid quarter headline in quarterly plan: %s" rt)))) (2 . "TUE")
(3 . "WED")
(4 . "THU")
(5 . "FRI")
(6 . "SAT")))
(defun org-x-dag-format-year-tag (year)
(format "Y%d" (mod year 2000)))
(defun org-x-dag-format-quarter-tag (quarter)
(format "Q%d" quarter))
(defun org-x-dag-format-month-tag (month)
(format "M%02d" month))
(defun org-x-dag-format-week-tag (week)
(format "W%02d" week))
(defun org-x-dag-format-day-of-week-tag (daynum)
(alist-get daynum org-x-dag-week-start-index))
(defun org-x-dag-format-day-tag (day)
(format "D%02d" day))
;; headline lookup
(defun org-x-dag-headlines-find-tag (tag headlines)
(--find (org-ml-headline-has-tag tag it) headlines))
(defun org-x-dag-headlines-find-year (year headlines)
(-> (org-x-dag-format-year-tag year)
(org-x-dag-headlines-find-tag headlines)))
(defun org-x-dag-headlines-find-quarter (quarter headlines)
(-> (org-x-dag-format-quarter-tag quarter)
(org-x-dag-headlines-find-tag headlines)))
(defun org-x-dag-headlines-find-week (weeknum headlines)
(-> (org-x-dag-format-week-tag weeknum)
(org-x-dag-headlines-find-tag headlines)))
(defun org-x-dag-headlines-find-day-of-week (daynum headlines)
(-> (org-x-dag-format-day-of-week-tag daynum)
(org-x-dag-headlines-find-tag headlines)))
(defun org-x-dag-headlines-find-month (month headlines)
(-> (org-x-dag-format-month-tag month)
(org-x-dag-headlines-find-tag headlines)))
(defun org-x-dag-headlines-find-day (day headlines)
(-> (org-x-dag-format-day-tag day)
(org-x-dag-headlines-find-tag headlines)))
;; headline builders
(defun org-x-dag-build-planning-headline (title tag level subheadlines)
(apply #'org-ml-build-headline!
:title-text title
:tag (list tag)
:level level
subheadlines))
(defun org-x-dag-build-year-headline (year subheadlines)
(let ((title (number-to-string year))
(tag (org-x-dag-format-year-tag year)))
(org-x-dag-build-planning-headline tag title 1 subheadlines)))
(defun org-x-dag-build-quarter-headline (quarter subheadlines)
(let ((title (format "Quarter %d" quarter))
(tag (org-x-dag-format-quarter-tag quarter)))
(org-x-dag-build-planning-headline title tag 2 subheadlines)))
(defun org-x-dag-build-week-headline (year weeknum subheadlines)
(-let* (((_ m d) (org-x-dag-week-number-to-date year weeknum))
(m* (calendar-month-name m))
(title (format "%s %s" m* d))
(tag (org-x-dag-format-week-tag weeknum)))
(org-x-dag-build-planning-headline title tag 2 subheadlines)))
(defun org-x-dag-build-month-headline (month subheadlines)
(let ((title (calendar-month-name month))
(tag (org-x-dag-format-month-tag month)))
(org-x-dag-build-planning-headline title tag 2 subheadlines)))
(defun org-x-dag-build-day-headline (date subheadlines)
(let ((title (format "%d-%02d-%02d" y m d))
(tag (org-x-dag-format-day-tag d)))
(org-x-dag-build-planning-headline title tag 3 subheadlines)))
(defun org-x-dag-build-day-of-week-headline (daynum subheadlines)
(let ((title (elt calendar-day-name-array daynum))
(tag (alist-get daynum org-x-dag-weekly-tags)))
(org-x-dag-build-planning-headline title tag 3 subheadlines)))
;; id headline builders
(defun org-x-dag-build-planning-id-headline (title level paragraph ids)
(let ((sec (-some-> paragraph
(org-ml-build-paragraph!)
(list))))
(->> (org-ml-build-headline! :title-text title
:level level
:todo-keyword org-x-kw-todo
:section-children sec)
(org-x-dag-headline-add-id)
(org-x-dag-headline-set-parent-links ids))))
(defun org-x-dag-build-qtp-headline (title paragraph ids allocation)
(->> (org-x-dag-build-planning-id-headline title 3 paragraph ids)
(org-ml-headline-set-node-property org-x-prop-allocate allocation)))
(defun org-x-dag-build-wkp-headline (title paragraph ids)
(org-x-dag-build-planning-id-headline title 4 paragraph ids))
(defun org-x-dag-build-dlp-headline (title paragraph ids datetime)
(let ((pl (org-ml-build-planning! :scheduled datetime)))
(->> (org-x-dag-build-planning-id-headline title 4 paragraph ids)
(org-ml-headline-set-planning pl))))
;; buffer manipulation
(defun org-x-dag-qtp-to-children (qt-plan) (defun org-x-dag-qtp-to-children (qt-plan)
(-let* (((&plist :categories :goals) qt-plan) (-let* (((&plist :categories :goals) qt-plan)
@ -317,32 +436,29 @@ A date like (YEAR MONTH DAY).")
(org-x-with-file (org-x-qtp-get-file) (org-x-with-file (org-x-qtp-get-file)
(-let (((year qnum) quarter)) (-let (((year qnum) quarter))
(->> (org-ml-parse-subtrees 'all) (->> (org-ml-parse-subtrees 'all)
(org-x--qtp-headline-find-year year) (org-x-dag-headlines-find-year year)
(org-ml-headline-get-subheadlines) (org-ml-headline-get-subheadlines)
(org-x--qtp-headline-find-quarter qnum) (org-x-dag-headlines-find-quarter qnum)
(org-ml-get-children) (org-ml-get-children)
(org-x-dag-qtp-from-children))))) (org-x-dag-qtp-from-children)))))
(defun org-x-dag-qtp-set (quarter qt-plan) (defun org-x-dag-qtp-set (quarter qt-plan)
(cl-flet* (cl-flet
((build-qt-headline ((build-yr-headline
(quarter children)
(let ((title (list (format "Q%s" quarter))))
(apply #'org-ml-build-headline :title title :level 2 children)))
(build-yr-headline
(year qnum children) (year qnum children)
(->> (build-qt-headline qnum children) (->> (org-x-dag-build-quarter-headline qnum children)
(org-ml-build-headline! :title-text (number-to-string year))))) (list)
(org-x-dag-build-year-headline year))))
(org-x-with-file (org-x-qtp-get-file) (org-x-with-file (org-x-qtp-get-file)
(-let* (((year qnum) quarter) (-let* (((year qnum) quarter)
(sts (org-ml-parse-subtrees 'all)) (sts (org-ml-parse-subtrees 'all))
(children (org-x-dag-qtp-to-children qt-plan))) (children (org-x-dag-qtp-to-children qt-plan)))
(-if-let (st-yr (org-x--qtp-headline-find-year year sts)) (-if-let (st-yr (org-x-dag-headlines-find-year year sts))
(-if-let (st-qt (->> (org-ml-headline-get-subheadlines st-yr) (-if-let (st-qt (->> (org-ml-headline-get-subheadlines st-yr)
(org-x--qtp-headline-find-quarter qnum))) (org-x-dag-headlines-find-quarter qnum)))
(org-ml-update* (org-ml-set-children children it) st-qt) (org-ml-update* (org-ml-set-children children it) st-qt)
(org-ml-update* (org-ml-update*
(-snoc it (build-qt-headline qnum children)) (-snoc it (org-x-dag-build-quarter-headline qnum children))
st-yr)) st-yr))
(let ((end (1+ (org-ml-get-property :end (-last-item sts))))) (let ((end (1+ (org-ml-get-property :end (-last-item sts)))))
(org-ml-insert end (build-yr-headline year qnum children)))))))) (org-ml-insert end (build-yr-headline year qnum children))))))))
@ -393,48 +509,10 @@ A date like (YEAR MONTH DAY).")
(defun org-x-dag-headline-add-id (headline) (defun org-x-dag-headline-add-id (headline)
(org-ml-headline-set-node-property "ID" (org-id-new) headline)) (org-ml-headline-set-node-property "ID" (org-id-new) headline))
(defun org-x-qtp-build-goal-headline (ids title allocation)
;; ASSUME the allocation is in a valid format
(let ((d (org-x-dag-build-parent-link-drawer ids)))
(->> (org-ml-build-headline! :level 3
:title-text title
:todo-keyword org-x-kw-todo
:section-children (list d))
(org-x-dag-headline-add-id)
(org-ml-headline-set-node-property org-x-prop-allocate allocation))))
(defun org-x-qtp-add-goal-ids (quarter ids title allocation) (defun org-x-qtp-add-goal-ids (quarter ids title allocation)
(->> (org-x-qtp-build-goal-headline ids title) (->> (org-x-dag-build-qtp-headline title nil ids allocation)
(org-x-qtp-add-goal quarter))) (org-x-qtp-add-goal quarter)))
(defun org-x-dag-headlines-find-tag (tag headlines)
(--find (org-ml-headline-has-tag tag it) headlines))
(defun org-x-dag-headlines-find-year (year headlines)
(org-x-dag-headlines-find-tag (format "Y%d" (mod year 2000)) headlines))
(defun org-x-dag-headlines-find-week (weeknum headlines)
(org-x-dag-headlines-find-tag (format "W%02d" weeknum) headlines))
(defconst org-x-dag-weekly-tags
'((0 . "SUN")
(1 . "MON")
(2 . "TUE")
(3 . "WED")
(4 . "THU")
(5 . "FRI")
(6 . "SAT")))
(defun org-x-dag-headlines-find-day-of-week (daynum headlines)
(-> (alist-get daynum org-x-dag-weekly-tags)
(org-x-dag-headlines-find-tag headlines)))
(defun org-x-dag-headlines-find-month (month headlines)
(org-x-dag-headlines-find-tag (format "M%02d" month) headlines))
(defun org-x-dag-headlines-find-day (day headlines)
(org-x-dag-headlines-find-tag (format "D%02d" day) headlines))
(defun org-x-dag-weekly-headlines-to-alist (headlines) (defun org-x-dag-weekly-headlines-to-alist (headlines)
(->> (-map #'car org-x-dag-weekly-tags) (->> (-map #'car org-x-dag-weekly-tags)
(--map (->> (org-x-dag-headlines-find-day-of-week it headlines) (--map (->> (org-x-dag-headlines-find-day-of-week it headlines)
@ -443,11 +521,7 @@ A date like (YEAR MONTH DAY).")
(defun org-x-dag-weekly-alist-to-headlines (plan) (defun org-x-dag-weekly-alist-to-headlines (plan)
(--map (-let (((daynum . hls) it)) (--map (-let (((daynum . hls) it))
(apply #'org-ml-build-headline! (org-x-dag-build-day-of-week-headline daynum hls))
:tags (list (alist-get daynum org-x-dag-weekly-tags))
:level 3
:title-text (elt calendar-day-name-array daynum)
hls))
plan)) plan))
(defun org-x-dag-wkp-get (week) (defun org-x-dag-wkp-get (week)
@ -462,23 +536,11 @@ A date like (YEAR MONTH DAY).")
(defun org-x-dag-wkp-set (week plan) (defun org-x-dag-wkp-set (week plan)
(cl-flet* (cl-flet*
((build-wk-headline ((build-yr-headline
(year weeknum children) (year weeknum children)
(-let* (((_ m d) (org-x-dag-week-number-to-date year weeknum)) (->> (org-x-dag-build-week-headline year weeknum children)
(m* (calendar-month-name m)) (list)
(title (format "%s %s" m* d)) (org-x-dag-build-year-headline year))))
(tag (format "W%02d" weeknum)))
(apply #'org-ml-build-headline!
:title-text title
:level 2
:tags (list tag)
children)))
(build-yr-headline
(year weeknum children)
(let ((title (number-to-string year))
(tag (format "Y%d" year)))
(->> (build-wk-headline year weeknum children)
(org-ml-build-headline! :title-text title :tag (list tag))))))
(org-x-with-file (org-x-get-weekly-plan-file) (org-x-with-file (org-x-get-weekly-plan-file)
(-let* (((year weeknum) week) (-let* (((year weeknum) week)
(sts (org-ml-parse-subtrees 'all)) (sts (org-ml-parse-subtrees 'all))
@ -488,7 +550,7 @@ A date like (YEAR MONTH DAY).")
(org-x-dag-headlines-find-week weeknum))) (org-x-dag-headlines-find-week weeknum)))
(org-ml-update* (org-ml-set-children children it) st-wk) (org-ml-update* (org-ml-set-children children it) st-wk)
(org-ml-update* (org-ml-update*
(-snoc it (build-wk-headline year weeknum children)) (-snoc it (org-x-dag-build-week-headline year weeknum children))
st-yr)) st-yr))
(let ((end (1+ (org-ml-get-property :end (-last-item sts))))) (let ((end (1+ (org-ml-get-property :end (-last-item sts)))))
(org-ml-insert end (build-yr-headline year weeknum children)))))))) (org-ml-insert end (build-yr-headline year weeknum children))))))))
@ -520,14 +582,8 @@ A date like (YEAR MONTH DAY).")
(org-x-dag-wkp-day-map week daynum (cons headline it))) (org-x-dag-wkp-day-map week daynum (cons headline it)))
(defun org-x-dag-wkp-add-goal (week daynum title ids desc) (defun org-x-dag-wkp-add-goal (week daynum title ids desc)
(let ((p (org-ml-build-paragraph! desc))) (->> (org-x-dag-build-wkp-headline title desc ids)
(->> (org-ml-build-headline! :level 4 (org-x-dag-wkp-day-add week daynum)))
:title-text title
:todo-keyword org-x-kw-todo
:section-children (list p))
(org-x-dag-headline-add-id)
(org-x-dag-headline-set-parent-links ids)
(org-x-dag-wkp-day-add week daynum))))
;; TODO not DRY ;; TODO not DRY
(defun org-x-dag-dlp-get (date) (defun org-x-dag-dlp-get (date)
@ -542,32 +598,18 @@ A date like (YEAR MONTH DAY).")
(defun org-x-dag-dlp-set (date headlines) (defun org-x-dag-dlp-set (date headlines)
(cl-flet* (cl-flet*
((build-day-headline ((build-mo-headline
(date headlines) (date headlines)
(-let* (((y m d) date) (-let (((_ m _) date))
(title (format "%d-%02d-%02d" y m d)) (->> (org-x-dag-build-day-headline date headlines)
(tag (format "D%02d" d))) (list)
(apply #'org-ml-build-headline! (org-x-dag-build-month-headline m))))
:title-text title
:tags (list tag)
:level 3
headlines)))
(build-mo-headline
(date headlines)
(-let* (((_ m _) date)
(title (calendar-month-name m))
(tag (format "M%02d" m)))
(->> (build-day-headline date headlines)
(org-ml-build-headline! :title-text title
:level 2
:tags (list tag)))))
(build-yr-headline (build-yr-headline
(date headlines) (date headlines)
(-let* (((y _ _) date) (-let* (((y _ _) date))
(title (number-to-string y))
(tag (format "Y%d" y)))
(->> (build-mo-headline date headlines) (->> (build-mo-headline date headlines)
(org-ml-build-headline! :title-text title :tags (list tag)))))) (list)
(org-x-dag-build-year-headline y)))))
(org-x-with-file (org-x-get-daily-plan-file) (org-x-with-file (org-x-get-daily-plan-file)
(-let (((y m d) date) (-let (((y m d) date)
(sts (org-ml-parse-subtrees 'all))) (sts (org-ml-parse-subtrees 'all)))
@ -578,7 +620,7 @@ A date like (YEAR MONTH DAY).")
(org-x-dag-headlines-find-day d))) (org-x-dag-headlines-find-day d)))
(org-ml-update* (org-ml-set-children headlines it) st-day) (org-ml-update* (org-ml-set-children headlines it) st-day)
(org-ml-update* (org-ml-update*
(-snoc it (build-day-headline date headlines)) (-snoc it (org-x-dag-build-day-headline date headlines))
st-mo)) st-mo))
(org-ml-update* (org-ml-update*
(-snoc it (build-mo-headline date headlines)) (-snoc it (build-mo-headline date headlines))
@ -598,14 +640,25 @@ A date like (YEAR MONTH DAY).")
(defun org-x-dag-dlp-add-task (date title ids time) (defun org-x-dag-dlp-add-task (date title ids time)
(let ((datetime `(,@date ,@time))) (let ((datetime `(,@date ,@time)))
(->> (org-ml-build-headline! :level 4 (->> (org-x-dag-build-dlp-headline title nil ids datetime)
:title-text title
:planning `(:scheduled ,datetime)
:todo-keyword org-x-kw-todo)
(org-x-dag-headline-add-id)
(org-x-dag-headline-set-parent-links ids)
(org-x-dag-dlp-add date)))) (org-x-dag-dlp-add date))))
(defun org-x-dag-date->dlp-ids (date)
(-let* (((y m d) date)
(target-tags (list (org-x-dag-format-year-tag y)
(org-x-dag-format-month-tag m)
(org-x-dag-format-day-tag d))))
(->> (list (org-x-get-daily-plan-file))
(org-x-dag-files->ids)
(--filter (let ((ts (org-x-dag-id->tags t nil it)))
(seq-set-equal-p ts target-tags #'equal))))))
(defun org-x-dag-date->dlp-action-ids (date)
(let ((dlp-ids (org-x-dag-date->dlp-ids date)))
(->> (org-x-get-action-and-incubator-files)
(org-x-dag-files->ids)
(--filter (-intersection (org-x-dag-id->children it) dlp-ids)))))
;;; BUFFER SCANNING ;;; BUFFER SCANNING
(defun org-x-dag-get-local-property (prop) (defun org-x-dag-get-local-property (prop)
@ -724,6 +777,8 @@ valid keyword or none of its parents have valid keywords."
`(,(org-x-get-lifetime-goal-file) `(,(org-x-get-lifetime-goal-file)
,(org-x-get-endpoint-goal-file) ,(org-x-get-endpoint-goal-file)
,(org-x-qtp-get-file) ,(org-x-qtp-get-file)
,(org-x-get-weekly-plan-file)
,(org-x-get-daily-plan-file)
,@(org-x-get-action-and-incubator-files))) ,@(org-x-get-action-and-incubator-files)))
(defun org-x-dag-get-md5 (path) (defun org-x-dag-get-md5 (path)