(define-module (html html)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-41)
#:use-module (srfi srfi-41 util)
#:use-module (vcalendar)
#:use-module (vcalendar datetime)
#:use-module (util)
#:use-module (util tree)
#: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))
(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! 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>? event-length))))
(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 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))
(* (/ 24) 100
(time->decimal-hour
(time-difference (attr ev 'DTSTART)
(start-of-day* (attr ev 'DTSTART)))))
0)
;; height
(* (/ 24) 100
(time->decimal-hour
(if (in-day? day (attr ev 'DTEND))
(if (in-day? day (attr ev 'DTSTART))
;; regular
(time-difference (attr ev 'DTEND)
(attr ev 'DTSTART))
;; end today, start later
(time-difference (attr ev 'DTEND)
time))
(if (in-day? day (attr ev 'DTSTART))
;; end today, start earlier
(time-difference (add-day time)
(attr ev 'DTSTART))
;; start earlier, end earlier
(time-difference (add-day time)
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))
,(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 (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-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; 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")
(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
(filter-sorted-stream
(compose (in-date-range?
(d "2019-04-15")
(d "2019-05-10"))
car)
(group-stream events)))))))))