lisp/calendar/cal-menu.el

   1 ;;; cal-menu.el --- calendar functions for menu bar and popup menu support
   2
   3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
   4
   5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   6 ;;      Lara Rios <lrios@coewl.cen.uiuc.edu>
   7 ;; Keywords: calendar
   8 ;; Human-Keywords: calendar, popup menus, menu bar
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY.  No author or distributor
  14 ;; accepts responsibility to anyone for the consequences of using it
  15 ;; or for whether it serves any particular purpose or works at all,
  16 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  17 ;; License for full details.
  18
  19 ;; Everyone is granted permission to copy, modify and redistribute
  20 ;; GNU Emacs, but only under the conditions described in the
  21 ;; GNU Emacs General Public License.   A copy of this license is
  22 ;; supposed to have been given to you along with GNU Emacs so you
  23 ;; can know your rights and responsibilities.  It should be in a
  24 ;; file named COPYING.  Among other things, the copyright notice
  25 ;; and this notice must be preserved on all copies.
  26
  27 ;;; Commentary:
  28
  29 ;; This collection of functions implements menu bar and popup menu support for
  30 ;; calendar.el.
  31
  32 ;; Comments, corrections, and improvements should be sent to
  33 ;;  Edward M. Reingold               Department of Computer Science
  34 ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  35 ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  36 ;;                                   Urbana, Illinois 61801
  37
  38 ;;; Code:
  39
  40 (define-key calendar-mode-map [down-mouse-2] 'calendar-mouse-date-menu)
  41
  42 (define-key calendar-mode-map [menu-bar moon]
  43   '("Moon" . calendar-phases-of-moon))
  44
  45 (define-key calendar-mode-map [menu-bar diary]
  46   (cons "Diary" (make-sparse-keymap "Diary")))
  47
  48 (define-key calendar-mode-map [menu-bar diary heb]
  49   '("Insert Hebrew" . calendar-mouse-insert-hebrew-diary-entry))
  50 (define-key calendar-mode-map [menu-bar diary isl]
  51   '("Insert Islamic" . calendar-mouse-insert-islamic-diary-entry))
  52 (define-key calendar-mode-map [menu-bar diary cyc]
  53   '("Insert cyclic" . insert-cyclic-diary-entry))
  54 (define-key calendar-mode-map [menu-bar diary blk]
  55   '("Insert block" . insert-block-diary-entry))
  56 (define-key calendar-mode-map [menu-bar diary ann]
  57   '("Insert anniversary" . insert-anniversary-diary-entry))
  58 (define-key calendar-mode-map [menu-bar diary yr]
  59   '("Insert yearly" . insert-yearly-diary-entry))
  60 (define-key calendar-mode-map [menu-bar diary mon]
  61   '("Insert monthly" . insert-monthly-diary-entry))
  62 (define-key calendar-mode-map [menu-bar diary wk]
  63   '("Insert weekly" . insert-weekly-diary-entry))
  64 (define-key calendar-mode-map [menu-bar diary ent]
  65   '("Insert daily". insert-diary-entry))
  66 (define-key calendar-mode-map [menu-bar diary all]
  67   '("Show all" . show-all-diary-entries))
  68 (define-key calendar-mode-map [menu-bar diary mark]
  69  '("Mark all" . mark-diary-entries))
  70 (define-key calendar-mode-map [menu-bar diary view]
  71   '("Cursor date" . view-diary-entries))
  72
  73 (define-key calendar-mode-map [menu-bar holidays]
  74   (cons "Holidays" (make-sparse-keymap "Holidays")))
  75
  76 (define-key calendar-mode-map [menu-bar holidays unmark]
  77   '("Unmark" . calendar-unmark))
  78 (define-key calendar-mode-map [menu-bar holidays mark]
  79   '("Mark" . mark-calendar-holidays))
  80 (define-key calendar-mode-map [menu-bar holidays 3-mon]
  81   '("3 months" . list-calendar-holidays))
  82 (define-key calendar-mode-map [menu-bar holidays 1-day]
  83   '("One day" . calendar-cursor-holidays))
  84
  85 (define-key calendar-mode-map [menu-bar goto]
  86   (cons "Goto" (make-sparse-keymap "Goto")))
  87
  88 (define-key calendar-mode-map [menu-bar goto french]
  89   '("French date" . calendar-goto-french-date))
  90 (define-key calendar-mode-map [menu-bar goto mayan]
  91   (cons "Mayan date" (make-sparse-keymap "Mayan")))
  92 (define-key calendar-mode-map [menu-bar goto julian]
  93   '("Julian date" . calendar-goto-julian-date))
  94 (define-key calendar-mode-map [menu-bar goto islamic]
  95   '("Islamic date" . calendar-goto-islamic-date))
  96 (define-key calendar-mode-map [menu-bar goto hebrew]
  97   '("Hebrew date" . calendar-goto-hebrew-date))
  98 (define-key calendar-mode-map [menu-bar goto astro]
  99   '("Astronomical date" . calendar-goto-astro-date))
 100 (define-key calendar-mode-map [menu-bar goto iso]
 101   '("ISO date" . calendar-goto-iso-date))
 102 (define-key calendar-mode-map [menu-bar goto gregorian]
 103   '("Other date" . calendar-goto-date))
 104 (define-key calendar-mode-map [menu-bar goto end-of-year]
 105   '("End of year" . calendar-end-of-year))
 106 (define-key calendar-mode-map [menu-bar goto beginning-of-year]
 107   '("Beginning of year" . calendar-beginning-of-year))
 108 (define-key calendar-mode-map [menu-bar goto end-of-month]
 109   '("End of month" . calendar-end-of-month))
 110 (define-key calendar-mode-map [menu-bar goto beginning-of-month]
 111   '("Beginning of month" . calendar-beginning-of-month))
 112 (define-key calendar-mode-map [menu-bar goto end-of-week]
 113   '("End of week" . calendar-end-of-week))
 114 (define-key calendar-mode-map [menu-bar goto beginning-of-week]
 115   '("Beginning of week" . calendar-beginning-of-week))
 116 (define-key calendar-mode-map [menu-bar goto today]
 117   '("Today" . calendar-current-month))
 118
 119
 120 (define-key calendar-mode-map [menu-bar goto mayan prev-rnd]
 121   '("Previous Round" . calendar-previous-calendar-round-date))
 122 (define-key calendar-mode-map [menu-bar goto mayan nxt-rnd]
 123   '("Next Round" . calendar-next-calendar-round-date))
 124 (define-key calendar-mode-map [menu-bar goto mayan prev-haab]
 125   '("Previous Haab" . calendar-previous-haab-date))
 126 (define-key calendar-mode-map [menu-bar goto mayan next-haab]
 127   '("Next Haab" . calendar-next-haab-date))
 128 (define-key calendar-mode-map [menu-bar goto mayan prev-tzol]
 129   '("Previous Tzolkin" . calendar-previous-tzolkin-date))
 130 (define-key calendar-mode-map [menu-bar goto mayan next-tzol]
 131   '("Next Tzolkin" . calendar-next-tzolkin-date))
 132
 133 (define-key calendar-mode-map [menu-bar scroll]
 134   (cons "Scroll" (make-sparse-keymap "Scroll")))
 135
 136 (define-key calendar-mode-map [menu-bar scroll bk-12]
 137   '("Backward 1 Year" . "4\ev"))
 138 (define-key calendar-mode-map [menu-bar scroll bk-3]
 139   '("Backward 3 Months" . scroll-calendar-right-three-months))
 140 (define-key calendar-mode-map [menu-bar scroll bk-1]
 141   '("Backward 1 Month" . scroll-calendar-right))
 142 (define-key calendar-mode-map [menu-bar scroll fwd-12]
 143   '("Forward 1 Year" . "4\C-v"))
 144 (define-key calendar-mode-map [menu-bar scroll fwd-3]
 145   '("Forward 3 Months" . scroll-calendar-left-three-months))
 146 (define-key calendar-mode-map [menu-bar scroll fwd-1]
 147   '("Forward 1 Month" . scroll-calendar-left))
 148
 149 (put 'calendar-forward-day 'menu-enable '(calendar-cursor-to-date))
 150 (put 'calendar-backward-day 'menu-enable '(calendar-cursor-to-date))
 151 (put 'calendar-forward-week 'menu-enable '(calendar-cursor-to-date))
 152 (put 'calendar-backward-week 'menu-enable '(calendar-cursor-to-date))
 153 (put 'calendar-forward-month 'menu-enable '(calendar-cursor-to-date))
 154 (put 'calendar-backward-month 'menu-enable '(calendar-cursor-to-date))
 155 (put 'calendar-forward-year 'menu-enable '(calendar-cursor-to-date))
 156 (put 'calendar-backward-year 'menu-enable '(calendar-cursor-to-date))
 157 (put 'calendar-beginning-of-year 'menu-enable '(calendar-cursor-to-date))
 158 (put 'calendar-end-of-year 'menu-enable '(calendar-cursor-to-date))
 159 (put 'calendar-beginning-of-month 'menu-enable '(calendar-cursor-to-date))
 160 (put 'calendar-end-of-month 'menu-enable '(calendar-cursor-to-date))
 161 (put 'calendar-end-of-week 'menu-enable '(calendar-cursor-to-date))
 162 (put 'calendar-beginning-of-week 'menu-enable '(calendar-cursor-to-date))
 163 (put 'calendar-mouse-print-dates 'menu-enable '(calendar-event-to-date))
 164 (put 'calendar-sunrise-sunset 'menu-enable '(calendar-event-to-date))
 165 (put 'calendar-cursor-holidays 'menu-enable '(calendar-cursor-to-date))
 166 (put 'view-diary-entries 'menu-enable '(calendar-cursor-to-date))
 167 (put 'calendar-mouse-insert-hebrew-diary-entry
 168      'menu-enable
 169      '(calendar-cursor-to-date))
 170 (put 'calendar-mouse-insert-islamic-diary-entry
 171      'menu-enable
 172      '(calendar-cursor-to-date))
 173 (put 'insert-cyclic-diary-entry 'menu-enable '(calendar-cursor-to-date))
 174 (put 'insert-block-diary-entry 'menu-enable '(calendar-cursor-to-date))
 175 (put 'insert-anniversary-diary-entry 'menu-enable '(calendar-cursor-to-date))
 176 (put 'insert-yearly-diary-entry 'menu-enable '(calendar-cursor-to-date))
 177 (put 'insert-monthly-diary-entry 'menu-enable '(calendar-cursor-to-date))
 178 (put 'insert-weekly-diary-entry 'menu-enable '(calendar-cursor-to-date))
 179
 180 (defun calendar-event-to-date ()
 181   "Date of last event. Nil if last event was not done on a date."
 182   (save-excursion
 183     (goto-char (posn-point (event-start last-input-event)))
 184     (calendar-cursor-to-date)))
 185
 186 (defun calendar-mouse-insert-hebrew-diary-entry (event)
 187   "Pop up menu to insert a Hebrew-date diary entry."
 188   (interactive "e")
 189   (let ((hebrew-selection
 190          (x-popup-menu
 191           event
 192           (list "Hebrew insert menu"
 193                 (list (calendar-hebrew-date-string (calendar-cursor-to-date))
 194                       '("One time" . insert-hebrew-diary-entry)
 195                       '("Monthly" . insert-monthly-hebrew-diary-entry)
 196                       '("Yearly" . insert-yearly-hebrew-diary-entry))))))
 197     (and hebrew-selection (call-interactively hebrew-selection))))
 198
 199 (defun calendar-mouse-insert-islamic-diary-entry (event)
 200   "Pop up menu to insert an Islamic-date diary entry."
 201   (interactive "e")
 202   (let ((islamic-selection
 203          (x-popup-menu
 204           event
 205           (list "Islamic insert menu"
 206                 (list (calendar-islamic-date-string (calendar-cursor-to-date))
 207                       '("One time" . insert-islamic-diary-entry)
 208                       '("Monthly" . insert-monthly-islamic-diary-entry)
 209                       '("Yearly" . insert-yearly-islamic-diary-entry))))))
 210     (and islamic-selection (call-interactively islamic-selection))))
 211
 212 (defun calendar-mouse-sunrise/sunset ()
 213   "Show sunrise/sunset times for mouse-selected date."
 214   (interactive)
 215   (save-excursion
 216     (calendar-goto-date (calendar-event-to-date))
 217     (calendar-sunrise-sunset)))
 218
 219 (defun calendar-mouse-holidays ()
 220   "Show holidays for mouse-selected date."
 221   (interactive)
 222   (save-excursion
 223     (calendar-goto-date (calendar-event-to-date))
 224     (calendar-cursor-holidays)))
 225
 226 (defun calendar-mouse-view-diary-entries ()
 227   "View diary entries on mouse-selected date."
 228   (interactive)
 229   (save-excursion
 230     (calendar-goto-date (calendar-event-to-date))
 231     (view-diary-entries 1)))
 232
 233 (defun calendar-mouse-print-dates ()
 234   "Pop up menu of equivalent dates to mouse selected date."
 235   (interactive)
 236   (let ((date (calendar-event-to-date)))
 237     (x-popup-menu
 238      event
 239      (list
 240       "Date Menu"
 241       (append
 242        (list
 243         (concat (calendar-date-string date) " (Gregorian)")
 244         (list (calendar-iso-date-string date))
 245         (list (format "ISO date: %s" (calendar-iso-date-string date)))
 246         (list (format "Julian date: %s" (calendar-julian-date-string date)))
 247         (list (format "Astronomical (Julian) date (before noon): %s"
 248                       (calendar-astro-date-string date)))
 249         (list (format "Hebrew date (before sunset): %s"
 250                       (calendar-hebrew-date-string date))))
 251        (let ((i (calendar-islamic-date-string date)))
 252          (if (not (string-equal i ""))
 253              (list (format "Islamic date (before sunset): %s" i))))
 254        (let ((f (calendar-french-date-string date)))
 255          (if (not (string-equal f ""))
 256              (list (format "French Revolutionary date: %s" f))))
 257        (list
 258          (format "Mayan date: %s" (calendar-mayan-date-string date))))))))
 259
 260 (defun calendar-mouse-date-menu (event)
 261   "Pop up menu for selected date."
 262   (interactive "e")
 263   (let ((selection
 264          (x-popup-menu
 265           event
 266           (if (calendar-event-to-date)
 267               (list "Menu"
 268                      (list
 269                       (calendar-date-string
 270                        (or (calendar-event-to-date)
 271                            (error "Mouse is not on a date!"))
 272                        t t)
 273                       '("Diary entries" . calendar-mouse-view-diary-entries)
 274                       '("Holidays" . calendar-mouse-holidays)
 275                       '("Mark date" . calendar-set-mark)
 276                       '("Sunrise/sunset" . calendar-mouse-sunrise/sunset)
 277                       '("Other calendars" . calendar-mouse-print-dates)))
 278             (list "Menu"
 279                    (list
 280                     (let ((m1 displayed-month)
 281                           (y1 displayed-year)
 282                           (m2 displayed-month)
 283                           (y2 displayed-year))
 284                       (increment-calendar-month m1 y1 -1)
 285                       (increment-calendar-month m2 y2 1)
 286                       (if (= y1 y2)
 287                           (format "%s--%s, %d"
 288                               (substring (calendar-month-name m1) 0 3)
 289                               (substring (calendar-month-name m2) 0 3) y2)
 290                         (format "%s, %d--%s, %d"
 291                                 (substring (calendar-month-name m1) 0 3) y1
 292                                 (substring (calendar-month-name m2) 0 3) y2)))
 293                      '("Scroll forward" . scroll-calendar-left-three-months)
 294                      '("Scroll backward" . scroll-calendar-right-three-months)
 295                      '("Show diary" . show-all-diary-entries)
 296                      '("Mark diary entries" . mark-diary-entries)
 297                      '("List holidays" . list-calendar-holidays)
 298                      '("Mark holidays" . mark-calendar-holidays)
 299                      '("Unmark" . calendar-unmark)
 300                      '("Lunar phases" . calendar-phases-of-moon)
 301                      '("Exit calendar" . exit-calendar)))))))
 302     (and selection (call-interactively selection))))
 303
 304 (run-hooks 'cal-menu-load-hook)
 305
 306 (provide 'cal-menu)
 307
 308 ;;; cal-menu.el ends here