1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
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)))))))))
|
