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

ADD functions to jump to current plans

This commit is contained in:
Nathan Dwarshuis 2022-04-11 23:33:45 -04:00
parent 1e54f4f78e
commit c0ed24a48b
1 changed files with 76 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -173,6 +173,10 @@
(- daynum)
(org-x-dag-absolute-to-date))))
(defun org-x-dag-date-to-day-number (date)
(->> (org-x-dag-date-to-gregorian date)
(calendar-day-number)))
;; date <-> quarter
(defun org-x-dag-quarter-to-date (quarter)
@ -1560,6 +1564,9 @@ If FORCE is non-nil, sync no matter what."
(defun org-x-dag->current-date ()
(plist-get org-x-dag :current-date))
(defun org-x-dag->selected-date ()
(plist-get org-x-dag :selected-date))
(defun org-x-dag->file-state ()
(plist-get org-x-dag :files))
@ -3064,7 +3071,7 @@ review phase)"
(tag (alist-get daynum org-x-dag-weekly-tags)))
(org-x-dag-build-planning-headline title tag 3 nil subheadlines)))
;; id headline builders
;; planning headline builders
(defun org-x-dag-build-planning-id-headline (title level paragraph ids)
(let ((sec (-some-> paragraph
@ -3124,6 +3131,14 @@ review phase)"
subtrees)))
(list :categories cats :goals goals)))
(defun org-x-dag-qtp-get-headline (date)
(org-x-with-file (org-x-dag->planning-file :quarterly)
(-let (((y q) (org-x-dag-date-to-quarter date)))
(->> (org-ml-parse-subtrees 'all)
(org-x-dag-headlines-find-year y)
(org-ml-headline-get-subheadlines)
(org-x-dag-headlines-find-quarter q)))))
(defun org-x-dag-qtp-get (quarter)
(org-x-with-file (org-x-qtp-get-file)
(-let (((year qnum) quarter))
@ -3220,15 +3235,26 @@ review phase)"
(org-x-dag-build-day-of-week-headline daynum hls))
plan))
(defun org-x-dag-wkp-get (week)
(defun org-x-dag-wkp-get-week-headline (date)
(org-x-with-file (org-x-get-weekly-plan-file)
(-let (((year weeknum) week))
(-let (((y _ _) date)
(w (org-x-dag-date-to-week-number date)))
(->> (org-ml-parse-subtrees 'all)
(org-x-dag-headlines-find-year year)
(org-x-dag-headlines-find-year y)
(org-ml-headline-get-subheadlines)
(org-x-dag-headlines-find-week weeknum)
(org-ml-headline-get-subheadlines)
(org-x-dag-weekly-headlines-to-alist)))))
(org-x-dag-headlines-find-week w)))))
(defun org-x-dag-wkp-get-day-headline (date)
(-let ((n (org-x-dag-date-to-day-number)))
(->> (org-x-dag-wkp-get-week-headline date)
(org-ml-headline-get-subheadlines)
(org-x-dag-headlines-find-day-of-week n))))
;; TODO these functions need to take dates and not 'week's (whatever those are)
(defun org-x-dag-wkp-get (week)
(->> (org-x-dag-wkp-get-day-headline date)
(org-ml-headline-get-subheadlines)
(org-x-dag-weekly-headlines-to-alist)))
(defun org-x-dag-wkp-set (week plan)
(cl-flet*
@ -3282,7 +3308,7 @@ review phase)"
(org-x-dag-wkp-day-add week daynum)))
;; TODO not DRY
(defun org-x-dag-dlp-get (date)
(defun org-x-dag-dlp-get-headline (date)
(org-x-with-file (org-x-dag->planning-file :daily)
(-let (((y m d) date))
(->> (org-ml-parse-subtrees 'all)
@ -3290,8 +3316,11 @@ review phase)"
(org-ml-headline-get-subheadlines)
(org-x-dag-headlines-find-month m)
(org-ml-headline-get-subheadlines)
(org-x-dag-headlines-find-day d)
(org-ml-headline-get-subheadlines)))))
(org-x-dag-headlines-find-day d)))))
(defun org-x-dag-dlp-get (date)
(->> (org-x-dag-dlp-get-headline date)
(org-ml-headline-get-subheadlines)))
(defun org-x-dag-dlp-set (date headlines)
(cl-flet*
@ -3342,6 +3371,8 @@ review phase)"
;;; INTERACTIVE FUNCTIONS
;; current date
(defun org-x-dag-set-date ()
(interactive)
(let ((date (->> (org-read-date nil t)
@ -3357,6 +3388,41 @@ review phase)"
(->> (plist-get org-x-dag :selected-date)
(apply #'message "Org-DAG date is %d-%02d-%02d")))
;; planning navigation
(defun org-x-dag--goto-current (what file-key hl-fun)
(declare (indent 2))
(-if-let (p (->> (org-x-dag->current-date)
(funcall hl-fun)
(org-ml-get-property :begin)))
(progn
(find-file (org-x-dag->planning-file file-key))
(goto-char p)
(org-reveal))
(message "%s does not exist for current date" what)))
(defun org-x-dag-goto-current-quarterly-plan ()
(interactive)
(org-x-dag--goto-current "Quarterly plan" :quarterly
#'org-x-dag-qtp-get-headline))
(defun org-x-dag-goto-current-weekly-plan ()
(interactive)
(org-x-dag--goto-current "Weekly plan (week)" :weekly
#'org-x-dag-wkp-get-week-headline))
(defun org-x-dag-goto-current-weekly-plan-day ()
(interactive)
(org-x-dag--goto-current "Weekly plan (day)" :weekly
#'org-x-dag-wkp-get-day-headline))
(defun org-x-dag-goto-current-daily-plan ()
(interactive)
(org-x-dag--goto-current "Daily plan" :daily
#'org-x-dag-dlp-get-headline))
;; node navigation
(defun org-x-dag-group-code (group)
(pcase group
(:lifetime "LTG")