diff options
Diffstat (limited to 'module/output/html.scm')
| -rw-r--r-- | module/output/html.scm | 164 |
1 files changed, 164 insertions, 0 deletions
diff --git a/module/output/html.scm b/module/output/html.scm new file mode 100644 index 00000000..3df3c713 --- /dev/null +++ b/module/output/html.scm @@ -0,0 +1,164 @@ +(define-module (output html) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-41) + #:use-module (srfi srfi-41 util) + #:use-module (vcomponent) + #:use-module (vcomponent datetime) + #:use-module (util) + #:use-module (util tree) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-19 util) + + #:use-module (parameters) + #:use-module (config)) + +(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)) + (tomorow (add-day (date->time-utc (drop-time day))))) + (let ((head (stream-take-while (ein? day) stream)) + (tail + (filter-sorted-stream* + (lambda (e) (time<? tomorow (attr e 'DTEND))) + (lambda (e) (time<=? tomorow (attr e 'DTSTART))) + 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, sets their widths and x-positions to optimally +;; fill out the space, without any overlaps. +(define (fix-event-widths! start-of-day lst) + + ;; @var{x} is how for left in the container we are. + (define (inner x tree) + (if (null? tree) #f + (let ((w (/ (- 1 x) + (+ 1 (length-of-longst-branch (left-subtree tree)))))) + (set! (width (car tree)) w + (x-pos (car tree)) x) + (inner (+ x w) (left-subtree tree)) + (inner x (right-subtree tree))))) + + (inner 0 (make-tree (lambda (head e) (overlapping? head e)) + ;; The tree construction is greedy. This means + ;; that if a smaller event preceeds a longer + ;; event it would capture the longer event to + ;; only find events which also overlaps the + ;; smaller event. + (sort* lst time>? (lambda (e) (event-length/day e start-of-day)))))) + +;; This should only be used on time intervals, never on absolute times. +;; For that see @var{date->decimal-hour}. +(define (time->decimal-hour time) + (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 day ev) + (define time (date->time-utc day)) + (define style + (format #f "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;" + + (* 100 (x-pos ev)) ; left + (* 100 (width ev)) ; width + + ;; top + (if (in-day? day (attr ev 'DTSTART)) + (* 100/24 + (time->decimal-hour + (time-difference (attr ev 'DTSTART) + (start-of-day* (attr ev 'DTSTART))))) + 0) + + ;; height + (* 100/24 (time->decimal-hour (event-length/day ev time))))) + + `(div (@ (class "event CAL_" ,(html-attr (let ((l (attr (parent ev) 'NAME))) + (if (pair? l) (car l) l))) + ,(if (time<? (attr ev 'DTSTART) time) + " continued" "") + ,(if (time<? (add-day time) (attr ev 'DTEND)) + " continuing" "")) + (style ,style)) + ,((summary-filter) ev (attr ev 'SUMMARY)))) + +(define (lay-out-day day) + (let* (((date . events) day)) + ;; (format (current-error-port) "Processing ~a~%" (date->string date)) + (fix-event-widths! (date->time-utc date) (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 (lambda (e) (vevent->sxml date e)) 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 (d str) + (string->date str "~Y-~m-~d")) + + +(define (calculate-fg-color c) + (define (str->num c n) (string->number (substring/shared c n (+ n 2)) 16)) + (let ((r (str->num c 1)) + (g (str->num c 3)) + (b (str->num c 5))) + (if (< 1/2 (/ (+ (* 0.299 r) + (* 0.587 g) + (* 0.144 b)) + #xFF)) + "black" "#e5e8e6"))) + +(define (include-css path) + `(link (@ (type "text/css") + (rel "stylesheet") + (href ,path)))) + +(define-public (html-main calendars events args) + + (define evs + (filter-sorted-stream + (compose (in-date-range? + (d "2019-04-15") + (d "2019-05-10")) + car) + (group-stream events))) + + ((@ (sxml simple) sxml->xml) + `(html (head + (title "Calendar") + (meta (@ (charset "utf-8"))) + ,(include-css "static/style.css") + (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%~}" + (map (lambda (c) + (list (html-attr (if (pair? (attr c 'NAME)) + (car (attr c 'NAME)) + (attr c 'NAME))) + (or (attr c 'COLOR) "white") + (or (and=> (attr c 'COLOR) calculate-fg-color) "black"))) + calendars)))) + (body (div (@ (class "calendar")) + ,@(time-marker-div) + (div (@ (class "days")) + ,@(stream->list (stream-map lay-out-day evs)))))))) |