From 517d4aca9c65071452ba9bec57e0dedc574b833c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sat, 4 Jul 2020 17:44:34 +0200
Subject: Major reordering in datetime.

---
 module/datetime.scm | 1440 +++++++++++++++++++++++++--------------------------
 1 file changed, 718 insertions(+), 722 deletions(-)

(limited to 'module/datetime.scm')

diff --git a/module/datetime.scm b/module/datetime.scm
index 126695d1..a95eac47 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -19,6 +19,9 @@
   :re-export (locale-month)
   )
 
+
+;;; Enums
+
 (define-many define-public
   (jan january   ) 1
   (feb february  ) 2
@@ -31,8 +34,26 @@
   (sep september ) 9
   (oct october   ) 10
   (nov november  ) 11
-  (dec december  ) 12
-  )
+  (dec december  ) 12)
+
+(define-many define-public
+  (sun) 0
+  (mon) 1
+  (tue) 2
+  (wed) 3
+  (thu) 4
+  (fri) 5
+  (sat) 6)
+
+
+;;; Configuration
+
+(define-public week-start (make-parameter sun))
+
+(define-config week-start sun
+  "First day of week"
+  pre: (ensure (lambda (x) (<= sun x sat)))
+  post: week-start)
 
 
 ;;; RECORD TYPES
@@ -151,6 +172,15 @@
   (set (tz (tm->datetime (gmtime n)))
        "UTC"))
 
+
+;; this returns UTC time, with a TZ component set to "UTC"
+(define-public (current-datetime)
+  (unix-time->datetime ((@ (guile) current-time))))
+
+(define-public (current-date)
+  (get-date (current-datetime)))
+
+
 
 
 ;; datetime → datetime
