; cal
(define (julian year month day)
(let* ((a (quotient (- 14 month) 12))
(y (+ year 4800 (- a)))
(m (+ month (* 12 a) -3)))
(+ day
(quotient (+ (* 153 m) 2) 5)
(* 365 y)
(quotient y 4)
(- (quotient y 100))
(quotient y 400)
(- 32045))))
(define (gregorian julian)
(let* ((j (+ julian 32044))
(g (quotient j 146097))
(dg (modulo j 146097))
(c (quotient (* (+ (quotient dg 36524) 1) 3) 4))
(dc (- dg (* c 36524)))
(b (quotient dc 1461))
(db (modulo dc 1461))
(a (quotient (* (+ (quotient db 365) 1) 3) 4))
(da (- db (* a 365)))
(y (+ (* g 400) (* c 100) (* b 4) a))
(m (- (quotient (+ (* da 5) 308) 153) 2))
(d (+ da (- (quotient (* (+ m 4) 153) 5)) 122))
(year (+ y (- 4800) (quotient (+ m 2) 12)))
(month (+ (modulo (+ m 2) 12) 1))
(day (+ d 1)))
(values year month day)))
(define (today) ; MzScheme
(let ((today (seconds->date (current-seconds))))
(julian (date-year today) (date-month today) (date-day today))))
(define year #f)
(define month #f)
(define day #f)
(define (today-set!)
(let ((t (today)))
(let-values (((y m d) (gregorian t)))
(set! year y)
(set! month m)
(set! day d))))
(define (string-put! str k substr)
(do ((i 0 (+ i 1)) (k k (+ k 1)))
((= i (string-length substr)) str)
(string-set! str k (string-ref substr i))))
(define (month-name m)
(vector-ref (vector "January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December") (- m 1)))
(define (center wid str)
(let* ((len (string-length str))
(lpad (quotient (- wid len) 2))
(rpad (- wid len lpad)))
(if (< wid len)
(substr str 0 wid)
(string-append
(make-string lpad #\space) str (make-string rpad #\space)))))
(define (make-month y m)
(define (s b i)
(+ (* (+ (quotient (+ b i -1) 7) 2) 22)
(* (modulo (+ b i -1) 7) 3) 1))
(define (r-just n)
(if (< n 10) (string-append " " (number->string n)) (number->string n)))
(let* ((str (make-string 176 #\space))
(j (julian y m 1))
(n (- (julian (if (= m 12) (+ y 1) y) (if (= m 12) 1 (+ m 1)) 1) j))
(b (modulo (+ j 1) 7)))
(string-put! str 0
(center 22 (string-append (month-name m) " " (number->string y))))
(string-put! str 22 " Su Mo Tu We Th Fr Sa ")
(do ((i 1 (+ i 1))) ((> i n))
(string-put! str (s b i) (r-just i))
(when (and (= y year) (= m month) (= i day))
(string-set! str (- (s b i) 1) #\<)
(string-set! str (+ (s b i) 2) #\>)))
str))
(define (display-month y m)
(let ((month-string (make-month y m)))
(do ((i 0 (+ i 1))) ((= i 8))
(display (substring month-string (* i 22) (* (+ i 1) 22)))
(newline))))
(define (display-three m1 m2 m3)
(do ((i 0 (+ i 1))) ((= i 8))
(display (substring m1 (* i 22) (* (+ i 1) 22)))
(display (substring m2 (* i 22) (* (+ i 1) 22)))
(display (substring m3 (* i 22) (* (+ i 1) 22)))
(newline)))
(define (display-year y)
(display-three (make-month y 1) (make-month y 2) (make-month y 3))
(newline)
(display-three (make-month y 4) (make-month y 5) (make-month y 6))
(newline)
(display-three (make-month y 7) (make-month y 8) (make-month y 9))
(newline)
(display-three (make-month y 10) (make-month y 11) (make-month y 12)))
(define (cal . args)
(today-set!)
(cond ((null? args) (display-month year month))
((and (number? (car args)) (= (car args) -3))
(display-three
(if (= month 1)
(make-month (- year 1) 12)
(make-month year (- month 1)))
(make-month year month)
(if (= month 12)
(make-month (+ year 1) 1)
(make-month year (+ month 1)))))
((= (length args) 1) (display-year (car args)))
(else (display-month (cadr args) (car args)))))
(cal 2010)