[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Dec 24:
; 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)


Output:
     January 2010         February 2010           March 2010      
 Su Mo Tu We Th Fr Sa  Su Mo Tu We Th Fr Sa  Su Mo Tu We Th Fr Sa 
                 1  2      1  2  3  4  5  6      1  2  3  4  5  6 
  3  4  5  6  7  8  9   7  8  9 10 11 12 13   7  8  9 10 11 12 13 
 10 11 12 13 14 15 16  14 15 16 17 18 19 20  14 15 16 17 18 19 20 
 17 18 19 20 21 22 23  21 22 23 24 25 26 27  21 22 23 24 25 26 27 
 24 25 26 27 28 29 30  28                    28 29 30 31          
 31                                                               

      April 2010             May 2010             June 2010       
 Su Mo Tu We Th Fr Sa  Su Mo Tu We Th Fr Sa  Su Mo Tu We Th Fr Sa 
              1  2  3                     1         1  2  3  4  5 
  4  5  6  7  8  9 10   2  3  4  5  6  7  8   6  7  8  9 10 11 12 
 11 12 13 14 15 16 17   9 10 11 12 13 14 15  13 14 15 16 17 18 19 
 18 19 20 21 22 23 24  16 17 18 19 20 21 22  20 21 22 23 24 25 26 
 25 26 27 28 29 30     23 24 25 26 27 28 29  27 28 29 30          
                       30 31                                      

      July 2010            August 2010          September 2010    
 Su Mo Tu We Th Fr Sa  Su Mo Tu We Th Fr Sa  Su Mo Tu We Th Fr Sa 
              1  2  3   1  2  3  4  5  6  7            1  2  3  4 
  4  5  6  7  8  9 10   8  9 10 11 12 13 14   5  6  7  8  9 10 11 
 11 12 13 14 15 16 17  15 16 17 18 19 20 21  12 13 14 15 16 17 18 
 18 19 20 21 22 23 24  22 23 24 25 26 27 28  19 20 21 22 23 24 25 
 25 26 27 28 29 30 31  29 30 31              26 27 28 29 30       
                                                                  

     October 2010         November 2010         December 2010     
 Su Mo Tu We Th Fr Sa  Su Mo Tu We Th Fr Sa  Su Mo Tu We Th Fr Sa 
                 1  2      1  2  3  4  5  6            1  2  3  4 
  3  4  5  6  7  8  9   7  8  9 10 11 12 13   5  6  7  8  9 10 11 
 10 11 12 13 14 15 16  14 15 16 17 18 19 20  12 13 14 15 16 17 18 
 17 18 19 20 21 22 23  21 22 23 24 25 26 27  19 20 21 22 23 24 25 
 24 25 26 27 28 29 30  28 29 30              26 27 28 29 30 31    
 31                                                               


Create a new paste based on this one


Comments: