[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/dPbrwFze    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Mar 29:
; passover

(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 (rosh-hashanah year)
  (let* ((g (+ (remainder year 19) 1))
         (r (remainder (* 12 g) 19))
         (n (+ (- (quotient year 100) (quotient year 400) 2)
               (* 765433 r 1/492480)
               (/ (remainder year 4) 4)
               (- (/ (+ (* 313 year) 89081) 98496))))
         (d (quotient (numerator n) (denominator n)))
         (f (- n d))
         (j (julian year 9 d)))
    (case (modulo j 7)
      ((2 4 6) (+ j 1))
      ((0) (if (and (>= f 23269/25920) (> r 11)) (+ j 1) j))
      ((1) (if (and (>= f 1367/2160) (> r 6)) (+ j 2) j))
      (else j))))

(define (passover year)
  (let-values (((y m d) (gregorian (rosh-hashanah year))))
    (let ((j (julian year 3 21)))
      (if (= m 9) (+ j d) (+ j d 30)))))

(call-with-values
  (lambda () (gregorian (passover 2010)))
  (lambda (y m d)
    (display y) (newline)
    (display m) (newline)
    (display d) (newline)))


Output:
1
2
3
2010
3
30


Create a new paste based on this one


Comments: