[emacs-wiki-discuss] Re: Heirarchical Planning

[Leon]

I like your idea!

Gregory Novak <address@hidden> writes:

> One of the things I like about using Planner is that it gets me into
> the habit of, at the beginning of the day, deciding what I'm going to
> do and, at the end of the day, evaluating whether or not I achieved my
> goals.  I'd like to do this same thing at the week level, the month
> level, the quarter level, and the year level.  This way each time
> period breaks down into 3-4 smaller time periods, and I can keep an
> eye on larger, longer-term goals.  (I've posted one or two messages
> about this before).
>
> To this end, I've put together a little code that lets you skip around
> on pages that correspond to the different time intervals.  When I'm
> looking at how I did over the past month, I want an easy way to look
> at how I did for the weeks of that month.  Typing out all the page
> names is tedious and time consuming, so I've created four functions
> zoom-iup (for interactive-up), zoom-idown, zoom-inext, and zoom-iprev
> (which I bind to Shift-up, Shift-down, etc).  
>
> The naming convention for pages is:
> year - "2006.Year"
> quarter - "2006.Quarter2"
> month - "2006.January"
> week - "2006.January.Week3"
> day - "2006.01.02"  
> (this can be changed by changing zoom-regexps)
>
> So typically I would look at the page named "2006.January" and then
> hit 'C-u S-down' which shows me 2006.January.Week1 in the other
> buffer.  Then I can hit S-left and S-right to look at
> 2006.January.Week2, 2006.January.Week3, etc.  
>
> I determine the month to which each week belongs by the month which
> contains the zoom-first-day-of-week'th day of that week.  Zero is
> Sunday, one is Monday, etc.  Therefore the March 1, 2006, would
> typically be fall into "2006.February.Week4"
>
> I'd like to be able to carry week-level tasks forward to the next
> week, but I haven't worked on that yet.  
>
> So, enjoy.  Comments welcome.
>
> Greg
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Config
> (defvar zoom-first-day-of-week 1 "What day should be considered the first of 
> the week.  Zero for Sunday, one for Monday, etc")
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Guts
> (defvar zoom-months '(("January" . 1)
>                     ("February" . 2)
>                     ("March" . 3)
>                     ("April" . 4)
>                     ("May" . 5)
>                     ("June" . 6)
>                     ("July" . 7)
>                     ("August" . 8)
>                     ("September" . 9)
>                     ("October" . 10)
>                     ("November" . 11)
>                     ("December" . 12)
>                     ("Month" . 13)) ; Extra invalid value
>   "Alist associating month names with numbers.")
>
> (defvar zoom-month-regexp (concat "\\(" 
>                                 (reduce (lambda (x y) (concat x "\\|" y)) 
>                                         (mapcar 'car zoom-months)) 
>                                 "\\)")
>   "Regexp matching any month name given in zoom-months")
>
> (defvar zoom-regexps (list '("^\\([0-9]\\{4\\}\\).Year$" 
>                            . year) ; (year)
>                          '("^\\([0-9]\\{4\\}\\).Quarter\\([0-5]\\)$" 
>                            . quarter) ; (year, quarter)
>                          (cons (concat "^\\([0-9]\\{4\\}\\)."
>                                        zoom-month-regexp
>                                        "$") 
>                                'month) ; (year, month)
>                          (cons (concat "^\\([0-9]\\{4\\}\\)."
>                                      zoom-month-regexp
>                                      ".Week\\([0-6]\\)$")
>                                'week); year, month, week
>                          
> '("^\\([0-9]\\{4\\}\\).\\([0-9]\\{1,2\\}\\).\\([0-9]\\{1,2\\}\\)$" 
>                            . day)) ; year, month, day
>   "Alist of regexps that match names of years, quarters, months,
>   weeks, and days")
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Heavy lifting functions
> (defun zoom-parse-to-strings (name &optional type)
>   "Parse a string NAME, into a period of time given by zoom-regexps.  
>
>   If TYPE is given, it is a symbol specifying the
>   type of time-period which NAME should be parsed as (one of
>   'day, 'week, 'month, 'quarter, or 'year.
>
>   Return a four element list consisting of the type of time
>   period and then a list of strings containing the subexpressions
>   matched by the successful regexp.  Eg, 
>   (zoom-parse-to-strings \"2006.Year\") 
>   returns (year \"2006\" nil nil) 
>   and (zoom-parse-to-strings \"2006.January.Week1\") 
>   returns (week \"2006\" \"January\" \"1\")"
>   (setq type (or type (assoc-default name zoom-regexps 'string-match)))  
>   ;; Make sure the match data is for the right search
>   (unless (string-match (car (rassoc type zoom-regexps)) name)
>     (error "Zoom: Couldn't Parse Name"))
>   (cons type (list (match-string 1 name) 
>                  (match-string 2 name) 
>                  (match-string 3 name))))
>
> (defun zoom-parse (&rest args)
>   "Parse a string NAME, into a period of time given by zoom-regexps.  
>
>   If TYPE is given, it is a symbol specifying the
>   type of time-period which NAME should be parsed as (one of
>   'day, 'week, 'month, 'quarter, or 'year.
>
>   Return a four element list consisting of the type of time
>   period and then numerical representations of the subexpressions
>   matched by the successful regexp.  Eg, 
>   (zoom-parse \"2006.Year\") returns (year 2006 nil nil)
>   and (zoom-parse \"2006.January.Week1\") returns (week 2006 1 1)" 
>
>   (let* ((result (apply 'zoom-parse-to-strings args))
>        (type (car result))
>        (strings (cdr result))
>        numbers)
>     (dotimes (i (length strings))
>       (setq numbers (cons (when (not (null (nth i strings)))
>                           (if (or (and (eq type 'month) (= i 1))
>                                   (and (eq type 'week) (= i 1)))
>                               (cdr (assoc (nth i strings) zoom-months))
>                             (string-to-number (nth i strings))))
>                         numbers)))
>     (cons type (reverse numbers))))
>
> (defun zoom-string (type &rest changes)
>   "Convert time-range info into a string name.  You can specify
>    numerical values or strings.  So
>   (zoom-string 'year 2006) -> \"2006.Year\"
>   (zoom-string 'year \"2006\") -> \"2006.Year\"
>   (zoom-string 'week 2006 \"February\" 3) -> \"2006.February.Week3\"
>   (zoom-string 'week 2006 2 3) -> \"2006.February.Week3\""
>   ;; use a template
>   (let ((name (cdr (assoc type '((year . "1000.Year")
>                                (quarter . "1000.Quarter5")
>                                (month . "1000.Month")
>                                (week . "1000.Month.Week6")
>                                (day . "1000.99.99"))))))
>       
>     ;; Make sure changes are strings
>     (let (result)
>       (dotimes (i (length changes))
>       (setq result (cons (if (not (numberp (nth i changes)))
>                              (nth i changes)
>                              (if (or (and (eq type 'month) (= i 1))
>                                      (and (eq type 'week) (= i 1)))
>                                  (car (rassoc (nth 1 changes) zoom-months))
>                                  (number-to-string (nth i changes))))
>                          result)))
>       (setq changes (reverse result)))
>     
>     ;; Special handling for days + months in 'day strings: make sure
>     ;; they're two digits
>     (when (eq type 'day)
>       (setq changes (mapcar (lambda (x) (if (= (length x) 1) 
>                                           (concat "0" x)
>                                           x))
>                           changes)))
>     
>     (dotimes (i (length changes))
>       (zoom-parse name type)    ; make sure match data is correct each time
>       (setq name (replace-match (nth i changes) t t name (1+ i))))
>     name))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Interactive
>
> (add-hook 'planner-mode-hook (lambda ()
>                              (local-set-key (kbd "<S-up>") 'zoom-iup)
>                              (local-set-key (kbd "<S-down>") 'zoom-idown)
>                              (local-set-key (kbd "<S-left>") 'zoom-iprev)
>                              (local-set-key (kbd "<S-right>") 'zoom-inext)))
>
> (defun zoom-iup (name other-window) 
>   "Move to the next higher level in the hierarchy."
>   (interactive (list (buffer-name)
>                   current-prefix-arg))
>   (when other-window (other-window 1))
>   (emacs-wiki-find-file (zoom-up name))
>   (when other-window (other-window 1)))
>
> (defun zoom-idown (name other-window) 
>   "Move to the next lower level in the hierarchy.  If the current
>   date is within the higher-level time range, zoom to the lower
>   level time range that also contains today.  Otherwise, just go
>   to the first lower-level time range."
>   (interactive (list (buffer-name)
>                    current-prefix-arg))
>   (when other-window (other-window 1))
>   (emacs-wiki-find-file (zoom-down name))
>   (when other-window (other-window 1)))
>
> (defun zoom-inext (name num other-window)
>   "Move to the next time range at the same level in the
>   hierarchy.  With a numeric prefix arg, move by that number of
>   time ranges.  With a non-numeric prefix arg, show the desired
>   page in the other window."
>   (interactive (list (buffer-name)
>                    (if (numberp current-prefix-arg) 
>                        current-prefix-arg
>                      1)
>                    (consp current-prefix-arg)))
>   (when other-window (other-window 1))
>   (emacs-wiki-find-file (zoom-next name num))
>   (when other-window (other-window 1)))
>
> (defun zoom-iprev (name num other-window)
>   "Move to the previous time range at the same level in the
>   hierarchy.  With a numeric prefix arg, move by that number of
>   time ranges.  With a non-numeric prefix arg, show the desired
>   page in the other window."
>   (interactive (list (buffer-name)
>                    (if (numberp current-prefix-arg) 
>                        current-prefix-arg
>                      1)
>                    (consp current-prefix-arg)))
>   (when other-window (other-window 1))
>   (emacs-wiki-find-file (zoom-next name (- num)))
>   (when other-window (other-window 1)))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Non-period-specific stuff
> (defun zoom-contains (name &optional today)
>   "Test if TODAY is contained within the time period specified by
>   string NAME.  If TODAY is not given, use the current date"
>   (setq today (or today (gsn/calendar-today-absolute)))
>   (and (<= (zoom-beg name) today)
>        (>= (zoom-end name) today)))
>
> (defun zoom-beg (name)
>   "Return the absolute date of the beginning of the time period
>   specified by string NAME."
>   (funcall 
>    ;; This is basically do-it-yourself object orientation.  Times are
>    ;; lists where the first element is the type and the other elements
>    ;; are type-specific information.  This function call dispatches on
>    ;; the type, so it's basically a method call on a time range.
>    (cdr (assoc (car (zoom-parse name)) '((year . zoom-year-beg)
>                                        (quarter . zoom-quarter-beg)
>                                        (month . zoom-month-beg)
>                                        (week . zoom-week-beg)
>                                        (day . zoom-day-beg))))
>    name))
>
> (defun zoom-end (name)
>   "Return the absolute date of the end of the time period
>   specified by string NAME."
>   (funcall 
>    ;; See zoom-beg comments
>    (cdr (assoc (car (zoom-parse name)) '((year . zoom-year-end)
>                                        (quarter . zoom-quarter-end)
>                                        (month . zoom-month-end)
>                                        (week . zoom-week-end)
>                                        (day . zoom-day-end))))
>    name))
>
> (defun zoom-up (name)
>   "For time range given by string NAME, return a string
>   representiang the next higher enclosing time range in the
>   heirarchy"
>   (funcall 
>    ;; See zoom-beg comments
>    (cdr (assoc (car (zoom-parse name)) '((year . zoom-up-year)
>                                        (quarter . zoom-up-quarter)
>                                        (month . zoom-up-month)
>                                        (week . zoom-up-week)
>                                        (day . zoom-up-day))))
>    name))
>
> (defun zoom-down (name)
>   "For time range given by string NAME, return a string
>   representiang the next lower time range in the heirarchy.  If
>   the current date is within the higher-level time range, choose
>   the lower-level time range that also includes the current date.
>   Otherwise, just retturn the first lower-level time range"
>   (funcall 
>    ;; See zoom-beg comments
>    (cdr (assoc (car (zoom-parse name)) '((year . zoom-down-year)
>                                        (quarter . zoom-down-quarter)
>                                        (month . zoom-down-month)
>                                        (week . zoom-down-week)
>                                        (day . zoom-down-day))))
>    name))
>
> (defun zoom-next (name num)
>   "For time range given by string NAME, return a string
>   representiang the next time range at the same level in the heirarchy."
>   (funcall 
>    ;; See zoom-beg comments
>    (cdr (assoc (car (zoom-parse name)) '((year . zoom-next-year)
>                                        (quarter . zoom-next-quarter)
>                                        (month . zoom-next-month)
>                                        (week . zoom-next-week)
>                                        (day . zoom-next-day))))
>    name num))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Year
> (defun zoom-year-beg (name)
>   "Return the absolute date of the beginning of the year
>   specified by string NAME"
>   (multiple-value-bind (type year) (zoom-parse name 'year)
>     (calendar-absolute-from-gregorian (list 1 1 year))))
>
> (defun zoom-year-end (name)
>   "Return the absolute date of the end of the year
>   specified by string NAME"
>   (multiple-value-bind (type year) (zoom-parse name 'year)
>     (calendar-absolute-from-gregorian (list 12 31 year))))
>
> (defun zoom-up-year (name) 
>   "Error: there's nothing above year in the heirarchy"
>   nil)
>
> (defun zoom-next-year (name num)
>   "Return a string NUM years after the one given by string NAME."
>   (multiple-value-bind (type year) (zoom-parse name 'year)
>     (zoom-string 'year (+ num year))))
>
> (defun zoom-down-year (name &optional today)
>   "If the absolute date TODAY is within the year specified by
>   NAME, return a string for the quarter that also contains TODAY.
>   Otherwise, return the a string for the first quarter in the
>   year.  If TODAY is not given, use the current date."
>   (multiple-value-bind (junk year) (zoom-parse name 'year)
>     (if (not (zoom-contains name today)) 
>       (zoom-string 'quarter year 1)
>       (car (remove-if-not (lambda (p) (zoom-contains p today))
>                         (mapcar (lambda (n) (zoom-string 'quarter year n))
>                                 (range 1 4)))))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Quarter
> (defun zoom-up-quarter (name)
>   "Return a string for the year containing the quarter specified
>   by string NAME."
>   (multiple-value-bind (type year quarter) (zoom-parse name 'quarter)
>     (zoom-string 'year year)))
>
> (defun zoom-quarter-beg (name)
>   "Return the absolute date of the first day of the quarter given
>   by string NAME"
>   (multiple-value-bind (type year quarter) (zoom-parse name 'quarter)
>     (calendar-absolute-from-gregorian (list (1+ (* 3 (1- quarter))) 1 year))))
>
> (defun zoom-quarter-end (name)
>   "Return the absolute date of the last day of the quarter given
>   by string NAME"
>   (multiple-value-bind (type year quarter) (zoom-parse name 'quarter)
>     (cond ((= 1 quarter) (calendar-absolute-from-gregorian (list 3 31 year)))
>         ((= 2 quarter) (calendar-absolute-from-gregorian (list 6 30 year)))
>         ((= 3 quarter) (calendar-absolute-from-gregorian (list 9 30 year)))
>         ((= 4 quarter) (calendar-absolute-from-gregorian (list 12 31 
> year))))))
>
> (defun zoom-next-quarter (name num)
>   "Return a string for the name of the NUMth quarter after the
>   one given by string NAME."
>   (multiple-value-bind (type year quarter) (zoom-parse name 'quarter)  
>     (let ((new-year (+ year (floor (/ (1- (float (+ quarter num))) 4))))
>         (new-quarter (1+ (mod (1- (+ quarter num)) 4))))
>       (zoom-string 'quarter new-year new-quarter))))
>
> (defun zoom-down-quarter (name &optional today)
>   "If the absolute TODAY is within the quarter given by string
>   NAME, return a string for the month that also contains TODAY.
>   Otherwise, return a string for the first month in the
>   quarter.  If TODAY is not given, use the current date."
>   (multiple-value-bind (type year quarter) (zoom-parse name 'quarter) 
>     (if (not (zoom-contains name today)) 
>       (zoom-string 'month year (1+ (* (1- quarter) 3)))
>       ;; inefficient, but correct, to just include all months in the
>       ;; test since we know that the current quarter contains today,
>       ;; therefore some month in another quarter _cannot_ contain
>       ;; today
>       (car (remove-if-not (lambda (p) (zoom-contains p today)) 
>                         (mapcar (lambda (n) (zoom-string 'month year n))
>                                 (range 1 12)))))))
>
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Month
>
> (defun zoom-month-beg (name)
>   "Return the absolute date of the first day of the month given
>   by the string NAME."
>   (multiple-value-bind (type year month) (zoom-parse name 'month)
>     (calendar-absolute-from-gregorian (list month 1 year))))
>
> (defun zoom-month-end (name)
>   "Return the absolute date of the last day of the month given
>   by the string NAME."
>   (multiple-value-bind (type year month) (zoom-parse name 'month)
>     (calendar-absolute-from-gregorian (list month (calendar-last-day-of-month 
> month year) year))))
>
> (defun zoom-up-month (name)
>   "Return a string for the quarter containing the month given by string NAME."
>   (multiple-value-bind (type year month) (zoom-parse name)
>     (let ((quarter (1+ (/ (1- month) 3))))
>       (zoom-string 'quarter year quarter))))
>                  
> (defun zoom-next-month (name num)
>   "Return a string for the NUMth month after the one given by the
>   string NAME"
>   (multiple-value-bind (type year month) (zoom-parse name 'month)
>     (let ((new-year (+ year (floor (/ (1- (float (+ month num))) 12))))
>         (new-month (1+ (mod (1- (+ month num)) 12))))
>       (zoom-string 'month new-year new-month))))
>
> (defun zoom-down-month (name &optional today)
>   "If the absolute date TODAY is within the month given by the
>   string NAME, return a string for the week that also contains
>   TODAY.  Otherwise, return a string for the first week in the
>   month.  If TODAY is not given, use the current date."
>   (multiple-value-bind (type year month) (zoom-parse name 'month)  
>     (if (not (zoom-contains name today)) 
>       (zoom-string 'week year month 1)
>       (car (remove-if-not (lambda (p) (zoom-contains p today))
>                         (mapcar (lambda (n) (zoom-string 'week year month n))
>                                 (range 1 5)))))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Week
>
> (defun zoom-week-beg (name)
>   "Return the absolute date of the first day of the week given by string 
> NAME."
>   (multiple-value-bind (type year month week) (zoom-parse name 'week)
>     (calendar-absolute-from-gregorian 
>      (calendar-nth-named-day week zoom-first-day-of-week month year))))
>
> (defun zoom-week-end (name)
>   "Return the absolute date of the last day of the week given by string NAME."
>   (+ 6 (zoom-week-beg name)))
>
> (defun zoom-up-week (name)
>   "Return a string for the month containing the week given by string NAME."
>   (multiple-value-bind (type year month week) (zoom-parse name 'week)
>     (zoom-string 'month year month)))
>
> (defun zoom-next-week (name num)
>   "Return a string for the NUMth week after the one specified by
>   the string NAME."
>   (multiple-value-bind (type year month week) (zoom-parse name 'week)
>     ;; New week <= 0 leads to problems with nth-named-day... try to fix them?
>     (let* ((new-week (if (> (+ week num) 0) 
>                        (+ week num)
>                      (1- (+ week num))))
>          (new-date (calendar-nth-named-day new-week zoom-first-day-of-week 
> month year 1))
>          (new-year (extract-calendar-year new-date))
>          (new-month (extract-calendar-month new-date))
>          (new-day (extract-calendar-day new-date))       
>          (first-date (calendar-nth-named-day 1 zoom-first-day-of-week 
> new-month new-year 1))
>          (first-day (extract-calendar-day first-date))
>          (new-week (1+ (/ (- new-day first-day) 7))))
>       (zoom-string 'week new-year new-month new-week))))
>
> (defun zoom-down-week (name &optional today)
>   "If the absolute date TODAY is within the week specified by
>   string NAME, return a string for TODAY.  Otherwise, return the
>   first day in the week.  If TODAY is not given, use the current date."
>   (setq today (or today (gsn/calendar-today-absolute)))
>   (multiple-value-bind (type year month week) (zoom-parse name 'week)
>     (if (not (zoom-contains name today))      
>       (zoom-string 'day year month 
>                    (extract-calendar-day 
>                     (calendar-nth-named-day week zoom-first-day-of-week month 
> year)))
>       (let* ((today (calendar-gregorian-from-absolute today))
>            (year (extract-calendar-year today))
>            (month (extract-calendar-month today))
>            (day (extract-calendar-day today)))
>       (zoom-string 'day year month day)))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Day
>
> (defun zoom-day-beg (name)
>   "Return the absolute date of the day given by the string NAME."
>   (multiple-value-bind (type year month day) (zoom-parse name 'day)
>     (calendar-absolute-from-gregorian (list month day year))))
>
> (defun zoom-day-end (name)
>   "Return the absolute date of the day given by the string NAME."
>   (zoom-day-beg name))
>
> (defun zoom-up-day (name)
>   "Return a string for the week that contains the day given by
>   the string NAME."
>   (multiple-value-bind (type year month day) (zoom-parse name 'day)
>     (let* ((first-date (calendar-nth-named-day 1 zoom-first-day-of-week month 
> year))
>          (first-day (extract-calendar-day first-date))
>          (week (1+ (/ (- day first-day) 7))))
>       (zoom-string 'week year month week))))
>
> (defun zoom-next-day (name num)
>   "Return the NUMth day after the one given by the string NAME."
>   (let ((new-date (calendar-gregorian-from-absolute (+ (zoom-day-beg name) 
> num))))
>     (zoom-string 'day 
>                (extract-calendar-year new-date)
>                (extract-calendar-month new-date)
>                (extract-calendar-day new-date))))
>
> (defun zoom-down-day (name) 
>   nil)
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> (defvar zoom-tests
>       '((zoom-parse-to-strings ("2006.Year")  (year "2006" nil nil))
>       (zoom-parse-to-strings ("2006.January") (month "2006" "January" nil))
>       (zoom-parse-to-strings ("2006.Quarter1") (quarter "2006" "1" nil))
>       (zoom-parse-to-strings ("2006.January.Week1") (week "2006" "January" 
> "1"))
>       (zoom-parse-to-strings ("2006.01.03") (day "2006" "01" "03"))
>       
>       (zoom-parse ("2006.Year") (year 2006 nil nil))
>       (zoom-parse ("2006.January") (month 2006 1 nil))
>       (zoom-parse ("2006.Quarter1") (quarter 2006 1 nil))
>       (zoom-parse ("2006.January.Week1") (week 2006 1 1))
>       (zoom-parse ("2006.01.03") (day 2006 1 3))
>       
>       (zoom-string (year 2007) "2007.Year")
>       (zoom-string (year "2007") "2007.Year")
>       (zoom-string (quarter 2007 2) "2007.Quarter2")
>       (zoom-string (quarter "2007" "2") "2007.Quarter2")
>       (zoom-string (month 2007 2) "2007.February")
>       (zoom-string (month "2007" "February") "2007.February")
>       (zoom-string (week 2007 2 2) "2007.February.Week2")
>       (zoom-string (week "2007" "February" "2") "2007.February.Week2")
>       (zoom-string (day 2007 2 2) "2007.02.02")
>       (zoom-string (day "2007" "2" "2") "2007.02.02")
>       
>       (zoom-contains ("2006.Year" 732311) nil)
>       (zoom-contains ("2006.Year" 732312) t)
>       (zoom-contains ("2006.Year" 732463) t)
>       (zoom-contains ("2006.Year" 732676) t)
>       (zoom-contains ("2006.Year" 732677) nil)
>       
>       (zoom-year-beg ("2006.Year") 732312)
>       (zoom-quarter-beg ("2006.Quarter1") 732312)
>       (zoom-quarter-beg ("2006.Quarter2") 732402)
>       (zoom-quarter-beg ("2006.Quarter3") 732493)
>       (zoom-quarter-beg ("2006.Quarter4") 732585)
>       (zoom-month-beg ("2006.January") 732312)
>       (zoom-week-beg ("2006.January.Week1") 732313)
>       (zoom-week-beg ("2006.January.Week2") 732320)
>       (zoom-week-beg ("2006.January.Week3") 732327)
>       (zoom-week-beg ("2006.January.Week4") 732334)
>       (zoom-week-beg ("2006.January.Week5") 732341)
>       (zoom-week-beg ("2006.January.Week6") 732348)
>       (zoom-day-beg ("2006.02.03") 732345)
>       
>       (zoom-year-end ("2006.Year") 732676)
>       (zoom-quarter-end ("2006.Quarter1") 732401)
>       (zoom-quarter-end ("2006.Quarter2") 732492)
>       (zoom-quarter-end ("2006.Quarter3") 732584)
>       (zoom-quarter-end ("2006.Quarter4") 732676)
>       (zoom-month-end ("2006.January") 732342)
>       (zoom-week-end ("2006.January.Week1") 732319)
>       (zoom-week-end ("2006.January.Week2") 732326)
>       (zoom-week-end ("2006.January.Week3") 732333)
>       (zoom-week-end ("2006.January.Week4") 732340)
>       (zoom-week-end ("2006.January.Week5") 732347)
>       (zoom-week-end ("2006.January.Week6") 732354)
>       (zoom-day-end ("2006.01.01")  732312)
>       
>       (zoom-next-year ("2006.Year" 2) "2008.Year")
>       (zoom-next-year ("2006.Year" -2) "2004.Year")
>       (zoom-next-year ("2006.Year" 0) "2006.Year")
>       (zoom-next-quarter ("2006.Quarter2" 5) "2007.Quarter3")
>       (zoom-next-quarter ("2006.Quarter2" -5) "2005.Quarter1")
>       (zoom-next-quarter ("2006.Quarter2" 0) "2006.Quarter2")
>       (zoom-next-month ("2006.June" 13) "2007.July")
>       (zoom-next-month ("2006.June" -13) "2005.May")
>       (zoom-next-month ("2006.June" 0) "2006.June")
>       (zoom-next-week ("2006.April.Week2" 3) "2006.May.Week1")
>       (zoom-next-week ("2006.April.Week2" -2) "2006.March.Week4")
>       (zoom-next-week ("2006.April.Week2" 0) "2006.April.Week2")
>       (zoom-next-day ("2006.04.03" -7) "2006.03.27")
>       (zoom-next-day ("2006.04.03" -1) "2006.04.02")
>       (zoom-next-day ("2006.04.03" 0) "2006.04.03")
>       (zoom-next-day ("2006.04.03" 1) "2006.04.04")
>       (zoom-next-day ("2006.04.03" 28) "2006.05.01")
>       
>       (zoom-up-quarter ("2006.Quarter1") "2006.Year")
>       (zoom-up-month ("2006.April") "2006.Quarter2")
>       (zoom-up-week ("2006.April.Week1") "2006.April")
>       (zoom-up-day ("2006.04.10") "2006.April.Week2")
>
>       ;(calendar-absolute-from-gregorian (4 30 2006) 732431)
>       ;(calendar-absolute-from-gregorian (4 30 2005) 732066)
>       
>       ;; April 30th, 2006: Should zoom down to Q2, Month 4, Week 4, day 
> 4.30.2006
>       (zoom-down-year ("2006.Year" 732431) "2006.Quarter2")
>       (zoom-down-quarter ("2006.Quarter2" 732431) "2006.April")
>       (zoom-down-month ("2006.April" 732431) "2006.April.Week4")
>       (zoom-down-week ("2006.April.Week4" 732431) "2006.04.30")
>       
>       ;; April 30th, 2005: Should zoom down to Q1, January, Week 1, 1.1.2006
>       (zoom-down-year ("2006.Year" 732066) "2006.Quarter1")
>       (zoom-down-quarter ("2006.Quarter1" 732066) "2006.January")
>       (zoom-down-month ("2006.January" 732066) "2006.January.Week1")
>       (zoom-down-week ("2006.January.Week1" 732066) "2006.01.02"))
>   "A list of lists of the form (function-name function-arguments
>   desired-result) which is used to test the functions in the zoom
>   package")
>
> (defun zoom-test ()
>   "Run all the tests in zoom-tests."
>   (dolist (test zoom-tests)
>     (let* ((fn (first test))
>          (fn-args (second test))
>          (desired-result (third test))
>          (result (apply fn fn-args)))
>       (when (not (equal desired-result result))
>       (error "Failed test!"))))
>   t)
>   
>
>
> (defun gsn/calendar-today-gregorian ()
>   (multiple-value-bind (junk junk junk day month year) (decode-time)
>     (list month day year)))
>
> (defun gsn/calendar-today-absolute ()
>   (calendar-absolute-from-gregorian (gsn/calendar-today-gregorian)))

-- 
Leon