cal-menu.el 18.1 KB
Newer Older
Richard M. Stallman's avatar
Richard M. Stallman committed
1 2
;;; cal-menu.el --- calendar functions for menu bar and popup menu support

Glenn Morris's avatar
Glenn Morris committed
3
;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007
Glenn Morris's avatar
Glenn Morris committed
4
;;   Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
5 6 7

;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;;	Lara Rios <lrios@coewl.cen.uiuc.edu>
8
;; Maintainer: Glenn Morris <rgm@gnu.org>
Richard M. Stallman's avatar
Richard M. Stallman committed
9 10 11 12 13
;; Keywords: calendar
;; Human-Keywords: calendar, popup menus, menu bar

;; This file is part of GNU Emacs.

14 15
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
16
;; the Free Software Foundation; either version 3, or (at your option)
17 18
;; any later version.

Richard M. Stallman's avatar
Richard M. Stallman committed
19
;; GNU Emacs is distributed in the hope that it will be useful,
20 21 22 23 24
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
Erik Naggum's avatar
Erik Naggum committed
25
;; along with GNU Emacs; see the file COPYING.  If not, write to the
Lute Kamstra's avatar
Lute Kamstra committed
26 27
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
Richard M. Stallman's avatar
Richard M. Stallman committed
28 29 30 31 32 33 34 35

;;; Commentary:

;; This collection of functions implements menu bar and popup menu support for
;; calendar.el.

;;; Code:

36 37
(defvar displayed-year)

38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
(defconst cal-menu-moon-menu
  '("Moon"
    ["Lunar Phases" calendar-phases-of-moon]))

(defconst cal-menu-diary-menu
  '("Diary"
    ["Other File" view-other-diary-entries]
    ["Cursor Date" diary-view-entries]
    ["Mark All" mark-diary-entries]
    ["Show All" diary-show-all-entries]
    ["Insert Diary Entry" insert-diary-entry]
    ["Insert Weekly" insert-weekly-diary-entry]
    ["Insert Monthly" insert-monthly-diary-entry]
    ["Insert Yearly" insert-yearly-diary-entry]
    ["Insert Anniversary" insert-anniversary-diary-entry]
    ["Insert Block" insert-block-diary-entry]
    ["Insert Cyclic" insert-cyclic-diary-entry]
    ("Insert Baha'i"
     [" " nil :suffix (calendar-bahai-date-string (calendar-cursor-to-date))]
57 58 59
     ["One time" diary-bahai-insert-entry]
     ["Monthly" diary-bahai-insert-monthly-entry]
     ["Yearly" diary-bahai-insert-yearly-entry])
60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89
    ("Insert Islamic"
     [" " nil :suffix (calendar-islamic-date-string (calendar-cursor-to-date))]
     ["One time" insert-islamic-diary-entry]
     ["Monthly" insert-monthly-islamic-diary-entry]
     ["Yearly" insert-yearly-islamic-diary-entry])
    ("Insert Hebrew"
     [" " nil :suffix (calendar-hebrew-date-string (calendar-cursor-to-date))]
     ["One time" insert-hebrew-diary-entry]
     ["Monthly" insert-monthly-hebrew-diary-entry]
     ["Yearly" insert-yearly-hebrew-diary-entry])))

