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