;; -*- Mode:Emacs-Lisp -*-				    
;; prince-calendar.el --- academic calendar for Princeton University
;; based directly on liu-calendar.el (http://www.contrapunctus.net/league/haques/) by Christopher League
;; Version: 0.1
;; Author: Hans Halvorson (www.princeton.edu/~hhalvors)
;; Time-stamp: <2006-12-28 15:37:07 hhalvors>

;; This is free software -- you may redistribute it under the GNU
;; General Public License, but it comes with ABSOLUTELY NO WARRANTY.

;;; Usage:

;; This software encodes the academic calendar of Princeton
;; University.  It enables you to put entries like these in your Emacs
;; diary:

;;    %%(prince-class 'spring 2006 '(1 3)) 10:00 PHI201
;;    %%(prince-class 'fall 2005 '(2 4)) 15:00 PHI340

;; These entries force PHI201 to show up on every Monday and Wednesday
;; (days 1 and 3) of the semester in Spring 2006, and PHI340 on Tuesdays
;; and Thursdays in Fall 2005.  The entries automatically know the
;; beginning and end of the semester, the academic holidays, and
;; reading periods.

;; Another nice feature is that it appends the ordinal lecture number
;; to the diary entry, so that we always know how far along we are in
;; the semester.

;;    Wednesday, November 8, 2006
;;    ===========================
;;    12:00 PHI201 #16/24

;; Also the entry %%(prince-schedule) can be used to mark the
;; beginnings and ends of semesters for any year, even if you don't
;; know yet which classes to mark.

;; From liu-calendar.el: "Probably the academic calendar at your
;; institution is different.  But unless your administration changes
;; its calendar from year to year, you should be able to adapt the
;; ideas here with minor reprogramming."

;; Indeed, Princeton's academic calendar is a bit of a puzzle.  I have
;; attempted in vain to find the formula that is used to determine the
;; first day of the fall semester.  So, the following -- in particular
;; `prince-key-dates' -- is not necessarily valid past the 2007-08
;; academic year.
;;
;; You might also wonder: is January of a year considered to be part
;; of the *previous* fall's semester (so that January 2007 is part of
;; fall semester 2006)? For the purpose of these functions, it does
;; not matter, since class meetings end in December.


;;; Code:

(require 'cl)
(provide 'prince-calendar)


(defvar prince-key-dates-cache nil
  "To speed things up, this variable caches the key dates of each
year's academic calendar.  Do not mess with it.")


(defvar prince-weeks-per-semester 12
  "This is just used to compute the number of lectures expected in any
given semester.")


(defun prince-assoc (key alist)
  "Composes `cdr' with `assoc'."
  (cdr (assoc key alist)))


