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

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