;; display-calendar.ss -- write out a calendar for a given month

;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College
;; stone@math.grin.edu
;; April 17, 1997

;; The objective is to define a procedure that takes two arguments, the
;; first an integer in the range from 1 to 12 (indicating a month of the
;; year) and the second an integer not less than 1753 (indicating a year
;; of the Gregorian calendar, which was adopted by English-speaking nations
;; in 1752), and displays a calendar for that month:
;;
;;                      > (display-calendar 7 1951)
;;                      July 1951
;;
;;                        S  M Tu  W Th  F  S
;;                        1  2  3  4  5  6  7
;;                        8  9 10 11 12 13 14
;;                       15 16 17 18 19 20 21
;;                       22 23 24 25 26 27 28
;;                       29 30 31

;; In pursuit of this objective, it will be handy to have symbolic names
;; for the various months ...

(define January 1)
(define February 2)
(define March 3)
(define April 4)
(define May 5)
(define June 6)
(define July 7)
(define August 8)
(define September 9)
(define October 10)
(define November 11)
(define December 12)

;; ... and to have an appropriate string representation for each one:

(define month-name
  (lambda (month)

    ;; Test the precondition.

    (if (not (month-number? month))
        (error 'month-name
               "The argument must be the number of a month."))

    ;; Return the appropriate name for each month.

    (cond ((= month January) "January")
          ((= month February) "February")
          ((= month March) "March")
          ((= month April) "April")
          ((= month May) "May")
          ((= month June) "June")
          ((= month July) "July")
          ((= month August) "August")
          ((= month September) "September")
          ((= month October) "October")
          ((= month November) "November")
          ((= month December) "December"))))

;; The MONTH-NUMBER? predicate tests whether a given object is an integer
;; in the range from 1 to 12.

(define month-number?
  (lambda (obj)
    (and (integer? obj)
         (exact? obj)
         (<= January obj December))))

;; It will also be handy to associate a natural number with each day of
;; the week; the most convenient convention is to use the number of days
;; since Sunday.

(define Sunday 0)
(define Monday 1)
(define Tuesday 2)
(define Wednesday 3)
(define Thursday 4)
(define Friday 5)
(define Saturday 6)

;; The DAY-OF-WEEK? predicate determines whether its object is one of these
;; day-of-the-week codes.

(define day-of-week?
  (lambda (obj)
    (and (integer? obj)
         (exact? obj)
         (<= Sunday obj Saturday))))

;; The DAY-AFTER procedure takes any of these day-of-the-week codes as an
;; argument and returns the code for the following day of the week.

(define day-after
  (lambda (day-of-week)

    ;; Test the precondition.

    (if (not (day-of-week? day-of-week))
        (error 'day-after
               "The argument must be the code for a day of the week"))

    ;; Add 1 to get the code for the next day; but cycle around on Saturday
    ;; so that it is followed by Sunday.

    (if (= day-of-week Saturday)
        Sunday
        (+ day-of-week 1))))

;; The LEAP? predicate takes the number of a year in the Gregorian calendar
;; and determines whether it is a leap year.

(define leap?
  (lambda (year)

    ;; Test the precondition.

    (if (not (Gregorian-year? year))
        (error 'leap?
               "The argument must be a year of the Gregorian calendar"))

    ;; A year is a leap year in the Gregorian calendar if, and only if,
    ;; it is either divisible by 400 or divisible by 4 but not by 100.

    (or (zero? (remainder year 400))
        (and (zero? (remainder year 4))
             (not (zero? (remainder year 100)))))))

;; The GREGORIAN-YEAR? predicate determines whether a given object is an
;; integer not less than 1753, the first full year in which the Gregorian
;; calendar was in use in English-speaking countries.

(define Gregorian-year?
  (lambda (obj)
    (and (integer? obj)
         (exact? obj)
         (<= 1753 obj))))

;; The DAYS-IN-MONTH procedure takes a month and year as arguments and
;; determines and returns the number of days in that month of that
;; particular year.

(define days-in-month
  (let ((thirty-day-months (list April June September November)))
    (lambda (month year)

      ;; Test the preconditions.

      (if (not (month-number? month))
          (error 'days-in-month
                 "The first argument must be the number of a month"))
      (if (not (Gregorian-year? year))
          (error 'days-in-month
                 (string-append "The second argument must be a year of "
                                "the Gregorian calendar")))

    (cond ((= month February) (if (leap? year) 29 28))
          ((member month thirty-day-months) 30)
          (else 31)))))

;; The FIRST-OF-YEAR procedure takes as argument a year of the Gregorian
;; calendar and returns the day of the week on which January 1 occurs in
;; that year.

