calendar.scm

(use srfi-1)
(use srfi-19)
(use srfi-42)

(define (split-when pred? list)
  (let loop ([item '()]
             [result '()]
             [list list])
    (cond
     [(null? list) (reverse (if (null? item)
                                result
                                (cons (reverse item) result)))]
     [(pred? list) (loop (cons (car list) '())
                         (if (null? item)
                             result
                             (cons (reverse item) result))
                         (cdr list))]
     (else (loop (cons (car list) item)
                 result
                 (cdr list))))))

(define (get-dates-in-a-month now)
  (let* ([first-day (make-date 1 1 1 1
                               1
                               (date-month now)
                               (date-year now)
                               (date-zone-offset now))]
         [same-month? (lambda (date)
                        (eqv? (date-month date)
                              (date-month now)))]
         [time-diff (lambda (nr-days)
                      (time-difference (make-time time-utc 0 (* nr-days 60 60 24))
                                       (make-time time-utc 0 0)))]
         [add-day (lambda (date nr-days)
                    (time-utc->date (add-duration (date->time-utc date)
                                                  (time-diff nr-days))
                                    (date-zone-offset date)))])
    (filter same-month?
            (list-ec (: nr-days 32)
                     (add-day first-day nr-days)))))

(define (pad-first-week weeks)
  (let ([padding (- 7 (length (first weeks)))])
    (if (> padding 0)
        (cons (append (list-ec (: i padding) #f) (first weeks))
              (cdr weeks))
        weeks)))

(define (calendar now)
  (let ([weeks (split-when (lambda (list)
                             (eqv? (date-week-day (car list)) 1))
                           (get-dates-in-a-month now))])

    (map (lambda (week)
           (map (lambda (date)
                  (and (date? date)
                       (date-day date)))
                week))
         (pad-first-week weeks))))

(let ([weeks (calendar (current-date))])
  (print "T2 T3 T4 T5 T6 T7 CN")
  (for-each (lambda (week)
              (for-each (lambda (day)
                          (if day
                            (format #t "~2a " day)
                            (format #t "   ")))
                        week)
              (print))
            weeks))