(define (event-start-time e) (list-ref e 0))
(define (event-end-time e) (list-ref e 1))
(define (event-brief-text e) (list-ref e 2))
(define (event-long-text e) (list-ref e 3))
(define (event-color e) (list-ref e 4))
(define (event-url e) (list-ref e 5))
(define (event-interval e) (list (event-start-time e) (event-end-time e)))
(define calendar-font-size 1)
(define week-separator-of-calendar 'thin)
(define (week-sep)
(cond ((eq? week-separator-of-calendar 'thin) "")
((eq? week-separator-of-calendar 'thick) (hr))
(else (error "Calendar: week separator problems"))))
(define month-width 150)
(define calendar-division-of-day
(let ((noon-time (/ seconds-in-a-day 2)))
(list (list 0 (- noon-time 1)) (list noon-time (- seconds-in-a-day 1)))))
(define calendar-background-color white)
(define (interval-overlap? interval-1 interval-2)
(let ((i1-start (car interval-1))
(i1-end (cadr interval-1))
(i2-start (car interval-2))
(i2-end (cadr interval-2)))
(or (and (<= i2-start i1-end) (<= i1-end i2-end))
(and (<= i1-start i2-end) (<= i2-end i1-end))
(and (<= i2-start i1-start) (<= i1-end i2-end))
(and (<= i1-start i2-start) (<= i2-end i1-end)))))
(define (part-of-day-interval year month day n)
(let* ((start (second-count year month day 0 0 0))
(division-interval (list-ref calendar-division-of-day (- n 1)))
)
(list (+ start (first division-interval)) (+ start (second division-interval)))))
(define (first-half-day-interval year month day)
(let ((start (second-count year month day 0 0 0)))
(list start (- (+ start (quotient seconds-in-a-day 2)) 1))))
(define (second-half-day-interval year month day)
(let ((start (second-count year month day 0 0 0)))
(list (+ start (quotient seconds-in-a-day 2)) (- (+ start seconds-in-a-day) 1))))
(define (month-list from-month year number-of-months)
(let ((y-m-l (year-month-list year from-month number-of-months)))
(map (lambda (y-m) (con (get-month-name (cdr y-m)) " " (as-string (car y-m))))
y-m-l)))
(define (make-second-counts month year)
(map (lambda (day)
(second-count year month day 0 0 0))
(number-interval 1 (days-in-month month year))))
(define (cal-table border cell-width-list cell-color-function weekend? cell-font-size list-of-list)
(let ((bdr (list 'border (as-string border))))
(table 'class "calendar-table" bdr
(tbody
(if (> (length calendar-division-of-day) 1) (calendar-division-presentation) '())
(map
(lambda (row)
(tr
(map (lambda (cell width color-1)
(td 'bgcolor (rgb-color-encoding color-1)
(div 'css:width (string-append (as-string width) "px") (present-cell cell cell-font-size))
(if (weekend? row) (hr) '())))
row cell-width-list (cell-color-function row))))
list-of-list)))))
(define (calendar-division-presentation)
(tr (td) (td) (map (lambda (i) (td (center (font 'size "1" (hour-minute-interval-presentation (list-ref calendar-division-of-day (- i 1))))))) (number-interval 1 (length calendar-division-of-day)))))
(define (hour-minute-interval-presentation from-to-second-list)
(let* ((from-second-count (first from-to-second-list))
(to-second-count (second from-to-second-list))
(from-hour-minute (hours-minutes-seconds-decode from-second-count))
(to-hour-minute (hours-minutes-seconds-decode to-second-count))
)
(list (two-ciffers (first from-hour-minute)) _ ":" _ (two-ciffers (second from-hour-minute)) "-" (two-ciffers (first to-hour-minute)) _ ":" _ (two-ciffers (second to-hour-minute)))))
(define (two-ciffers n)
(cond ((< n 10) (string-append "0" (as-string n)))
(else (as-string n))))
(define (present-cell cell size)
cell)
(define (find-all p lst)
(find-all-help p lst '()))
(define (find-all-help p lst res)
(cond ((null? lst) (reverse res))
((p (car lst)) (find-all-help p (cdr lst) (cons (car lst) res)))
(else (find-all-help p (cdr lst) res))))
(define (tasks year month day part-of-day)
(let* ((cal-interval (part-of-day-interval year month day part-of-day))
(matching-events
(find-all
(lambda (e) (interval-overlap? cal-interval (event-interval e)))
calendar-events))
(wnc (week-number-contribution year month day part-of-day)))
(if (equal? "" wnc)
(boil-together matching-events "")
(list (i wnc) (boil-together matching-events "")))))
(define (week-number-contribution year month day part-of-day)
(if (= 1 part-of-day)
(let* ((sc (second-count year month day 0 0 0))
(day-number (weekday-number sc)))
(if (= 1 day-number)
(let ((week-num (danish-week-number sc)))
(as-string week-num))
""))
""))
(define (boil-together matching-events sep)
(if (null? matching-events)
(space 1)
(let ((res (map (lambda (s)
(con s sep))
(map (lambda (e)
(let* ((brief-txt (event-brief-text e))
(al (level-of-attention brief-txt))
(unattensioned-brief-txt (substring brief-txt 0 (- (string-length brief-txt) al)))
)
(if (> (string-length (event-url e)) 0)
(color-frame (attention-deco al (a 'href (event-url e) 'title (event-long-text e) unattensioned-brief-txt)) (event-color e))
(color-frame (attention-deco al (span unattensioned-brief-txt 'title (event-long-text e))) (event-color e)) )))
(sort-list matching-events event-leq?)))))
res)))
(define (level-of-attention str)
(let* ((len (string-length str))
(c (- len 1))
(d (- len 2))
(e (- len 3)))
(cond ((and (>= len 3) (eqv? #\! (string-ref str c)) (eqv? #\! (string-ref str d)) (eqv? #\! (string-ref str e))) 3)
((and (>= len 2) (eqv? #\! (string-ref str c)) (eqv? #\! (string-ref str d))) 2)
((and (>= len 1) (eqv? #\! (string-ref str c))) 1)
(else 0))))
(define (attention-deco level x)
(cond ((= level 0) x)
((= level 1) (span x (b (font 'color (rgb-color-encoding 255 0 0) 'size "2" "!"))))
((= level 2) (span x (b (font 'color (rgb-color-encoding 255 0 0) 'size "3" "!!"))))
((> level 2) (span (b x (font 'color (rgb-color-encoding 255 0 0) 'size "4" "!!!")) 'css:text-decoration "blink"))))
(define (attention-deco-week level x)
(cond ((= level 0) x)
((= level 1) (span x (b (font 'color (rgb-color-encoding 255 0 0) 'size "4" "!"))))
((= level 2) (span x (b (font 'color (rgb-color-encoding 255 0 0) 'size "5" "!!"))))
((> level 2) (span (b x (font 'color (rgb-color-encoding 255 0 0) 'size "6" "!!!")) 'css:text-decoration "blink"))))
(define (event-leq? e1 e2)
(<= (event-start-time e1) (event-start-time e2)))
(define (the-event-color cal-interval day-number)
(let ((matching-events
(find-all
(lambda (e) (interval-overlap? cal-interval (event-interval e)))
calendar-events)))
(if (null? matching-events)
(if (even? day-number) green1 green2)
(event-color (car matching-events)))))
(define (month-column month year today-info? number-of-divisions)
(let ((days (days-in-month month year))
(half-column-width (quotient (- month-width 40) 2))
(other-columns-width (quotient (- month-width 40) number-of-divisions))
)
(cal-table 0
(append (list 20 20) (make-list number-of-divisions other-columns-width))
(lambda (row)
(if (equal? (car row) (week-sep))
(make-list (+ number-of-divisions 2) (if (eq? week-separator-of-calendar 'thin) grey1 black))
(let* ((day (as-number (cadr row)))
(start-time (second-count year month day 0 0 0))
(end-time (+ start-time seconds-in-a-day))
(today (and today-info? (>= (current-time) start-time) (<= (current-time) end-time)))
(event-color-1 (the-event-color (first-half-day-interval year month day) day))
(event-color-2 (the-event-color (second-half-day-interval year month day) day))
)
(background-color-list number-of-divisions (even? day) today))))
(lambda (row) #f)
calendar-font-size
(month-list-with-week-separators (make-second-counts month year) days year month number-of-divisions)
)))
(define (background-color-list number-of-divisions even? today?)
(append
(cond (today? (list red red))
(even? (list green1 green1))
(else (list green2 green2)))
(if even? (make-list number-of-divisions green1) (make-list number-of-divisions green2))))
(define (month-list-with-week-separators second-count-list days year month number-of-divisions)
(let* ((entries (map2 (lambda (day sec-count)
(append
(list sec-count (brief-weekday sec-count) (as-string day))
(map (lambda (n) (tasks year month day n)) (number-interval 1 number-of-divisions))
)
)
(number-interval 1 days)
second-count-list
))
(entries-with-sep (week-separator-extend entries number-of-divisions))
)
(map cdr entries-with-sep)))
(define (week-separator-extend entries number-of-divisions)
(cond ((null? entries) '())
((= 7 (weekday-number (caar entries)))
(cons (car entries)
(cons (make-week-separator number-of-divisions)
(week-separator-extend (cdr entries) number-of-divisions))))
(else (cons (car entries) (week-separator-extend (cdr entries) number-of-divisions)))))
(define (make-week-separator number-of-divisions)
(cons 0 (make-list (+ 2 number-of-divisions) (week-sep))))
(define (year-month-list start-year start-month number-of-months)
(cond ((= 0 number-of-months) '())
((= start-month 12) (cons (cons start-year start-month) (year-month-list (+ 1 start-year) 1 (- number-of-months 1))))
((< start-month 12) (cons (cons start-year start-month) (year-month-list start-year (+ 1 start-month) (- number-of-months 1))))
(else (error "year-month-list problem"))))
(define (calendar year from-month number-of-months . optional-parameter-list)
(let ((show-today? (optional-parameter 1 optional-parameter-list #f))
(number-of-divisions (optional-parameter 2 optional-parameter-list 2))
)
(if (not (= number-of-divisions (length calendar-division-of-day)))
(laml-error "calendar: the value of number-of-divisions must be equal to the length of the list calendar-division-of-day" number-of-divisions (length calendar-division-of-day)))
(table-2 1 (make-list number-of-months month-width)
(make-list number-of-months calendar-background-color)
(month-list from-month year number-of-months)
(list
(map (lambda (y-m) (month-column (cdr y-m) (car y-m) show-today? number-of-divisions)) (year-month-list year from-month number-of-months))))))
(define xml-error-truncation-length 1000)
(define (week-tasks year month day part-of-day)
(let* ((cal-interval (part-of-day-interval year month day part-of-day))
(matching-events
(find-all
(lambda (e) (interval-overlap? cal-interval (event-interval e)))
calendar-events))
(wnc ""))
(div (if (equal? "" wnc) "" (em wnc)) (boil-together-week matching-events ""))))
(define (boil-together-week matching-events sep)
(if (null? matching-events)
(space 1)
(let ((res (map (lambda (s)
(con s sep))
(map
(lambda (e)
(let* ((brief-txt (event-brief-text e))
(al (level-of-attention brief-txt))
(unattensioned-brief-txt (substring brief-txt 0 (- (string-length brief-txt) al)))
)
(if (> (string-length (event-url e)) 0)
(color-frame (attention-deco-week al (a 'href (event-url e) (event-long-text e))) (event-color e))
(color-frame (attention-deco-week al (span (event-long-text e) )) (event-color e)) )))
(sort-list matching-events event-leq?) ))))
res)))
(define (week-calendar t0 . optional-parameter-list)
(let ((number-of-divisions (optional-parameter 1 optional-parameter-list 2))
(week-cal-column-width (optional-parameter 2 optional-parameter-list 200))
)
(let* ((dec-t0 (time-decode t0))
(wdn (weekday-number t0))
(day-start (time-encode (year-of-time dec-t0) (month-of-time dec-t0) (day-of-time dec-t0) 0 0 0))
(week-start (- day-start (* (- wdn 1) seconds-in-a-day)))
(decoded-week-start (time-decode week-start))
(week-end (- (+ (* 7 seconds-in-a-day) week-start) 1))
(week-start-time-list (map (lambda (i) (+ week-start (* i seconds-in-a-day))) (number-interval 0 6)))
(weekday-list (if (eq? language-preference 'english)
(list "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")
(list "Mandag" "Tirsdag" "Onsdag" "Torsdag" "Fredag" "Lørdag" "Søndag")
))
(weekday-assoc-list (pair-up weekday-list week-start-time-list))
)
(div
(text-choice "Ugestart: " "Start of week: ") (car (date-time week-start)) (br)
(text-choice "Ugenummer: " "Week number: ") (as-string (danish-week-number week-start)) (p)
(let ((other-columns-width week-cal-column-width))
(cal-table
1
(append (list 100 50) (make-list number-of-divisions other-columns-width))
(lambda (row)
(let* ((weekday (car row))
(start-time (cdr (assoc weekday weekday-assoc-list)))
(cur-time (current-time)))
(cond ((and (<= start-time cur-time) (<= cur-time (+ start-time seconds-in-a-day)))
(append (list red red) (make-list number-of-divisions green2)))
(else (make-list (+ 2 number-of-divisions) green2)))))
(lambda (row) #f)
3
(map2 (lambda (weekday daystart-time)
(let* ((decoded-daystart-time (time-decode daystart-time))
(day (day-of-time decoded-daystart-time))
(month (month-of-time decoded-daystart-time))
(year (year-of-time decoded-daystart-time))
)
(append
(list weekday (as-string day))
(map (lambda (n) (week-tasks year month day n)) (number-interval 1 number-of-divisions))
)
)
)
weekday-list week-start-time-list)))))))