Improve *->decimal-hour procedures.

3 files changed, 38 insertions, 25 deletions

diff --git a/module/datetime.scm b/module/datetime.scm
index aa9a15f1..ac826601 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -650,27 +650,6 @@
 
 
 
-;; @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))))
-
-(define-public (datetime->decimal-hour dt)
-  (unless (and (zero? (month (get-date dt)))
-               (zero? (year (get-date dt))))
-    (error "Multi-month intervals not yet supported" dt))
-  ;; TODO
-  ;; (date-difference #2020-12-31 #2020-01-01) ; => 0000-11-30
-  ;; to get number of days in diff-time we need to count number of days
-  ;; in each month from start and forward
-  (+ (time->decimal-hour (get-time% dt))
-     (* (day (get-date dt)) 24)))
-
-
-
 ;;; Parsers for vcomponent usage
 
 ;; substring to number, local here
diff --git a/module/datetime/util.scm b/module/datetime/util.scm
index c8d199c9..9a04c99b 100644
--- a/module/datetime/util.scm
+++ b/module/datetime/util.scm
@@ -3,6 +3,7 @@
   :use-module (srfi srfi-1)
   :use-module (srfi srfi-26)
   :use-module (srfi srfi-41)
+  :use-module (srfi srfi-41 util)
   :use-module (util)
   )
 
@@ -299,3 +300,35 @@
      (map (lambda (d) (set (day (month+ date)) d))
           (iota (modulo (- (* 7 5) month-len month-start) 7) 1)))))
 
+
+
+
+(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)))))))
+
+;; @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))))
+
+(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 ((@ (datetime) get-time%) dt))
+       (* (1- date-diff) 24))))
diff --git a/module/output/html.scm b/module/output/html.scm
index cf200ea3..6e64d176 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -161,8 +161,8 @@
 ;; better.
 (define (create-top-block start-date end-date ev)
 
-  ;; NOTE be vary of api changes to date-diffenence
-  (define total-length (* 24 (day (date-difference (date+ end-date (date day: 1)) start-date))))
+  (define total-length
+    (* 24 (days-in-interval start-date end-date)))
 
   (define style
     (format #f "top:~,3f%;height:~,3f%;left:~,3f%;width:~,3f%;"
@@ -177,12 +177,13 @@
                (let* ((dt (datetime date: start-date))
                       (diff (datetime-difference (datetime-max dt (as-datetime (attr ev 'DTSTART)))
                                                  dt)))
-                 (/ (datetime->decimal-hour diff) total-length)))
+                 (/ (datetime->decimal-hour diff start-date) total-length)))
 
             ;; Set length of event, which makes end time
             ;; width
             (* 100
-               (/ (datetime->decimal-hour (as-datetime (event-length/clamped start-date end-date ev)))
+               (/ (datetime->decimal-hour (as-datetime (event-length/clamped start-date end-date ev))
+                                          start-date)
                   total-length))))
 
   `(a (@ (href "#" ,(UID ev))