;; note: because of `prince-key-dates-cache', redefining this function
;; on the fly does not always produce new values -- you have to clear
;; the cache and then re-evaluate

(defun prince-key-dates (year)
  "Return an alist containing key dates of the academic calendar of
given year.  Uses the `prince-key-dates-cache'."
  (let ((result (assoc year prince-key-dates-cache)))
    (if result (cdr result)             ; cache hit!
      (let* ( 
             ;; Fall semester
             ; Princeton fall begin date seems to be random, so we define by cases for the next few years
	     (f-class-b (cond
			 ((= year 2007) (calendar-absolute-from-gregorian '(9 17 2007)))
			 ((= year 2008) (calendar-absolute-from-gregorian '(9 11 2007)))
			 ((= year 2009) (calendar-absolute-from-gregorian '(9 17 2009)))
			 ;; pick a random date for other years
			 (t (calendar-absolute-from-gregorian (list 9 12 year)))))
	     ; fall break begins on the Saturday after the sixth *full* week of classes
	     ; ... at least it has been this way for the past few years
	     (f-break-b (if 
                         ;; if classes begin on Monday, add forty days 
			 (= (calendar-day-of-week (calendar-gregorian-from-absolute f-class-b)) 1)
			    (+ f-class-b 40)
		         ;; otherwise, add 42 days and then enough more to get to Saturday
			  (+ f-class-b 42 (- 6 (mod (calendar-day-of-week (calendar-gregorian-from-absolute f-class-b)) 6)))))
	     ; fall break lasts eight days
	     (f-break-e (+ 8 f-break-b))
	     (thanks-d (calendar-nth-named-absday 4 4 11 year)) ; thanksgiving = 4th Thurs in Nov
	     ; Princeton: always exactly six weeks of classes after fall break?
	     ; for now, we just compute it by cases through fall 2009
	     (f-class-e (cond
			 ((= year 2007) (calendar-absolute-from-gregorian '(12 18 2007)))
			 ((= year 2008) (calendar-absolute-from-gregorian '(12 12 2007)))
			 ((= year 2009) (calendar-absolute-from-gregorian '(12 18 2007)))
			 ;; in general, 41 days after the last day of fall break?
			 (t (+ 41 f-break-e))))
	     ; reading period begins first Monday after Jan 2nd?
	     ; this recipe is valid at least until January 2010
	     (f-read-b (if (> (elt (calendar-nth-named-day 1 1 1 year) 1) 2)
			   (calendar-nth-named-absday 1 1 1 year)
			 (calendar-nth-named-absday 2 1 1 year)))
	     ; dean's date = eight days after beginning of reading period
	     (f-deans (+ 8 f-read-b))
	     ; fall exams begin the day after dean's date
	     (f-exams-b (+ 1 f-deans))
             ; fall exam period is 10 days
	     (f-exams-e (+ 10 f-exams-b))
	     ;; +Spring semester
	     ;; Princeton: valid through spring 2010
             (s-class-b (+ 9 f-exams-e))   ; spring classes begin 9 days after fall exams end 
             (s-break-b (+ 40 s-class-b))  ; 6 weeks of classes until spring break
	                                   ; spring classes always begin on Monday  
             (s-break-e (+ 8 s-break-b)) ; 
             (s-class-e (+ 40 s-break-e)) ; 6 weeks of classes after spring break
             (s-read-b (+ 3 s-class-e)) ; spring reading period begins Monday after classes end
	     (s-deans (+ 8 s-read-b))
	     (s-exams-b (+ 1 s-deans))
             (s-exams-e (+ 10 s-exams-b)) ; 10 days of exams
             ;; Join them
             (alist (list (cons 'f-class-b f-class-b)
                          (cons 'f-break-b f-break-b)
			  (cons 'f-break-e f-break-e)
			  (cons 'thanks-d thanks-d)
			  (cons 'f-class-e f-class-e)
			  (cons 'f-read-b f-read-b)
			  (cons 'f-deans f-deans)
                          (cons 'f-exams-e f-exams-e)
	                  (cons 's-class-b s-class-b)
			  (cons 's-class-e s-class-e)
                          (cons 's-break-b s-break-b)
                          (cons 's-break-e s-break-e)
                          (cons 's-read-b s-read-b)
			  (cons 's-deans s-deans))))
        (setq prince-key-dates-cache 
              (cons (cons year alist) prince-key-dates-cache))
        alist))))


(defun prince-class-day-p (semester year weekdays)
  "Is the current day a lecture day?"
  (let* ((alist (prince-key-dates year))
         (absday (calendar-absolute-from-gregorian date))
         (dayname (calendar-day-of-week date)))
    (cond 
     ((eq semester 'fall)
      (and (>= absday (prince-assoc 'f-class-b alist)) ; Fall semester
           (<= absday (prince-assoc 'f-class-e alist))
	   (not (and (>= absday (prince-assoc 'f-break-b alist)) ; Fall break
                     (< absday (prince-assoc 'f-break-e alist))))
           (/= absday (prince-assoc 'thanks-d alist)) ; Thanksgiving break
           (/= absday (1+ (prince-assoc 'thanks-d alist)))
           ;; fall 2007 quirk
	   (cond 
	    ; on Mon (12 17 2007), Thu classes meet
	    ((equal date '(12 17 2007)) (memq 4 weekdays))
	    ; on Tue (12 18 2007), Fri classes meet
	    ((equal date '(12 18 2007)) (memq 5 weekdays))
	    ; all other days
	    (t (memq dayname weekdays)))
	   )
      )
     ((eq semester 'spring)
      (and (>= absday (prince-assoc 's-class-b alist)) ; Spring semester
           (<= absday (prince-assoc 's-class-e alist))
           (not (and (>= absday (prince-assoc 's-break-b alist)) ; Spring break
                     (< absday (prince-assoc 's-break-e alist))))
           (memq dayname weekdays))))))


; Given the following function, if you put
;
;   %%(prince-class 'spring 2007 '(1 3)) 10:00 PHI201
;
; in your diary file, then your diary will show "10:00 PHI201" on each
; Monday and Wednesday (teaching day) of the spring semester, 2007.

(defun prince-class (semester year weekdays)
  "This is used in the diary file to mark classes.  It appends to the
entry the lecture number (#6/14, for example)."
  (if (prince-class-day-p semester year weekdays)
      (let* ((alist (prince-key-dates year))
             (day (prince-assoc (if (eq semester 'fall) 'f-class-b 's-class-b) 
                             alist))
             (today (calendar-absolute-from-gregorian date))
             (total (* prince-weeks-per-semester (length weekdays)))
             (num 0))
        (while (<= day today)
          (let ((date (calendar-gregorian-from-absolute day)))
            (if (prince-class-day-p semester year weekdays)
                (setq num (1+ num))))
          (setq day (1+ day)))
        (setq entry (concat entry " #" (int-to-string num)
                            "/" (int-to-string total)))
        t)))


;; The rest automatically modifies the `calendar-holidays' variable so
;; that academic holidays (such as the day after Thanksgiving and
;; Spring break) are treated the same as other holidays.

(defun prince-holidays-iter (alist offset)
  (if (= 5 offset) nil
    (cons (list (calendar-gregorian-from-absolute 
                 (+ (prince-assoc 's-break-b alist) offset))
                "Spring break")
          (prince-holidays-iter alist (1+ offset)))))

(defun prince-holidays-iter-2 (alist offset)
  (if (= 5 offset) nil
    (cons (list (calendar-gregorian-from-absolute 
                 (+ (prince-assoc 'f-break-b alist) offset))
                "Fall break")
          (prince-holidays-iter-2 alist (1+ offset)))))


(add-to-list 'calendar-holidays
             '(let* ((alist (prince-key-dates displayed-year))
                     (holidays (cond 
 		       ((memq displayed-month '(2 3 4)) (prince-holidays-iter alist 0))
 		       ((memq displayed-month '(9 10 11)) (prince-holidays-iter-2 alist 0))
 		       )))
                (if (memq displayed-month '(10 11 12))
                    (add-to-list 'holidays 
                                 (list (calendar-gregorian-from-absolute
                                        (1+ (prince-assoc 'thanks-d alist)))
                                       "Thanksgiving break")))
                (if (memq displayed-month '(4 5 6))
                    (add-to-list 'holidays
                                 (list (calendar-gregorian-from-absolute
                                        (prince-assoc 's-deans alist))
                                       "Dean's date")))
		(if (memq displayed-month '(12 1 2))
                    (add-to-list 'holidays
                                 (list (calendar-gregorian-from-absolute
                                        (prince-assoc 'f-deans alist))
                                       "Dean's date")))
                holidays))

;; end of file prince-calendar.el