Change date{,time}-difference to hopefully sensible types.

4 files changed, 89 insertions, 26 deletions

diff --git a/module/datetime.scm b/module/datetime.scm
index 1dd2f9bd..4a53ed95 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -581,17 +581,71 @@
 ;;; the *-difference procedures takes two actual datetimes.
 ;;; date- instead takes a date and a delta (but NOT an actual date).
 
-;; TODO TZ
-;; NOTE currently returns the time span in seconds as an int.
-;; Who knew that months doesn't have a constant width...
-(define-public (datetime-difference end start)
-  (- (car (mktime (datetime->tm end)))
-     (car (mktime (datetime->tm start)))))
-
-(define-public (date-difference end start)
-  (date day: (ceiling-quotient (datetime-difference (datetime date: end)
-                                     (datetime date: start))
-                86400)))
+;; 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))
+      ;; (format (current-error-port) "a=~a b=~a~%" a b)
+      (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 (set (month b) = (- 0)))))))
+                  new-a))
+          ;; elif (> (day b) (day a))
+          (values (set (day b) = (- (day a)))
+                  (set (day a) 0)))))
+
+  (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) = (- (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 (date-difference b a)
+  (when (or (negative? (month b))
+            (negative? (day   b))
+            (negative? (month a))
+            (negative? (day   a)) )
+    (error "Negative months or days are an error"))
+
+  (date-difference% (set-> b
+                           (month = (- 1))
+                           (day = (- 1)))
+                    (set-> a
+                           (month = (- 1))
+                           (day = (- 1)))))
+
+
+(define-public (datetime-difference end* start*)
+  ;; NOTE Makes both start and end datetimes in the current local time.
+  (let ((end   (get-datetime end*))
+        (start (get-datetime start*)))
+   (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))))
+
 
 
 ;;; Parsers for vcomponent usage
diff --git a/module/output/html.scm b/module/output/html.scm
index cb0ba9b5..9f5c7c81 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -82,9 +82,9 @@
 ;; of a regular day.
 (define (long-event? ev)
   (or (date? (attr ev 'DTSTART))
-      (<= (* 3600 24)
-       (datetime-difference (attr ev 'DTEND)
-                            (attr ev 'DTSTART)))))
+      (datetime<= (datetime date: (date day: 1))
+                  (datetime-difference (attr ev 'DTEND)
+                                       (attr ev 'DTSTART)))))
 
 
 (define (event-debug-html event)
@@ -185,15 +185,16 @@
             ;; Set start time
             ;; left
             (* 100
-               (let ((dt (datetime date: start-date)))
-                 (/ (datetime-difference (datetime-max dt (as-datetime (attr ev 'DTSTART))) dt)
-                    3600 total-length)))
+               (let* ((dt (datetime date: start-date))
+                      (diff (datetime-difference (datetime-max dt (as-datetime (attr ev 'DTSTART)))
+                                                 dt)))
+                 (/ (datetime->decimal-hour diff) total-length)))
 
             ;; Set length of event, which makes end time
             ;; width
             (* 100
-               (/ (event-length/clamped start-date end-date ev)
-                  3600 total-length))))
+               (/ (datetime->decimal-hour (as-datetime (event-length/clamped start-date end-date ev)))
+                  total-length))))
 
   `(a (@ (href "#" ,(UID ev))
          (class "hidelink"))
@@ -232,7 +233,7 @@
 
 (define (lay-out-long-events start end events)
   (fix-event-widths! events event-length-key: event-length
-                     event-length-comperator: >)
+                     event-length-comperator: date/-time>)
   (map (lambda (e) (create-top-block start end e))
        events))
 
diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm
index 4db9dbf1..5df4dfab 100644
--- a/module/vcomponent/datetime.scm
+++ b/module/vcomponent/datetime.scm
@@ -51,12 +51,20 @@ Event must have the DTSTART and DTEND attribute set."
                 (if (date? (attr e 'DTSTART))
                     #24:00:00
                     #01:00:00))
-      (datetime-difference (as-datetime (attr e 'DTEND))
-                           (as-datetime (attr e 'DTSTART)))))
+      ((if (date? (attr e 'DTSTART))
+           date-difference datetime-difference)
+       (attr e 'DTEND) (attr e 'DTSTART))))
 
 (define-public (event-length/clamped start-date end-date e)
-  (datetime-difference (datetime-min (datetime date: (date+ end-date (date day: 1)))   (as-datetime (attr e 'DTEND)))
-                       (datetime-max (datetime date: start-date) (as-datetime (attr e 'DTSTART)))))
+  (if (date? (attr e 'DTSTART))
+      (date-difference (date-min (date+ end-date (date day: 1))
+                                 (attr e 'DTEND))
+                       (date-max start-date
+                                 (attr e 'DTSTART)))
+      (datetime-difference (datetime-min (datetime date: (date+ end-date (date day: 1)))
+                                         (get-datetime (attr e 'DTEND)))
+                           (datetime-max (datetime date: start-date)
+                                         (get-datetime (attr e 'DTSTART))))))
 
 ;; Returns the length of the part of @var{e} which is within the day
 ;; starting at the time @var{start-of-day}.
diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm
index ac8a6ad8..ce64e741 100644
--- a/module/vcomponent/recurrence/generate.scm
+++ b/module/vcomponent/recurrence/generate.scm
@@ -78,7 +78,7 @@
                    (set! (attr e 'DTEND)
                      (if (date? start)
                          (date+ start change)
-                         (datetime+ start (datetime time: change))))))))
+                         (datetime+ start change)))))))
 
     e))
 
@@ -153,7 +153,7 @@
                          ;; according to RFC 5545 3.8.2.2 (Date-Time End).
                          (if (date? end)
                              (date-difference end (attr event 'DTSTART))
-                             (time second: (datetime-difference end (attr event 'DTSTART)))))]))
+                             (datetime-difference end (attr event 'DTSTART))))]))
            (if (attr event "RRULE")
                (recur-event-stream event (parse-recurrence-rule
                                           (attr event "RRULE")