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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
(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 (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.
;;; 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 (d str)
(string->date str "~Y-~m-~d"))
(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-map
lay-out-day
(filter-sorted-stream
(compose (in-date-range?
(d "2019-04-15")
(d "2019-04-22"))
car)
(group-stream events)))))))))
|