(defun cal-menu-holiday-window-suffix ()
  (let ((my1 (calendar-increment-month -1))
        (my2 (calendar-increment-month 1)))
    (if (= (cdr my1) (cdr my2))
        (format "%s-%s, %d"
                (calendar-month-name (car my1) 'abbrev)
                (calendar-month-name (car my2) 'abbrev)
                (cdr my2))
      (format "%s, %d-%s, %d"
              (calendar-month-name (car my1) 'abbrev)
              (cdr my1)
              (calendar-month-name (car my2) 'abbrev)
              (cdr my2)))))

(defconst cal-menu-holidays-menu
  `("Holidays"
    ["For Cursor Date -" calendar-cursor-holidays
     :suffix (calendar-date-string (calendar-cursor-to-date) t t)
     :visible (calendar-cursor-to-date)]
90
    ["For Window -" calendar-list-holidays
91 92 93 94 95 96
     :suffix (cal-menu-holiday-window-suffix)]
    ["For Today -" cal-menu-today-holidays
     :suffix (calendar-date-string (calendar-current-date) t t)]
    "--"
    ,@(let ((l ()))
        ;; Show 11 years--5 before, 5 after year of middle month.
97
        ;; http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01813.html
98
        (dotimes (i 11)
99
          (push (vector (format "hol-year-%d" i)
100 101 102 103
                        `(lambda ()
                           (interactive)
                           (holiday-list (+ displayed-year ,(- i 5))
                                         (+ displayed-year ,(- i 5))))
104 105
                        :label `(format "For Year %d"
                                       (+ displayed-year ,(- i 5))))
106
                l))
107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
        (nreverse l))
    "--"
    ["Unmark Calendar" calendar-unmark]
    ["Mark Holidays" mark-calendar-holidays]))

(defconst cal-menu-goto-menu
  '("Goto"
    ["Today" calendar-goto-today]
    ["Beginning of Week" calendar-beginning-of-week]
    ["End of Week" calendar-end-of-week]
    ["Beginning of Month" calendar-beginning-of-month]
    ["End of Month" calendar-end-of-month]
    ["Beginning of Year" calendar-beginning-of-year]
    ["End of Year" calendar-end-of-year]
    ["Other Date" calendar-goto-date]
    ["Day of Year" calendar-goto-day-of-year]
    ["ISO Week" calendar-goto-iso-week]
    ["ISO Date" calendar-goto-iso-date]
    ["Astronomical Date" calendar-goto-astro-day-number]
    ["Hebrew Date" calendar-goto-hebrew-date]
    ["Persian Date" calendar-goto-persian-date]
128
    ["Baha'i Date" calendar-bahai-goto-date]
129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
    ["Islamic Date" calendar-goto-islamic-date]
    ["Julian Date" calendar-goto-julian-date]
    ["Chinese Date" calendar-goto-chinese-date]
    ["Coptic Date" calendar-goto-coptic-date]
    ["Ethiopic Date" calendar-goto-ethiopic-date]
    ("Mayan Date"
     ["Next Tzolkin" calendar-next-tzolkin-date]
     ["Previous Tzolkin" calendar-previous-tzolkin-date]
     ["Next Haab" calendar-next-haab-date]
     ["Previous Haab" calendar-previous-haab-date]
     ["Next Round" calendar-next-calendar-round-date]
     ["Previous Round" calendar-previous-calendar-round-date])
    ["French Date" calendar-goto-french-date]))

(defconst cal-menu-scroll-menu
  '("Scroll"
145 146
    ["Forward 1 Month" calendar-scroll-left]
    ["Forward 3 Months" calendar-scroll-left-three-months]
147
    ["Forward 1 Year" "4\C-v"]
148 149
    ["Backward 1 Month" calendar-scroll-right]
    ["Backward 3 Months" calendar-scroll-right-three-months]
150
    ["Backward 1 Year" "4\ev"]))
151

152 153 154 155 156
(defun cal-menu-x-popup-menu (position menu)
  "Like `x-popup-menu', but prints an error message if popup menus are
not available."
  (if (display-popup-menus-p)
      (x-popup-menu position menu)
157
    (error "Popup menus are not available on this system")))
158

159 160 161 162
(defun cal-menu-list-holidays-year ()
  "Display a list of the holidays of the selected date's year."
  (interactive)
  (let ((year (extract-calendar-year (calendar-cursor-to-date))))
163
    (holiday-list year year)))
164 165 166 167 168

(defun cal-menu-list-holidays-following-year ()
  "Display a list of the holidays of the following year."
  (interactive)
  (let ((year (1+ (extract-calendar-year (calendar-cursor-to-date)))))
169
    (holiday-list year year)))
170 171 172 173 174

(defun cal-menu-list-holidays-previous-year ()
  "Display a list of the holidays of the previous year."
  (interactive)
  (let ((year (1- (extract-calendar-year (calendar-cursor-to-date)))))
175
    (holiday-list year year)))
176

177 178 179 180
(defun calendar-event-to-date (&optional error)
  "Date of last event.
If event is not on a specific date, signals an error if optional parameter
ERROR is t, otherwise just returns nil."
181 182
  (with-current-buffer
      (window-buffer (posn-window (event-start last-input-event)))
Richard M. Stallman's avatar
Richard M. Stallman committed
183
    (goto-char (posn-point (event-start last-input-event)))
184
    (calendar-cursor-to-date error)))
Richard M. Stallman's avatar
Richard M. Stallman committed
185 186 187 188 189

(defun calendar-mouse-sunrise/sunset ()
  "Show sunrise/sunset times for mouse-selected date."
  (interactive)
  (save-excursion
190
    (calendar-mouse-goto-date (calendar-event-to-date))
Richard M. Stallman's avatar
Richard M. Stallman committed
191 192
    (calendar-sunrise-sunset)))

193 194 195 196 197 198 199
(defun cal-menu-today-holidays ()
  "Show holidays for today's date."
  (interactive)
  (save-excursion
    (calendar-cursor-to-date (calendar-current-date))
    (calendar-cursor-holidays)))

200
(autoload 'calendar-check-holidays "holidays")
201 202
(autoload 'diary-list-entries "diary-lib")

203
(defun calendar-mouse-holidays (&optional event)
204
  "Pop up menu of holidays for mouse selected date."
205
  (interactive "e")
206
  (let* ((date (calendar-event-to-date))
207
         (l (mapcar 'list (calendar-check-holidays date)))
208
         (selection
209
          (cal-menu-x-popup-menu
210 211 212 213 214 215 216
           event
           (list
            (format "Holidays for %s" (calendar-date-string date))
            (append
             (list (format "Holidays for %s" (calendar-date-string date)))
             (if l l '("None")))))))
    (and selection (call-interactively selection))))
Richard M. Stallman's avatar
Richard M. Stallman committed
217

218
(defun calendar-mouse-view-diary-entries (&optional date diary event)
219 220 221 222
  "Pop up menu of diary entries for mouse-selected date.
Use optional DATE and alternative file DIARY.

Any holidays are shown if `holidays-in-diary-buffer' is t."
223
  (interactive "i\ni\ne")
224
  (let* ((date (or date (calendar-event-to-date)))
225 226 227 228
         (diary-file (if diary diary diary-file))
         (diary-list-include-blanks nil)
         (diary-display-hook 'ignore)
         (diary-entries
229
          (mapcar (lambda (x) (split-string (cadr x) "\n"))
230
                  (diary-list-entries date 1 'list-only)))
231
         (holidays (if holidays-in-diary-buffer
232
                       (calendar-check-holidays date)))
233 234 235 236
         (title (concat "Diary entries "
                        (if diary (format "from %s " diary) "")
                        "for "
                        (calendar-date-string date)))
237
         (selection
238
          (cal-menu-x-popup-menu
239
           event
240 241 242
           (list title
                 (append
                  (list title)
243
                  (mapcar (lambda (x) (list (concat "     " x))) holidays)
244 245 246
                  (if holidays
                      (list "--shadow-etched-in" "--shadow-etched-in"))
                  (if diary-entries
247
                      (mapcar 'list (apply 'append diary-entries))
248
                    '("None")))))))
249
    (and selection (call-interactively selection))))
Richard M. Stallman's avatar
Richard M. Stallman committed
250

251
(defun calendar-mouse-view-other-diary-entries ()
252
  "Pop up menu of diary entries from alternative file on mouse-selected date."
253
  (interactive)
254 255 256
  (calendar-mouse-view-diary-entries
   (calendar-event-to-date)
   (read-file-name "Enter diary file name: " default-directory nil t)))
257

258 259 260 261
(defun calendar-mouse-insert-diary-entry ()
  "Insert diary entry for mouse-selected date."
  (interactive)
  (save-excursion
262
    (calendar-mouse-goto-date (calendar-event-to-date))
263 264
    (insert-diary-entry nil)))

265 266 267 268
(defun calendar-mouse-set-mark ()
  "Mark the date under the cursor."
  (interactive)
  (save-excursion
269
    (calendar-mouse-goto-date (calendar-event-to-date))
270 271
    (calendar-set-mark nil)))

272 273 274 275
(defun cal-tex-mouse-day ()
  "Make a buffer with LaTeX commands for the day mouse is on."
  (interactive)
  (save-excursion
276
    (calendar-mouse-goto-date (calendar-event-to-date))
277 278 279 280 281 282 283
    (cal-tex-cursor-day nil)))

(defun cal-tex-mouse-week ()
  "One page calendar for week indicated by cursor.
Holidays are included if `cal-tex-holidays' is t."
  (interactive)
  (save-excursion
284
    (calendar-mouse-goto-date (calendar-event-to-date))
285 286 287 288 289 290 291
    (cal-tex-cursor-week nil)))

(defun cal-tex-mouse-week2 ()
  "Make a buffer with LaTeX commands for the week cursor is on.
The printed output will be on two pages."
  (interactive)
  (save-excursion
292
    (calendar-mouse-goto-date (calendar-event-to-date))
293 294
    (cal-tex-cursor-week2 nil)))

295
(defun cal-tex-mouse-week-iso ()
296 297 298 299
  "One page calendar for week indicated by cursor.
Holidays are included if `cal-tex-holidays' is t."
  (interactive)
  (save-excursion
300
    (calendar-mouse-goto-date (calendar-event-to-date))
301
    (cal-tex-cursor-week-iso nil)))
302

303
(defun cal-tex-mouse-week-monday ()
304 305 306
  "One page calendar for week indicated by cursor."
  (interactive)
  (save-excursion
307
    (calendar-mouse-goto-date (calendar-event-to-date))
308
    (cal-tex-cursor-week-monday nil)))
309

310 311 312 313 314 315 316
(defun cal-tex-mouse-filofax-daily ()
  "Day-per-page Filofax calendar for week indicated by cursor."
  (interactive)
  (save-excursion
    (calendar-mouse-goto-date (calendar-event-to-date))
    (cal-tex-cursor-filofax-daily nil)))

317
(defun cal-tex-mouse-filofax-2week ()
318 319 320
  "One page Filofax calendar for week indicated by cursor."
  (interactive)
  (save-excursion
321
    (calendar-mouse-goto-date (calendar-event-to-date))
322
    (cal-tex-cursor-filofax-2week nil)))
323

324
(defun cal-tex-mouse-filofax-week ()
325 326 327
  "Two page Filofax calendar for week indicated by cursor."
  (interactive)
  (save-excursion
328
    (calendar-mouse-goto-date (calendar-event-to-date))
329
    (cal-tex-cursor-filofax-week nil)))
330 331 332 333 334 335

(defun cal-tex-mouse-month ()
  "Make a buffer with LaTeX commands for the month cursor is on.
Calendar is condensed onto one page."
  (interactive)
  (save-excursion
336
    (calendar-mouse-goto-date (calendar-event-to-date))
337 338 339 340 341 342 343
    (cal-tex-cursor-month nil)))

(defun cal-tex-mouse-month-landscape ()
  "Make a buffer with LaTeX commands for the month cursor is on.
The output is in landscape format, one month to a page."
  (interactive)
  (save-excursion
344
    (calendar-mouse-goto-date (calendar-event-to-date))
345 346 347 348 349 350
    (cal-tex-cursor-month-landscape nil)))

(defun cal-tex-mouse-year ()
  "Make a buffer with LaTeX commands for the year cursor is on."
  (interactive)
  (save-excursion
351
    (calendar-mouse-goto-date (calendar-event-to-date))
352 353 354 355 356 357
    (cal-tex-cursor-year nil)))

(defun cal-tex-mouse-filofax-year ()
  "Make a buffer with LaTeX commands for Filofax calendar of year cursor is on."
  (interactive)
  (save-excursion
358
    (calendar-mouse-goto-date (calendar-event-to-date))
359 360 361 362 363 364
    (cal-tex-cursor-filofax-year nil)))

(defun cal-tex-mouse-year-landscape ()
  "Make a buffer with LaTeX commands for the year cursor is on."
  (interactive)
  (save-excursion
365
    (calendar-mouse-goto-date (calendar-event-to-date))
366 367
    (cal-tex-cursor-year-landscape nil)))

368
(defun calendar-mouse-print-dates (&optional event)
Richard M. Stallman's avatar
Richard M. Stallman committed
369
  "Pop up menu of equivalent dates to mouse selected date."
370 371
  (interactive "e")
  (let* ((date (calendar-event-to-date))
372
        (selection
373
         (cal-menu-x-popup-menu
374 375
          event
          (list
376
           (concat (calendar-date-string date) " (Gregorian)")
377 378 379 380 381 382 383 384
           (append
            (list
             (concat (calendar-date-string date) " (Gregorian)")
             (list (calendar-day-of-year-string date))
             (list (format "ISO date: %s" (calendar-iso-date-string date)))
             (list (format "Julian date: %s"
                           (calendar-julian-date-string date)))
             (list
Edward M. Reingold's avatar
Edward M. Reingold committed
385
              (format "Astronomical (Julian) day number (at noon UTC): %s.0"
386
                           (calendar-astro-date-string date)))
387
             (list
388
              (format "Fixed (RD) date: %s"
389
                      (calendar-absolute-from-gregorian date)))
390
             (list (format "Hebrew date (before sunset): %s"
391 392
                           (calendar-hebrew-date-string date)))
             (list (format "Persian date: %s"
393 394 395
                           (calendar-persian-date-string date)))
             (list (format "Baha'i date (before sunset): %s"
                           (calendar-bahai-date-string date))))
396 397 398
            (let ((i (calendar-islamic-date-string date)))
              (if (not (string-equal i ""))
                  (list (list (format "Islamic date (before sunset): %s" i)))))
399 400 401
            (list
             (list (format "Chinese date: %s"
                           (calendar-chinese-date-string date))))
402 403
            ;; (list '("Chinese date (select to echo Chinese date)"
            ;;         . calendar-mouse-chinese-date))
404 405 406 407 408 409 410 411 412 413 414 415 416 417 418
            (let ((c (calendar-coptic-date-string date)))
              (if (not (string-equal c ""))
                  (list (list (format "Coptic date: %s" c)))))
            (let ((e (calendar-ethiopic-date-string date)))
              (if (not (string-equal e ""))
                  (list (list (format "Ethiopic date: %s" e)))))
            (let ((f (calendar-french-date-string date)))
              (if (not (string-equal f ""))
                  (list (list (format "French Revolutionary date: %s" f)))))
            (list
             (list
              (format "Mayan date: %s"
                      (calendar-mayan-date-string date)))))))))
        (and selection (call-interactively selection))))

419 420 421 422
(defun calendar-mouse-chinese-date ()
  "Show Chinese equivalent for mouse-selected date."
  (interactive)
  (save-excursion
423
    (calendar-mouse-goto-date (calendar-event-to-date))
424
    (calendar-print-chinese-date)))
Richard M. Stallman's avatar
Richard M. Stallman committed
425

426 427 428 429
(defun calendar-mouse-goto-date (date)
  (set-buffer (window-buffer (posn-window (event-start last-input-event))))
  (calendar-goto-date date))

430
(easy-menu-define cal-menu-context-mouse-menu nil
431
  "Pop up menu for Mouse-2 for selected date in the calendar window."
432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463
  '("foo" :filter cal-menu-set-date-title
    "--"
    ["Holidays" calendar-mouse-holidays]
    ["Mark date" calendar-mouse-set-mark]
    ["Sunrise/sunset" calendar-mouse-sunrise/sunset]
    ["Other calendars" calendar-mouse-print-dates]
    ("Prepare LaTeX buffer"
     ["Daily (1 page)" cal-tex-mouse-day]
     ["Weekly (1 page)" cal-tex-mouse-week]
     ["Weekly (2 pages)" cal-tex-mouse-week2]
     ["Weekly (other style; 1 page)" cal-tex-mouse-week-iso]
     ["Weekly (yet another style; 1 page)" cal-tex-mouse-week-monday]
     ["Monthly" cal-tex-mouse-month]
     ["Monthly (landscape)" cal-tex-mouse-month-landscape]
     ["Yearly" cal-tex-mouse-year]
     ["Yearly (landscape)" cal-tex-mouse-year-landscape]
     ("Filofax styles"
      ["Filofax Daily (one-day-per-page)" cal-tex-mouse-filofax-daily]
      ["Filofax Weekly (2-weeks-at-a-glance)" cal-tex-mouse-filofax-2week]
      ["Filofax Weekly (week-at-a-glance)" cal-tex-mouse-filofax-week]
      ["Filofax Yearly" cal-tex-mouse-filofax-year]))
    ["Diary entries" calendar-mouse-view-diary-entries]
    ["Insert diary entry" calendar-mouse-insert-diary-entry]
    ["Other diary file entries" calendar-mouse-view-other-diary-entries]))

(defun cal-menu-set-date-title (menu)
  (easy-menu-filter-return
   menu (calendar-date-string (calendar-event-to-date t) t nil)))

(easy-menu-define cal-menu-global-mouse-menu nil
  "Menu bound to a mouse event, not specific to the mouse-click location."
  '("Calendar"
464 465
    ["Scroll forward" calendar-scroll-left-three-months]
    ["Scroll backward" calendar-scroll-right-three-months]
466
    ["Mark diary entries" mark-diary-entries]
467 468
    ["List holidays" calendar-list-holidays]
    ["Mark holidays" calendar-mark-holidays]
469 470 471 472
    ["Unmark" calendar-unmark]
    ["Lunar phases" calendar-phases-of-moon]
    ["Show diary" diary-show-all-entries]
    ["Exit calendar" exit-calendar]))
Richard M. Stallman's avatar
Richard M. Stallman committed
473 474 475 476 477

(run-hooks 'cal-menu-load-hook)

(provide 'cal-menu)

478
;; arch-tag: aa81cf73-ce89-48a4-97ec-9ef861e87fe9
Richard M. Stallman's avatar
Richard M. Stallman committed
479
;;; cal-menu.el ends here