;;; -*- Mode:Common-Lisp; Package:USER; Base:10 -*-

;; Display calendars for every month and year starting at 1/1/1.
;;
;; Based on the algorithms used in the Minix utility CAL.
;;
;; To display a calendar for 1987 do (CALENDAR 1987).
;; To display a calendar for September 1752 do (CALENDAR 1752 9).
;; (CALENDAR) defaults to printing the current month/year.

(DEFPARAMETER output-array
	      (MAKE-ARRAY 144 :element-type '(MOD 256))
  "Array to temporarily store the output values of the calendar program")

(DEFPARAMETER DaysPerMonth (MAKE-ARRAY 13
				       :initial-contents '(0
							    31 29 31 30
							    31 30 31 31
							    30 31 30 31))
  "Array containing number of days in every month")

(DEFUN calendar (&optional year month)
  "Print the calendar for the given year or year/month combination.
If nothing is specified, print the current month.  If the year is
specified, but not the month, print the entire year.  Otherwise
print only the given month.  Try September 1752 (calendar 1752 9)."
  (DECLARE (SPECIAL output-array))
  (DO ((i 0 (1+ i)))
      ((>= i 48) nil)
    (SETF (AREF output-array i) 0))
  (WHEN (NULL year)
    (MULTIPLE-VALUE-SETQ (nil nil nil nil month year) (GET-DECODED-TIME)))
  (IF (NULL month)		; Print entire year
      (calendar-year year)
      (calendar-month year month)))

(DEFUN calendar-year (year)
  "Print a full calendar year.  Year should be the full year,
not just the last two digits, i.e. 87 is the year 87, NOT 1987."
  (DECLARE (SPECIAL output-array))
  (WHEN (NOT (<= 1 year))
    (ERROR nil "Bad year specification ~s" year))
  (FORMAT t "~%~36d~%~%" year)
  (DO ((quarter 0 (1+ quarter)))		; For every quarter
      ((>= quarter 4))
    (DO ((j 0 (1+ j)))				; Clean the output array
	((>= j 144))
      (SETF (AREF output-array j) 0))
    (FORMAT t "	 ~?" "~24a~24a~a~%"		; Print the proper headings
	    (NTH quarter '(("Jan" "Feb" "Mar")
			   ("Apr" "May" "Jun")
			   ("Jul" "Aug" "Sep")
			   ("Oct" "Nov" "Dec"))))
    (FORMAT t " ~a     ~:*~a     ~:*~a~%" "S  M Tu  W Th  F  S")
    (DO ((i 0 (1+ i)))				; Compute individual months
	((>= i 3))				;   within current quarter
      (cal (+ (* 3 quarter) i 1) year output-array (ASH i 3) 24))
    (DO ((i 0 (1+ i)))				; Print 3 months per line
	((>= i 6))				;   for a total of 6 lines
      (print-calendar-line output-array (* i 24) 24)))
  (FORMAT t "~%~%~%"))				; End with 3 newlines

(DEFUN calendar-month (year month)
  "Print the calendar month specified by YEAR and MONTH."
  (DECLARE (SPECIAL output-array))
  (WHEN (NOT (<= 1 month 12))			; Weed out bad month
    (ERROR nil "Bad month specification ~s" month))
  (WHEN (NOT (<= 1 year))			;     and year specifications
    (ERROR nil "Bad year specification ~s" year))
  (FORMAT t "~&    ~[January~;February~;March~;April~;May~;June~;July~
              ~;August~;September~;October~;November~;December~] ~d~%"
	  (1- month) year)			; Print the month name
  (FORMAT t " S  M Tu  W Th  F  S~%")		;   and the weekdays
  (cal month year output-array 0 8)		; Compute the calendar for that month
  (DO ((i 0 (1+ i)))				;   and print it
      ((>= i 6))				;     for a total of 6 lines
    (print-calendar-line output-array (ASH i 3) 8)))

(DEFUN cal (month year s index width)
  "Calculate the calendar entry for MONTH/YEAR, and fill out string S,
starting at INDEX.  Next line, same column is WIDTH characters forward."
  (DECLARE (SPECIAL DaysPerMonth))
  (LET* ((local-index index)
	 (Weekday (January1st year)))		; Weekday on January 1st
    (SETF (AREF DaysPerMonth 2) 29)		; Assume leap year
    (SETF (AREF DaysPerMonth 9) 30)		; Normal September month
    (CASE (REM (- (+ (January1st (1+ year)) 7) Weekday) 7)	; Compute special cases:
      (1 (SETF (AREF DaysPerMonth 2) 28))	; Not a leap year
      (2)					; Ordinary leap year
      (t (SETF (AREF DaysPerMonth 9) 19)))	; September had 19 days in 1752
    (DO ((i 1 (1+ i)))				; Step through the months
	((>= i month) nil)			;   incrementing day of the week
      (INCF Weekday (AREF DaysPerMonth i)))	;     by number of days in month
    (SETQ Weekday (REM Weekday 7))		; Push back into range 0..6
    (INCF local-index Weekday)			; Skip unused day locations on
    (DO ((i 1 (1+ i)))				;   first print line
	((> i (AREF DaysPerMonth month)))	; Fill all remaining days this month
      (WHEN (AND (= i 3)			; If it's the first wednesday
		 (= (AREF DaysPerMonth month) 19))	;    in September 1752
	(INCF i 11)				;    skip 11 days, and
	(INCF (AREF DaysPerMonth month) 11))	;    adjust the month back to 30 days
      (SETF (AREF s local-index) i)		; Fill location with date
      (INCF local-index 1)			; Move to the next day of the week
      (WHEN (= (INCF Weekday) 7)		; Wrap around on saturday
	(SETQ Weekday 0				;    back to sunday
	      local-index (+ index width)	;    move up one line
	      index local-index)))))		;    and remember the start of this line

(DEFUN January1st (year)
  "Return day of the week of January 1st of given year."
  (LET ((day (+ 4 year (TRUNCATE (+ year 3) 4))))	; Julian calendar
    (WHEN (> year 1800)				; If it's recent, do
      (DECF day (TRUNCATE (- year 1701) 100))	; Clavian correction
      (INCF day (TRUNCATE (- year 1601) 400)))	; Gregorian correction
    (WHEN (> year 1752)				; Adjust for Gregorian calendar
      (INCF day 3))
    (REM day 7)))

(DEFUN print-calendar-line (calendar-array index n)
  (DO ((i index (1+ i))
       (j n (1- j)))
      ((<= j 0))
    (LET ((temp (AREF calendar-array i)))
      (IF (ZEROP temp)
	  (PRINC "   ")
	(FORMAT t "~2d " temp))))
  (FORMAT t "~%"))
