; zeller's congruence
(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-syntax assert
(syntax-rules ()
((assert expr result)
(if (not (equal? expr result))
(for-each display `(
#\newline "failed assertion:" #\newline
expr #\newline "expected: " ,result
#\newline "returned: " ,expr #\newline))))))
(define (zeller year month day)
(let* ((m (if (< month 3) (+ month 10) (- month 2)))
(yr (if (< month 3) (- year 1) year))
(d (modulo yr 100)) (c (quotient yr 100)))
(list-ref '(Sunday Monday Tuesday Wednesday Thursday Friday Saturday)
(modulo (+ day (quotient (- (* 13 m) 1) 5) d
(quotient d 4) (quotient c 4) (* -2 c)) 7))))
(do ((i 2361331 (+ i 1))) ((= i 2726573))
(let-values (((year month day) (gregorian i)))
(assert (list-ref '(Monday Tuesday Wednesday Thursday Friday Saturday Sunday)
(modulo (julian year month day) 7))
(zeller year month day))))
(display (zeller 2010 10 8))