cgit.sxemacs.org Git - syinit/blob - 11-cal-sy.el

   1 ;; 12-cal-sy.el --- Calendar Settings   -*- Emacs-Lisp -*-
   2
   3 ;; Copyright (C) 2007 - 2013 Steve Youngs
   4
   5 ;;     Author: Steve Youngs <steve@sxemacs.org>
   6 ;; Maintainer: Steve Youngs <steve@sxemacs.org>
   7 ;;    Created: <2007-12-02>
   8 ;; Time-stamp: <Tuesday Nov 17, 2015 09:01:19 steve>
   9 ;;   Download: <http://bastard.steveyoungs.com/~steve/SXEmacs/inits/>
  10 ;;   HTMLised: <http://bastard.steveyoungs.com/~steve/SXEmacs/htmlinits/12-cal-sy.html>
  11 ;;   Git Repo: git clone http://git.sxemacs.org/syinit
  12 ;;   Keywords: init, compile
  13
  14 ;; This file is part of SYinit
  15
  16 ;; Redistribution and use in source and binary forms, with or without
  17 ;; modification, are permitted provided that the following conditions
  18 ;; are met:
  19 ;;
  20 ;; 1. Redistributions of source code must retain the above copyright
  21 ;;    notice, this list of conditions and the following disclaimer.
  22 ;;
  23 ;; 2. Redistributions in binary form must reproduce the above copyright
  24 ;;    notice, this list of conditions and the following disclaimer in the
  25 ;;    documentation and/or other materials provided with the distribution.
  26 ;;
  27 ;; 3. Neither the name of the author nor the names of any contributors
  28 ;;    may be used to endorse or promote products derived from this
  29 ;;    software without specific prior written permission.
  30 ;;
  31 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  32 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  33 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  34 ;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  35 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  36 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  37 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  38 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  39 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  40 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  41 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  42
  43 ;;; Commentary:
  44 ;;
  45 ;;   My calendar/diary settings
  46 ;;
  47
  48 ;;; Credits:
  49 ;;
  50 ;;   The HTML version of this file was created with Hrvoje Niksic's
  51 ;;   htmlize.el which is part of the XEmacs "text-modes" package.
  52 ;;
  53
  54 ;;; Todo:
  55 ;;
  56 ;;
  57
  58 ;;; Code:
  59 ;:*=======================
  60 ;:* Calendar
  61 (require 'diary-lib)
  62 ;(require 'calendar)
  63 (setq
  64  calendar-latitude -27.3
  65  calendar-longitude 153.0
  66  calendar-location-name "Brisbane"
  67  calendar-time-zone 600
  68  calendar-standard-time-zone-name "EST"
  69  cal-tex-diary t
  70 ; calendar-date-display-form ; see: "Howm Integration" below
  71 ; '((if dayname (concat dayname ", ")) day " " monthname " " year)
  72  calendar-time-display-form
  73  '(24-hours ":" minutes
  74             (if time-zone " (") time-zone (if time-zone ")"))
  75  calendar-week-start-day 1
  76  diary-file (expand-file-name "diary" user-init-directory)
  77  diary-mail-addr "steve"
  78  diary-mail-days 7
  79  european-calendar-style t
  80  mark-diary-entries-in-calendar t
  81  number-of-diary-entries 7
  82  view-diary-entries-initially t)
  83
  84 ;:*=======================
  85 ;:* Todo
  86 ;; Turning this off for a while to see if I can get used to using Howm
  87 ;; more.
  88 ;;(autoload 'todo-mode "todo-mode"
  89 ;;  "Major mode for editing TODO lists." t)
  90 ;;(autoload 'todo-show "todo-mode"
  91 ;;  "Show TODO items." t)
  92 ;;(autoload 'todo-insert-item "todo-mode"
  93 ;;  "Add TODO item." t)
  94 ;;(global-set-key "\C-ct" 'todo-show) ;; switch to TODO buffer
  95 ;;(global-set-key "\C-cn" 'todo-insert-item) ;; insert new item
  96 ;;(setq
  97 ;; todo-prefix "&%%(todo-cp)"
  98 ;; todo-file-do (expand-file-name ".todo-do" (getenv "HOME"))
  99 ;; todo-file-done (expand-file-name ".todo-done" (getenv "HOME"))
 100 ;; todo-file-top (expand-file-name ".todo-top" (getenv "HOME"))
 101 ;; todo-time-string-format "%3b, %d")
 102
 103 ;:*=======================
 104 ;:* Fancy Diary with perdy colours!
 105 (defun sy-hide-fancy-dashes ()
 106   "Hides the long lines of dashes from todo-mode in fancy diary display."
 107   (save-excursion
 108     (goto-char (point-min))
 109     (while (re-search-forward "-----" nil t)
 110       (set-extent-property
 111        (make-extent (match-beginning 0) (1+ (match-end 0)))
 112        'invisible t))))
 113
 114 (define-derived-mode fancy-diary-display-mode fundamental-mode "Diary"
 115   "Minor mode for displaying Fancy Diary entries buffer."
 116   (set (make-local-variable 'font-lock-defaults)
 117        '(fancy-diary-font-lock-keywords t))
 118   (sy-hide-fancy-dashes)
 119   (font-lock-mode)
 120   (define-key (current-local-map) "o" 'other-window)
 121   (define-key (current-local-map) [space] 'scroll-up-command)
 122   (define-key (current-local-map) [backspace] 'scroll-down-command))
 123
 124 (defadvice fancy-diary-display (after set-mode activate)
 125   "Give the Fancy Diary Entries buffer a mode of its own.
 126
 127 It has the ever-so-original name of: `fancy-diary-display-mode', adds
 128 a couple of motion keybindings, and lets you set up font lock keywords
 129 for a fontified Diary buffer."
 130   (save-excursion
 131     (set-buffer (get-buffer-create fancy-diary-buffer))
 132     (fancy-diary-display-mode)))
 133
 134 (defun fancy-diary-font-lock-keywords ()
 135   (let* ((today (regexp-opt (list (calendar-date-string (calendar-current-date)))))
 136          (keywords `(("^---\\s-\\(.*$\\)" (1 font-lock-function-name-face))
 137                      ("^.*SY:" . font-lock-keyword-face)
 138                      ("\"\\(.*\\)\"" (1 font-lock-string-face))
 139                      ("`\\(.*?\\)'" (1 font-lock-reference-face))
 140                      ("[0-9]+:[0-9]+" . font-lock-warning-face)
 141                      (,today . font-lock-warning-face)
 142                      ("\\(^.*\\)\n=" (1 font-lock-comment-face)))))
 143     keywords))
 144
 145 (defvar fancy-diary-font-lock-keywords (fancy-diary-font-lock-keywords))
 146
 147 ;:*=======================
 148 ;:* Display ISO week numbers
 149 ;;
 150 ;; I saw this code mentioned on c.e.x.  I just snarfed what I needed
 151 ;; and SXEmacserised it.
 152 (require 'cal-iso)
 153
 154 (defvar calendar-use-colours t
 155   "Tries to fontify Calendar if non-nil.")
 156
 157 (defvar calendar-week-string "WK"
 158   "String (up to three chars) used in calendar header to identify week numbers.")
 159
 160 (defun sy-generate-calendar-month (month year indent)
 161   "Produce a calendar for ISO-week, month, year on the Gregorian calendar.
 162 The calendar is inserted in the buffer starting at the line on which point
 163 is currently located, but indented INDENT spaces.  The indentation is done
 164 from the first character on the line and does not disturb the first INDENT
 165 characters on the line."
 166   (let* ((blank-days                    ; At start of month
 167           (mod
 168            (- (calendar-day-of-week (list month 1 year))
 169               calendar-week-start-day)
 170            7))
 171          (last (calendar-last-day-of-month month year)))
 172     (goto-char (point-min))
 173     (calendar-insert-indented
 174      (calendar-string-spread
 175       (list (format "%s %d" (calendar-month-name month) year)) ?  20)
 176      indent t)
 177     ;; Add colour to month name
 178     (if calendar-use-colours
 179         (set-extent-property (make-extent (point-min) (1- (point)))
 180                      'face 'calendar-header-face))
 181     (calendar-insert-indented "" indent) ; Go to proper spot
 182     (calendar-for-loop
 183      i from 0 to 6 do
 184      (insert (substring (aref calendar-day-name-array
 185                               (mod (+ calendar-week-start-day i) 7)) 0 2))
 186      ;; Add colour to week day names and sundays
 187      (if calendar-use-colours
 188          (set-extent-property (make-extent  (- (point) 2) (point)) 'face
 189                       (if (= 0 (mod (+ calendar-week-start-day i) 7))
 190                           'calendar-sunday-face
 191                         'calendar-header-face)))
 192      (insert " "))
 193     ;; Add week-string after week dates
 194     (insert (concat calendar-week-string
 195                     (make-string (- 3 (length calendar-week-string)) ? )))
 196     ;; Add colour to week-string
 197     (if calendar-use-colours
 198         (set-extent-property (make-extent  (- (point) 3) (point))
 199                      'face 'calendar-week-face))
 200     (calendar-insert-indented "" 0 t);; Force onto following line
 201     (calendar-insert-indented "" indent);; Go to proper spot
 202     ;; Add blank days before the first of the month
 203     (calendar-for-loop i from 1 to blank-days do (insert "   "))
 204     ;; Put in the days of the month
 205     (calendar-for-loop
 206      i from 1 to last do
 207      (insert (format "%2d " i))
 208      (if (not calendar-use-colours)
 209          nil
 210        (put-text-property (- (point) 3) (1- (point)) 'mouse-face 'highlight)
 211        ;; Add colour to sunday
 212        (if (= 1 (mod (+ blank-days calendar-week-start-day i) 7))
 213            (set-extent-property (make-extent  (- (point) 3) (1- (point)))
 214                         'face 'calendar-sunday-face)))
 215      (and (zerop (mod (+ i blank-days) 7))
 216           ;; Add ISO-week # at the end each week entry
 217           (not (insert
 218                 (format "%2d " (extract-calendar-month
 219                                 (calendar-iso-from-absolute
 220                                  (calendar-absolute-from-gregorian
 221                                   (list month i year)))))))
 222           ;; Add colour to week #
 223           (if calendar-use-colours
 224               (set-extent-property (make-extent  (- (point) 3) (1- (point)))
 225                            'face 'calendar-week-face)
 226             t)
 227           (/= i last)
 228           (calendar-insert-indented "" 0 t);; Force onto following line
 229           (calendar-insert-indented "" indent)))));; Go to proper spot
 230
 231 (defalias 'generate-calendar-month #'sy-generate-calendar-month)
 232
 233 ;:*=======================
 234 ;:* Hooks
 235 (add-hook 'diary-display-hook #'fancy-diary-display)
 236 (add-hook 'diary-hook #'appt-make-list)
 237 (add-hook 'list-diary-entries-hook
 238           #'(lambda ()
 239              (sort-diary-entries)
 240              (include-other-diary-files)))
 241 (add-hook 'mark-diary-entries-hook #'mark-included-diary-files)
 242 (add-hook 'today-visible-calendar-hook #'calendar-mark-today)
 243 (add-hook 'calendar-move-hook #'(lambda () (diary-view-entries 1)))
 244 (add-hook 'calendar-mode-hook
 245           #'(lambda ()
 246               (setq fancy-diary-font-lock-keywords
 247                     (fancy-diary-font-lock-keywords))))
 248
 249 ;:*=======================
 250 ;:* Appointments
 251 (require 'appt)
 252 (require 'balloon-help)
 253 (balloon-help-mode 1)
 254 (setq
 255  balloon-help-background "BlanchedAlmond"
 256  balloon-help-foreground "Black"
 257  display-time-24hr-format t
 258  display-time-day-and-date t
 259  display-time-no-mail-balloon "What! No mail? That can't be right."
 260  display-time-mail-balloon-show-gnus-group t
 261  display-time-mail-balloon-max-displayed 20
 262  display-time-mail-balloon-gnus-split-width 19
 263  display-time-mail-balloon-enhance-gnus-group
 264  '("private.*")
 265  display-time-mail-balloon-suppress-gnus-group
 266  '("\\(SPAM.*\\|returned\\.mail\\)"))
 267 (display-time)
 268 (appt-initialize)
 269 (setq
 270  appt-message-warning-time 30
 271  appt-display-format 'echo
 272  appt-audible t
 273  appt-display-mode-line t
 274  appt-announce-method 'appt-persistent-message-announce)
 275 (appt-activate 1)
 276 ;:*=======================
 277 ;:* Holidays
 278 (defvar displayed-month)
 279 (defvar displayed-year)
 280 (require 'holidays)
 281
 282 ;; First up, a slightly re-written easter-holiday function
 283 (defun sy-easter-holidays ()
 284   "List of dates related to Easter, as visible in calendar window.
 285 Ever-so-slightly modified to include the Easter Monday holiday."
 286  (if (and (> displayed-month 5) (not all-christian-calendar-holidays))
 287      nil;; Ash Wednesday, Good Friday, and Easter are not visible.
 288    (let* ((century (1+ (/ displayed-year 100)))
 289           (shifted-epact        ;; Age of moon for April 5...
 290            (% (+ 14 (* 11 (% displayed-year 19));;     ...by Nicaean rule
 291                  (-           ;; ...corrected for the Gregorian century rule
 292                   (/ (* 3 century) 4))
 293                  (/    ;; ...corrected for Metonic cycle inaccuracy.
 294                   (+ 5 (* 8 century)) 25)
 295                  (* 30 century));;              Keeps value positive.
 296               30))
 297           (adjusted-epact       ;;  Adjust for 29.5 day month.
 298            (if (or (= shifted-epact 0)
 299                    (and (= shifted-epact 1) (< 10 (% displayed-year 19))))
 300                (1+ shifted-epact)
 301              shifted-epact))
 302           (paschal-moon       ;; Day after the full moon on or after March 21.
 303            (- (calendar-absolute-from-gregorian (list 4 19 displayed-year))
 304               adjusted-epact))
 305           (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7)))
 306           (mandatory
 307            (list
 308             (list (calendar-gregorian-from-absolute abs-easter)
 309                   "Easter Sunday")
 310             (list (calendar-gregorian-from-absolute (- abs-easter 2))
 311                   "Good Friday")
 312             (list (calendar-gregorian-from-absolute (+ abs-easter 1))
 313                   "Easter Monday")
 314             (list (calendar-gregorian-from-absolute (- abs-easter 46))
 315                   "Ash Wednesday")
 316             (list (calendar-gregorian-from-absolute (- abs-easter 47))
 317                   "Shrove Tuesday \(Pancake Tuesday\)")))
 318           (optional
 319            (list
 320             (list (calendar-gregorian-from-absolute (- abs-easter 63))
 321                   "Septuagesima Sunday")
 322             (list (calendar-gregorian-from-absolute (- abs-easter 56))
 323                   "Sexagesima Sunday")
 324             (list (calendar-gregorian-from-absolute (- abs-easter 49))
 325                   "Shrove Sunday")
 326             (list (calendar-gregorian-from-absolute (- abs-easter 48))
 327                   "Shrove Monday")
 328             (list (calendar-gregorian-from-absolute (- abs-easter 14))
 329                   "Passion Sunday")
 330             (list (calendar-gregorian-from-absolute (- abs-easter 7))
 331                   "Palm Sunday")
 332             (list (calendar-gregorian-from-absolute (- abs-easter 3))
 333                   "Maundy Thursday")
 334             (list (calendar-gregorian-from-absolute (+ abs-easter 35))
 335                   "Rogation Sunday")
 336             (list (calendar-gregorian-from-absolute (+ abs-easter 39))
 337                   "Ascension Day")
 338             (list (calendar-gregorian-from-absolute (+ abs-easter 49))
 339                   "Pentecost (Whitsunday)")
 340             (list (calendar-gregorian-from-absolute (+ abs-easter 50))
 341                   "Whitmonday")
 342             (list (calendar-gregorian-from-absolute (+ abs-easter 56))
 343                   "Trinity Sunday")
 344             (list (calendar-gregorian-from-absolute (+ abs-easter 60))
 345                   "Corpus Christi")))
 346           (output-list
 347            (filter-visible-calendar-holidays mandatory)))
 348      (if all-christian-calendar-holidays
 349          (setq output-list
 350                (append
 351                 (filter-visible-calendar-holidays optional)
 352                 output-list)))
 353      output-list)))
 354
 355 ;; Get rid of all the Americanised holidays
 356 (setq
 357  christian-holidays nil
 358  hebrew-holidays nil
 359  islamic-holidays nil
 360  general-holidays nil
 361  local-holidays nil
 362  other-holidays nil)
 363
 364 ;; Set up standard Aussie holidays
 365 (setq calendar-holidays
 366       '((holiday-fixed 1 1 "New Year's Day")
 367         ;; If New Year's day is on a weekend the public
 368         ;; holiday is the following Monday
 369         (if (or (eq 0 (calendar-day-of-week (list 1 1 displayed-year)))
 370                 (eq 6 (calendar-day-of-week (list 1 1 displayed-year))))
 371             (holiday-float 1 1 1 "New Year's Day Public Holiday"))
 372         (holiday-fixed 1 26 "Australia Day")
 373         ;; If Australia Day falls on a weekend, the
 374         ;; holiday is the following Monday
 375         (if (eq 0 (calendar-day-of-week (list 1 26 displayed-year)))
 376             (holiday-fixed 1 27 "Australia Day Public Holiday"))
 377         (if (eq 6 (calendar-day-of-week (list 1 26 displayed-year)))
 378             (holiday-fixed 1 28 "Australia Day Public Holiday"))
 379         (holiday-fixed 2 14 "Valentine's Day")
 380         (holiday-fixed 3 17 "St. Patrick's Day")
 381         (holiday-fixed 4 1 "April Fools' Day")
 382         (holiday-fixed 4 25 "Anzac Day")
 383         ;; If Anzac Day falls on a weekend, the holiday
 384         ;; is the following Monday
 385         (if (eq 0 (calendar-day-of-week (list 4 25 displayed-year)))
 386             (holiday-fixed 4 26 "Anzac Day Public Holiday"))
 387         (if (eq 6 (calendar-day-of-week (list 4 25 displayed-year)))
 388             (holiday-fixed 4 27 "Anzac Day Public Holiday"))
 389         (holiday-float 5 1 1 "Labour Day")
 390         (holiday-float 5 0 2 "Mother's Day")
 391         (holiday-float 6 1 2 "Queen's Birthday")
 392         ;; Brisbane Ekka holiday is on the 2nd Wednesday
 393         ;; in August, unless there are 5 Wednesdays in
 394         ;; August, then it is the 3rd Wednesday.
 395         (if (eq 8 (car (calendar-nth-named-day 5 3 8 displayed-year)))
 396             (holiday-float 8 3 3 "Brisbane Show Day")
 397           (holiday-float 8 3 2 "Brisbane Show Day"))
 398         (holiday-float 9 0 1 "Father's Day")
 399         (holiday-fixed 12 25 "Christmas Day")
 400         (holiday-fixed 12 26 "Boxing Day")
 401         ;; If Xmas falls on weekend, the public holiday
 402         ;; is the following Mon/Tue
 403         (if (or (eq 0 (calendar-day-of-week (list 12 25 displayed-year)))
 404                 (eq 6 (calendar-day-of-week (list 12 25 displayed-year))))
 405             (holiday-fixed 12 27 "Xmas Day Public Holiday"))
 406         (if (or (eq 0 (calendar-day-of-week (list 12 26 displayed-year)))
 407                 (eq 6 (calendar-day-of-week (list 12 26 displayed-year))))
 408             (holiday-fixed 12 28 "Boxing Day Public Holiday"))
 409         (solar-equinoxes-solstices)
 410         (sy-easter-holidays)))
 411 (setq mark-holidays-in-calendar t)
 412
 413 ;:*=======================
 414 ;:* Howm integration
 415 (setq
 416  calendar-date-display-form
 417  '("[" year "-" (format "%02d" (string-to-int month))
 418    "-" (format "%02d" (string-to-int day)) "] "
 419    (if dayname (concat dayname ", ")) day " " monthname " " year))
 420
 421 (defun howm-mark-calendar-date ()
 422   (interactive)
 423   (let* ((howm-schedule-types
 424           howm-schedule-menu-types)
 425          (raw (howm-reminder-search
 426                howm-schedule-types))
 427          (str nil) (yy nil) (mm nil) (dd nil))
 428     (while raw
 429       (setq str (nth 1 (car raw)))
 430       (when
 431           (string-match
 432            "\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)"
 433            str)
 434         (setq yy (match-string 1 str))
 435         (setq mm (match-string 2 str))
 436         (setq dd (match-string 3 str)))
 437       (when (and yy mm dd)
 438         (mark-calendar-date-pattern
 439          (string-to-int mm)
 440          (string-to-int dd)
 441          (string-to-int yy)))
 442       (setq mm nil)
 443       (setq dd nil)
 444       (setq yy nil)
 445       (setq raw (cdr raw)))))
 446
 447 (defadvice mark-diary-entries
 448   (after mark-howm-entry activate)
 449   (howm-mark-calendar-date))
 450
 451 (and-boundp 'howm-menu-display-rules
 452   (setq
 453    howm-menu-display-rules
 454    (cons
 455     (cons "%hdiary[\n]?" 'howm-menu-diary)
 456     howm-menu-display-rules)))
 457
 458 (defun howm-menu-diary ()
 459   (message "scanning diary...")
 460   (delete-region
 461    (match-beginning 0) (match-end 0))
 462   (let* ((now (decode-time (current-time)))
 463          (diary-date
 464           (list (nth 4 now) (nth 3 now) (nth 5 now)))
 465          (diary-display-hook 'ignore)
 466          (howm-diary-entry nil)
 467          (howm-diary-entry-day nil)
 468          (str nil)
 469          yy mm dd)
 470     (unwind-protect
 471         (setq howm-diary-entry
 472               (diary-list-entries
 473                diary-date howm-menu-schedule-days))
 474       (save-excursion
 475         (set-buffer
 476          (find-buffer-visiting diary-file))
 477         (subst-char-in-region
 478          (point-min) (point-max) ?\^M ?\n t)
 479         (setq selective-display nil)))
 480     (while howm-diary-entry
 481       (setq howm-diary-entry-day (car howm-diary-entry))
 482       (setq mm (nth 0 (car howm-diary-entry-day)))
 483       (setq dd (nth 1 (car howm-diary-entry-day)))
 484       (setq yy (nth 2 (car howm-diary-entry-day)))
 485       (setq str (nth 1 howm-diary-entry-day))
 486       (setq howm-diary-entry (cdr howm-diary-entry))
 487       (insert
 488        (format
 489         ">>d [%04d-%02d-%02d] %s\n" yy mm dd str))))
 490   (message "scanning diary...done"))
 491
 492 (setq diary-date-forms
 493       '((month "/" day "[^/0-9]")
 494         (month "/" day "/" year "[^0-9]")
 495         ("\\[" year "-" month "-" day "\\]" "[^0-9]")
 496         (monthname " *" day "[^,0-9]")
 497         (monthname " *" day ", *" year "[^0-9]")
 498         (dayname "\\W")))
 499
 500 (defun howm-open-diary (&optional dummy)
 501   (interactive)
 502   (let ((date-str nil) (str nil))
 503     (save-excursion
 504       (beginning-of-line)
 505       (when (re-search-forward
 506              ">>d \\(\\[[-0-9]+\\]\\) " nil t)
 507         (setq str
 508               (concat
 509                "^.+"
 510                (buffer-substring-no-properties
 511                 (point) (line-end-position))))
 512         (setq date-str
 513               (concat
 514                "^.+"
 515                (buffer-substring-no-properties
 516                 (match-beginning 1)
 517                 (match-end 1))
 518                " " str))
 519         (find-file
 520          (substitute-in-file-name diary-file))
 521         (howm-mode t)
 522         (goto-char (point-min))
 523         (if (re-search-forward date-str nil t)
 524             ()
 525           (re-search-forward str nil t))))))
 526
 527 (defun add-diary-action-lock-rule ()
 528   (let ((rule
 529          (action-lock-general
 530           'howm-open-diary
 531           "^\\(>>d\\) "
 532           1 1)))
 533     (if (not (member rule action-lock-default-rules))
 534         (progn
 535           (setq action-lock-default-rules
 536                 (cons rule action-lock-default-rules))
 537           (action-lock-set-rules
 538            action-lock-default-rules)))))
 539
 540 (add-hook 'action-lock-mode-on-hook
 541           'add-diary-action-lock-rule)
 542
 543 (defadvice make-diary-entry
 544   (after howm-mode activate)
 545   (text-mode)
 546   (howm-mode t))
 547
 548 ;;; ;;;;;;;;;;
 549
 550 ;;; ;; M-x calendar, move cursor to a certain date, and
 551 ;;; ;; M-x howm-from-calendar to search that date in howm notes.
 552 (defun howm-from-calendar ()
 553   (interactive)
 554   (let* ((mdy (calendar-cursor-to-date t))
 555          (m (car mdy))
 556          (d (second mdy))
 557          (y (third mdy))
 558          (key (format-time-string
 559                howm-date-format
 560                (encode-time 0 0 0 d m y))))
 561     (howm-keyword-search key)))
 562
 563 ;; Bind howm-from-calendar to "H-d" key.
 564 (add-hook 'initial-calendar-window-hook
 565           #'(lambda ()
 566             (local-set-key [(hyper ?d)] 'howm-from-calendar)))
 567
 568
 569
 570 ;; Type "H-d" in howm menu to open calendar.
 571 (add-hook 'howm-menu-hook
 572           #'(lambda ()
 573             (local-set-key [(hyper ?d)] 'calendar)))
 574
 575 ;:*=======================
 576 ;:* Get the show on the road
 577 (defun sy-calendar-setup ()
 578   (mark-diary-entries)
 579   (mark-calendar-holidays)
 580   (diary-show-all-entries))
 581
 582 (add-hook 'calendar-load-hook 'sy-calendar-setup)
 583 ;:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::*
 584 (message "Calendar settings loaded")