CalendarForm

These lines compute a month view calendar panel.

(begin

(define (calendar month . off)
 (define offset (if (pair? off) (car off) 1))
 (define mon1st (make-date 0 0 0 0  1 (date-month month)
                (date-year month) (date-zone-offset month)))
 (define lml (julian-day->date (- (date->julian-day mon1st) 1)
                               (date-zone-offset month)))
 (define nm1st
   (if (eqv? (date-month month) 12)
       (make-date 0 0 0 0  1 1
                   (+ (date-year month) 1) (date-zone-offset month))
       (make-date 0 0 0 0  1 (+ 1 (date-month month))
                       (date-year month) (date-zone-offset month))))
 (define tml (julian-day->date (- (date->julian-day nm1st) 1)
                               (date-zone-offset month)))

 (define wk1 (let ((x (modulo (- offset (date-week-day mon1st)) 7)))
               (if (eqv? x 0) 7 x)))
 
 (define (week start end)
  (cons
   'tr
   (let loop ((day start) (wd 7))
     (if (eqv? wd 0)
         '()
         `((td ,(literal day))
           . ,(loop (if (eqv? day end) 1 (+ day 1)) (- wd 1)))))))

 (sxml
  `(table
    (tr . ,(let loop ((n 7)
                    (day (+ (date->julian-day lml)
                            (- offset (date-week-day lml)))))
           (if (eqv? n 0) '()
               `((td ,(date->string 
                       (julian-day->date day (date-zone-offset month))
                       "~a" "de"))
                 . ,(loop (- n 1) (+ day 1))))))
    (tr
     ,@(let loop ((run  (- 7 wk1))
                  (day (+ (date-day lml)
                          (- offset (date-week-day lml)))))
         (if (<= run 0)
             (let loop ((day 1))
                  (if (< wk1 day) '()
                      `((td ,(literal day)) . ,(loop (+ day 1)))))
             `((td ,(literal day))
               . ,(loop (- run 1) (+ day 1))))))
     ,(week (+ wk1 1) (+ wk1 7))
     ,(week (+ wk1 8) (+ wk1 14))
     ,(week (+ wk1 15) (date-day tml))
     ,@(let ((start (+ wk1 22)))
         (if (>= (date-day tml) start)
             (list (week start (date-day tml)))
             '()))
     ,@(let ((start (+ wk1 29)))
         (if (>= (date-day tml) start)
             (list (week start (date-day tml)))
             '()))
   ))

)

(calendar (make-date 0 0 0 0  23 12 1965 0) 1)

)

Source code:

<p>These lines compute a month view calendar panel.</p>
<pre>
(begin

(define (calendar month . off)
 (define offset (if (pair? off) (car off) 1))
 (define mon1st (make-date 0 0 0 0  1 (date-month month)
                (date-year month) (date-zone-offset month)))
 (define lml (julian-day-&gt;date (- (date-&gt;julian-day mon1st) 1)
                               (date-zone-offset month)))
 (define nm1st
   (if (eqv? (date-month month) 12)
       (make-date 0 0 0 0  1 1
                   (+ (date-year month) 1) (date-zone-offset month))
       (make-date 0 0 0 0  1 (+ 1 (date-month month))
                       (date-year month) (date-zone-offset month))))
 (define tml (julian-day-&gt;date (- (date-&gt;julian-day nm1st) 1)
                               (date-zone-offset month)))

 (define wk1 (let ((x (modulo (- offset (date-week-day mon1st)) 7)))
               (if (eqv? x 0) 7 x)))
 
 (define (week start end)
  (cons
   'tr
   (let loop ((day start) (wd 7))
     (if (eqv? wd 0)
         '()
         `((td ,(literal day))
           . ,(loop (if (eqv? day end) 1 (+ day 1)) (- wd 1)))))))

 (sxml
  `(table
    (tr . ,(let loop ((n 7)
                    (day (+ (date-&gt;julian-day lml)
                            (- offset (date-week-day lml)))))
           (if (eqv? n 0) '()
               `((td ,(date-&gt;string 
                       (julian-day-&gt;date day (date-zone-offset month))
                       "~a" "de"))
                 . ,(loop (- n 1) (+ day 1))))))
    (tr
     ,@(let loop ((run  (- 7 wk1))
                  (day (+ (date-day lml)
                          (- offset (date-week-day lml)))))
         (if (&lt;= run 0)
             (let loop ((day 1))
                  (if (&lt; wk1 day) '()
                      `((td ,(literal day)) . ,(loop (+ day 1)))))
             `((td ,(literal day))
               . ,(loop (- run 1) (+ day 1))))))
     ,(week (+ wk1 1) (+ wk1 7))
     ,(week (+ wk1 8) (+ wk1 14))
     ,(week (+ wk1 15) (date-day tml))
     ,@(let ((start (+ wk1 22)))
         (if (&gt;= (date-day tml) start)
             (list (week start (date-day tml)))
             '()))
     ,@(let ((start (+ wk1 29)))
         (if (&gt;= (date-day tml) start)
             (list (week start (date-day tml)))
             '()))
   ))

)

(calendar (make-date 0 0 0 0  23 12 1965 0) 1)

)
</pre>