codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; 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)
Private
[
?
]
Run code
Submit