Start work on better wide html renderer.

4 files changed, 156 insertions, 77 deletions

diff --git a/module/datetime.scm b/module/datetime.scm
index 3a84e9a2..6c613c55 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -144,8 +144,8 @@
 ;; than the original. which is fun...
 (define-public (get-time dt)
   (get-time% (get-datetime dt)))
-
 
+
 ;;; UTIL
 
 ;; int -> bool
@@ -170,14 +170,23 @@
 
 
 (define-public (as-date date/-time)
-  (if (date? date/-time)
-      date/-time
-      (get-date date/-time)))
+  (cond [(datetime? date/-time) (get-date date/-time)]
+        [(date? date/-time) date/-time]
+        [(time? date/-time) (date)]
+        [else "Object not a date, time, or datetime object ~a" date/-time]))
 
 (define-public (as-time date/-time)
-  (if (datetime? date/-time)
-      (get-time date/-time)
-      (time)))
+  (cond [(datetime? date/-time) (get-time date/-time)]
+        [(date? date/-time) (time)]
+        [(time? date/-time) date/-time]
+        [else "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 "Object not a date, time, or datetime object ~a" dt]))
+
 
 ;;; EQUIALENCE
 
@@ -263,15 +272,7 @@
       (date<= (get-date a) (get-date b))))
 
 (define-public (date/-time< a b)
-  ;; (format (current-error-port) "~a < ~a = " a b)
-  (let ((res
-         (cond [(date= (as-date a) (as-date b))
-                (time< (as-time a) (as-time b))]
-               [(date< (as-date a) (as-date b))
-                #t]
-               [else #f])))
-    ;; (format (current-error-port) "~a~%" res)
-    res))
+  (datetime< (as-datetime a) (as-datetime b)))
 
 (define-many define-public
   (date<?) date<
@@ -532,46 +533,45 @@
                            (date day: overflow))
               time: time)))
 
-(define (datetime->srfi-19-date date)
-  ((@ (srfi srfi-19) make-date)
-    0
-    (second (get-time date))
-    (minute (get-time date))
-    (hour (get-time date))
-    (day (get-date date))
-    (month (get-date date))
-    (year (get-date date))
-    0                                   ; TODO TZ
-    ))
-
-(define (srfi-19-date->datetime o)
-  (let ((y ((@ (srfi srfi-19) date-year)   o)))
-    ;; TODO find better way to translate from 1970 to 0, since this WILL
-    ;; cause problems sooner or later.
-   (datetime year:   (if (= 1970 y) 0 y)
-             month:  (let ((m ((@ (srfi srfi-19) date-month) o)))
-                       (if (and (= 1970 y) (= 1 m)) 0 m))
-             day:    (let ((d ((@ (srfi srfi-19) date-day) o)))
-                       (if (and (= 1970 y) (= 1 d)) 0 d))
-             hour:   ((@ (srfi srfi-19) date-hour)   o)
-             minute: ((@ (srfi srfi-19) date-minute) o)
-             second: ((@ (srfi srfi-19) date-second) o)
-             )))
+;; (define (datetime->srfi-19-date date)
+;;   ((@ (srfi srfi-19) make-date)
+;;     0
+;;     (second (get-time date))
+;;     (minute (get-time date))
+;;     (hour (get-time date))
+;;     (day (get-date date))
+;;     (month (get-date date))
+;;     (year (get-date date))
+;;     0                                   ; TODO TZ
+;;     ))
+
+;; (define (srfi-19-date->datetime o)
+;;   (let ((y ((@ (srfi srfi-19) date-year)   o)))
+;;     ;; TODO find better way to translate from 1970 to 0, since this WILL
+;;     ;; cause problems sooner or later.
+;;    (datetime year:   (if (= 1970 y) 0 y)
+;;              month:  (let ((m ((@ (srfi srfi-19) date-month) o)))
+;;                        (if (and (= 1970 y) (= 1 m)) 0 m))
+;;              day:    (let ((d ((@ (srfi srfi-19) date-day) o)))
+;;                        (if (and (= 1970 y) (= 1 d)) 0 d))
+;;              hour:   ((@ (srfi srfi-19) date-hour)   o)
+;;              minute: ((@ (srfi srfi-19) date-minute) o)
+;;              second: ((@ (srfi srfi-19) date-second) o)
+;;              )))
 
 ;;; 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)
-  (let ((t
-         ((@ (srfi srfi-19) time-difference)
-          ((@ (srfi srfi-19) date->time-utc) (datetime->srfi-19-date end))
-          ((@ (srfi srfi-19) date->time-utc) (datetime->srfi-19-date start)))))
-    ((@ (srfi srfi-19) set-time-type!) t (@ (srfi srfi-19) time-utc))
-    (srfi-19-date->datetime ((@ (srfi srfi-19) time-utc->date) t 0))))  ; TODO tz offset
+  (- (car (mktime (datetime->tm end)))
+     (car (mktime (datetime->tm start)))))
 
 (define-public (date-difference end start)
-  (get-date (datetime-difference (datetime date: end)
-                                 (datetime date: start))))
+  (datetime-difference (datetime date: end)
+                       (datetime date: start)))
 
 
 ;;; Parsers for vcomponent usage
diff --git a/module/output/html.scm b/module/output/html.scm
index 9b672a0d..a3e74a44 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -41,6 +41,13 @@
                      (/ (minute time) 60)
                      (/ (second time) 3600))))
 
+(define (datetime->decimal-hour datetime)
+  ;; (+ (time->decimal-hour (get-time datetime))
+  ;;    (date->decimal-hour (get-date datetime)))
+  (+ (time->decimal-hour (get-time datetime))
+     ;; TODO
+     (* 3600 24 (day (get-date datetime)))))
+
 ;; Retuns an HTML-safe version of @var{str}.
 (define (html-attr str)
   (define cs (char-set-adjoin char-set:letter+digit #\- #\_))
@@ -89,7 +96,7 @@
 
 ;; Takes a list of vcomponents, sets their widths and x-positions to optimally
 ;; fill out the space, without any overlaps.
-(define (fix-event-widths! date lst)
+(define* (fix-event-widths! lst key: event-length-key (event-length-comperator date/-time>?))
   ;; The tree construction is greedy. This means
   ;; that if  a smaller  event preceeds a longer
   ;; event it would capture  the longer event to
@@ -99,8 +106,8 @@
   ;; @var{x} is how for left in the container we are.
   (let inner ((x 0)
               (tree (make-tree overlapping?
-                               (sort* lst time>?
-                                      (lambda (e) (event-length/day date e))))))
+                               (sort* lst event-length-comperator event-length-key
+                                      ))))
     (unless (null? tree)
       (let ((w (/ (- 1 x)
                   (+ 1 (length-of-longst-branch (left-subtree tree))))))
@@ -149,33 +156,66 @@
 (define (create-block date ev)
   (create-block-general date ev "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;"))
 
-(define (create-top-block date ev)
-  (create-block-general date ev "top:~,3f%;height:~,3f%;left:~,3f%;width:~,3f%;"))
+(define (create-top-block start-date end-date ev)
+
+  ;; TODO
+  (define total-length (exact->inexact (/ (date-difference (date+ end-date (date day: 1)) start-date) 3600)))
+
+  (define style
+    (format #f "top:~,3f%;height:~,3f%;left:~,3f%;width:~,3f%;"
+
+            ;; Prevent collisions
+            (* 100 (x-pos ev))          ; top
+            (* 100 (width ev))          ; height
+
+            ;; Set start time
+            ;; left
+            (* 100
+               (/ (datetime-difference (as-datetime (attr ev 'DTSTART)) (datetime date: start-date))
+                  3600 total-length))
+
+            ;; Set length of event, which makes end time
+            ;; width
+            (* 100
+               (/ (event-length/clamped start-date end-date ev)
+                  3600 total-length))))
+
+  `(a (@ (href "#" ,(UID ev))
+         (class "hidelink"))
+      (div (@ (class "event CAL_" ,(html-attr (attr (parent ev) 'NAME))
+                ,(when (and (attr ev 'PARTSTAT) (string= "TENTATIVE" (attr ev 'PARTSTAT)))
+                   " tentative"))
+              (style ,style))
+           ,((summary-filter) ev (attr ev 'SUMMARY))))
+
+  )
+
 
 ;; Lay out complete day (graphical)
 ;; (date . (events)) -> sxml
 (define (lay-out-day day)
   (let* (((day-date . events) day)
          (time-obj (datetime date: day-date))
-         (long-events short-events
+         (_ short-events
                       (partition (lambda (ev)
                                    (or (date? (attr ev 'DTSTART))
-                                       (datetime<=? (datetime date: (date day: 1))
+                                       (;datetime<=? (datetime date: (date day: 1))
+                                        <= (* 3600 24)
                                                     (datetime-difference (attr ev 'DTEND)
                                                                          (attr ev 'DTSTART)))))
                                  (stream->list events))))
 
-    (fix-event-widths! day-date short-events)
-    (fix-event-widths! day-date long-events)
-    `(div (@ (class "day"))
+    (fix-event-widths! short-events event-length-key: (lambda (e) (event-length/day day-date e)))
+    ;; (fix-event-widths! day-date long-events)
+    `(;div (@ (class "day"))
           (div (@ (class "meta"))
                ,(let ((str (date-link day-date)))
                   `(span (@ (id ,str) (class "daydate")) ,str))
                (span (@ (class "dayname")) ,(date->string day-date "~a")))
-          (div (@ (class "wholeday"))
-               "" ; To prevent self closing div tag
-               ,@(map (lambda (e) (create-top-block day-date e))
-                      long-events))
+          ;; (div (@ (class "wholeday"))
+          ;;      "" ; To prevent self closing div tag
+          ;;      ,@(map (lambda (e) (create-top-block day-date e))
+          ;;             long-events))
           (div (@ (class "events"))
                "" ; To prevent self closing div tag
                ,@(map (lambda (time)
@@ -183,6 +223,33 @@
                       (iota 12 0 2))
                ,@(map (lambda (e) (create-block day-date e)) short-events)))))
 
+(define (lay-out-long-events event-groups)
+
+  (define start (car (stream-car event-groups)))
+  (define end (car (stream-car (stream-reverse event-groups))))
+
+  (stream-map
+   (match-lambda
+     [(d . events)
+      (let* ((long-events _
+                (partition (lambda (ev)
+                             (or (date? (attr ev 'DTSTART))
+                                 (; datetime<=? (datetime date: (date day: 1))
+                                  <= (* 3600 24)
+                                              (datetime-difference (attr ev 'DTEND)
+                                                                   (attr ev 'DTSTART)))))
+                           (stream->list events))))
+        (let ((long-events
+               (filter (lambda (e) (date= d (as-date (attr e 'DTSTART))))
+                       long-events)))
+          (fix-event-widths! long-events event-length-key: event-length
+                             event-length-comperator: >)
+          (map (lambda (e) (create-top-block start end e))
+               long-events)
+
+          ))])
+   event-groups))
+
 (define (time-marker-div)
   `(div (@ (class "sideclock"))
         (div (@ (class "day"))
@@ -197,9 +264,13 @@
 
 (define-public (render-calendar event-groups)
   `(div (@ (class "calendar"))
-        ,(time-marker-div)
+        ;; ,(time-marker-div)
        (div (@ (class "days"))
-            ,@(stream->list (stream-map lay-out-day event-groups)))))
+            (div (@ (class "longevents")
+                    (style "grid-column-end:" ,(1+ (stream-length event-groups))))
+                 ""                     ; prevent self-closing
+                 ,@(stream->list (lay-out-long-events event-groups)))
+            ,@(concatenate (stream->list (stream-map lay-out-day event-groups))))))
 
 
 ;;; Prodcedures for text output
diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm
index 27153cea..ffde1e6e 100644
--- a/module/vcomponent/datetime.scm
+++ b/module/vcomponent/datetime.scm
@@ -46,9 +46,19 @@ Event must have the DTSTART and DTEND attribute set."
 
 ;; Returns length of the event @var{e}, as a time-duration object.
 (define-public (event-length e)
-  (time-
-   (attr e 'DTEND)
-   (attr e 'DTSTART)))
+  (if (not (attr e 'DTEND))
+      (datetime date:
+                (if (date? (attr e 'DTSTART))
+                    #24:00:00
+                    #01:00:00))
+      (let ((ret (datetime-difference (as-datetime (attr e 'DTEND))
+                                      (as-datetime (attr e 'DTSTART)))))
+        (format (current-error-port) "ret = ~a~%" ret)
+        ret)))
+
+(define-public (event-length/clamped start-date end-date e)
+  (datetime-difference (datetime-min (datetime date: end-date)   (as-datetime (attr e 'DTEND)))
+                       (datetime-max (datetime date: start-date) (as-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 f786a586..ba6257f8 100644
--- a/module/vcomponent/recurrence/generate.scm
+++ b/module/vcomponent/recurrence/generate.scm
@@ -81,11 +81,7 @@
                      (change (attr e 'X-HNH-DURATION)))
                  (when end
                    (set! (attr e 'DTEND)
-                     ((cond
-                        [(date? end)  date+ ]
-                        [(datetime? end) datetime+]
-                        [else (error "End neither date nor datetime ~a" end)])
-                      start change))))))
+                     (datetime+ (as-datetime start) (datetime time: change)))))))
 
     e))
 
@@ -159,8 +155,9 @@
                          ;; The value type of dtstart and dtend must be the same
                          ;; according to RFC 5545 3.8.2.2 (Date-Time End).
                          (if (date? end)
-                             (date-difference end (attr event 'DTSTART))
-                             (datetime-difference end (attr event 'DTSTART))))]))
+                             (time second: (print-and-return (date-difference end (attr event 'DTSTART))))
+                             (time second: (print-and-return (datetime-difference end (attr event 'DTSTART))))))]))
+           (format (current-error-port) "duration = ~a~%" (attr event 'X-HNH-DURATION))
            (if (attr event "RRULE")
                (recur-event-stream event (parse-recurrence-rule
                                           (attr event "RRULE")
@@ -171,8 +168,9 @@
                stream-null))))
     (lambda (err . args)
       (format (current-error-port)
-              "\x1b[0;31mError\x1b[m while parsing recurrence rule (ignoring and continuing)~%~a ~a~%~a~%~%"
+              "\x1b[0;31mError\x1b[m while parsing recurrence rule (ignoring and continuing)~%~a ~s~%~a~%~%"
               err args
               (attr event 'X-HNH-FILENAME))
       (stream ; event
-       ))))
+       )
+      )))