I like your idea!
Gregory Novak <[EMAIL PROTECTED]> 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
_______________________________________________
emacs-wiki-discuss mailing list
emacs-wiki-discuss@nongnu.org
http://lists.nongnu.org/mailman/listinfo/emacs-wiki-discuss
