#! /usr/local/bin/csi -script-meta
-r5rs

;;;; Simple annual calendar printer

; Copyright (c) 2002, Dale E. Jordan
; All rights reserved.
;
; Redistribution and use, with or without modification, are permitted
; provided that the following conditions are met:

;   Redistributions of source code must retain the above copyright
;   notice, this list of conditions and the following disclaimer.

;   Redistributions in binary form must reproduce the above copyright
;   notice, this list of conditions and the following disclaimer in
;   the documentation and/or other materials provided with the
;   distribution.

; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER "AS IS" AND ANY
; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE
; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

; Send bugs, suggestions and ideas to: dalej@alum.mit.edu


(require 'srfi-1)

(define main
  (lambda (args)
    (if (and (= (length args) 1)
             (let ((y (string->number (car args))))
               (if y
                   (begin (calendar y) #t)
                   #f)))
        0
        (begin
          (display "Usage: calendar <year>") (newline)
          1))))

(define-syntax receive
  (syntax-rules ()
    ((_ vars expr . body)
     (call-with-values
         (lambda () expr)
       (lambda vars . body)))))

(define right-justify
  (lambda (str width . maybe-fill)
    (string-append
     (make-string (max 0 (- width (string-length str)))
                  (if (null? maybe-fill) #\space (car maybe-fill)))
     str)))

(define bind                            ; bind first arg of binary function
  (lambda (f x)
    (lambda (y) (f x y))))

(define bind~                           ; bind second arg of binary function
  (lambda (f y)
    (lambda (x) (f x y))))

(define (compose-n f g)                 ; compose functions (from Shivers)
  (lambda args (call-with-values (lambda () (apply g args)) f)))

(define scan                            ; APL scan operator for lists
  (lambda (f zero lis)
    (let recur ((lis lis)
                (ac zero))
      (if (null? lis)
          '()
          (let ((ac- (f (car lis) ac)))
            (cons ac- (recur (cdr lis) ac-)))))))

;;; The following procedures are useful for manipulating complete
;;; nested lists that are simulating multi-dimensional arrays.

(define map-level                       ; map f at level n in nested lists
  (lambda (n)
    (lambda (f . lists)
      (let recur ((i n) (lists lists))
        (cond ((zero? i)                ; level 0 is straight apply
               (apply f lists))
              ((= i 1)
               (apply map f lists))     ; level 1 is normal map
              (else
               (apply map (lambda sub-lists (recur (- i 1) sub-lists))
                      lists)))))))

(define nest                            ; create list of size chunks of lis
  (lambda (size lis)                    ; size must divide (length lis)
    (let recur ((lis lis))
      (if (null? lis)
          '()
          (receive (chunk rest) (split-at lis size)
              (cons chunk (recur rest)))))))

(define transpose                       ; transpose top 2 levels of list
  (lambda (lis)
    (let recur ((lis lis))
      (if (null? (car lis))
          '()
          (cons (map car lis) (recur (map cdr lis)))))))

(define flatten (lambda (lis) (apply append lis)))

(define vector-tabulate
  (lambda (n init-proc)
    (do ((v (make-vector n))
         (i 0 (+ 1 i)))
        ((= i n) v)
      (vector-set! v i (init-proc i)))))

(define vector-map
  (lambda (f vec . vecs)
    (let* ((n (vector-length vec))
           (vr (make-vector n)))
      (if (pair? vecs)
          (if (null? (cdr vecs))        ; special case binary f, too
              (do ((i 0 (+ 1 i))
                   (vec1 (car vecs)))
                  ((= i n) vr)
                (vector-set! vr i (f (vector-ref vec i) (vector-ref vec1 i))))
              (do ((i 0 (+ 1 i)))
                  ((= i n) vr)
                (vector-set!
                 vr i
                 (apply f (vector-ref vec i)
                        (map (lambda (v) (vector-ref v i)) vecs)))))
          (do ((i 0 (+ 1 i)))
              ((= i n) vr)
            (vector-set! vr i (f (vector-ref vec i))))))))

(define vector-iota
  (lambda (count . maybe-start+step)
    (receive (start step)
      (if (pair? maybe-start+step)
          (if (pair? (cdr maybe-start+step))
              (values (car maybe-start+step) (cadr maybe-start+step))
              (values (car maybe-start+step) 1))
          (values 0 1))
      (vector-tabulate count (lambda (i) (+ start (* i step)))))))

(define cum-days        ; days since 1 March of first of each adjusted month
   '#( 0 31 61 92 122 153 184 214 245 275 306 337 ))
(define years-per-period '#( 400 100 4 1 ))
(define days-per-period  '#( 146097 36524 1461 365 ))

(define date->days                      ; days since 0000 Mar 1 (Wed)
  (let ((adjust-date
         (lambda (y m)                  ; adjust to Mar 1 start of year
           (if (> m 2)
               (values y (- m 3) )
               (values (- y 1) (+ m 9))))))
    (lambda (y m d)                     ; date is (YYYY MM DD)
      (receive (y m) (adjust-date y m)
        (+ d -1 (vector-ref cum-days m)
           (let loop ((i 0) (t 0) (rem y))
             (if (= i 4)
                 t
                 (loop  (+ i 1)
                        (+ t (* (quotient rem (vector-ref years-per-period i))
                                (vector-ref days-per-period i)))
                        (remainder rem (vector-ref years-per-period i))))))))))

(define (leap-year? year)
  (and (zero? (remainder year 4))
       (or (not (zero? (remainder year 100)))
           (zero? (remainder year 400)))))

(define days->dow       ; mon = 0 ... sun = 6
  (lambda (days) (remainder (+ days 2) 7)))

(define date->dow (compose-n days->dow date->days))

;;; This algorithm is purely functional, using arrays simulated by nested
;;; lists.  The comments give the shapes of the intermediate arrays.

(define calendar
  (let ((blanks "   ")
        (day-strings                    ; " nn" for 31 day numbers
         (vector-map
          (lambda (n) (right-justify (number->string n) 3))
          (vector-iota 31 1)))
        (month-labels                   ; columns of month labels for calendar
         ((map-level 2)                 ; (4 3 6 1 3)
          (bind nest 1)
          ((map-level 2)                ; (4 3 6 3)
           (let ((spaces-3 '((#\space #\space #\space))))
             (lambda (l)
               (append spaces-3 l spaces-3 spaces-3)))
             (nest                      ; (4 3 3 3)
              3
              ((map-level 2)            ; (12 3 3)
               (lambda (char) (list #\space #\space char))
               (map                     ; (12 3)
                string->list
                '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
                  "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))))))))
    (lambda (year)
      (for-each
       (lambda (s) (display s) (newline))
       (map                             ; (24)
        list->string
        (map                            ; (24 79)
         append
         (let ((spaces-10 (make-list 10 #\space))) ; (24 1) year column
           (nest
            1
            (append spaces-10
                    (string->list (right-justify (number->string year) 4))
                    spaces-10)))
         (map                           ; (24 78)
          flatten
          (flatten                      ; (24 3 26)
           (map                         ; (4 6 3 26)
            transpose
            ((map-level 3)              ; (4 3 6 26)
             (compose-n
              (bind~ append '(#\space #\space))
              (compose-n                ; (4 3 6 24)
               flatten                  ; (4 3 6 8 3)
               append))
             month-labels               ; (4 3 6 1 3)
             ((map-level 2)             ; (4 3 6 7 3)
              (bind nest 7)
              (nest                     ; (4 3 42 3)
               3
               (let* ((months-days
                      `(31 ,(if (leap-year? year) 29 28)
                           31 30 31 30 31 31 30 31 30 31))
                      (jan-1-day (remainder (+ 1 (date->dow year 1 1)) 7))
                      (start-days
                       (map (lambda (doy) (remainder (+ doy jan-1-day) 7))
                            (cons 0 (drop-right (scan + 0 months-days) 1)))))
                 (map                   ; (12 42 3)
                  (lambda (days start-day)
                    (map
                     string->list
                     (append (make-list start-day blanks)
                             (map (bind vector-ref day-strings) (iota days))
                             (make-list (- 42 (+ start-day days)) blanks))))
                  months-days
                  start-days))))))))))))))

; Example
; (calendar 2002) =>
;            1  2  3  4  5                      1  2                      1  2 
;   J  6  7  8  9 10 11 12    F  3  4  5  6  7  8  9    M  3  4  5  6  7  8  9 
;   a 13 14 15 16 17 18 19    e 10 11 12 13 14 15 16    a 10 11 12 13 14 15 16 
;   n 20 21 22 23 24 25 26    b 17 18 19 20 21 22 23    r 17 18 19 20 21 22 23 
;     27 28 29 30 31            24 25 26 27 28            24 25 26 27 28 29 30 
;                                                         31                   
;         1  2  3  4  5  6                1  2  3  4                         1 
;   A  7  8  9 10 11 12 13    M  5  6  7  8  9 10 11    J  2  3  4  5  6  7  8 
;   p 14 15 16 17 18 19 20    a 12 13 14 15 16 17 18    u  9 10 11 12 13 14 15 
;   r 21 22 23 24 25 26 27    y 19 20 21 22 23 24 25    n 16 17 18 19 20 21 22 
;2    28 29 30                  26 27 28 29 30 31         23 24 25 26 27 28 29 
;0                                                        30                   
;0        1  2  3  4  5  6                   1  2  3       1  2  3  4  5  6  7 
;2  J  7  8  9 10 11 12 13    A  4  5  6  7  8  9 10    S  8  9 10 11 12 13 14 
;   u 14 15 16 17 18 19 20    u 11 12 13 14 15 16 17    e 15 16 17 18 19 20 21 
;   l 21 22 23 24 25 26 27    g 18 19 20 21 22 23 24    p 22 23 24 25 26 27 28 
;     28 29 30 31               25 26 27 28 29 30 31      29 30                
;                                                                             
;            1  2  3  4  5                      1  2       1  2  3  4  5  6  7 
;   O  6  7  8  9 10 11 12    N  3  4  5  6  7  8  9    D  8  9 10 11 12 13 14 
;   c 13 14 15 16 17 18 19    o 10 11 12 13 14 15 16    e 15 16 17 18 19 20 21 
;   t 20 21 22 23 24 25 26    v 17 18 19 20 21 22 23    c 22 23 24 25 26 27 28 
;     27 28 29 30 31            24 25 26 27 28 29 30      29 30 31             

(main (command-line-arguments))
