From 74bcaa5ced42941492f321682a8c225379decbd1 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Mon, 14 Feb 2022 23:18:29 -0500
Subject: [PATCH] REF organize all the datetime functions

---
 local/lib/org-x/org-x-dag.el | 356 ++++++++++++++++++-----------------
 1 file changed, 183 insertions(+), 173 deletions(-)

diff --git a/local/lib/org-x/org-x-dag.el b/local/lib/org-x/org-x-dag.el
index 2cc2e41..e82bb1c 100644
--- a/local/lib/org-x/org-x-dag.el
+++ b/local/lib/org-x/org-x-dag.el
@@ -28,15 +28,165 @@
 (require 'dag)
 (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
 
 ;; variables to store state
 
-(defun org-x-dag-create (d m f)
-  (list :dag d :id->meta m :file->ids f))
+(defun org-x-dag-create (d m f c)
+  (list :dag d :id->meta m :file->ids f :current-date c))
 
 (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)
                         
@@ -220,65 +370,13 @@ Is a list like (YEAR QUARTER).")
   "The current week to be used for planning.
 A date like (YEAR MONTH DAY).")
 
-(defvar org-x-dag-week-start-index 0
-  "The day considered to start a week (0 = Sunday).")
+;; (defvar org-x-dag-week-start-index 0
+;;   "The day considered to start a week (0 = Sunday).")
 
 (defvar org-x-dag-selected-date nil
   "The current week to be used for planning.
 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 buffer tags
@@ -308,7 +406,7 @@ A date like (YEAR MONTH DAY).")
   (format "W%02d" week))
 
 (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)
   (format "D%02d" day))
@@ -983,42 +1081,6 @@ encountered will be returned."
        ,form
      (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)
   "Return the next timestamp repeater of DATETIME."
   (pcase reptype
@@ -1031,17 +1093,17 @@ encountered will be returned."
      (let ((next datetime)
            (pastp t))
        (while pastp
-         (setq next (org-x-dag-time-shift next shift shifttype)
-               pastp (org-x-dag-date< next sel-datetime)))
+         (setq next (org-x-dag-datetime-shift next shift shifttype)
+               pastp (org-x-dag-datetime< next sel-datetime)))
        next))
     ('restart
      ;; Next time is one repeater interval after now
      ;;
      ;; 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
      ;; 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)
   "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
 FUTURE-LIMIT in a list."
   ;; 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
       (`nil `(,datetime))
       (`(,value ,unit ,reptype)
        (->> (org-x-dag-repeater-get-next cur datetime value unit reptype)
-            (--unfold (unless (org-x-dag-date< future-limit it)
-                        (cons it (org-x-dag-time-shift it value unit))))
+            (--unfold (unless (org-x-dag-datetime< future-limit it)
+                        (cons it (org-x-dag-datetime-shift it value unit))))
             (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)
   (-let* (((&plist :datetime d :repeater r) pts)
           (islongp (org-ml-time-is-long d))
           (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)))
 
 (defun org-x-dag-get-deadlines-at (sel-date pts)
@@ -1077,8 +1135,8 @@ FUTURE-LIMIT in a list."
            (if w w
              (let ((f (if islongp 1440 1)))
                `(,(* f org-deadline-warning-days) submonth))))
-          (sel-datetime (if islongp (org-x-dag-date-add-time sel-date) sel-date))
-          (future-limit (org-x-dag-time-shift sel-datetime warn-shift warn-shifttype)))
+          (sel-datetime (if islongp (org-x-dag-date-at-current-time sel-date) sel-date))
+          (future-limit (org-x-dag-datetime-shift sel-datetime warn-shift warn-shifttype)))
     (org-x-dag-unfold-timestamp sel-datetime d r future-limit)))
 
 (defun org-x-dag-headline-get-planning ()
@@ -1119,24 +1177,6 @@ FUTURE-LIMIT in a list."
             ;; misc
             '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)
   (let* ((tags* (org-x-dag-prepare-tags tags))
          (head (org-get-heading))
@@ -1153,26 +1193,21 @@ FUTURE-LIMIT in a list."
             'priority priority))))
 
 (defun org-x-dag-planning-props (id face pos date ts-date type)
-  (cl-flet
-      ((to-abs
-        (date)
-        (->> (org-x-dag-date-to-gregorian date)
-             (calendar-absolute-from-gregorian))))
-    (list
-     ;; face
-     'face (if (org-x-dag-id->is-done-p id) 'org-agenda-done face)
-     'undone-face face
-     'done-face 'org-agenda-done
-     ;; marker
-     'org-hd-marker (org-agenda-new-marker)
-     'org-marker (org-agenda-new-marker pos)
-     ;; headline stuff
-     'date (to-abs date)
-     'ts-date (to-abs ts-date)
-     'type type)))
+  (list
+   ;; face
+   'face (if (org-x-dag-id->is-done-p id) 'org-agenda-done face)
+   'undone-face face
+   'done-face 'org-agenda-done
+   ;; marker
+   'org-hd-marker (org-agenda-new-marker)
+   'org-marker (org-agenda-new-marker pos)
+   ;; headline stuff
+   'date (org-x-dag-date-to-absolute date)
+   'ts-date (org-x-dag-date-to-absolute ts-date)
+   'type type))
 
 (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))
           (pastp (< diff 0))
           (todayp (= diff 0))
@@ -1192,7 +1227,7 @@ FUTURE-LIMIT in a list."
         (org-add-props props))))
 
 (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))
           (pastp (< diff 0))
           (futurep (< 0 diff))
@@ -1729,8 +1764,8 @@ FUTURE-LIMIT in a list."
               (-let (((&plist :pos) pts)
                      (donep (org-x-dag-id->is-done-p id)))
                 (--> datetimes
-                     (--remove (and donep (not (org-x-dag-date= (-take 3 it) sel-date))) it)
-                     (if (not todayp) (--remove (org-x-dag-date< (-take 3 it) sel-date) it) it)
+                     (--remove (and donep (not (org-x-dag-datetime= (-take 3 it) sel-date))) 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)))))))
        (format-id
         (todayp cat id)
@@ -1748,9 +1783,7 @@ FUTURE-LIMIT in a list."
                                     #'org-x-dag-format-scheduled-node))))))))
     (org-x-dag-with-files (org-x-get-action-files)
         nil
-      (let ((todayp (->> (org-x-dag-date-to-gregorian sel-date)
-                         (calendar-absolute-from-gregorian)
-                         (= (org-today)))))
+      (let ((todayp (= (org-x-dag-date-to-absolute sel-date) (org-today))))
         (format-id todayp it-category it)))))
 
 (defun org-x-dag-scan-quarterly-plan ()
@@ -1906,29 +1939,6 @@ FUTURE-LIMIT in a list."
 
 ;;; 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)
   `(and x (let ,capture (s-match ,regexp x))))