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

REF organize all the datetime functions

This commit is contained in:
Nathan Dwarshuis 2022-02-14 23:18:29 -05:00
parent ee969077b4
commit 74bcaa5ced
1 changed files with 183 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -28,15 +28,165 @@
(require 'dag) (require 'dag)
(require 'ht) (require 'ht)
;;; DATE/TIME FUNCTIONS
;; current state
(defun org-x-dag-current-datetime ()
(->> (current-time)
(decode-time)
(-drop 1)
(-take 5)
(reverse)))
(defun org-x-dag-current-date ()
(-take 3 (org-x-dag-current-datetime)))
(defun org-x-dag-current-time ()
(-drop 3 (org-x-dag-current-datetime)))
(defun org-x-dag-date-at-current-time (date)
`(,@date ,@(org-x-dag-current-time)))
;; calendar interface
(defun org-x-dag-gregorian-to-date (greg)
(-let (((m d y) greg))
`(,y ,m ,d)))
(defun org-x-dag-date-to-gregorian (date)
(-let (((y m d) date))
`(,m ,d ,y)))
(defun org-x-dag-date-to-absolute (date)
(->> (org-x-dag-date-to-gregorian date)
(calendar-absolute-from-gregorian)))
(defun org-x-dag-absolute-to-date (abs)
(->> (calendar-gregorian-from-absolute abs)
(org-x-dag-gregorian-to-date)))
;; datetime operations
(defun org-x-dag-datetime< (datetime0 datetime1)
(org-x-dag-with-times datetime0 datetime1
(-when-let (next (->> (-zip-with #'cons datetime0 datetime1)
(--drop-while (= (car it) (cdr it)))
(car)))
(< (car next) (cdr next)))))
(defun org-x-dag-datetime= (datetime0 datetime1)
(org-x-dag-with-times datetime0 datetime1
(->> (-zip-with #'cons datetime0 datetime1)
(--drop-while (= (car it) (cdr it)))
(not))))
(defun org-x-dag-datetime-split (datetime)
;; TODO this function doesn't guarantee that a short timestamp is properly
;; formatted
(if (org-ml-time-is-long datetime)
(-split-at 3 datetime)
`(,(-take 3 datetime) nil)))
(defun org-x-dag-datetime-shift (datetime shift unit)
(cl-flet*
((enc-dec-long
(y m d H M)
(-let (((_ M* H* d* m* y* _ _ _)
(->> (list 0 M H d m y nil nil (current-time-zone))
(encode-time)
(decode-time))))
(list y* m* d* H* M*)))
(enc-dec-short
(y m d)
(-take 3 (enc-dec-long y m d 0 0))))
(pcase datetime
((or `(,y ,m ,d) `(,y ,m ,d nil nil))
(pcase unit
('month (enc-dec-short y (+ m shift) d))
('submonth (enc-dec-short y m (+ d shift)))))
(`(,y ,m ,d ,H ,M)
(pcase unit
('month (enc-dec-long y (+ m shift) d H M))
('submonth (enc-dec-long y m d H (+ M shift))))))))
(defun org-x-dag-date-diff (date0 date1)
""
(pcase (list date0 date1)
(`((,y0 ,m0 ,d0) (,y1 ,m1 ,d1))
(- (calendar-absolute-from-gregorian `(,m0 ,d0 ,y0))
(calendar-absolute-from-gregorian `(,m1 ,d1 ,y1))))
(_ (error "Invalid date format(s): %S or %S" date0 date1))))
;; date <-> week
(defun org-x-dag-date-to-week-number (date)
(-let* (((y m d) date)
(greg (org-x-dag-date-to-gregorian date))
(abs (calendar-absolute-from-gregorian greg))
(daynum (calendar-day-of-week greg))
;; Catch the special case where the first few days of January might
;; belong to the previous year
(start-year (if (and (= 1 m) (< d (1+ daynum))) (1- y)))
(start-greg `(1 1 ,start-year))
(start-daynum (calendar-day-of-week start-greg))
(start-abs (calendar-absolute-from-gregorian start-greg))
(start-diff (if (= 0 start-daynum) 0 (- 7 start-daynum))))
(1+ (/ (- abs start-abs start-diff) 7))))
(defun org-x-dag-week-number-to-date (year weeknum)
(let* ((start-greg `(1 1 ,year))
(start-abs (calendar-absolute-from-gregorian start-greg))
(start-weeknum (calendar-day-of-week start-greg))
(start-diff (if (= 0 start-weeknum) 0 (- 7 start-weeknum))))
(->> (* (1- weeknum) 7)
(+ start-abs start-diff)
(org-x-dag-absolute-to-date))))
(defun org-x-dag-date-to-week-start (date)
""
(let* ((greg (org-x-dag-date-to-gregorian date))
(daynum (calendar-day-of-week greg)))
(-> (calendar-absolute-from-gregorian greg)
(- daynum)
(org-x-dag-absolute-to-date))))
;; date <-> quarter
(defun org-x-dag-quarter-to-date (quarter)
(-let (((y q) quarter))
(list y (1+ (* q 3)) 1)))
(defun org-x-dag-shift-quarter (quarter n unit)
(-let (((y q) quarter))
(pcase unit
(`year `(,(+ n y) ,q))
(`quarter
(let* ((x (+ q n))
(q* (mod x 4))
(y* (+ y (floor (/ x 4.0)))))
`(,y* ,q*))))))
(defun org-x-dag-quarter-diff (quarter1 quarter2)
(cl-flet
((qt-to-abs
(q)
(->> (org-x-dag-quarter-to-date q)
(org-x-dag-date-to-absolute))))
(- (qt-to-abs quarter1) (qt-to-abs quarter2))))
;;; GLOBAL STATE ;;; GLOBAL STATE
;; variables to store state ;; variables to store state
(defun org-x-dag-create (d m f) (defun org-x-dag-create (d m f c)
(list :dag d :id->meta m :file->ids f)) (list :dag d :id->meta m :file->ids f :current-date c))
(defun org-x-dag-empty () (defun org-x-dag-empty ()
(org-x-dag-create (dag-empty) (ht-create #'equal) (ht-create #'equal))) (org-x-dag-create (dag-empty)
(ht-create #'equal)
(ht-create #'equal)
(org-x-dag-current-date)))
(defvar org-x-dag (org-x-dag-empty) (defvar org-x-dag (org-x-dag-empty)
@ -220,65 +370,13 @@ Is a list like (YEAR QUARTER).")
"The current week to be used for planning. "The current week to be used for planning.
A date like (YEAR MONTH DAY).") A date like (YEAR MONTH DAY).")
(defvar org-x-dag-week-start-index 0 ;; (defvar org-x-dag-week-start-index 0
"The day considered to start a week (0 = Sunday).") ;; "The day considered to start a week (0 = Sunday).")
(defvar org-x-dag-selected-date nil (defvar org-x-dag-selected-date nil
"The current week to be used for planning. "The current week to be used for planning.
A date like (YEAR MONTH DAY).") A date like (YEAR MONTH DAY).")
(defun org-x-dag-gregorian-to-date (greg)
(-let (((m d y) greg))
`(,y ,m ,d)))
(defun org-x-dag-set-planning-quarter-at-date (date)
;; ASSUME the date is valid with no overflow digits
(-let (((y m _) date))
(setq org-x-dag-selected-quarter `(,y ,(/ m 3)))))
(defun org-x-dag-date-to-week-number (date)
(-let* (((y m d) date)
(greg (org-x-dag-date-to-gregorian date))
(abs (calendar-absolute-from-gregorian greg))
(daynum (calendar-day-of-week greg))
;; Catch the special case where the first few days of January might
;; belong to the previous year
(start-year (if (and (= 1 m) (< d (1+ daynum))) (1- y)))
(start-greg `(1 1 ,start-year))
(start-daynum (calendar-day-of-week start-greg))
(start-abs (calendar-absolute-from-gregorian start-greg))
(start-diff (if (= 0 start-daynum) 0 (- 7 start-daynum))))
(1+ (/ (- abs start-abs start-diff) 7))))
(defun org-x-dag-week-number-to-date (year weeknum)
(let* ((start-greg `(1 1 ,year))
(start-abs (calendar-absolute-from-gregorian start-greg))
(start-weeknum (calendar-day-of-week start-greg))
(start-diff (if (= 0 start-weeknum) 0 (- 7 start-weeknum))))
(->> (* (1- weeknum) 7)
(+ start-abs start-diff)
(calendar-gregorian-from-absolute)
(org-x-dag-gregorian-to-date))))
(defun org-x-dag-date-to-week-start (date)
""
(let ((greg (org-x-dag-date-to-gregorian date)))
(while (not (= (calendar-day-of-week greg) org-x-dag-week-start-index))
(setq greg (->> (calendar-absolute-from-gregorian greg)
(1-)
(calendar-gregorian-from-absolute))))
(org-x-dag-gregorian-to-date greg)))
(defun org-x-dag-set-planning-week-at-date (date)
(setq org-x-dag-selected-week date))
(defun org-x-dag-set-planning-date (date)
;; TODO validate date?
(let ((week-start (org-x-dag-date-to-week-start date)))
(setq org-x-dag-selected-date date)
(setq org-x-dag-selected-week week-date)
(org-x-dag-set-planning-quarter-at-date week-date)))
;;; PLANNING ;;; PLANNING
;; planning buffer tags ;; planning buffer tags
@ -308,7 +406,7 @@ A date like (YEAR MONTH DAY).")
(format "W%02d" week)) (format "W%02d" week))
(defun org-x-dag-format-day-of-week-tag (daynum) (defun org-x-dag-format-day-of-week-tag (daynum)
(alist-get daynum org-x-dag-week-start-index)) (alist-get daynum org-x-dag-weekly-tags))
(defun org-x-dag-format-day-tag (day) (defun org-x-dag-format-day-tag (day)
(format "D%02d" day)) (format "D%02d" day))
@ -983,42 +1081,6 @@ encountered will be returned."
,form ,form
(error "Datetimes are invalid lengths: %S and %S" ,datetime0 ,datetime1))) (error "Datetimes are invalid lengths: %S and %S" ,datetime0 ,datetime1)))
;; TODO this function name sucks, call it datetime
(defun org-x-dag-date< (datetime0 datetime1)
(org-x-dag-with-times datetime0 datetime1
(-when-let (next (->> (-zip-with #'cons datetime0 datetime1)
(--drop-while (= (car it) (cdr it)))
(car)))
(< (car next) (cdr next)))))
(defun org-x-dag-date= (datetime0 datetime1)
(org-x-dag-with-times datetime0 datetime1
(->> (-zip-with #'cons datetime0 datetime1)
(--drop-while (= (car it) (cdr it)))
(not))))
(defun org-x-dag-time-shift (datetime shift unit)
(cl-flet*
((enc-dec-long
(y m d H M)
(-let (((_ M* H* d* m* y* _ _ _)
(->> (list 0 M H d m y nil nil (current-time-zone))
(encode-time)
(decode-time))))
(list y* m* d* H* M*)))
(enc-dec-short
(y m d)
(-take 3 (enc-dec-long y m d 0 0))))
(pcase datetime
((or `(,y ,m ,d) `(,y ,m ,d nil nil))
(pcase unit
('month (enc-dec-short y (+ m shift) d))
('submonth (enc-dec-short y m (+ d shift)))))
(`(,y ,m ,d ,H ,M)
(pcase unit
('month (enc-dec-long y (+ m shift) d H M))
('submonth (enc-dec-long y m d H (+ M shift))))))))
(defun org-x-dag-repeater-get-next (sel-datetime datetime shift shifttype reptype) (defun org-x-dag-repeater-get-next (sel-datetime datetime shift shifttype reptype)
"Return the next timestamp repeater of DATETIME." "Return the next timestamp repeater of DATETIME."
(pcase reptype (pcase reptype
@ -1031,17 +1093,17 @@ encountered will be returned."
(let ((next datetime) (let ((next datetime)
(pastp t)) (pastp t))
(while pastp (while pastp
(setq next (org-x-dag-time-shift next shift shifttype) (setq next (org-x-dag-datetime-shift next shift shifttype)
pastp (org-x-dag-date< next sel-datetime))) pastp (org-x-dag-datetime< next sel-datetime)))
next)) next))
('restart ('restart
;; Next time is one repeater interval after now ;; Next time is one repeater interval after now
;; ;;
;; ASSUME cur needs to match the length of time ;; ASSUME cur needs to match the length of time
(org-x-dag-time-shift sel-datetime shift shifttype)) (org-x-dag-datetime-shift sel-datetime shift shifttype))
('cumulate ('cumulate
;; Next time is one repeater interval after the base timestamp ;; Next time is one repeater interval after the base timestamp
(org-x-dag-time-shift datetime shift shifttype)))) (org-x-dag-datetime-shift datetime shift shifttype))))
(defun org-x-dag-unfold-timestamp (cur datetime rep future-limit) (defun org-x-dag-unfold-timestamp (cur datetime rep future-limit)
"Return all timestamps associated with DATETIME. "Return all timestamps associated with DATETIME.
@ -1050,24 +1112,20 @@ If REP is nil, return a singleton list just containing DATETIME.
If REP is non-nil, return DATETIME and all repeaters up until If REP is non-nil, return DATETIME and all repeaters up until
FUTURE-LIMIT in a list." FUTURE-LIMIT in a list."
;; ASSUME pts and future-limit are both long or short timestamps ;; ASSUME pts and future-limit are both long or short timestamps
(unless (org-x-dag-date< future-limit datetime) (unless (org-x-dag-datetime< future-limit datetime)
(pcase rep (pcase rep
(`nil `(,datetime)) (`nil `(,datetime))
(`(,value ,unit ,reptype) (`(,value ,unit ,reptype)
(->> (org-x-dag-repeater-get-next cur datetime value unit reptype) (->> (org-x-dag-repeater-get-next cur datetime value unit reptype)
(--unfold (unless (org-x-dag-date< future-limit it) (--unfold (unless (org-x-dag-datetime< future-limit it)
(cons it (org-x-dag-time-shift it value unit)))) (cons it (org-x-dag-datetime-shift it value unit))))
(cons datetime)))))) (cons datetime))))))
(defun org-x-dag-date-add-time (date)
(-let (((_ M H) (decode-time (current-time))))
`(,@date ,H ,M)))
(defun org-x-dag-get-scheduled-at (sel-date pts) (defun org-x-dag-get-scheduled-at (sel-date pts)
(-let* (((&plist :datetime d :repeater r) pts) (-let* (((&plist :datetime d :repeater r) pts)
(islongp (org-ml-time-is-long d)) (islongp (org-ml-time-is-long d))
(future-limit (if islongp `(,@sel-date 23 59) sel-date)) (future-limit (if islongp `(,@sel-date 23 59) sel-date))
(sel-datetime (if islongp (org-x-dag-date-add-time sel-date) sel-date))) (sel-datetime (if islongp (org-x-dag-date-at-current-time sel-date) sel-date)))
(org-x-dag-unfold-timestamp sel-datetime d r future-limit))) (org-x-dag-unfold-timestamp sel-datetime d r future-limit)))
(defun org-x-dag-get-deadlines-at (sel-date pts) (defun org-x-dag-get-deadlines-at (sel-date pts)
@ -1077,8 +1135,8 @@ FUTURE-LIMIT in a list."
(if w w (if w w
(let ((f (if islongp 1440 1))) (let ((f (if islongp 1440 1)))
`(,(* f org-deadline-warning-days) submonth)))) `(,(* f org-deadline-warning-days) submonth))))
(sel-datetime (if islongp (org-x-dag-date-add-time sel-date) sel-date)) (sel-datetime (if islongp (org-x-dag-date-at-current-time sel-date) sel-date))
(future-limit (org-x-dag-time-shift sel-datetime warn-shift warn-shifttype))) (future-limit (org-x-dag-datetime-shift sel-datetime warn-shift warn-shifttype)))
(org-x-dag-unfold-timestamp sel-datetime d r future-limit))) (org-x-dag-unfold-timestamp sel-datetime d r future-limit)))
(defun org-x-dag-headline-get-planning () (defun org-x-dag-headline-get-planning ()
@ -1119,24 +1177,6 @@ FUTURE-LIMIT in a list."
;; misc ;; misc
'type (concat "tagsmatch" ts-type))))) 'type (concat "tagsmatch" ts-type)))))
(defun org-x-dag-date-to-gregorian (date)
(-let (((y m d) date))
`(,m ,d ,y)))
(defun org-x-dag-time-get-clock-time (time)
(when (org-ml-time-is-long time) (list (nth 3 time) (nth 4 time))))
(defun org-x-dag-time-partition (time)
(if (org-ml-time-is-long time) (-split-at 3 time) `(,(-take 3 time) nil)))
(defun org-x-dag-date-diff (date0 date1)
""
(pcase (list date0 date1)
(`((,y0 ,m0 ,d0) (,y1 ,m1 ,d1))
(- (calendar-absolute-from-gregorian `(,m0 ,d0 ,y0))
(calendar-absolute-from-gregorian `(,m1 ,d1 ,y1))))
(_ (error "Invalid date format(s): %S or %S" date0 date1))))
(defun org-x-dag-format-item (id extra category tags time) (defun org-x-dag-format-item (id extra category tags time)
(let* ((tags* (org-x-dag-prepare-tags tags)) (let* ((tags* (org-x-dag-prepare-tags tags))
(head (org-get-heading)) (head (org-get-heading))
@ -1153,26 +1193,21 @@ FUTURE-LIMIT in a list."
'priority priority)))) 'priority priority))))
(defun org-x-dag-planning-props (id face pos date ts-date type) (defun org-x-dag-planning-props (id face pos date ts-date type)
(cl-flet (list
((to-abs ;; face
(date) 'face (if (org-x-dag-id->is-done-p id) 'org-agenda-done face)
(->> (org-x-dag-date-to-gregorian date) 'undone-face face
(calendar-absolute-from-gregorian)))) 'done-face 'org-agenda-done
(list ;; marker
;; face 'org-hd-marker (org-agenda-new-marker)
'face (if (org-x-dag-id->is-done-p id) 'org-agenda-done face) 'org-marker (org-agenda-new-marker pos)
'undone-face face ;; headline stuff
'done-face 'org-agenda-done 'date (org-x-dag-date-to-absolute date)
;; marker 'ts-date (org-x-dag-date-to-absolute ts-date)
'org-hd-marker (org-agenda-new-marker) 'type type))
'org-marker (org-agenda-new-marker pos)
;; headline stuff
'date (to-abs date)
'ts-date (to-abs ts-date)
'type type)))
(defun org-x-dag-format-scheduled-node (sel-date pos datetime category tags id) (defun org-x-dag-format-scheduled-node (sel-date pos datetime category tags id)
(-let* (((this-date this-time) (org-x-dag-time-partition datetime)) (-let* (((this-date this-time) (org-x-dag-datetime-split datetime))
(diff (org-x-dag-date-diff this-date sel-date)) (diff (org-x-dag-date-diff this-date sel-date))
(pastp (< diff 0)) (pastp (< diff 0))
(todayp (= diff 0)) (todayp (= diff 0))
@ -1192,7 +1227,7 @@ FUTURE-LIMIT in a list."
(org-add-props props)))) (org-add-props props))))
(defun org-x-dag-format-deadline-node (sel-date pos datetime category tags id) (defun org-x-dag-format-deadline-node (sel-date pos datetime category tags id)
(-let* (((this-date this-time) (org-x-dag-time-partition datetime)) (-let* (((this-date this-time) (org-x-dag-datetime-split datetime))
(diff (org-x-dag-date-diff this-date sel-date)) (diff (org-x-dag-date-diff this-date sel-date))
(pastp (< diff 0)) (pastp (< diff 0))
(futurep (< 0 diff)) (futurep (< 0 diff))
@ -1729,8 +1764,8 @@ FUTURE-LIMIT in a list."
(-let (((&plist :pos) pts) (-let (((&plist :pos) pts)
(donep (org-x-dag-id->is-done-p id))) (donep (org-x-dag-id->is-done-p id)))
(--> datetimes (--> datetimes
(--remove (and donep (not (org-x-dag-date= (-take 3 it) sel-date))) it) (--remove (and donep (not (org-x-dag-datetime= (-take 3 it) sel-date))) it)
(if (not todayp) (--remove (org-x-dag-date< (-take 3 it) sel-date) it) it) (if (not todayp) (--remove (org-x-dag-datetime< (-take 3 it) sel-date) it) it)
(--map (funcall format-datetime-fun sel-date pos it cat tags id) it))))))) (--map (funcall format-datetime-fun sel-date pos it cat tags id) it)))))))
(format-id (format-id
(todayp cat id) (todayp cat id)
@ -1748,9 +1783,7 @@ FUTURE-LIMIT in a list."
#'org-x-dag-format-scheduled-node)))))))) #'org-x-dag-format-scheduled-node))))))))
(org-x-dag-with-files (org-x-get-action-files) (org-x-dag-with-files (org-x-get-action-files)
nil nil
(let ((todayp (->> (org-x-dag-date-to-gregorian sel-date) (let ((todayp (= (org-x-dag-date-to-absolute sel-date) (org-today))))
(calendar-absolute-from-gregorian)
(= (org-today)))))
(format-id todayp it-category it))))) (format-id todayp it-category it)))))
(defun org-x-dag-scan-quarterly-plan () (defun org-x-dag-scan-quarterly-plan ()
@ -1906,29 +1939,6 @@ FUTURE-LIMIT in a list."
;;; ALLOCATION ;;; ALLOCATION
(defun org-x-dag-quarter-to-date (quarter)
(-let (((y q) quarter))
(list y (1+ (* q 3)) 1)))
(defun org-x-dag-shift-quarter (quarter n unit)
(-let (((y q) quarter))
(pcase unit
(`year `(,(+ n y) ,q))
(`quarter
(let* ((x (+ q n))
(q* (mod x 4))
(y* (+ y (floor (/ x 4.0)))))
`(,y* ,q*))))))
(defun org-x-dag-quarter-diff (quarter1 quarter2)
(cl-flet
((qt-to-abs
(q)
(->> (org-x-dag-quarter-to-date q)
(org-x-dag-date-to-gregorian)
(calendar-absolute-from-gregorian))))
(- (qt-to-abs quarter1) (qt-to-abs quarter2))))
(pcase-defmacro regexp (capture regexp) (pcase-defmacro regexp (capture regexp)
`(and x (let ,capture (s-match ,regexp x)))) `(and x (let ,capture (s-match ,regexp x))))