planner-zoom.el

   1 ;;; planner-zoom.el --- navigate Planner pages
   2
   3 ;; Copyright (C) 2006, 2008 Gregory Novak
   4 ;; Parts copyright (C) 2006, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: Gregory Novak <novak@ucolick.org>
   7 ;; Date: 10-Mar-2006
   8
   9 ;; This file is part of Planner.  It is not part of GNU Emacs.
  10
  11 ;; Planner is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; Planner is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with Planner; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; One of the things I like about using Planner is that it gets me
  29 ;; into the habit of, at the beginning of the day, deciding what I'm
  30 ;; going to do and, at the end of the day, evaluating whether or not I
  31 ;; achieved my goals.  I'd like to do this same thing at the week
  32 ;; level, the month level, the quarter level, and the year level.
  33 ;; This way each time period breaks down into 3-4 smaller time
  34 ;; periods, and I can keep an eye on larger, longer-term goals.  (I've
  35 ;; posted one or two messages about this before).
  36 ;;
  37 ;; To this end, I've put together a little code that lets you skip
  38 ;; around on pages that correspond to the different time intervals.
  39 ;; When I'm looking at how I did over the past month, I want an easy
  40 ;; way to look at how I did for the weeks of that month.  Typing out
  41 ;; all the page names is tedious and time consuming, so I've created
  42 ;; four functions zoom-iup (for interactive-up), zoom-idown,
  43 ;; zoom-inext, and zoom-iprev (which I bind to Shift-up, Shift-down,
  44 ;; etc).
  45 ;;
  46 ;; The naming convention for pages is:
  47 ;; year - "2006.Year"
  48 ;; quarter - "2006.Quarter2"
  49 ;; month - "2006.January"
  50 ;; week - "2006.January.Week3"
  51 ;; day - "2006.01.02"
  52 ;; (this can be changed by changing zoom-regexps)
  53 ;;
  54 ;; So typically I would look at the page named "2006.January" and then
  55 ;; hit 'C-u S-down' which shows me 2006.January.Week1 in the other
  56 ;; buffer.  Then I can hit S-left and S-right to look at
  57 ;; 2006.January.Week2, 2006.January.Week3, etc.
  58 ;;
  59 ;; I determine the month to which each week belongs by the month which
  60 ;; contains the zoom-first-day-of-week'th day of that week.  Zero is
  61 ;; Sunday, one is Monday, etc.  Therefore the March 1, 2006, would
  62 ;; typically be fall into "2006.February.Week4"
  63
  64 ;;; Contributors:
  65
  66 ;;; Code:
  67
  68 (require 'planner)
  69
  70 (eval-when-compile (require 'cl))
  71
  72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73 ;; Config
  74 (defvar planner-zoom-first-day-of-week 1
  75   "What day should be considered the first of the week.
  76 Zero for Sunday, one for Monday, etc")
  77
  78 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79 ;; Guts
  80 (defvar planner-zoom-months
  81   '(("January" . 1)
  82     ("February" . 2)
  83     ("March" . 3)
  84     ("April" . 4)
  85     ("May" . 5)
  86     ("June" . 6)
  87     ("July" . 7)
  88     ("August" . 8)
  89     ("September" . 9)
  90     ("October" . 10)
  91     ("November" . 11)
  92     ("December" . 12)
  93     ("Month" . 13)) ; Extra invalid value
  94   "Alist associating month names with numbers.")
  95
  96 (defvar planner-zoom-month-regexp
  97   (concat "\\(" (mapconcat #'car planner-zoom-months "\\|") "\\)")
  98   "Regexp matching any month name given in planner-planner-zoom-months.")
  99
 100 (defvar planner-zoom-regexps
 101   (list '("^\\([0-9]\\{4\\}\\).Year$"
 102           . year) ; (year)
 103         '("^\\([0-9]\\{4\\}\\).Quarter\\([0-5]\\)$"
 104           . quarter) ; (year, quarter)
 105         (cons (concat "^\\([0-9]\\{4\\}\\)." planner-zoom-month-regexp "$")
 106               'month) ; (year, month)
 107         (cons (concat "^\\([0-9]\\{4\\}\\)."
 108                       planner-zoom-month-regexp
 109                       ".Week\\([0-6]\\)$")
 110               'week); year, month, week
 111         '("^\\([0-9]\\{4\\}\\).\\([0-9]\\{1,2\\}\\).\\([0-9]\\{1,2\\}\\)$"
 112           . day)) ; year, month, day
 113   "Alist of regexps that match names of years, quarters, months,
 114 weeks, and days.")
 115
 116 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 117 ;; Heavy lifting functions
 118 (defun planner-zoom-parse-to-strings (name &optional type)
 119   "Parse a string NAME, into a period of time given by `planner-zoom-regexps'.
 120
 121 If TYPE is given, it is a symbol specifying the type of
 122 time-period which NAME should be parsed as (one of 'day, 'week,
 123 'month, 'quarter, or 'year.
 124
 125 Return a four element list consisting of the type of time
 126 period and then a list of strings containing the subexpressions
 127 matched by the successful regexp.  Eg,
 128 \(planner-zoom-parse-to-strings \"2006.Year\") returns
 129 \(year \"2006\" nil nil) and
 130 \(planner-zoom-parse-to-strings \"2006.January.Week1\") returns
 131 \(week \"2006\" \"January\" \"1\")"
 132   (setq type (or type (assoc-default name planner-zoom-regexps 'string-match)))
 133   ;; Make sure the match data is for the right search
 134   (unless (string-match (car (rassoc type planner-zoom-regexps)) name)
 135     (error "planner-zoom: Couldn't parse name"))
 136   (cons type (list (match-string 1 name)
 137                    (match-string 2 name)
 138                    (match-string 3 name))))
 139
 140 (defun planner-zoom-parse (&rest args)
 141   "Parse a string NAME, into a period of time given by `planner-zoom-regexps'.
 142
 143 If TYPE is given, it is a symbol specifying the type of
 144 time-period which NAME should be parsed as (one of 'day, 'week,
 145 'month, 'quarter, or 'year.
 146
 147 Return a four element list consisting of the type of time period
 148 and then numerical representations of the subexpressions matched
 149 by the successful regexp.
 150
 151 Eg,
 152 \(planner-zoom-parse \"2006.Year\") returns (year 2006 nil nil)
 153 and (planner-zoom-parse \"2006.January.Week1\") returns (week 2006 1 1)."
 154
 155   (let* ((result (apply 'planner-zoom-parse-to-strings args))
 156          (type (car result))
 157          (strings (cdr result))
 158          numbers)
 159     (dotimes (i (length strings))
 160       (setq numbers (cons (when (not (null (nth i strings)))
 161                             (if (or (and (eq type 'month) (= i 1))
 162                                     (and (eq type 'week) (= i 1)))
 163                                 (cdr (assoc (nth i strings)
 164                                             planner-zoom-months))
 165                               (string-to-number (nth i strings))))
 166                           numbers)))
 167     (cons type (nreverse numbers))))
 168
 169 (defun planner-zoom-string (type &rest changes)
 170   "Convert time-range info into a string name.  You can specify
 171 numerical values or strings.
 172
 173 So,
 174 \(planner-zoom-string 'year 2006) -> \"2006.Year\"
 175 \(planner-zoom-string 'year \"2006\") -> \"2006.Year\"
 176 \(planner-zoom-string 'week 2006 \"February\" 3) -> \"2006.February.Week3\"
 177 \(planner-zoom-string 'week 2006 2 3) -> \"2006.February.Week3\""
 178   ;; use a template
 179   (let ((name (cdr (assoc type '((year . "1000.Year")
 180                                  (quarter . "1000.Quarter5")
 181                                  (month . "1000.Month")
 182                                  (week . "1000.Month.Week6")
 183                                  (day . "1000.99.99"))))))
 184
 185     ;; Make sure changes are strings
 186     (let (result)
 187       (dotimes (i (length changes))
 188         (setq result (cons (if (not (numberp (nth i changes)))
 189                                (nth i changes)
 190                              (if (or (and (eq type 'month) (= i 1))
 191                                      (and (eq type 'week) (= i 1)))
 192                                  (car (rassoc (nth 1 changes)
 193                                               planner-zoom-months))
 194                                (number-to-string (nth i changes))))
 195                            result)))
 196       (setq changes (nreverse result)))
 197
 198     ;; Special handling for days + months in 'day strings: make sure
 199     ;; they're two digits
 200     (when (eq type 'day)
 201       (setq changes (mapcar (lambda (x) (if (= (length x) 1)
 202                                             (concat "0" x)
 203                                           x))
 204                             changes)))
 205
 206     (dotimes (i (length changes))
 207       (planner-zoom-parse name type)    ; make sure match data is
 208                                         ; correct each time
 209       (setq name (replace-match (nth i changes) t t name (1+ i))))
 210     name))
 211
 212 (defun planner-zoom-range (min max)
 213   "Return a list of numbers from MIN to MAX."
 214   (let ((lst nil))
 215     (while (<= min max)
 216       (setq lst (cons max lst))
 217       (setq max (1- max)))
 218     lst))
 219
 220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 221 ;; Interactive
 222
 223 (add-hook 'planner-mode-hook
 224           (lambda ()
 225             (local-set-key (kbd "<S-up>") 'planner-zoom-iup)
 226             (local-set-key (kbd "<S-down>") 'planner-zoom-idown)
 227             (local-set-key (kbd "<S-left>") 'planner-zoom-iprev)
 228             (local-set-key (kbd "<S-right>") 'planner-zoom-inext)))
 229
 230 (defun planner-zoom-iup (name other-window)
 231   "Move to the next higher level in the hierarchy."
 232   (interactive (list (planner-page-name)
 233                      current-prefix-arg))
 234   (when other-window (other-window 1))
 235   (planner-find-file (planner-zoom-up name))
 236   (when other-window (other-window 1)))
 237
 238 (defun planner-zoom-idown (name other-window)
 239   "Move to the next lower level in the hierarchy.
 240 If the current date is within the higher-level time range, zoom
 241 to the lower level time range that also contains today.
 242 Otherwise, just go to the first lower-level time range."
 243   (interactive (list (planner-page-name)
 244                      current-prefix-arg))
 245   (when other-window (other-window 1))
 246   (planner-find-file (planner-zoom-down name))
 247   (when other-window (other-window 1)))
 248
 249 (defun planner-zoom-inext (name num other-window)
 250   "Move to the next time range at the same level in the
 251 hierarchy.  With a numeric prefix arg, move by that number of
 252 time ranges.  With a non-numeric prefix arg, show the desired
 253 page in the other window."
 254   (interactive (list (planner-page-name)
 255                      (if (numberp current-prefix-arg)
 256                          current-prefix-arg
 257                        1)
 258                      (consp current-prefix-arg)))
 259   (when other-window (other-window 1))
 260   (planner-find-file (planner-zoom-next name num))
 261   (when other-window (other-window 1)))
 262
 263 (defun planner-zoom-iprev (name num other-window)
 264   "Move to the previous time range at the same level in the
 265 hierarchy.  With a numeric prefix arg, move by that number of
 266 time ranges.  With a non-numeric prefix arg, show the desired
 267 page in the other window."
 268   (interactive (list (planner-page-name)
 269                      (if (numberp current-prefix-arg)
 270                          current-prefix-arg
 271                        1)
 272                      (consp current-prefix-arg)))
 273   (when other-window (other-window 1))
 274   (planner-find-file (planner-zoom-next name (- num)))
 275   (when other-window (other-window 1)))
 276
 277 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 278 ;; Non-period-specific stuff
 279 (defun planner-zoom-contains (name &optional today)
 280   "Test if TODAY is contained within the time period specified by
 281 string NAME.  If TODAY is not given, use the current date"
 282   (setq today (or today (gsn/calendar-today-absolute)))
 283   (and (<= (planner-zoom-beg name) today)
 284        (>= (planner-zoom-end name) today)))
 285
 286 (defun planner-zoom-beg (name)
 287   "Return the absolute date of the beginning of the time period
 288 specified by string NAME."
 289   (funcall
 290    ;; This is basically do-it-yourself object orientation.  Times are
 291    ;; lists where the first element is the type and the other elements
 292    ;; are type-specific information.  This function call dispatches on
 293    ;; the type, so it's basically a method call on a time range.
 294    (cdr (assoc (car (planner-zoom-parse name))
 295                '((year . planner-zoom-year-beg)
 296                  (quarter . planner-zoom-quarter-beg)
 297                  (month . planner-zoom-month-beg)
 298                  (week . planner-zoom-week-beg)
 299                  (day . planner-zoom-day-beg))))
 300    name))
 301
 302 (defun planner-zoom-end (name)
 303   "Return the absolute date of the end of the time period
 304 specified by string NAME."
 305   (funcall
 306    ;; See planner-zoom-beg comments
 307    (cdr (assoc (car (planner-zoom-parse name))
 308                '((year . planner-zoom-year-end)
 309                  (quarter . planner-zoom-quarter-end)
 310                  (month . planner-zoom-month-end)
 311                  (week . planner-zoom-week-end)
 312                  (day . planner-zoom-day-end))))
 313    name))
 314
 315 (defun planner-zoom-up (name)
 316   "For time range given by string NAME, return a string
 317 representiang the next higher enclosing time range in the
 318 heirarchy."
 319   (funcall
 320    ;; See planner-zoom-beg comments
 321    (cdr (assoc (car (planner-zoom-parse name))
 322                '((year . planner-zoom-up-year)
 323                  (quarter . planner-zoom-up-quarter)
 324                  (month . planner-zoom-up-month)
 325                  (week . planner-zoom-up-week)
 326                  (day . planner-zoom-up-day))))
 327    name))
 328
 329 (defun planner-zoom-down (name)
 330   "For time range given by string NAME, return a string
 331 representiang the next lower time range in the heirarchy.  If the
 332 current date is within the higher-level time range, choose the
 333 lower-level time range that also includes the current date.
 334 Otherwise, just retturn the first lower-level time range"
 335   (funcall
 336    ;; See planner-zoom-beg comments
 337    (cdr (assoc (car (planner-zoom-parse name))
 338                '((year . planner-zoom-down-year)
 339                  (quarter . planner-zoom-down-quarter)
 340                  (month . planner-zoom-down-month)
 341                  (week . planner-zoom-down-week)
 342                  (day . planner-zoom-down-day))))
 343    name))
 344
 345 (defun planner-zoom-next (name num)
 346   "For time range given by string NAME, return a string
 347 representiang the next time range at the same level in the
 348 heirarchy."
 349   (funcall
 350    ;; See planner-zoom-beg comments
 351    (cdr (assoc (car (planner-zoom-parse name))
 352                '((year . planner-zoom-next-year)
 353                  (quarter . planner-zoom-next-quarter)
 354                  (month . planner-zoom-next-month)
 355                  (week . planner-zoom-next-week)
 356                  (day . planner-zoom-next-day))))
 357    name num))
 358
 359 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 360 ;; Year
 361 (defun planner-zoom-year-beg (name)
 362   "Return the absolute date of the beginning of the year
 363 specified by string NAME."
 364   (multiple-value-bind (type year) (planner-zoom-parse name 'year)
 365     (calendar-absolute-from-gregorian (list 1 1 year))))
 366
 367 (defun planner-zoom-year-end (name)
 368   "Return the absolute date of the end of the year specified by
 369 string NAME."
 370   (multiple-value-bind (type year) (planner-zoom-parse name 'year)
 371     (calendar-absolute-from-gregorian (list 12 31 year))))
 372
 373 (defun planner-zoom-up-year (name)
 374   "Error: there's nothing above year in the heirarchy."
 375   nil)
 376
 377 (defun planner-zoom-next-year (name num)
 378   "Return a string NUM years after the one given by string NAME."
 379   (multiple-value-bind (type year) (planner-zoom-parse name 'year)
 380     (planner-zoom-string 'year (+ num year))))
 381
 382 (defun planner-zoom-down-year (name &optional today)
 383   "If the absolute date TODAY is within the year specified by
 384 NAME, return a string for the quarter that also contains TODAY.
 385 Otherwise, return the a string for the first quarter in the year.
 386 If TODAY is not given, use the current date."
 387   (multiple-value-bind (junk year) (planner-zoom-parse name 'year)
 388     (if (not (planner-zoom-contains name today))
 389         (planner-zoom-string 'quarter year 1)
 390       (car (planner-remove-if-not
 391             (lambda (p) (planner-zoom-contains p today))
 392             (mapcar (lambda (n)
 393                       (planner-zoom-string 'quarter year n))
 394                     (planner-zoom-range 1 4)))))))
 395
 396 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 397 ;; Quarter
 398 (defun planner-zoom-up-quarter (name)
 399   "Return a string for the year containing the quarter specified
 400 by string NAME."
 401   (multiple-value-bind (type year quarter) (planner-zoom-parse name 'quarter)
 402     (planner-zoom-string 'year year)))
 403
 404 (defun planner-zoom-quarter-beg (name)
 405   "Return the absolute date of the first day of the quarter given
 406 by string NAME."
 407   (multiple-value-bind (type year quarter) (planner-zoom-parse name 'quarter)
 408     (calendar-absolute-from-gregorian (list (1+ (* 3 (1- quarter))) 1 year))))
 409
 410 (defun planner-zoom-quarter-end (name)
 411   "Return the absolute date of the last day of the quarter given
 412 by string NAME"
 413   (multiple-value-bind (type year quarter) (planner-zoom-parse name 'quarter)
 414     (cond ((= 1 quarter) (calendar-absolute-from-gregorian (list 3 31 year)))
 415           ((= 2 quarter) (calendar-absolute-from-gregorian (list 6 30 year)))
 416           ((= 3 quarter) (calendar-absolute-from-gregorian (list 9 30 year)))
 417           ((= 4 quarter)
 418            (calendar-absolute-from-gregorian (list 12 31 year))))))
 419
 420 (defun planner-zoom-next-quarter (name num)
 421   "Return a string for the name of the NUMth quarter after the
 422 one given by string NAME."
 423   (multiple-value-bind (type year quarter) (planner-zoom-parse name 'quarter)
 424     (let ((new-year (+ year (floor (/ (1- (float (+ quarter num))) 4))))
 425           (new-quarter (1+ (mod (1- (+ quarter num)) 4))))
 426       (planner-zoom-string 'quarter new-year new-quarter))))
 427
 428 (defun planner-zoom-down-quarter (name &optional today)
 429   "If the absolute TODAY is within the quarter given by string
 430 NAME, return a string for the month that also contains TODAY.
 431 Otherwise, return a string for the first month in the quarter.
 432 If TODAY is not given, use the current date."
 433   (multiple-value-bind (type year quarter) (planner-zoom-parse name 'quarter)
 434     (if (not (planner-zoom-contains name today))
 435         (planner-zoom-string 'month year (1+ (* (1- quarter) 3)))
 436       ;; inefficient, but correct, to just include all months in the
 437       ;; test since we know that the current quarter contains today,
 438       ;; therefore some month in another quarter _cannot_ contain
 439       ;; today
 440       (car (planner-remove-if-not
 441             (lambda (p) (planner-zoom-contains p today))
 442             (mapcar (lambda (n)
 443                       (planner-zoom-string 'month year n))
 444                     (planner-zoom-range 1 12)))))))
 445
 446 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 447 ;; Month
 448
 449 (defun planner-zoom-month-beg (name)
 450   "Return the absolute date of the first day of the month given
 451 by the string NAME."
 452   (multiple-value-bind (type year month) (planner-zoom-parse name 'month)
 453     (calendar-absolute-from-gregorian (list month 1 year))))
 454
 455 (defun planner-zoom-month-end (name)
 456   "Return the absolute date of the last day of the month given
 457 by the string NAME."
 458   (multiple-value-bind (type year month) (planner-zoom-parse name 'month)
 459     (calendar-absolute-from-gregorian
 460      (list month (calendar-last-day-of-month month year) year))))
 461
 462 (defun planner-zoom-up-month (name)
 463   "Return a string for the quarter containing the month given by string NAME."
 464   (multiple-value-bind (type year month) (planner-zoom-parse name)
 465     (let ((quarter (1+ (/ (1- month) 3))))
 466       (planner-zoom-string 'quarter year quarter))))
 467
 468 (defun planner-zoom-next-month (name num)
 469   "Return a string for the NUMth month after the one given by the string NAME."
 470   (multiple-value-bind (type year month) (planner-zoom-parse name 'month)
 471     (let ((new-year (+ year (floor (/ (1- (float (+ month num))) 12))))
 472           (new-month (1+ (mod (1- (+ month num)) 12))))
 473       (planner-zoom-string 'month new-year new-month))))
 474
 475 (defun planner-zoom-down-month (name &optional today)
 476   "If the absolute date TODAY is within the month given by the
 477 string NAME, return a string for the week that also contains
 478 TODAY.  Otherwise, return a string for the first week in the
 479 month.  If TODAY is not given, use the current date."
 480   (multiple-value-bind (type year month) (planner-zoom-parse name 'month)
 481     (if (not (planner-zoom-contains name today))
 482         (planner-zoom-string 'week year month 1)
 483       (car (planner-remove-if-not
 484             (lambda (p) (planner-zoom-contains p today))
 485             (mapcar (lambda (n)
 486                       (planner-zoom-string 'week year month n))
 487                     (planner-zoom-range 1 5)))))))
 488
 489 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 490 ;; Week
 491
 492 (defun planner-zoom-week-beg (name)
 493   "Return the absolute date of the first day of the week given by string NAME."
 494   (multiple-value-bind (type year month week) (planner-zoom-parse name 'week)
 495     (calendar-absolute-from-gregorian
 496      (calendar-nth-named-day week planner-zoom-first-day-of-week month year))))
 497
 498 (defun planner-zoom-week-end (name)
 499   "Return the absolute date of the last day of the week given by string NAME."
 500   (+ 6 (planner-zoom-week-beg name)))
 501
 502 (defun planner-zoom-up-week (name)
 503   "Return a string for the month containing the week given by string NAME."
 504   (multiple-value-bind (type year month week) (planner-zoom-parse name 'week)
 505     (planner-zoom-string 'month year month)))
 506
 507 (defun planner-zoom-next-week (name num)
 508   "Return a string for the NUMth week after the one specified by
 509 the string NAME."
 510   (multiple-value-bind (type year month week) (planner-zoom-parse name 'week)
 511     ;; New week <= 0 leads to problems with nth-named-day... try to fix them?
 512     (let* ((new-week (if (> (+ week num) 0)
 513                          (+ week num)
 514                        (1- (+ week num))))
 515            (new-date (calendar-nth-named-day
 516                       new-week planner-zoom-first-day-of-week month year 1))
 517            (new-year (extract-calendar-year new-date))
 518            (new-month (extract-calendar-month new-date))
 519            (new-day (extract-calendar-day new-date))
 520            (first-date (calendar-nth-named-day
 521                         1 planner-zoom-first-day-of-week new-month new-year 1))
 522            (first-day (extract-calendar-day first-date))
 523            (new-week (1+ (/ (- new-day first-day) 7))))
 524       (planner-zoom-string 'week new-year new-month new-week))))
 525
 526 (defun planner-zoom-down-week (name &optional today)
 527   "If the absolute date TODAY is within the week specified by
 528 string NAME, return a string for TODAY.  Otherwise, return the
 529 first day in the week.  If TODAY is not given, use the current
 530 date."
 531   (setq today (or today (gsn/calendar-today-absolute)))
 532   (multiple-value-bind (type year month week) (planner-zoom-parse name 'week)
 533     (if (not (planner-zoom-contains name today))
 534         (planner-zoom-string 'day year month
 535                              (extract-calendar-day
 536                               (calendar-nth-named-day
 537                                week planner-zoom-first-day-of-week
 538                                month year)))
 539       (let* ((today (calendar-gregorian-from-absolute today))
 540              (year (extract-calendar-year today))
 541              (month (extract-calendar-month today))
 542              (day (extract-calendar-day today)))
 543         (planner-zoom-string 'day year month day)))))
 544
 545 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 546 ;; Day
 547
 548 (defun planner-zoom-day-beg (name)
 549   "Return the absolute date of the day given by the string NAME."
 550   (multiple-value-bind (type year month day) (planner-zoom-parse name 'day)
 551     (calendar-absolute-from-gregorian (list month day year))))
 552
 553 (defun planner-zoom-day-end (name)
 554   "Return the absolute date of the day given by the string NAME."
 555   (planner-zoom-day-beg name))
 556
 557 (defun planner-zoom-up-day (name)
 558   "Return a string for the week that contains the day given by
 559 the string NAME."
 560   (multiple-value-bind (type year month day) (planner-zoom-parse name 'day)
 561     (let* ((first-date (calendar-nth-named-day
 562                         1 planner-zoom-first-day-of-week month year))
 563            (first-day (extract-calendar-day first-date))
 564            (week (1+ (/ (- day first-day) 7))))
 565       (planner-zoom-string 'week year month week))))
 566
 567 (defun planner-zoom-next-day (name num)
 568   "Return the NUMth day after the one given by the string NAME."
 569   (let ((new-date (calendar-gregorian-from-absolute
 570                    (+ (planner-zoom-day-beg name) num))))
 571     (planner-zoom-string 'day
 572                          (extract-calendar-year new-date)
 573                          (extract-calendar-month new-date)
 574                          (extract-calendar-day new-date))))
 575
 576 (defun planner-zoom-down-day (name)
 577   nil)
 578
 579 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 580 (defvar planner-zoom-tests
 581   '((planner-zoom-parse-to-strings ("2006.Year")  (year "2006" nil nil))
 582     (planner-zoom-parse-to-strings ("2006.January")
 583                                    (month "2006" "January" nil))
 584     (planner-zoom-parse-to-strings ("2006.Quarter1") (quarter "2006" "1" nil))
 585     (planner-zoom-parse-to-strings ("2006.January.Week1")
 586                                    (week "2006" "January" "1"))
 587     (planner-zoom-parse-to-strings ("2006.01.03") (day "2006" "01" "03"))
 588
 589     (planner-zoom-parse ("2006.Year") (year 2006 nil nil))
 590     (planner-zoom-parse ("2006.January") (month 2006 1 nil))
 591     (planner-zoom-parse ("2006.Quarter1") (quarter 2006 1 nil))
 592     (planner-zoom-parse ("2006.January.Week1") (week 2006 1 1))
 593     (planner-zoom-parse ("2006.01.03") (day 2006 1 3))
 594
 595     (planner-zoom-string (year 2007) "2007.Year")
 596     (planner-zoom-string (year "2007") "2007.Year")
 597     (planner-zoom-string (quarter 2007 2) "2007.Quarter2")
 598     (planner-zoom-string (quarter "2007" "2") "2007.Quarter2")
 599     (planner-zoom-string (month 2007 2) "2007.February")
 600     (planner-zoom-string (month "2007" "February") "2007.February")
 601     (planner-zoom-string (week 2007 2 2) "2007.February.Week2")
 602     (planner-zoom-string (week "2007" "February" "2") "2007.February.Week2")
 603     (planner-zoom-string (day 2007 2 2) "2007.02.02")
 604     (planner-zoom-string (day "2007" "2" "2") "2007.02.02")
 605
 606     (planner-zoom-contains ("2006.Year" 732311) nil)
 607     (planner-zoom-contains ("2006.Year" 732312) t)
 608     (planner-zoom-contains ("2006.Year" 732463) t)
 609     (planner-zoom-contains ("2006.Year" 732676) t)
 610     (planner-zoom-contains ("2006.Year" 732677) nil)
 611
 612     (planner-zoom-year-beg ("2006.Year") 732312)
 613     (planner-zoom-quarter-beg ("2006.Quarter1") 732312)
 614     (planner-zoom-quarter-beg ("2006.Quarter2") 732402)
 615     (planner-zoom-quarter-beg ("2006.Quarter3") 732493)
 616     (planner-zoom-quarter-beg ("2006.Quarter4") 732585)
 617     (planner-zoom-month-beg ("2006.January") 732312)
 618     (planner-zoom-week-beg ("2006.January.Week1") 732313)
 619     (planner-zoom-week-beg ("2006.January.Week2") 732320)
 620     (planner-zoom-week-beg ("2006.January.Week3") 732327)
 621     (planner-zoom-week-beg ("2006.January.Week4") 732334)
 622     (planner-zoom-week-beg ("2006.January.Week5") 732341)
 623     (planner-zoom-week-beg ("2006.January.Week6") 732348)
 624     (planner-zoom-day-beg ("2006.02.03") 732345)
 625
 626     (planner-zoom-year-end ("2006.Year") 732676)
 627     (planner-zoom-quarter-end ("2006.Quarter1") 732401)
 628     (planner-zoom-quarter-end ("2006.Quarter2") 732492)
 629     (planner-zoom-quarter-end ("2006.Quarter3") 732584)
 630     (planner-zoom-quarter-end ("2006.Quarter4") 732676)
 631     (planner-zoom-month-end ("2006.January") 732342)
 632     (planner-zoom-week-end ("2006.January.Week1") 732319)
 633     (planner-zoom-week-end ("2006.January.Week2") 732326)
 634     (planner-zoom-week-end ("2006.January.Week3") 732333)
 635     (planner-zoom-week-end ("2006.January.Week4") 732340)
 636     (planner-zoom-week-end ("2006.January.Week5") 732347)
 637     (planner-zoom-week-end ("2006.January.Week6") 732354)
 638     (planner-zoom-day-end ("2006.01.01")  732312)
 639
 640     (planner-zoom-next-year ("2006.Year" 2) "2008.Year")
 641     (planner-zoom-next-year ("2006.Year" -2) "2004.Year")
 642     (planner-zoom-next-year ("2006.Year" 0) "2006.Year")
 643     (planner-zoom-next-quarter ("2006.Quarter2" 5) "2007.Quarter3")
 644     (planner-zoom-next-quarter ("2006.Quarter2" -5) "2005.Quarter1")
 645     (planner-zoom-next-quarter ("2006.Quarter2" 0) "2006.Quarter2")
 646     (planner-zoom-next-month ("2006.June" 13) "2007.July")
 647     (planner-zoom-next-month ("2006.June" -13) "2005.May")
 648     (planner-zoom-next-month ("2006.June" 0) "2006.June")
 649     (planner-zoom-next-week ("2006.April.Week2" 3) "2006.May.Week1")
 650     (planner-zoom-next-week ("2006.April.Week2" -2) "2006.March.Week4")
 651     (planner-zoom-next-week ("2006.April.Week2" 0) "2006.April.Week2")
 652     (planner-zoom-next-day ("2006.04.03" -7) "2006.03.27")
 653     (planner-zoom-next-day ("2006.04.03" -1) "2006.04.02")
 654     (planner-zoom-next-day ("2006.04.03" 0) "2006.04.03")
 655     (planner-zoom-next-day ("2006.04.03" 1) "2006.04.04")
 656     (planner-zoom-next-day ("2006.04.03" 28) "2006.05.01")
 657
 658     (planner-zoom-up-quarter ("2006.Quarter1") "2006.Year")
 659     (planner-zoom-up-month ("2006.April") "2006.Quarter2")
 660     (planner-zoom-up-week ("2006.April.Week1") "2006.April")
 661     (planner-zoom-up-day ("2006.04.10") "2006.April.Week2")
 662
 663     ;(calendar-absolute-from-gregorian (4 30 2006) 732431)
 664     ;(calendar-absolute-from-gregorian (4 30 2005) 732066)
 665
 666     ;; April 30th, 2006: Should zoom down to Q2, Month 4, Week 4, day 4.30.2006
 667     (planner-zoom-down-year ("2006.Year" 732431) "2006.Quarter2")
 668     (planner-zoom-down-quarter ("2006.Quarter2" 732431) "2006.April")
 669     (planner-zoom-down-month ("2006.April" 732431) "2006.April.Week4")
 670     (planner-zoom-down-week ("2006.April.Week4" 732431) "2006.04.30")
 671
 672     ;; April 30th, 2005: Should zoom down to Q1, January, Week 1, 1.1.2006
 673     (planner-zoom-down-year ("2006.Year" 732066) "2006.Quarter1")
 674     (planner-zoom-down-quarter ("2006.Quarter1" 732066) "2006.January")
 675     (planner-zoom-down-month ("2006.January" 732066) "2006.January.Week1")
 676     (planner-zoom-down-week ("2006.January.Week1" 732066) "2006.01.02"))
 677   "A list of lists of the form (function-name function-arguments
 678 desired-result) which is used to test the functions in the zoom
 679 package.")
 680
 681 (defun planner-zoom-test ()
 682   "Run all the tests in planner-zoom-tests."
 683   (dolist (test planner-zoom-tests)
 684     (let* ((fn (first test))
 685            (fn-args (second test))
 686            (desired-result (third test))
 687            (result (apply fn fn-args)))
 688       (when (not (equal desired-result result))
 689         (error "Failed test!"))))
 690   t)
 691
 692 (defun gsn/calendar-today-gregorian ()
 693   (multiple-value-bind (junk junk junk day month year) (decode-time)
 694     (list month day year)))
 695
 696 (defun gsn/calendar-today-absolute ()
 697   (calendar-absolute-from-gregorian (gsn/calendar-today-gregorian)))
 698
 699 (provide 'planner-zoom)
 700
 701 ;;; planner-zoom.el ends here