76 lines
3.0 KiB
Common Lisp
76 lines
3.0 KiB
Common Lisp
(ql:quickload '(date-calc))
|
|
|
|
(defparameter *day-row* "Su Mo Tu We Th Fr Sa")
|
|
(defparameter *calendar-margin* 3)
|
|
|
|
(defun month-to-word (month)
|
|
"Translate a MONTH from 1 to 12 into its word representation."
|
|
(svref #("January" "February" "March" "April"
|
|
"May" "June" "July" "August"
|
|
"September" "October" "November" "December")
|
|
(1- month)))
|
|
|
|
(defun month-strings (year month)
|
|
"Collect all of the strings that make up a calendar for a given
|
|
MONTH and YEAR."
|
|
`(,(date-calc:center (month-to-word month) (length *day-row*))
|
|
,*day-row*
|
|
;; We can assume that a month calendar will always fit into a 7 by 6 block
|
|
;; of values. This makes it easy to format the resulting strings.
|
|
,@ (let ((days (make-array (* 7 6) :initial-element nil)))
|
|
(loop :for i :from (date-calc:day-of-week year month 1)
|
|
:for day :from 1 :to (date-calc:days-in-month year month)
|
|
:do (setf (aref days i) day))
|
|
(loop :for i :from 0 :to 5
|
|
:collect
|
|
(format nil "~{~:[ ~;~2,d~]~^ ~}"
|
|
(loop :for day :across (subseq days (* i 7) (+ 7 (* i 7)))
|
|
:append (if day (list day day) (list day))))))))
|
|
|
|
(defun calc-columns (characters margin-size)
|
|
"Calculate the number of columns given the number of CHARACTERS per
|
|
column and the MARGIN-SIZE between them."
|
|
(multiple-value-bind (cols excess)
|
|
(truncate characters (+ margin-size (length *day-row*)))
|
|
(incf excess margin-size)
|
|
(if (>= excess (length *day-row*))
|
|
(1+ cols)
|
|
cols)))
|
|
|
|
(defun take (n list)
|
|
"Take the first N elements of a LIST."
|
|
(loop :repeat n :for x :in list :collect x))
|
|
|
|
(defun drop (n list)
|
|
"Drop the first N elements of a LIST."
|
|
(cond ((or (<= n 0) (null list)) list)
|
|
(t (drop (1- n) (cdr list)))))
|
|
|
|
(defun chunks-of (n list)
|
|
"Split the LIST into chunks of size N."
|
|
(assert (> n 0))
|
|
(loop :for x := list :then (drop n x)
|
|
:while x
|
|
:collect (take n x)))
|
|
|
|
(defun print-calendar (year &key (characters 80) (margin-size 3))
|
|
"Print out the calendar for a given YEAR, optionally specifying
|
|
a width limit in CHARACTERS and MARGIN-SIZE between months."
|
|
(assert (>= characters (length *day-row*)))
|
|
(assert (>= margin-size 0))
|
|
(let* ((calendars (loop :for month :from 1 :to 12
|
|
:collect (month-strings year month)))
|
|
(column-count (calc-columns characters margin-size))
|
|
(total-size (+ (* column-count (length *day-row*))
|
|
(* (1- column-count) margin-size)))
|
|
(format-string (concatenate 'string
|
|
"~{~a~^~" (write-to-string margin-size) ",0@T~}~%")))
|
|
(format t "~a~%~a~%~%"
|
|
(date-calc:center "[Snoopy]" total-size)
|
|
(date-calc:center (write-to-string year) total-size))
|
|
(loop :for row :in (chunks-of column-count calendars)
|
|
:do (apply 'mapcar
|
|
(lambda (&rest heads)
|
|
(format t format-string heads))
|
|
row))))
|