; =>man/calendar.laml
;;;; This is a tool for generation of calendars, which can be shown in an Internet Browser. ;;;; The stuff in this file relies on the XHTML 1.0 transitional mirror together with the XHTML ;;;; convenience library. Thus, in order to use this calendar tool, you should load libraries in the following way (besides the fundamental LAML library): ;;;; <pre> ;;;; (laml-style "simple-xhtml1.0-transitional-validating") ;;;; (lib-load "xhtml1.0-convenience.scm") <br> ;;;; (load (string-append laml-dir "tools/calendar/xml-in-laml/calendar.scm")) <br> ;;;; </pre> <p> ;;;; ;;;; ;;;; The main function of the tool is <kbd>calendar</kbd>. The function <kbd>week-calendar</kbd> is also a top-level function. ;;;; Besides these two functions, it is important to understand the input format of appointments in the calendar. ;;;; Also, there are a number of constants, which affect the appearance of the calendar. <p> ;;;; ;;;; ;;;; This tools requires input in terms of calendar events, which are assumed to be hold the the Scheme ;;;; variabel <kbd>calendar-events</kbd>. In other words, you must define this variable to a value which represents a list of calendar event. ;;;; Below, in section 1, we explain the calendar event format. <p> ;;;; ;;;; ;;;; Besides the general LAML stuff (laml.scm) and the XHTML mirror libraries (mentioned above) this tools requires the libraries ;;;; <a href = "../../../../lib/man/color.html">color.scm</a>, <a href="../../../../lib/man/time.html">time.scm</a> and <a href="../../../../lib/man/file-read.html">file-read.scm</a> (all from directory lib in the LAML distribution). ;;;; The required libraries are not loaded by the tool itself. Notice however, that the loading example given above also includes ;;;; loading of color, time and file-read (because they are loaded by <a href="../../../../styles/man/simple-xhtml1.0-transitional-validating.html">simple-xhtml1.0-transitional-validating</a>). <p> ;;;; ;;;; ;;;; The font size of the calendar entries is controlled by CSS. ;;;; You can either link to a CSS file, or embed a CSS clause in the head of your HTML element. ;;;; The following CSS clauses is an example: ;;;; <pre><kbd> (style 'type "text/css" "TABLE.calendar-table TD { font-size: 7pt; }")</kbd></pre> <p> ;;;; A clause like this should be a constituent of the HTML head element.<p> ;;;; ;;;; Please take look at the <a href = "../../../../examples/calendar-xml/index.html">calendar examples</a>.<p> ;;;; ;;;; At www.cs.aau.dk we support a <a href="http://www.cs.aau.dk/~normark/cgi-bin/calendar/calendar-entry.cgi">LAML web calendar service</a> which will generate a calendar for you based on web input. ;;;; You are welcome to try it out.
;;;; .title Reference Manual of the LAML Calendar Tool - XHTML
; The LAML library and programs are written by Kurt Normark, Aalborg University, Denmark. ; Copyright (C) 2002 Kurt Normark, normark@s.auc.dk. ; ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
; LOG: ; 21.12.98: ; Changed such that multiple appointments on a single day get their own colors. ; boil-together has been changed to return color-frames instead of a simple text. ; The color-function in month-column has been changed to use background colors now that each appointment has its color-frame
; 5.2.98: We introduced a new week separation which looks real good in Internet Explorer 4.0, but not as good in Netscape 4.01.
; 4.10.02: Converted to XHTML
; 16.8.2005: Generalized to more than two columns (before and after noon).
;;; About the format of calendar input. ;;; The calendar input must be present in a variable named <kbd>calendar-events</kbd>. ;;; <kbd>calendar-events</kbd> must be defined externally to the calendar tool. ;;; <kbd>calendar-events</kbd> is a list of appointments. ;;; A single appointment is, in turn, a list. Thus <kbd>calendar-events</kbd> is a list of lists.<p> ;;; ;;; The detailed format of an appointment is the following: <br> ;;; ;;; <pre> (start-time end-time brief-description long-description color url) </pre> ;;; ;;; Start-time and end-time are integers (a number of seconds since january 1, 1970). ;;; The function time-encoding from the <a href="../../../../lib/man/time.html">time library</a> is useful for construction of these ;;; numbers.<p> ;;; ;;; Brief-description is a string, the contents of which goes into the calendar. ;;; Long-description is a longer description of the event. The long description is supposed to contain the brief description as well. ;;; The long description is currently used as a popup title text of a calendar event presentation. ;;; In addition, the long description is shown instead of the brief description in a week calendar. <p> ;;; ;;; Color is a RGB color. ;;; The color can be given in all formats accepted by the function <a href = "../../../../lib/man/color.html#rgb-color-encoding">rgb-color-encoding</a> from the LAML color library. ;;; You can also use the color constants of the <a href = "../../../../lib/man/color.html">LAML color library</a>. <p> ;;; ;;; Finally, url is an URL, to which we link from the calendar entry. If it is the empty string, no link will be made.
; ---------------------------------------------------------------------------------------------------------------
;;; Event selection functions. ;;; The event selector functions define accessors into a calendar appointment.

(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))) ; ---------------------------------------------------------------------------------------------------------------
;;; Calendar parameters. ;;; In this section we find a number of variables which control the calendar appearance.
; The calendar font size. Default value is 1. ; Not used any more. The font size is controlled by a CSS clause, external to the calendar fragment.
(define calendar-font-size 1)
(define week-separator-of-calendar 'thin) ; alternative: 'thick
(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) ;
; is there an overlap between the intervals, each of which is a list (x y), x <= y. ; function of general interest
(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)) ; embedding
(and (<= i2-start i1-start) (<= i1-end i2-end)) (and (<= i1-start i2-start) (<= i2-end i1-end))))) ; Return a second count interval from calendar-division-of-day, as of year, month and day. ; The first interval is numbered 1. ; The size of n is coupled to the length of calendar-division-of-day.
(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))))) ; Return an interval of first half day. From 00:00 to 12:00
(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)))) ; Return an interval of second half day. From 12:00 to 24:00
(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)))) ; Return a list of the form (y . m). There are number-of-months entries in the list
(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))) ; enumerate the second counts of month in year
(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))))) ; Return a string of (at least) two characters given a non-negative integer n. Pad with '0'.
(define (two-ciffers n) (cond ((< n 10) (string-append "0" (as-string n))) (else (as-string n)))) ; Jeg har taget (as-string) væk rundt om cell - det giver problemer på uge numre...
(define (present-cell cell size) cell) ; earlier (font-size size cell) - does not validate. Cannot have font around table structure
; return all elements of list which satiesfy the predicate p ; general
(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)))) ; Return the text of a day in a calendar, given year, month, day and day-part. ; Searches in calendar-events. ; part-of-day addresses a (relative) time interval in the calendar-division-of-day, and it is an integer (1 or larger). ; In the original version of this tool (before Aug 16, 2005) part-of-day was either 1 or 2 (before or after noon).
(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) ; monday
(let ((week-num (danish-week-number sc))) (as-string week-num)) "")) "")) ; aggreates the matching event to a single string, use separator sep between entries.
(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")))) ; Is calendar event e1 less than or equal to calendar event e2
(define (event-leq? e1 e2) (<= (event-start-time e1) (event-start-time e2))) ; Given a particular calendar interval, cal-interval, which is day-number (redundant), ; return the color asked for in the event-list
(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))))) ; Return a HTML table for month in year. ; if today-info? is true, emphasize today in red. ; number-of-divisions is an integer that gives the number of calendar divisions of a single 24 hour period (a day and a night).
(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)) ; not used any more
(other-columns-width (quotient (- month-width 40) number-of-divisions)) ) (cal-table 0 ; width list
(append (list 20 20) (make-list number-of-divisions other-columns-width)) ; background color function
(lambda (row) (if (equal? (car row) (week-sep)) (make-list (+ number-of-divisions 2) (if (eq? week-separator-of-calendar 'thin) grey1 black)) ; WEEK SEPARATOR
(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)) ; not used in this version
(event-color-2 (the-event-color (second-half-day-interval year month day) day)) ; not used in this version
) (background-color-list number-of-divisions (even? day) today)))) ; week separator predicate: NOT USED ANY MORE. SEPARATORS AFTER SUNDAY HOW HAS THEIR OWN ROW. THUS ALWAYS FALSE
(lambda (row) #f) ; font-size
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)))) ; Given the second-count-list for a month, return a list of (second-count brief-weekday day tasks-1 tasks-2 ... ) for each day in month if year. ; The parameter month is supposed to have days number of days. ; Week separators are returned as (0 "" "" "" "" ...), made by the function make-week-separator.
(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)) ; tasks of the number-of-divisions periods
) ) (number-interval 1 days) second-count-list )) (entries-with-sep (week-separator-extend entries number-of-divisions)) ) (map cdr entries-with-sep))) ; Introduce week separators into entries
(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)))) ; enumerate years and months, starting from start-year and start-month. The entries in the list ; are of the form (y . m). The length of the list is number-of-months
(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"))))
;;; The main calendar function. ;;; In this section we find the most important function at all, the calendar function which generates a calendar.

(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) ; part-of-day addresses a (relative) time interval in the calendar-division-of-day, and it is an integer (1 or larger).
(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 "")))) ; aggreates the matching event to a single string, use separator sep between entries. ; A variant of boil-together.
(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 ; width list
(append (list 100 50) (make-list number-of-divisions other-columns-width)) ; background color function
(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) ; not relevant
3 ; font size
; content list
(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)) ; week-tasks of the number-of-divisions periods
) ) ) weekday-list week-start-time-list)))))))