HTMLのカレンダー - Shammer's Philosophy

ちょっとしたお遊び。Lisp で HTML の簡易カレンダーを出力するプログラム。
(defparameter *weeks* 1)
(defparameter *month* 1)
(defparameter *date* 1)
(defparameter *is-leap-year* nil)
(with-open-file (f "calendar.html" :direction :output :if-exists :supersede)
  (format f "<?xml version=\"1.0\" encoding=\"UTF-8\"?>")
  (format f "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
  (format f "<html>")
  (format f "<head>")
  (format f "<title>Calendar</title>")
  (format f "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\"/>")
  (format f "</head>")
  (format f "<body>")
  (format f "<table border=\"1\">")
  (format f "<caption></caption>")
  (format f "<tbody>")
  (format f "<tr>")
  (format t "How many weeks?:")
  (do ((weeks (read) (read)))
      ((and (numberp weeks) (< 0 weeks))
       (setf *weeks* weeks))
    (format t "Invalid answer, How many weeks would you like to generate?"))
  (format t "From Month(1-12):")
  (do ((month (read) (read)))
      ((and (numberp month)
	    (and (< 0 month) (<= month 12)))
       (setf *month* month))
    (format t "Invalid input, try again(1-12):"))
  (format t "From Date(1-31):")
  (do ((date (read) (read)))
      ((and (numberp date)
	    (cond ((member *month* '(1 3 5 7 8 10 12))
		   (and (< 0 date) (<= date 31)))
		  ((member *month* '(4 6 9 11))
		   (and (< 0 date) (<= date 30)))
		  (t ; Febrary
		   (format t "Leap year(y/n)?:")
		   (do ((answer (read-line) (read-line)))
		       ()
		     (cond ((string= "y" answer)
			    (setf *is-leap-year* t)
			    (return (and (< 0 date) (<= date 29))))
			   ((string= "n" answer)
			    (return (and (< 0 date) (<= date 28))))
			   (t
			    (format t "Invalid answer, y or n with case sensitive:")))))))
       (setf *date* date))
    (format t "Invalid date, try again:"))
  (dotimes (i *weeks*)
    (dotimes (j 7)
      (format f "<th align=\"center\" width=\"200\">~A/~A(~A)</th>"
	      (write-to-string *month*)
	      (write-to-string *date*)
	      (nth j '("日" "月" "火" "水" "木" "金" "土")))
      (setf *date* (+ 1 *date*))
      (cond ((and (eql *date* 29)
		  (eql *month* 2))
	     (unless *is-leap-year*
	       (setf *date* 1)
	       (setf *month* 3)))
	    ((and (eql *date* 30)
		  (eql *month* 2)
		  *is-leap-year*)
	     (setf *month* 3)
	     (setf *date* 1))
	    ((eql *date* 31)
	     (when (member *month* '(4 6 9 11))
	       (setf *date* 1)
	       (setf *month* (+ 1 *month*))))
	    ((eql *date* 32)
	     (when (member *month* '(1 3 5 7 8 10 12))
	       (setf *date* 1)
	       (setf *month* (mod (+ 1 *month*) 12))))))
    (format f "</tr>")
    (format f "<tr>")
    (format f "<th align=\"center\" height=\"175\"></th>")
    (dotimes (j 6)
      (format f "<td align=\"center\"></td>"))
    (format f "</tr>"))
  (format f "</tbody></table></body></html>"))
(quit)