#
# Yes, the unix cal program, kind of 
# some algorithms from SFRI-19 used
#
eval (define (normal) \
       (display (integer->char 27)) \
       (display (integer->char 91)) \
       (display "0") \
       (display "m"))
eval (define (underscore) \
       (display (integer->char 27)) \
       (display (integer->char 91)) \
       (display "4") \
       (display "m"))
eval (define (reversevideo) \
       (display (integer->char 27)) \
       (display (integer->char 91)) \
       (display "7") \
       (display "m"))
eval (define days (list "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa"))
eval (define months (list "January" "February" "March" "April" "May" "June" "July" \
                          "August" "September" "October" "November" "December" \
                           "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12" \
                          "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" \
                          "Nov" "Dec"))
eval (define (months-number m) (if (number? m) m (+ 1 (remainder (- 36 (length (member m months))) 12))))
eval (define (tojulian day month year) \
  (let* ((m (months-number month)) \
         (a (quotient (- 14 m) 12)) \
         (y (- (+ year 4800) a (if (negative? year) -1  0))) \
         (m (- (+ m (* 12 a)) 3))) \
    (+ day \
       (quotient (+ (* 153 m) 2) 5) \
       (* 365 y) \
       (quotient y 4) \
       (- (quotient y 100)) \
       (quotient y 400) \
       -32045)))
eval (define (easter year) \
  (let* ((a (modulo year 19)) \
         (b (quotient year 100)) \
         (c (modulo year 100)) \
         (d (quotient b 4)) \
         (e (modulo b 4)) \
         (f (quotient (+ b 8) 25)) \
         (g (quotient (+ (- b f) 1) 3)) \
         (h (modulo (- (+ (* 19 a) b 15) d g) 30)) \
         (i (quotient c 4)) \
         (k (modulo c 4)) \
         (l (modulo (- (+ 32 (* 2 e) (* 2 i)) h k) 7)) \
         (m (quotient (+ a (* 11 h) (* 22 l)) 451)) \
         (month (quotient (- (+ h l 114) (* 7 m)) 31)) \
         (day (+ (modulo (- (+ h l 114) (* 7 m)) 31) 1))) \
    (list (tojulian day month year) (list day month year))))
eval (define (dayofweek jd) (+ (remainder jd 7) 1))
eval (define (firstmonday month year) \
        (let* ((d1 (tojulian 1 (months-number month) year)) \
              (offset (remainder (- 8 (dayofweek d1)) 7))) \
           (+ d1 offset)))
eval (define (julian-date) \
  (let* ((today (string-split (date))) \
         (day (string->number (caddr today))) \
         (month (months-number (cadr today))) \
         (year (string->number (list-ref today 4)))) \
     (list (tojulian day month year) (list day month year))))
eval (define (month-limits today) \
  (let* ((first (tojulian 1 (cadr (cadr today)) (caddr (cadr today)))) \
         (last (- (tojulian 1 (+ (months-number (cadr (cadr today))) 1) (caddr (cadr today))) 1))) \
    (list first (dayofweek first) \
          last (dayofweek  last))))
#
# Queensland public holidays:
# New Years Day, Australia Day, Easter, May Day, Queens Birthday,
# Xmas, Boxing Day
#
eval (define (list-holidays year) \
  (list (tojulian 1 1 year) \
        (tojulian 26 1 year) \
        (- (car (easter year)) 2) (+  (car (easter year)) 1)  \
        (tojulian 25 4 year) \
        (tojulian 1 5 year) \
        (+ (firstmonday 6 year) 7) \
        (tojulian 25 12 year) \
        (tojulian 26 12 year)))
eval (define (scheme-cal args) \
  (let* ((arg-list (string-split args)) \
         (this-month (= (length arg-list) 0)) \
         (today (if this-month (julian-date) \
                   (list (tojulian 1 (car arg-list) (string->number (cadr arg-list))) \
                          (list 1 (car arg-list) (string->number (cadr arg-list)))))) \
         (holidays (list-holidays (caddr (cadr today)))) \
         (ends (month-limits today))) \
    (display "   (") \
    (display (list-ref months (- (months-number (cadr (cadr today))) 1))) \
    (display " ") \
    (display (caddr (cadr today))) \
    (display ")") \
    (newline) \
    (display days) \
    (newline) \
    (let loop ((i 0)) \
      (if (< i (remainder (cadr ends) 7)) \
         (begin (display "  -") (loop (+ i 1))))) \
    (let loop ((i (car ends)) (j 1) (k (cadr ends))) \
      (if (<= i (caddr ends)) \
         (begin (display " ") \
                (if (and this-month (= i (car today))) (reversevideo)) \
                (if (member i holidays) (underscore)) \
                (format "~2d" j) \
                (if (or (member i holidays) (and this-month (= i (car today)))) (normal)) \
                (if (= k 6) (newline)) \
                (loop (+ i 1) (+ j 1) (remainder (+ k 1) 7))) \
         (display " ")))))
macro cal
  eval (scheme-cal "%0")
;;;;