58 lines
2.5 KiB
Text
58 lines
2.5 KiB
Text
(defun calendar (year)
|
|
(define months-list '(("JANUARY" 31) ("FEBRUARY" 28) ("MARCH" 31) ("APRIL" 30) ("MAY" 31) ("JUNE" 30) ("JULY" 31) ("AUGUST" 31) ("SEPTEMBER" 30) ("OCTOBER" 31) ("NOVEMBER" 30) ("DECEMBER" 31)))
|
|
(define days #(" Sunday " "Monday " "Tuesday " "Wednesday " "Thursday " "Friday " "Saturday"))
|
|
(defun gauss-algorithm (a)
|
|
(rem (+ 1 (+ (* 5 (rem (- a 1) 4)) (* 4 (rem (- a 1) 100)) (* 6 (rem (- a 1) 400)))) 7))
|
|
(defun range (start end)
|
|
(if (<= start end)
|
|
(cons start (range (+ start 1) end))))
|
|
(defun string-repeat (s n)
|
|
(if (= n 0)
|
|
""
|
|
(string-append s (string-repeat s (- n 1)))))
|
|
(defun print-month (number-of-days start-day)
|
|
(defun print-days (day day-of-week end-day)
|
|
(if (= day-of-week 7)
|
|
(begin
|
|
(newline)
|
|
(define day-of-week 0)))
|
|
(display (string-repeat " " 8))
|
|
(if (= day-of-week 0)
|
|
(display (string-repeat " " 6)))
|
|
(if (< day 10)
|
|
(display " "))
|
|
(display day)
|
|
(display (string-repeat " " 8))
|
|
(if (= day end-day)
|
|
(begin
|
|
(fresh-line)
|
|
(+ day-of-week 1))
|
|
(print-days (+ day 1) (+ day-of-week 1) end-day)))
|
|
(mapcar (lambda (n) (display (vector-ref days n))) (range 0 6))
|
|
(newline)
|
|
(display (string-repeat (string-repeat " " 18) start-day))
|
|
(print-days 1 start-day number-of-days))
|
|
(defun leap-yearp (y)
|
|
(and (= (mod year 4) 0) (or (/= (mod year 100) 0) (= (mod year 400) 0))))
|
|
(define months (make-table))
|
|
(mapcar (lambda (month) (table-set! months (car month) (cadr month))) months-list)
|
|
(if (leap-yearp year)
|
|
(table-set! months "FEBRUARY" 29))
|
|
(defun print-calendar (calendar-months weekday)
|
|
(newline)
|
|
(newline)
|
|
(display (string-repeat " " 60))
|
|
(display (caar calendar-months))
|
|
(newline)
|
|
(define next-month-starts (print-month (table-ref months (caar calendar-months)) weekday))
|
|
(if (cdr calendar-months)
|
|
(print-calendar (cdr calendar-months) next-month-starts)))
|
|
(display (string-repeat " " 60))
|
|
(display "******** SNOOPY CALENDAR ")
|
|
(display year)
|
|
(display " ********")
|
|
(newline)
|
|
(newline)
|
|
(print-calendar months-list (gauss-algorithm year)))
|
|
|
|
(calendar 1969)
|