From 44c960c08bc8a36ec09bc9fd228df1213c3c9f11 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Mon, 22 Apr 2019 01:59:17 +0200
Subject: Add rudamentary HTML output.

---
 module/html/html.scm | 115 +++++++++++++++++++++++++++++++++++++++++++++++++++
 module/main.scm      |  14 +++++--
 2 files changed, 125 insertions(+), 4 deletions(-)
 create mode 100644 module/html/html.scm

diff --git a/module/html/html.scm b/module/html/html.scm
new file mode 100644
index 00000000..5ad98b0a
--- /dev/null
+++ b/module/html/html.scm
@@ -0,0 +1,115 @@
+(define-module (html html)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-41)
+  #:use-module (vcalendar)
+  #:use-module (vcalendar datetime)
+  #:use-module (util)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-19 util)
+
+  )
+
+
+(define-stream (group-stream in-stream)
+  (define (ein? day) (lambda (e) (event-in? e (date->time-utc day))))
+
+  (let loop ((days (day-stream (time-utc->date (attr (stream-car in-stream) 'DTSTART))))
+             (stream in-stream))
+    (if (stream-null? stream)
+        stream-null
+        (let ((day (stream-car days)))
+          (let ((head (stream-take-while (ein? day) stream))
+                (tail (stream-drop-while (ein? day) stream)))
+            (stream-cons (cons day head)
+                         (loop (stream-cdr days)
+                               tail)))))))
+
+(define x-pos (make-object-property))
+(define width (make-object-property))
+
+;; Takes a list of vcomponents.
+;;; And makes each sublist have better laid out elements.
+;;; It's not perfect if there are many elements that overlap
+;;; In different ways. But it works perfectly for a block
+;;; schedule!
+(define (fix-event-widths! ev-list)
+  (if (null? ev-list)
+      #f
+      (let* ((pred? (lambda (next)
+                      (time<=? (attr next 'DTSTART)
+                               (attr (car ev-list) 'DTEND))))
+             (overlapping (take-while pred? ev-list))
+             (rest (drop-while pred? ev-list)))
+        (for-each (lambda (o x) (set! (x-pos o) x)) overlapping (iota (length overlapping)))
+        (for-each (lambda (o) (set! (width o) (/ (length overlapping))))
+                  overlapping)
+        (fix-event-widths! rest))))
+
+(define (time->decimal-hour time)
+  "This should only be used on time intervals,
+never on absolute times. For that see date->decimal-hour"
+  (exact->inexact (/ (time-second time)
+                     3600)))
+
+(define (html-attr str)
+  (define cs (char-set-adjoin char-set:letter+digit #\- #\_))
+  (string-filter (lambda (c) (char-set-contains? cs c)) str))
+
+(define (vevent->sxml ev)
+  (define style
+    (format #f "top: ~,3f%; height: ~,3f%; width: ~,3f%; left: ~,3f%"
+            (* (/ 24) 100
+               (time->decimal-hour
+                (time-difference (attr ev 'DTSTART)
+                                 (start-of-day* (attr ev 'DTSTART)))))
+            (* (/ 24) 100
+               (time->decimal-hour (time-difference (attr ev 'DTEND)
+                                                    (attr ev 'DTSTART))))
+            (* 100 (width ev))
+            (* 100 (width ev) (x-pos ev))))
+  `(div (@ (class "event CAL_" ,(html-attr (let ((l (attr (parent ev) 'NAME)))
+                                         (if (pair? l) (car l) l))))
+           (style ,style))
+        ,(attr ev 'SUMMARY)))
+
+(define (lay-out-day day)
+  (let* (((date . events) day))
+    ;; (format (current-error-port) "Processing ~a~%" (date->string date))
+    (fix-event-widths! (stream->list events))
+    `(div (@ (class "day"))
+          (div (@ (class "meta"))
+               (span (@ (class "dayname")) ,(date->string date "~a"))
+               (span (@ (class "daydate")) ,(date->string date "~Y-~m-~d")))
+          (div (@ (class "events"))
+               " "
+               ,@(stream->list (stream-map vevent->sxml events))))))
+
+
+(define (time-marker-div)
+  (map (lambda (time)
+         `(div (@ (id ,(string-append "clock-" time))
+                  (class "clock"))
+               ,(string-append time ":00")))
+       (map number->string (iota 12 0 2))))
+
+(define-public (html-main calendars events)
+  `(html (head
+          (title "Calendar")
+          (meta (@ (charset "utf-8")))
+          (link (@ (type "text/css")
+                   (rel "stylesheet")
+                   (href "static/style.css")))
+          (style ,(format #f "~{.CAL_~a { background-color: ~a }~%~}"
+                          (concat (map (lambda (c)
+                                         (list
+                                          (html-attr (if (pair? (attr c 'NAME))
+                                                         (car (attr c 'NAME))
+                                                         (attr c 'NAME)))
+                                          (or (attr c 'COLOR) "white")))
+                                       calendars)))))
+         (body (div (@ (class "calendar"))
+                    ,@(time-marker-div)
+                    (div (@ (class "days"))
+                         ,@(stream->list
+                            (stream-take 2000 (stream-map lay-out-day (group-stream events)))))))))
+
diff --git a/module/main.scm b/module/main.scm
index aef7fa8b..a83f651f 100755
--- a/module/main.scm
+++ b/module/main.scm
@@ -19,7 +19,10 @@
              (vcalendar datetime)
              (vcalendar output)
              (terminal escape)
-             (terminal util))
+             (terminal util)
+
+             (html html)
+             )
 
 (define (ev-time<? a b)
   (time<? (attr a 'DTSTART)
@@ -146,12 +149,15 @@
           regular   (sort*! regular   time<? (extract 'DTSTART)))
 
     (proc
+     calendars
      (interleave-streams
       ev-time<?
       (cons (list->stream regular)
             (map generate-recurrence-set repeating))))))
 
 (define (main args)
-  (init (lambda (events)
-          (with-vulgar
-           (lambda () (main-loop events))))))
+  ;; (init (lambda (calendars events)
+  ;;         (with-vulgar
+  ;;          (lambda () (main-loop events)))))
+  ((@ (sxml simple) sxml->xml) (init html-main))
+  )
-- 
cgit v1.2.3