Fix problem introduced by recent commit that broke using SPC as separator.
[planner-el.git] / planner-zoom.el
bloba2bfcb0c5ca4e1ca43ee2ec42619f5c3884293a7
1 ;;; planner-zoom.el --- navigate Planner pages
3 ;; Copyright (C) 2006, 2008 Gregory Novak
4 ;; Parts copyright (C) 2006, 2008 Free Software Foundation, Inc.
6 ;; Author: Gregory Novak <novak@ucolick.org>
7 ;; Date: 10-Mar-2006
9 ;; This file is part of Planner. It is not part of GNU Emacs.
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.
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.
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.
26 ;;; Commentary:
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).
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).
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)
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.
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"
64 ;;; Contributors:
66 ;;; Code:
68 (require 'planner)
70 (eval-when-compile (require 'cl))
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")
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.")
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.")
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.")
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'.
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.
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))))
140 (defun planner-zoom-parse (&rest args)
141 "Parse a string NAME, into a period of time given by `planner-zoom-regexps'.
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.
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.
152 \(planner-zoom-parse \"2006.Year\") returns (year 2006 nil nil)
153 and (planner-zoom-parse \"2006.January.Week1\") returns (week 2006 1 1)."
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))))
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.
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"))))))
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)))
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)
204 changes)))
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))
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))
220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
221 ;; Interactive
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)))
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)))
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)))
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
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)))
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
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)))
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)))
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))
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))
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))
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))
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))
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))))
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))))
373 (defun planner-zoom-up-year (name)
374 "Error: there's nothing above year in the heirarchy."
375 nil)
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))))
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)))))))
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)))
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))))
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))))))
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))))
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)))))))
446 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
447 ;; Month
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))))
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))))
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))))
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))))
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)))))))
489 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
490 ;; Week
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))))
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)))
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)))
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))))
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)))))
545 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
546 ;; Day
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))))
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))
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))))
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))))
576 (defun planner-zoom-down-day (name)
577 nil)
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"))
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))
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")
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)
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)
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)
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")
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")
663 ;(calendar-absolute-from-gregorian (4 30 2006) 732431)
664 ;(calendar-absolute-from-gregorian (4 30 2005) 732066)
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")
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.")
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!"))))
692 (defun gsn/calendar-today-gregorian ()
693 (multiple-value-bind (junk junk junk day month year) (decode-time)
694 (list month day year)))
696 (defun gsn/calendar-today-absolute ()
697 (calendar-absolute-from-gregorian (gsn/calendar-today-gregorian)))
699 (provide 'planner-zoom)
701 ;;; planner-zoom.el ends here