(define first-of-year
  (lambda (year)

    ;; Test the preconditions.

    (if (not (Gregorian-year? year))
        (error 'first-of-year
               "The argument must be a year of the Gregorian calendar"))

    ;; The number of days in 400 years of the Gregorian calendar is a
    ;; multiple of 7, so the days of the week match up against calendar
    ;; dates in a 400-year cycle.  Begin by identifying two quantities that
    ;; fix the position of YEAR in that cycle:  CENTURY-IN-CYCLE, the
    ;; number of century years (mod 4) since the calendar was adopted (0
    ;; for dates in the 1700s, 1 for the 1800s, 2 for the 1900s, 3 for 
    ;; the 2000s, 0 again for the 2100s, 1 for the 2200s, etc.), and 
    ;; YEAR-OFFSET, the number of years since the most recent century year
    ;; (0 for 1900, 1 for 1901, 2 for 1902, ... 99 for 1999, 0 again for
    ;; 2000, etc.)

    (let ((century-in-cycle (remainder (quotient (- year 1700) 100) 4))
          (year-offset (remainder year 100)))

      ;; The number of days in the 1700s, in the 1800s, or in the 1900s
      ;; is 5 more than a multiple of 7, so each century year that passes
      ;; before the 400-year cycle begins again starts five days later in
      ;; the week than the previous century year.  The CENTURY-OFFSET
      ;; is the number of days due to such advances:  It is five times
      ;; CENTURY-IN-CYCLE.

      ;; 365 is 1 more than a multiple of 7, so each year of the century
      ;; starts one day later in the week than its predecessor -- unless
      ;; its predecessor was a leap year, in which case it begins two days
      ;; later.  YEAR-OFFSET includes all of the one-day advances and one
      ;; of the two days in each of the two-day advances; LEAP-YEAR-OFFSET,
      ;; which counts the number of leap days between January 1 of the most
      ;; recent century year and January 1 of YEAR, takes in the second day
      ;; of each of the two-day advances.

      (let ((century-offset (* 5 century-in-cycle))
            (leap-year-offset (cond ((= century-in-cycle 3)
                                     (quotient (+ year-offset 3) 4))
                                    ((zero? year-offset) 0) 
                                    (else (quotient (- year-offset 1)
                                                    4)))))

        ;; So to find the day of the week of the first day of YEAR, start
        ;; on Friday (= January 1, 1700/2100/2500/2900/... Gregorian), add
        ;; CENTURY-OFFSET, YEAR-OFFSET, and LEAP-YEAR-OFFSET, and find the
        ;; remainder mod 7.

        (remainder (+ Friday century-offset year-offset leap-year-offset)
                   7)))))

;; The FIRST-OF-MONTH procedure takes a month and year as arguments and
;; determines and returns the day of the week of the first day of that
;; month in that year.

(define first-of-month
  (lambda (month year)

    ;; Test the preconditions.

    (if (not (month-number? month))
        (error 'first-of-month
               "The first argument must be the number of a month"))
    (if (not (Gregorian-year? year))
        (error 'first-of-month
               "The second argument must be a year of the Gregorian calendar"))

    ;; Find the first day of January and count forward to the specified
    ;; month, adding the number of days in each month that you pass by.

    (let loop ((first-of-current-month (first-of-year year))
               (current-month 1))

      ;; Stop when you reach the specified month and take the remainder
      ;; mod 7 to get a day of the week.

      (if (= current-month month)
          (remainder first-of-current-month 7)

          ;; If you're not there yet, add the number of days in the current
          ;; month to FIRST-OF-CURRENT-MONTH and advance the month number
          ;; by 1.

          (loop (+ first-of-current-month (days-in-month current-month year))
                (+ current-month 1))))))

;; Finally, we reach the DISPLAY-CALENDAR procedure.  It takes a month and
;; a year as arguments and writes out the calendar for that month.
;; DISPLAY-CALENDAR is invoked only for its side effect.

(define display-calendar
  (lambda (month year)

    ;; Test the preconditions.

    (if (not (month-number? month))
        (error 'first-of-month
               "The first argument must be the number of a month"))
    (if (not (Gregorian-year? year))
        (error 'first-of-month
               "The second argument must be a year of the Gregorian calendar"))

    ;; Write out the month and year, followed by a blank line.

    (display (month-name month))
    (display " ")
    (display year)
    (newline)
    (newline)

    (let ((column-width 3))

      ;; Print the column headings.

      (for-each (lambda (str) (display (pad-on-left str column-width)))
                '("Su" "M" "Tu" "W" "Th" "F" "Sa"))
      (newline)

      (let ((starting-weekday (first-of-month month year))
            (total-days (days-in-month month year)))

        ;; Space over to the correct column.

        (display (make-string (* starting-weekday column-width) #\space))

        
        ;; Start at day 1 and print each day, inserting a newline when
        ;; you reach Saturday or finish the month.

        (let loop ((day-number 1)
                   (weekday starting-weekday))
          (if (<= day-number total-days)
              (begin
                (display (pad-on-left (number->string day-number)
                                      column-width))
                (if (or (= weekday Saturday)
                        (= day-number total-days))
                    (newline))
                (loop (+ day-number 1)
                      (day-after weekday)))))))))

;; The PAD-ON-LEFT procedure takes a string and a desired width as argument
;; and adds spaces to the left end of the string until the desired width is
;; reached, returning the resulting padded string.  If the given string is
;; already of the desired width or longer, PAD-ON-LEFT returns it without
;; change.

(define pad-on-left
  (lambda (str desired-width)
    (let ((len (string-length str)))
      (if (< len desired-width)
          (string-append (make-string (- desired-width len) #\space)
                         str)
          str))))