@@ -169,9 +199,31 @@
       ;; strip tz-name, to conform with my local time.
       (set (tz (tm->datetime tm)) #f))))
 
+(define-public (as-date date/-time)
+  (cond [(datetime? date/-time) (get-date date/-time)]
+        [(date? date/-time) date/-time]
+        [(time? date/-time) (date)]
+        [else (error "Object not a date, time, or datetime object ~a" date/-time)]))
+
+(define-public (as-time date/-time)
+  (cond [(datetime? date/-time) (get-time% date/-time)]
+        [(date? date/-time) (time)]
+        [(time? date/-time) date/-time]
+        [else (error "Object not a date, time, or datetime object ~a" date/-time)]))
+
+(define-public (as-datetime dt)
+  (cond [(datetime? dt) dt]
+        [(date? dt) (datetime date: dt time: (time))]
+        [(time? dt) (datetime time: dt date: (date))]
+        [else (error "Object not a date, time, or datetime object ~a" dt)]))
+
 
 
-;;; UTIL
+(define-public (date-zero? date)
+  (= 0 (year date) (month date) (day date)))
+
+(define-public (time-zero? time)
+  (= 0 (hour time) (minute time) (second time)))
 
 ;; int -> bool
 (define-public (leap-year? year)
@@ -193,459 +245,377 @@
   (if (leap-year? (year date))
       366 365))
 
-
-
-(define-public (as-date date/-time)
-  (cond [(datetime? date/-time) (get-date date/-time)]
-        [(date? date/-time) date/-time]
-        [(time? date/-time) (date)]
-        [else (error "Object not a date, time, or datetime object ~a" date/-time)]))
-
-(define-public (as-time date/-time)
-  (cond [(datetime? date/-time) (get-time% date/-time)]
-        [(date? date/-time) (time)]
-        [(time? date/-time) date/-time]
-        [else (error "Object not a date, time, or datetime object ~a" date/-time)]))
+(define-public (start-of-month date)
+  (set (day date) 1))
 
-(define-public (as-datetime dt)
-  (cond [(datetime? dt) dt]
-        [(date? dt) (datetime date: dt time: (time))]
-        [(time? dt) (datetime time: dt date: (date))]
-        [else (error "Object not a date, time, or datetime object ~a" dt)]))
+(define-public (end-of-month date)
+  (set (day date) (days-in-month date)))
 
-
-;;; EQUIALENCE
+(define-public (start-of-year date)
+  (set-> date
+         (day 1)
+         (month 1)))
 
-(define-public (date= . args)
-  (reduce (lambda (a b)
-            (and b ; did a previous iteration return false?
-                 (= (year a) (year b))
-                 (= (month a) (month b))
-                 (= (day a) (day b))
-                 ;; return object
-                 a))
-          #t args))
+(define-public (date-stream date-increment start-day)
+  (stream-iterate (lambda (d) (date+ d date-increment))
+                  start-day))
 
-(define-public (time= . args)
-  (reduce (lambda (a b)
-            (and b
-                 (= (hour a) (hour b))
-                 (= (minute a) (minute b))
-                 (= (second a) (second b))
-                 a))
-          #t args))
+(define-public (day-stream start-day)
+  (date-stream (date day: 1) start-day))
 
-(define-public (datetime= . args)
-  (reduce (lambda (a b)
-            (and (date= (get-date a) (get-date b))
-                 (time= (get-time% a) (get-time% b))
-                 a))
-          #t args))
+(define-public (month-stream start-day)
+  (date-stream (date month: 1) start-day))
 
-(define-many define-public
-  (date=?) date=
-  (time=?) time=
-  (datetime=?) datetime=)
+(define-public (week-stream start-day)
+  (date-stream (date day: 7) start-day))
 
-(define (date<% a b)
-  (let ((ay (year a))
-        (by (year b)))
-    (if (= ay by)
-        (let ((am (month a))
-              (bm (month b)))
-          (if (= am bm)
-              (< (day a) (day b))
-              (< am bm)))
-        (< ay by))))
+(define-public (time-min a b)
+  (if (time<? a b) a b))
 
-(define-public date<
-  (case-lambda
-    [() #t]
-    [(_) #t]
-    [(first second . rest)
-     (and (date<% first second)
-          (apply date< second rest))]))
+(define-public (time-max a b)
+  (if (time<? a b) b a))
 
-(define (date<=% a b)
-  (or (date= a b)
-      (date< a b)))
+(define-public (date-min a b)
+  (if (date< a b) a b))
 
-(define-public date<=
-  (case-lambda
-    [() #t]
-    [(_) #t]
-    [(first second . rest)
-     (and (date<=% first second)
-          (apply date<= second rest))]))
+(define-public (date-max a b)
+  (if (date< a b) b a))
 
-(define-public (time< a b)
-  (let ((ah (hour a))
-        (bh (hour b)))
-    (if (= ah bh)
-        (let ((am (minute a))
-              (bm (minute b)))
-          (if (= am bm)
-              (< (second a) (second b))
-              (< am bm)))
-        (< ah bh))))
+(define-public (datetime-min a b)
+  (if (datetime< a b) a b))
 
-(define-public (time<= a b)
-  (or (time= a b)
-      (time< a b)))
+(define-public (datetime-max a b)
+  (if (datetime< a b) b a))
 
-(define-public (datetime< a b)
-  (if (date= (get-date a) (get-date b))
-      (time< (get-time% a) (get-time% b))
-      (date< (get-date a) (get-date b))))
+(define*-public (month+ date-object #:optional (change 1))
+  (date+ date-object (date month: change)))
 
-(define-public (datetime<= a b)
-  (if (date= (get-date a) (get-date b))
-      (time<= (get-time% a) (get-time% b))
-      (date<= (get-date a) (get-date b))))
+(define*-public (month- date-object #:optional (change 1))
+  (date- date-object (date month: change)))
 
-(define-public (date/-time< a b)
-  (datetime< (as-datetime a) (as-datetime b)))
+;; https://projecteuclid.org/euclid.acta/1485888738
+;; 1. Begel.
+;; J sei die Zahl des Jahrhunderts,
+;; K die Jahrszahl innerhalb desselben,
+;; m die Zahl des Monats,
+;; q die Zahl des Monatstags,
+;; h die Zahl des Wochentags;
+(define (zeller J K m q)
+  (modulo (+ q
+             (floor-quotient (* 13 (1+ m))
+                             5)
+             K
+             (floor-quotient K 4)
+             5
+             (- J))
+          7))
 
-(define-many define-public
-  (date<?) date<
-  (date> date>?) (swap date<)
-  (date<=?) date<=
-  (date>= date>=?) (swap date<=)
+;; 0 indexed, starting at sunday.
+(define-public (week-day date)
+  (let* ((J K (floor/ (year date) 100))
+         (m (month date)))
+    (if (memv m '(1 2))
+        (zeller J (1- K) (+ m 12) (day date))
+        (zeller J K (month date) (day date)))))
 
-  (time<?) time<
-  (time> time>?) (swap time<)
-  (time<=?) time<=
-  (time>= time>=?) (swap time<=)
 
-  (datetime<?) datetime<
-  (datetime> datetime>?) (swap datetime<)
-  (datetime<=?) datetime<=
-  (datetime>= datetime>=?) (swap datetime<=)
 
-  (date/-time<?) date/-time<
-  (date/-time> date/-time>?) (swap date/-time<)
-  (date/-time<= date/-time<=?) (negate date/-time>)
-  (date/-time>= date/-time>=?) (negate date/-time<)
-  )
+;; given a date, returns the date the first week of that year starts on.
+;; @example
+;; (week-1-start #2020-01-01 mon)
+;; ⇒ 2019-12-30
+;; @end example
+(define*-public (week-1-start d optional: (wkst (week-start)))
+  (let* ((ystart (start-of-year d))
+         (day-index (modulo (- (week-day ystart) wkst) 7)))
+    (if (> day-index 3)
+        (date+ ystart (date day: (- 7 day-index)))
+        (date- ystart (date day: day-index)))))
 
-
+;; (week-number #2020-01-01 mon) ; => 1
+;; (week-number #2019-12-31 mon) ; => 1
+(define*-public (week-number d optional: (wkst (week-start)))
+  ;; Calculating week number for starts of week was much simpler.
+  ;; We can both skip the special cases for Jan 1, 2 & 3. It also
+  ;; solved some weird bug that was here before.
 
-;;; OPERATIONS
+  (let ((d (start-of-week d wkst)))
+   (cond
+    [(and (= 12 (month d))
+          (memv (day d) '(29 30 31))
+          (< (year d) (year (date+ (start-of-week d wkst)
+                                   (date day: 3)))))
+     1]
 
-(define-public (date-zero? date)
-  (= 0 (year date) (month date) (day date)))
+    [else
+     (let* ((w1-start (week-1-start d wkst))
+            (week day (floor/ (days-in-interval w1-start d)
+                              7)))
+       (1+ week))])))
 
-(define-public (time-zero? time)
-  (= 0 (hour time) (minute time) (second time)))
-
-;; TODO +1 month is weird for late days in a month.
-;; is the last of january +1 month the last of february,
-;; or a few days into march? It's at least not the 31 of
-;; February, as the code is currently written.
-;; (date+ #2020-01-31 #0000-01-00) ; => 2020-02-31
-(define (date+%% change base)
+(define*-public (date-starting-week
+                 week-number d
+                 optional: (wkst (week-start)))
+  (date+ (week-1-start d wkst)
+         (date day: (* (1- week-number) 7))))
 
-  (define-values (days-fixed change*)
-    (let loop ((target base) (change change))
-      (if (>= (days-in-month target) (+ (day change) (day target)))
-          ;; No date overflow, just add the change
-          (values (set-> target (day = (+ (day change))))
-                  (set-> change (day 0)))
-          ;; Date (and possibly year) overflow
-          (loop (if (= 12 (month target))
-                    (set-> target
-                           (year = (+ 1))
-                           (month 1)
-                           (day 1))
-                    (set-> target
-                           (month = (+ 1))
-                           (day 1)))
-                (set-> change
-                       (day = (- (1+ (- (days-in-month target) (day target))))))))))
 
-  (define-values (month-fixed change**)
-    (if (date-zero? change*)
-        (values days-fixed change*)
-     (let loop ((target days-fixed) (change change*))
-       (if (< 12 (+ (month change) (month target)))
-           ;; if we overflow into the next year
-           (loop (set-> target
-                        (year = (+ 1))
-                        (month 1))
-                 (set (month change) = (- (- 13 (month target)))))
+(define*-public (week-day-name week-day-number optional: truncate-to
+                               key: (locale %global-locale))
 
-           ;; if we don't overflow our date
-           (values (set (month target) = (+ (month change)))
-                   (set (month change) 0))
+  ;; NOTE this allows days larger than 7 (sunday if counting from monday).
+  (let ((str (catch 'out-of-range
+               (lambda () (locale-day (1+ (modulo week-day-number 7)) locale))
+               (lambda (oor str num)
+                 (scm-error 'out-of-range 'week-day-name
+                            "~a == (~a % 7) + 1"
+                            (list num week-day-number)
+                            (list week-day-number))))))
+    ;; I also know about the @var{locale-day-short} method, but I need
+    ;; strings of length 2.
+    (if truncate-to
+        (string-take str truncate-to)
+        str)))
 
-           ))))
 
-  ;; change** should here should have both month and date = 0
+;; @verbatim
+;;    A          B          C          D          E         ¬F
+;; |s1|     :     |s2| : |s1|     :     |s2| :          : |s1|
+;; |  |     :     |  | : |  ||s2| : |s1||  | : |s1||s2| : |  |
+;; |  ||s2| : |s1||  | : |  ||  | : |  ||  | : |  ||  | :
+;;     |  | : |  |     : |  ||  | : |  ||  | : |  ||  | :     |s2|
+;;     |  | : |  |     : |  |     :     |  | :          :     |  |
+;;
+;; Infinitely short ---+|s2| : |s1|+--- : two instants don't overlap
+;; events, overlap   s1      :      s2  :
+;; @end verbatim
+;; 
+;; E is covered by both case A and B.
+(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end)
+  "Return whetever or not two timespans overlap."
+  (or
+   ;; A
+   (and (date/-time<? s2-begin s1-end)
+        (date/-time<? s1-begin s2-end))
 
-  (set (year month-fixed) = (+ (year change**))))
+   ;; B
+   (and (date/-time<? s1-begin s2-end)
+        (date/-time<? s2-begin s1-end))
 
-(define (date+% change base)
+   ;; C
+   (and (date/-time<=? s1-begin s2-begin)
+        (date/-time<? s2-end s1-end))
 
-  (when (or (negative? (year change))
-            (negative? (month change))
-            (negative? (day change)))
-    (error "Change can't be negative"))
+   ;; D
+   (and (date/-time<=? s2-begin s1-begin)
+        (date/-time<? s1-end s2-end))))
 
-  (unless (and (< 0 (month base))
-               (< 0 (day base)))
-    (error "Base day and month needs to be at least one" base))
 
-  (date+%% change base))
+;; Returns the first instance of the given week-day after @var{d}.
+;; @example
+;; (find-first-week-day mon #2020-04-01)
+;; => #2020-04-06
+;; (find-first-week-day mon #2020-04-10)
+;; => #2020-04-13
+;; (find-first-week-day mon #2020-04-30)
+;; => #2020-05-04
+;; @end example
+(define-public (find-first-week-day wday d)
+  (let* ((start-day (week-day d))
+         (diff (- wday start-day)))
+    (date+ d (date day: (modulo diff 7)))))
 
-;; @var{base} MUST be a valid real date. all rest arguments can however
-;; be "invalid" dates, such as 0000-00-10
-(define-public (date+ base . rest)
-  (fold date+% base rest))
+;; returns instances of the given week-day in month between
+;; month-date and end of month.
+;; @example
+;; (all-wday-in-month mon #2020-06-01)
+;; => (#2020-06-01 #2020-06-08 #2020-06-15 #2020-06-22 #2020-06-29)
+;; (all-wday-in-month mon #2020-06-10)
+;; => (#2020-06-15 #2020-06-22 #2020-06-29)
+;; @end example
+;; week-day, date → (list date)
+(define-public (all-wday-in-month wday month-date)
+  (stream->list
+   (stream-take-while
+    (lambda (d) (= (month d) (month month-date)))
+    (week-stream (find-first-week-day wday month-date)))))
 
-(define (date-%% change base)
-  (define-values (days-fixed change*)
-    (let loop ((target base) (change change))
-      (if (>= (day change) (day target))
-          (let ((new-change (set (day change) = (- (day target)))))
-            (loop (if (= 1 (month target))
-                      (set-> target
-                             (year = (- 1))
-                             (month 12)
-                             (day 31)              ; days in december
-                             )
-                      (set-> target
-                             (month = (- 1))
-                             (day (days-in-month (set (month target) = (- 1))))))
-                  new-change))
-          (values (set (day target) = (- (day change)))
-                  (set (day change) 0)))))
 
-  (define-values (month-fixed change**)
-    (let loop ((target days-fixed) (change change*))
-      (if (>= (month change) (month target))
-          (loop (set-> target
-                       (year = (- 1))
-                       (month 12))
-                (set (month change) = (- (month target))))
-          (values (set (month target) = (- (month change)))
-                  (set (month change) 0)))))
+(define-public (all-wday-in-year wday year-date)
+  (stream->list
+   (stream-take-while
+    (lambda (d) (= (year d) (year year-date)))
+    (week-stream (find-first-week-day wday year-date)))))
 
-  ;; change** should here should have both month and date = 0
+(define-public (add-day d)
+  (date+ d (date day: 1)))
 
-  (set (year month-fixed) = (- (year change**))))
+(define-public (remove-day d)
+  (date- d (date day: 1)))
 
-(define (date-% change base)
+(define-public (in-date-range? start-date end-date)
+  (lambda (date)
+    (date<= start-date date end-date)))
 
-  (when (or (negative? (year change))
-            (negative? (month change))
-            (negative? (day change)))
-    (error "Change can't be negative"))
+;; Returns a list of the seven week days, with @var{week-start}
+;; as the beginning of the week.
+;; @example
+;; (weekday-list sun)
+;; => (0 1 2 3 4 5 6)
+;; @end example
+(define-public (weekday-list week-start)
+  (take (drop (apply circular-list (iota 7))
+              week-start)
+        7))
 
-  (when (or (negative? (month base))
-            (negative? (day base)))
-    (error "Base month or day can't be negative"))
+;; returns the date the week containing d started.
+;; (start-of-week #2020-04-02 sun) ; => 2020-03-29
+(define*-public (start-of-week d optional: (week-start (week-start)))
+  (date- d (date day: (modulo (- (week-day d)
+                                 week-start)
+                              7))))
 
-  (date-%% change base)
-  )
+;; (end-of-week #2020-04-01 mon)
+;; => 2020-04-05
+(define*-public (end-of-week d optional: (week-start (week-start)))
+  (date+ (start-of-week d week-start)
+         (date day: 6)))
 
-;;; Only use this with extreme caution
-(define-public (date- base . rest)
-  (fold date-% base rest))
 
-;;; time
+;; Given a month and and which day the week starts on,
+;; returns three lists, which are:
+;; The days leading up to the current month, but share a week
+;; The days in the current month
+;; The days after the current month, but which shares a week.
+;; 
+;;       mars 2020
+;; må ti on to fr lö sö
+;;                    1
+;;  2  3  4  5  6  7  8
+;;  9 10 11 12 13 14 15
+;; 16 17 18 19 20 21 22
+;; 23 24 25 26 27 28 29
+;; 30 31
+;; @lisp
+;; (month-days #2020-03-01 mon)
+;; ; ⇒ (2020-02-24 ... 2020-02-29)
+;; ; ⇒ (2020-03-01 ... 2020-03-31)
+;; ; ⇒ (2020-04-01 ... 2020-04-05)
+;; @end lisp
+;; Ignores day component of @var{date}.
+(define*-public (month-days date optional: (week-start (week-start)))
+  (let* ((month-len (days-in-month date))
+         (prev-month-len (days-in-month (month- date)))
+         (month-start (modulo (- (week-day date) week-start) 7)))
+    (values
+     (map (lambda (d) (set (day (month- date)) d))
+          (iota month-start (1+ (- prev-month-len month-start))))
+     (map (lambda (d) (set (day date) d)) (iota month-len 1))
+     (map (lambda (d) (set (day (month+ date)) d))
+          (iota (modulo (- (* 7 5) month-len month-start) 7) 1)))))
 
-;; overflow is number of days above
-;; time x time → time x int
-(define-public (time+% base change)
 
-  ;; while (day base) > (days-in-month base)
-  ;;     month++; days -= (days-in-month base)
-  (define second-fixed
-    (let loop ((target (set (second base) = (+ (second change)))))
-      (if (>= (second target) 60)
-          (loop (set-> target
-                       (minute = (+ 1))
-                       (second = (- 60))))
-          target)))
-
-  ;; while (month base) > 12
-  ;;     year++; month -= 12
-  (define minute-fixed
-    (let loop ((target (set (minute second-fixed) = (+ (minute change)))))
-      (if (>= (minute target) 60)
-          (loop (set-> target
-                       (hour = (+ 1))
-                       (minute = (- 60))))
-          target)))
-
-  (define hour-almost-fixed (set (hour minute-fixed) = (+ (hour change))))
-
-  (if (<= 24 (hour hour-almost-fixed))
-      (let* ((div remainder (floor/ (hour hour-almost-fixed) 24)))
-        (values (set (hour hour-almost-fixed) remainder) div))
-      (values hour-almost-fixed 0)))
-
-;;; PLUS
-(define-public (time+ base . rest)
-  (let ((sum 0))
-    (let ((time (fold (lambda (next done)
-                        (let* ((next-time rem (time+% done next)))
-                          (mod! sum = (+ rem))
-                          next-time))
-                      base rest)))
-      (values time sum))))
-
-;; time, Δtime → time, hour
-(define (time-% base change)
-
-  (define-values (second-fixed change*)
-    (let loop ((target base) (change change))
-      (if (> (second change) (second target))
-          (loop (set-> target
-                       (minute = (- 1))
-                       (second 60))
-                (set (second change) = (- (second target))))
-          (values (set (second target) = (- (second change)))
-                  (set (second change) 0)))))
-
-  (define-values (minute-fixed change**)
-    (let loop ((target second-fixed) (change change*))
-      (if (> (minute change) (minute target))
-          (loop (set-> target
-                       (hour = (- 1))
-                       (minute 60))
-                (set (minute change) = (- (minute target))))
-          (values (set (minute target) = (- (minute change)))
-                  (set (minute change) 0)))))
-
-  (if (>= (hour minute-fixed) (hour change**))
-      (values (set (hour minute-fixed) = (- (hour change**))) 0)
-      (let ((diff (- (hour minute-fixed)
-                     (hour change**))))
-        (values (set (hour minute-fixed) (modulo diff 24))
-                (abs (floor (/ diff 24)))))))
-
-;; Goes backwards from base, returning the two values:
-;; the new time, and the number of days back we went.
-;; Note that neither time+ or time- can return a time
-;; component greater than 24h, but nothing is stoping
-;; a user from creating them manually.
-;; @lisp
-;; (time- #10:00:00 #09:00:00) ; => 01:00:00 => 0
-;; (time- #03:00:00 #07:00:00) ; => 20:00:00 => 1
-;; (time- #10:00:00 (time hour: 48)) ; => 10:00:00 => 2
-;; (time- #10:00:00 (time hour: (+ 48 4))) ; => 06:00:00 => 2
-;; @end lisp
-(define-public (time- base . rest)
-  (let ((sum 0))
-    (let ((time (fold (lambda (next done)
-                        (let* ((next-time rem (time-% done next)))
-                          (mod! sum = (+ rem))
-                          next-time))
-                      base rest)))
-      (values time sum))))
-
-
-;;; DATETIME
-
-
-(define-public (datetime+ base change)
-  (let* ((time overflow (time+ (get-time% base) (get-time% change))))
-    (datetime date: (date+ (get-date base)
-                           (get-date change)
-                           (date day: overflow))
-              time: time
-              tz: (get-timezone base)
-              )))
-
-;;; the *-difference procedures takes two actual datetimes.
-;;; date- instead takes a date and a delta (but NOT an actual date).
-
-;; Works on 0-based dates. So the last of January 2020 becomes
-;; 2020-00-30
-(define (date-difference% b a)
-  ;; #2020-01-01 #2020-00-26 → #2020-00-06 #2020-00-00
-  (define-values (b* a*)
-    (let loop ((b b) (a a))
-      (if (> (day a) (day b))
-          (let ((new-a (set (day a) = (- (1+ (day b))))))
-            (loop (if (= 0 (month b))
-                      (set-> b
-                             (year = (- 1))
-                             (month 11)
-                             (day 30)   ; Last day in december
-                             )
-                      (set-> b
-                             (month = (- 1))
-                             (day (1- (days-in-month b))))) ; last in prev month
-                  new-a))
-          ;; elif (> (day b) (day a))
-          (values (set (day b) = (- (day a)))
-                  (set (day a) 0)))))
-
-
-  ;; (day a*) should be 0 here.
-
-  (define-values (b** a**)
-    (let loop ((b b*) (a a*))
-      (if (> (month a) (month b))
-          (loop (set-> b
-                       (year = (- 1))
-                       (month 11))
-                (set (month a) = (- (1+ (month b)))))
-          ;; elif (> (month b) (month a))
-          (values (set (month b) = (- (month a)))
-                  (set (month a) 0)))))
-
-  ;; a** should here should have both month and date = 0
-
-  (set (year b**) = (- (year a**))))
+(define-public (days-in-interval start-date end-date)
+  (let ((diff (date-difference (date+ end-date (date day: 1)) start-date)))
+    (with-streams
+     (fold + (day diff)
+           (map days-in-month
+                (take (+ (month diff)
+                         (* 12 (year diff)))
+                      (month-stream start-date)))))))
 
+;; Day from start of the year, so 1 feb would be day 32.
+;; Also known as Julian day.
+(define-public (year-day date)
+  (days-in-interval (start-of-year date) date))
 
 
-;; NOTE, this is only properly defined when b is greater than a.
-(define-public (date-difference b a)
-  (when (or (negative? (month b))
-            (negative? (day   b))
-            (negative? (month a))
-            (negative? (day   a)) )
-    (error "Negative months or days are errors"))
+;; @example
+;; (time->decimal-hour #10:30:00) ; => 10.5
+;; @end example
+(define-public (time->decimal-hour time)
+  (exact->inexact (+ (hour time)
+                     (/ (minute time) 60)
+                     (/ (second time) 3600))))
 
-  (date-difference% (set-> b
-                           (month = (- 1))
-                           (day = (- 1)))
-                    (set-> a
-                           (month = (- 1))
-                           (day = (- 1)))))
+(define*-public (datetime->decimal-hour dt optional: start-date)
 
+  (let ((date-diff
+         (cond [start-date
+                (let* ((end-date (date+ start-date (get-date dt))))
+                  (days-in-interval start-date end-date)) ]
+               [(or (not (zero? (month (get-date dt))))
+                    (not (zero? (year (get-date dt)))))
+                (error "Multi-month intervals only supported when start-date is given" dt)]
+               [else (day (get-date dt))])))
+    (+ (time->decimal-hour (get-time% dt))
+       (* (1- date-diff) 24))))
 
-;; NOTE, this is only properly defined when end is greater than start.
-(define-public (datetime-difference end start)
-  ;; NOTE Makes both start and end datetimes in the current local time.
-  (let* ((fixed-time overflow (time- (get-time% end)
-                                     (get-time% start))))
-    (datetime date: (date-difference (date- (get-date end)
-                                            (date day: overflow))
-                                     (get-date start))
-              time: fixed-time)))
+;; Returns a list of all dates from start to end.
+;; both inclusive
+;; date, date → [list date]
+(define-public (date-range start end)
+  (stream->list
+   (stream-take-while (lambda (d) (date<= d end))
+                      (day-stream start))))
 
 
+;;; Output
 
-;; this returns UTC time, with a TZ component set to "UTC"
-(define-public (current-datetime)
-  (unix-time->datetime ((@ (guile) current-time))))
+(define*-public (datetime->string
+                 datetime
+                 optional: (fmt "~Y-~m-~dT~H:~M:~S")
+                 key: allow-unknown?)
+  (define date (get-date datetime))
+  (define time (get-time% datetime))
+  (with-output-to-string
+    (lambda ()
+      (fold (lambda (token state)
+              (case state
+                ((#\~)
+                 (case token
+                   ((#\~) (display "~"))
+                   ((#\H) (format #t "~2'0d" (hour time)))
+                   ((#\k) (format #t "~2' d" (hour time)))
+                   ((#\M) (format #t "~2'0d" (minute time)))
+                   ((#\S) (format #t "~2'0d" (second time)))
+                   ((#\Y) (format #t "~4'0d" (year date)))
+                   ((#\m) (format #t "~2'0d" (month date)))
+                   ((#\d) (format #t "~2'0d" (day date)))
+                   ;; Should be same as ~_d
+                   ((#\s) (display (datetime->unix-time datetime))) ; epoch time!
+                   ((#\e) (format #t "~2' d" (day date)))
+                   ((#\1) (format #t "~4'0d-~2'0d-~2'0d"
+                                  (year date) (month date) (day date)))
+                   ((#\3) (format #t "~2'0d:~2'0d:~2'0d"
+                                  (hour time) (minute time) (second time)))
+                   ((#\A) (display (week-day-name (week-day date))))
+                   ((#\a) (display (week-day-name (week-day date) 3)))
+                   ((#\b) (display (locale-month-short (month date))))
+                   ((#\B) (display (locale-month (month date))))
+                   ((#\Z) (when (equal? "UTC" (get-timezone datetime)) (display "Z")))
+                   (else (unless allow-unknown?
+                           (error 'datetime->string "Invalid format token ~a" token))))
+                 #f)
+                (else (unless (char=? #\~ token) (display token)) token)))
+            #f
+            (string->list fmt)))))
 
-(define-public (current-date)
-  (get-date (current-datetime)))
+(define*-public (date->string date
+                              optional: (fmt "~Y-~m-~d")
+                              key: allow-unknown?)
+  (datetime->string (datetime date: date)
+                    fmt allow-unknown?: allow-unknown?))
 
-
-
+(define*-public (time->string time
+                              optional: (fmt "~H:~M:~S")
+                              key: allow-unknown?)
+  (datetime->string (datetime time: time)
+                    fmt allow-unknown?: allow-unknown?))
 
 
-(define-public (parse-freeform-date str)
-  (let* (((year month day) (map string->number (string-split str #\-))))
-    (date year: year month: month day: day)
-    ))
+
+;;; Input
 
 (define*-public (string->datetime str optional: (fmt "~Y-~m-~dT~H:~M:~S~Z"))
   (let loop ((str (string->list str))
@@ -718,7 +688,6 @@
 (define*-public (string->date str optional: (fmt "~Y-~m-~d"))
   (get-date (string->datetime str fmt)))
 
-
 
 (define-public (parse-ics-date str)
   (string->date str "~Y~m~d"))
@@ -741,6 +710,9 @@
 (define-public (parse-iso-datetime str)
   (string->datetime str))
 
+(define-public (parse-freeform-date str)
+  (parse-iso-datetime str))
+
 (define (date->sexp d)
   `(date year: ,(year d)
          month: ,(month d)
@@ -770,391 +742,415 @@
 (read-hash-extend #\1 date-reader)
 (read-hash-extend #\2 date-reader)
 
-
 
+;;; Everything below really messy
 
+;;; EQUIALENCE
 
-(define-public (start-of-month date)
-  (set (day date) 1))
-
-(define-public (end-of-month date)
-  (set (day date) (days-in-month date)))
-
-(define-public (start-of-year date)
-  (set-> date
-         (day 1)
-         (month 1)))
+(define-public (date= . args)
+  (reduce (lambda (a b)
+            (and b ; did a previous iteration return false?
+                 (= (year a) (year b))
+                 (= (month a) (month b))
+                 (= (day a) (day b))
+                 ;; return object
+                 a))
+          #t args))
 
-(define-public (date-stream date-increment start-day)
-  (stream-iterate (lambda (d) (date+ d date-increment))
-                  start-day))
+(define-public (time= . args)
+  (reduce (lambda (a b)
+            (and b
+                 (= (hour a) (hour b))
+                 (= (minute a) (minute b))
+                 (= (second a) (second b))
+                 a))
+          #t args))
 
-(define-public (day-stream start-day)
-  (date-stream (date day: 1) start-day))
+(define-public (datetime= . args)
+  (reduce (lambda (a b)
+            (and (date= (get-date a) (get-date b))
+                 (time= (get-time% a) (get-time% b))
+                 a))
+          #t args))
 
-(define-public (month-stream start-day)
-  (date-stream (date month: 1) start-day))
+(define-many define-public
+  (date=?) date=
+  (time=?) time=
+  (datetime=?) datetime=)
 
-(define-public (week-stream start-day)
-  (date-stream (date day: 7) start-day))
+(define (date<% a b)
+  (let ((ay (year a))
+        (by (year b)))
+    (if (= ay by)
+        (let ((am (month a))
+              (bm (month b)))
+          (if (= am bm)
+              (< (day a) (day b))
+              (< am bm)))
+        (< ay by))))
 
-(define-public (time-min a b)
-  (if (time<? a b) a b))
+(define-public date<
+  (case-lambda
+    [() #t]
+    [(_) #t]
+    [(first second . rest)
+     (and (date<% first second)
+          (apply date< second rest))]))
 
-(define-public (time-max a b)
-  (if (time<? a b) b a))
+(define (date<=% a b)
+  (or (date= a b)
+      (date< a b)))
 
-(define-public (date-min a b)
-  (if (date< a b) a b))
+(define-public date<=
+  (case-lambda
+    [() #t]
+    [(_) #t]
+    [(first second . rest)
+     (and (date<=% first second)
+          (apply date<= second rest))]))
 
-(define-public (date-max a b)
-  (if (date< a b) b a))
+(define-public (time< a b)
+  (let ((ah (hour a))
+        (bh (hour b)))
+    (if (= ah bh)
+        (let ((am (minute a))
+              (bm (minute b)))
+          (if (= am bm)
+              (< (second a) (second b))
+              (< am bm)))
+        (< ah bh))))
 
-(define-public (datetime-min a b)
-  (if (datetime< a b) a b))
+(define-public (time<= a b)
+  (or (time= a b)
+      (time< a b)))
 
-(define-public (datetime-max a b)
-  (if (datetime< a b) b a))
+(define-public (datetime< a b)
+  (if (date= (get-date a) (get-date b))
+      (time< (get-time% a) (get-time% b))
+      (date< (get-date a) (get-date b))))
 
-(define*-public (month+ date-object #:optional (change 1))
-  (date+ date-object (date month: change)))
+(define-public (datetime<= a b)
+  (if (date= (get-date a) (get-date b))
+      (time<= (get-time% a) (get-time% b))
+      (date<= (get-date a) (get-date b))))
 
-(define*-public (month- date-object #:optional (change 1))
-  (date- date-object (date month: change)))
+(define-public (date/-time< a b)
+  (datetime< (as-datetime a) (as-datetime b)))
 
-;; https://projecteuclid.org/euclid.acta/1485888738
-;; 1. Begel.
-;; J sei die Zahl des Jahrhunderts,
-;; K die Jahrszahl innerhalb desselben,
-;; m die Zahl des Monats,
-;; q die Zahl des Monatstags,
-;; h die Zahl des Wochentags;
-(define (zeller J K m q)
-  (modulo (+ q
-             (floor-quotient (* 13 (1+ m))
-                             5)
-             K
-             (floor-quotient K 4)
-             5
-             (- J))
-          7))
+(define-many define-public
+  (date<?) date<
+  (date> date>?) (swap date<)
+  (date<=?) date<=
+  (date>= date>=?) (swap date<=)
 
-;; 0 indexed, starting at sunday.
-(define-public (week-day date)
-  (let* ((J K (floor/ (year date) 100))
-         (m (month date)))
-    (if (memv m '(1 2))
-        (zeller J (1- K) (+ m 12) (day date))
-        (zeller J K (month date) (day date)))))
+  (time<?) time<
+  (time> time>?) (swap time<)
+  (time<=?) time<=
+  (time>= time>=?) (swap time<=)
 
+  (datetime<?) datetime<
+  (datetime> datetime>?) (swap datetime<)
+  (datetime<=?) datetime<=
+  (datetime>= datetime>=?) (swap datetime<=)
 
-(define-many define-public
-  (sun) 0
-  (mon) 1
-  (tue) 2
-  (wed) 3
-  (thu) 4
-  (fri) 5
-  (sat) 6
+  (date/-time<?) date/-time<
+  (date/-time> date/-time>?) (swap date/-time<)
+  (date/-time<= date/-time<=?) (negate date/-time>)
+  (date/-time>= date/-time>=?) (negate date/-time<)
   )
 
+
 
-(define-public week-start (make-parameter sun))
+;;; OPERATIONS
 
-(define-config week-start sun
-  "First day of week"
-  pre: (ensure (lambda (x) (<= sun x sat)))
-  post: week-start)
 
-;; given a date, returns the date the first week of that year starts on.
-;; @example
-;; (week-1-start #2020-01-01 mon)
-;; ⇒ 2019-12-30
-;; @end example
-(define*-public (week-1-start d optional: (wkst (week-start)))
-  (let* ((ystart (start-of-year d))
-         (day-index (modulo (- (week-day ystart) wkst) 7)))
-    (if (> day-index 3)
-        (date+ ystart (date day: (- 7 day-index)))
-        (date- ystart (date day: day-index)))))
+;; TODO +1 month is weird for late days in a month.
+;; is the last of january +1 month the last of february,
+;; or a few days into march? It's at least not the 31 of
+;; February, as the code is currently written.
+;; (date+ #2020-01-31 #0000-01-00) ; => 2020-02-31
+(define (date+%% change base)
 
-;; (week-number #2020-01-01 mon) ; => 1
-;; (week-number #2019-12-31 mon) ; => 1
-(define*-public (week-number d optional: (wkst (week-start)))
-  ;; Calculating week number for starts of week was much simpler.
-  ;; We can both skip the special cases for Jan 1, 2 & 3. It also
-  ;; solved some weird bug that was here before.
+  (define-values (days-fixed change*)
+    (let loop ((target base) (change change))
+      (if (>= (days-in-month target) (+ (day change) (day target)))
+          ;; No date overflow, just add the change
+          (values (set-> target (day = (+ (day change))))
+                  (set-> change (day 0)))
+          ;; Date (and possibly year) overflow
+          (loop (if (= 12 (month target))
+                    (set-> target
+                           (year = (+ 1))
+                           (month 1)
+                           (day 1))
+                    (set-> target
+                           (month = (+ 1))
+                           (day 1)))
+                (set-> change
+                       (day = (- (1+ (- (days-in-month target) (day target))))))))))
 
-  (let ((d (start-of-week d wkst)))
-   (cond
-    [(and (= 12 (month d))
-          (memv (day d) '(29 30 31))
-          (< (year d) (year (date+ (start-of-week d wkst)
-                                   (date day: 3)))))
-     1]
+  (define-values (month-fixed change**)
+    (if (date-zero? change*)
+        (values days-fixed change*)
+     (let loop ((target days-fixed) (change change*))
+       (if (< 12 (+ (month change) (month target)))
+           ;; if we overflow into the next year
+           (loop (set-> target
+                        (year = (+ 1))
+                        (month 1))
+                 (set (month change) = (- (- 13 (month target)))))
 
-    [else
-     (let* ((w1-start (week-1-start d wkst))
-            (week day (floor/ (days-in-interval w1-start d)
-                              7)))
-       (1+ week))])))
+           ;; if we don't overflow our date
+           (values (set (month target) = (+ (month change)))
+                   (set (month change) 0))
 
-(define*-public (date-starting-week
-                 week-number d
-                 optional: (wkst (week-start)))
-  (date+ (week-1-start d wkst)
-         (date day: (* (1- week-number) 7))))
+           ))))
 
+  ;; change** should here should have both month and date = 0
 
-(define*-public (week-day-name week-day-number optional: truncate-to
-                               key: (locale %global-locale))
+  (set (year month-fixed) = (+ (year change**))))
 
-  ;; NOTE this allows days larger than 7 (sunday if counting from monday).
-  (let ((str (catch 'out-of-range
-               (lambda () (locale-day (1+ (modulo week-day-number 7)) locale))
-               (lambda (oor str num)
-                 (scm-error 'out-of-range 'week-day-name
-                            "~a == (~a % 7) + 1"
-                            (list num week-day-number)
-                            (list week-day-number))))))
-    ;; I also know about the @var{locale-day-short} method, but I need
-    ;; strings of length 2.
-    (if truncate-to
-        (string-take str truncate-to)
-        str)))
+(define (date+% change base)
 
-(define*-public (datetime->string
-                 datetime
-                 optional: (fmt "~Y-~m-~dT~H:~M:~S")
-                 key: allow-unknown?)
-  (define date (get-date datetime))
-  (define time (get-time% datetime))
-  (with-output-to-string
-    (lambda ()
-      (fold (lambda (token state)
-              (case state
-                ((#\~)
-                 (case token
-                   ((#\~) (display "~"))
-                   ((#\H) (format #t "~2'0d" (hour time)))
-                   ((#\k) (format #t "~2' d" (hour time)))
-                   ((#\M) (format #t "~2'0d" (minute time)))
-                   ((#\S) (format #t "~2'0d" (second time)))
-                   ((#\Y) (format #t "~4'0d" (year date)))
-                   ((#\m) (format #t "~2'0d" (month date)))
-                   ((#\d) (format #t "~2'0d" (day date)))
-                   ;; Should be same as ~_d
-                   ((#\s) (display (datetime->unix-time datetime))) ; epoch time!
-                   ((#\e) (format #t "~2' d" (day date)))
-                   ((#\1) (format #t "~4'0d-~2'0d-~2'0d"
-                                  (year date) (month date) (day date)))
-                   ((#\3) (format #t "~2'0d:~2'0d:~2'0d"
-                                  (hour time) (minute time) (second time)))
-                   ((#\A) (display (week-day-name (week-day date))))
-                   ((#\a) (display (week-day-name (week-day date) 3)))
-                   ((#\b) (display (locale-month-short (month date))))
-                   ((#\B) (display (locale-month (month date))))
-                   ((#\Z) (when (equal? "UTC" (get-timezone datetime)) (display "Z")))
-                   (else (unless allow-unknown?
-                           (error 'datetime->string "Invalid format token ~a" token))))
-                 #f)
-                (else (unless (char=? #\~ token) (display token)) token)))
-            #f
-            (string->list fmt)))))
+  (when (or (negative? (year change))
+            (negative? (month change))
+            (negative? (day change)))
+    (error "Change can't be negative"))
 
-(define*-public (date->string date
-                              optional: (fmt "~Y-~m-~d")
-                              key: allow-unknown?)
-  (datetime->string (datetime date: date)
-                    fmt allow-unknown?: allow-unknown?))
+  (unless (and (< 0 (month base))
+               (< 0 (day base)))
+    (error "Base day and month needs to be at least one" base))
 
-(define*-public (time->string time
-                              optional: (fmt "~H:~M:~S")
-                              key: allow-unknown?)
-  (datetime->string (datetime time: time)
-                    fmt allow-unknown?: allow-unknown?))
+  (date+%% change base))
 
+;; @var{base} MUST be a valid real date. all rest arguments can however
+;; be "invalid" dates, such as 0000-00-10
+(define-public (date+ base . rest)
+  (fold date+% base rest))
 
-;; @verbatim
-;;    A          B          C          D          E         ¬F
-;; |s1|     :     |s2| : |s1|     :     |s2| :          : |s1|
-;; |  |     :     |  | : |  ||s2| : |s1||  | : |s1||s2| : |  |
-;; |  ||s2| : |s1||  | : |  ||  | : |  ||  | : |  ||  | :
-;;     |  | : |  |     : |  ||  | : |  ||  | : |  ||  | :     |s2|
-;;     |  | : |  |     : |  |     :     |  | :          :     |  |
-;;
-;; Infinitely short ---+|s2| : |s1|+--- : two instants don't overlap
-;; events, overlap   s1      :      s2  :
-;; @end verbatim
-;; 
-;; E is covered by both case A and B.
-(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end)
-  "Return whetever or not two timespans overlap."
-  (or
-   ;; A
-   (and (date/-time<? s2-begin s1-end)
-        (date/-time<? s1-begin s2-end))
+(define (date-%% change base)
+  (define-values (days-fixed change*)
+    (let loop ((target base) (change change))
+      (if (>= (day change) (day target))
+          (let ((new-change (set (day change) = (- (day target)))))
+            (loop (if (= 1 (month target))
+                      (set-> target
+                             (year = (- 1))
+                             (month 12)
+                             (day 31)              ; days in december
+                             )
+                      (set-> target
+                             (month = (- 1))
+                             (day (days-in-month (set (month target) = (- 1))))))
+                  new-change))
+          (values (set (day target) = (- (day change)))
+                  (set (day change) 0)))))
 
-   ;; B
-   (and (date/-time<? s1-begin s2-end)
-        (date/-time<? s2-begin s1-end))
+  (define-values (month-fixed change**)
+    (let loop ((target days-fixed) (change change*))
+      (if (>= (month change) (month target))
+          (loop (set-> target
+                       (year = (- 1))
+                       (month 12))
+                (set (month change) = (- (month target))))
+          (values (set (month target) = (- (month change)))
+                  (set (month change) 0)))))
 
-   ;; C
-   (and (date/-time<=? s1-begin s2-begin)
-        (date/-time<? s2-end s1-end))
+  ;; change** should here should have both month and date = 0
 
-   ;; D
-   (and (date/-time<=? s2-begin s1-begin)
-        (date/-time<? s1-end s2-end))))
+  (set (year month-fixed) = (- (year change**))))
+
+(define (date-% change base)
+
+  (when (or (negative? (year change))
+            (negative? (month change))
+            (negative? (day change)))
+    (error "Change can't be negative"))
+
+  (when (or (negative? (month base))
+            (negative? (day base)))
+    (error "Base month or day can't be negative"))
+
+  (date-%% change base)
+  )
+
+;;; Only use this with extreme caution
+(define-public (date- base . rest)
+  (fold date-% base rest))
+
+;;; time
+
+;; overflow is number of days above
+;; time x time → time x int
+(define-public (time+% base change)
+
+  ;; while (day base) > (days-in-month base)
+  ;;     month++; days -= (days-in-month base)
+  (define second-fixed
+    (let loop ((target (set (second base) = (+ (second change)))))
+      (if (>= (second target) 60)
+          (loop (set-> target
+                       (minute = (+ 1))
+                       (second = (- 60))))
+          target)))
+
+  ;; while (month base) > 12
+  ;;     year++; month -= 12
+  (define minute-fixed
+    (let loop ((target (set (minute second-fixed) = (+ (minute change)))))
+      (if (>= (minute target) 60)
+          (loop (set-> target
+                       (hour = (+ 1))
+                       (minute = (- 60))))
+          target)))
 
-(define-public (add-day d)
-  (date+ d (date day: 1)))
+  (define hour-almost-fixed (set (hour minute-fixed) = (+ (hour change))))
 
-(define-public (remove-day d)
-  (date- d (date day: 1)))
+  (if (<= 24 (hour hour-almost-fixed))
+      (let* ((div remainder (floor/ (hour hour-almost-fixed) 24)))
+        (values (set (hour hour-almost-fixed) remainder) div))
+      (values hour-almost-fixed 0)))
 
-(define-public (in-date-range? start-date end-date)
-  (lambda (date)
-    (date<= start-date date end-date)))
+;;; PLUS
+(define-public (time+ base . rest)
+  (let ((sum 0))
+    (let ((time (fold (lambda (next done)
+                        (let* ((next-time rem (time+% done next)))
+                          (mod! sum = (+ rem))
+                          next-time))
+                      base rest)))
+      (values time sum))))
 
-;; Returns a list of the seven week days, with @var{week-start}
-;; as the beginning of the week.
-;; @example
-;; (weekday-list sun)
-;; => (0 1 2 3 4 5 6)
-;; @end example
-(define-public (weekday-list week-start)
-  (take (drop (apply circular-list (iota 7))
-              week-start)
-        7))
+;; time, Δtime → time, hour
+(define (time-% base change)
 
-;; returns the date the week containing d started.
-;; (start-of-week #2020-04-02 sun) ; => 2020-03-29
-(define*-public (start-of-week d optional: (week-start (week-start)))
-  (date- d (date day: (modulo (- (week-day d)
-                                 week-start)
-                              7))))
+  (define-values (second-fixed change*)
+    (let loop ((target base) (change change))
+      (if (> (second change) (second target))
+          (loop (set-> target
+                       (minute = (- 1))
+                       (second 60))
+                (set (second change) = (- (second target))))
+          (values (set (second target) = (- (second change)))
+                  (set (second change) 0)))))
 
-;; (end-of-week #2020-04-01 mon)
-;; => 2020-04-05
-(define*-public (end-of-week d optional: (week-start (week-start)))
-  (date+ (start-of-week d week-start)
-         (date day: 6)))
+  (define-values (minute-fixed change**)
+    (let loop ((target second-fixed) (change change*))
+      (if (> (minute change) (minute target))
+          (loop (set-> target
+                       (hour = (- 1))
+                       (minute 60))
+                (set (minute change) = (- (minute target))))
+          (values (set (minute target) = (- (minute change)))
+                  (set (minute change) 0)))))
 
+  (if (>= (hour minute-fixed) (hour change**))
+      (values (set (hour minute-fixed) = (- (hour change**))) 0)
+      (let ((diff (- (hour minute-fixed)
+                     (hour change**))))
+        (values (set (hour minute-fixed) (modulo diff 24))
+                (abs (floor (/ diff 24)))))))
 
-;; Given a month and and which day the week starts on,
-;; returns three lists, which are:
-;; The days leading up to the current month, but share a week
-;; The days in the current month
-;; The days after the current month, but which shares a week.
-;; 
-;;       mars 2020
-;; må ti on to fr lö sö
-;;                    1
-;;  2  3  4  5  6  7  8
-;;  9 10 11 12 13 14 15
-;; 16 17 18 19 20 21 22
-;; 23 24 25 26 27 28 29
-;; 30 31
+;; Goes backwards from base, returning the two values:
+;; the new time, and the number of days back we went.
+;; Note that neither time+ or time- can return a time
+;; component greater than 24h, but nothing is stoping
+;; a user from creating them manually.
 ;; @lisp
-;; (month-days #2020-03-01 mon)
-;; ; ⇒ (2020-02-24 ... 2020-02-29)
-;; ; ⇒ (2020-03-01 ... 2020-03-31)
-;; ; ⇒ (2020-04-01 ... 2020-04-05)
+;; (time- #10:00:00 #09:00:00) ; => 01:00:00 => 0
+;; (time- #03:00:00 #07:00:00) ; => 20:00:00 => 1
+;; (time- #10:00:00 (time hour: 48)) ; => 10:00:00 => 2
+;; (time- #10:00:00 (time hour: (+ 48 4))) ; => 06:00:00 => 2
 ;; @end lisp
-;; Ignores day component of @var{date}.
-(define*-public (month-days date optional: (week-start (week-start)))
-  (let* ((month-len (days-in-month date))
-         (prev-month-len (days-in-month (month- date)))
-         (month-start (modulo (- (week-day date) week-start) 7)))
-    (values
-     (map (lambda (d) (set (day (month- date)) d))
-          (iota month-start (1+ (- prev-month-len month-start))))
-     (map (lambda (d) (set (day date) d)) (iota month-len 1))
-     (map (lambda (d) (set (day (month+ date)) d))
-          (iota (modulo (- (* 7 5) month-len month-start) 7) 1)))))
+(define-public (time- base . rest)
+  (let ((sum 0))
+    (let ((time (fold (lambda (next done)
+                        (let* ((next-time rem (time-% done next)))
+                          (mod! sum = (+ rem))
+                          next-time))
+                      base rest)))
+      (values time sum))))
 
-
 
+;;; DATETIME
 
-(define-public (days-in-interval start-date end-date)
-  (let ((diff (date-difference (date+ end-date (date day: 1)) start-date)))
-    (with-streams
-     (fold + (day diff)
-           (map days-in-month
-                (take (+ (month diff)
-                         (* 12 (year diff)))
-                      (month-stream start-date)))))))
 
-;; Day from start of the year, so 1 feb would be day 32.
-;; Also known as Julian day.
-(define-public (year-day date)
-  (days-in-interval (start-of-year date) date))
+(define-public (datetime+ base change)
+  (let* ((time overflow (time+ (get-time% base) (get-time% change))))
+    (datetime date: (date+ (get-date base)
+                           (get-date change)
+                           (date day: overflow))
+              time: time
+              tz: (get-timezone base)
+              )))
 
+;;; the *-difference procedures takes two actual datetimes.
+;;; date- instead takes a date and a delta (but NOT an actual date).
 
-;; @example
-;; (time->decimal-hour #10:30:00) ; => 10.5
-;; @end example
-(define-public (time->decimal-hour time)
-  (exact->inexact (+ (hour time)
-                     (/ (minute time) 60)
-                     (/ (second time) 3600))))
+;; Works on 0-based dates. So the last of January 2020 becomes
+;; 2020-00-30
+(define (date-difference% b a)
+  ;; #2020-01-01 #2020-00-26 → #2020-00-06 #2020-00-00
+  (define-values (b* a*)
+    (let loop ((b b) (a a))
+      (if (> (day a) (day b))
+          (let ((new-a (set (day a) = (- (1+ (day b))))))
+            (loop (if (= 0 (month b))
+                      (set-> b
+                             (year = (- 1))
+                             (month 11)
+                             (day 30)   ; Last day in december
+                             )
+                      (set-> b
+                             (month = (- 1))
+                             (day (1- (days-in-month b))))) ; last in prev month
+                  new-a))
+          ;; elif (> (day b) (day a))
+          (values (set (day b) = (- (day a)))
+                  (set (day a) 0)))))
 
-(define*-public (datetime->decimal-hour dt optional: start-date)
 
-  (let ((date-diff
-         (cond [start-date
-                (let* ((end-date (date+ start-date (get-date dt))))
-                  (days-in-interval start-date end-date)) ]
-               [(or (not (zero? (month (get-date dt))))
-                    (not (zero? (year (get-date dt)))))
-                (error "Multi-month intervals only supported when start-date is given" dt)]
-               [else (day (get-date dt))])))
-    (+ (time->decimal-hour (get-time% dt))
-       (* (1- date-diff) 24))))
+  ;; (day a*) should be 0 here.
 
-;; Returns a list of all dates from start to end.
-;; both inclusive
-;; date, date → [list date]
-(define-public (date-range start end)
-  (stream->list
-   (stream-take-while (lambda (d) (date<= d end))
-                      (day-stream start))))
+  (define-values (b** a**)
+    (let loop ((b b*) (a a*))
+      (if (> (month a) (month b))
+          (loop (set-> b
+                       (year = (- 1))
+                       (month 11))
+                (set (month a) = (- (1+ (month b)))))
+          ;; elif (> (month b) (month a))
+          (values (set (month b) = (- (month a)))
+                  (set (month a) 0)))))
 
+  ;; a** should here should have both month and date = 0
 
+  (set (year b**) = (- (year a**))))
 
-;; Returns the first instance of the given week-day after @var{d}.
-;; @example
-;; (find-first-week-day mon #2020-04-01)
-;; => #2020-04-06
-;; (find-first-week-day mon #2020-04-10)
-;; => #2020-04-13
-;; (find-first-week-day mon #2020-04-30)
-;; => #2020-05-04
-;; @end example
-(define-public (find-first-week-day wday d)
-  (let* ((start-day (week-day d))
-         (diff (- wday start-day)))
-    (date+ d (date day: (modulo diff 7)))))
 
-;; returns instances of the given week-day in month between
-;; month-date and end of month.
-;; @example
-;; (all-wday-in-month mon #2020-06-01)
-;; => (#2020-06-01 #2020-06-08 #2020-06-15 #2020-06-22 #2020-06-29)
-;; (all-wday-in-month mon #2020-06-10)
-;; => (#2020-06-15 #2020-06-22 #2020-06-29)
-;; @end example
-;; week-day, date → (list date)
-(define-public (all-wday-in-month wday month-date)
-  (stream->list
-   (stream-take-while
-    (lambda (d) (= (month d) (month month-date)))
-    (week-stream (find-first-week-day wday month-date)))))
 
+;; NOTE, this is only properly defined when b is greater than a.
+(define-public (date-difference b a)
+  (when (or (negative? (month b))
+            (negative? (day   b))
+            (negative? (month a))
+            (negative? (day   a)) )
+    (error "Negative months or days are errors"))
 
-(define-public (all-wday-in-year wday year-date)
-  (stream->list
-   (stream-take-while
-    (lambda (d) (= (year d) (year year-date)))
-    (week-stream (find-first-week-day wday year-date)))))
+  (date-difference% (set-> b
+                           (month = (- 1))
+                           (day = (- 1)))
+                    (set-> a
+                           (month = (- 1))
+                           (day = (- 1)))))
+
+
+;; NOTE, this is only properly defined when end is greater than start.
+(define-public (datetime-difference end start)
+  ;; NOTE Makes both start and end datetimes in the current local time.
+  (let* ((fixed-time overflow (time- (get-time% end)
+                                     (get-time% start))))
+    (datetime date: (date-difference (date- (get-date end)
+                                            (date day: overflow))
+                                     (get-date start))
+              time: fixed-time)))
-- 
cgit v1.2.3