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

   1 ;; 11-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: <Thursday Dec 31, 2015 01:18:15 steve>
   9 ;;   Download: <http://bastard.steveyoungs.com/~steve/SXEmacs/inits/>
  10 ;;   HTMLised: <http://bastard.steveyoungs.com/~steve/SXEmacs/htmlinits/11-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)