;; 12-cal-sy.el --- Calendar Settings   -*- Emacs-Lisp -*-

;; Copyright (C) 2007 - 2013 Steve Youngs

;;     Author: Steve Youngs <steve@sxemacs.org>
;; Maintainer: Steve Youngs <steve@sxemacs.org>
;;    Created: <2007-12-02>
;; Time-stamp: <Monday Aug 19, 2013 09:27:26 steve>
;;   Download: <http://bastard.steveyoungs.com/~steve/SXEmacs/inits/>
;;   HTMLised: <http://bastard.steveyoungs.com/~steve/SXEmacs/htmlinits/12-cal-sy.html>
;;   Git Repo: git clone http://git.sxemacs.org/syinit
;;   Keywords: init, compile

;; This file is part of SYinit

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;;
;; 3. Neither the name of the author nor the names of any contributors
;;    may be used to endorse or promote products derived from this
;;    software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; Commentary:
;;
;;   My calendar/diary settings
;;

;;; Credits:
;;
;;   The HTML version of this file was created with Hrvoje Niksic's
;;   htmlize.el which is part of the XEmacs "text-modes" package.
;;

;;; Todo:
;;
;;     

;;; Code:
;:*=======================
;:* Calendar
(require 'diary-lib)
;(require 'calendar)
(setq 
 calendar-latitude -27.3
 calendar-longitude 153.0
 calendar-location-name "Brisbane"
 calendar-time-zone 600
 calendar-standard-time-zone-name "EST"
 cal-tex-diary t
; calendar-date-display-form ; see: "Howm Integration" below
; '((if dayname (concat dayname ", ")) day " " monthname " " year)
 calendar-time-display-form
 '(24-hours ":" minutes
	    (if time-zone " (") time-zone (if time-zone ")"))
 calendar-week-start-day 1
 diary-file (expand-file-name "etc/SXEmacs/.diary"
			      (getenv "HOME"))
 diary-mail-addr "steve"
 diary-mail-days 7
 european-calendar-style t
 mark-diary-entries-in-calendar t
 number-of-diary-entries 7
 view-diary-entries-initially t)

;:*=======================
;:* Todo
;; Turning this off for a while to see if I can get used to using Howm
;; more.
;;(autoload 'todo-mode "todo-mode"
;;  "Major mode for editing TODO lists." t)
;;(autoload 'todo-show "todo-mode"
;;  "Show TODO items." t)
;;(autoload 'todo-insert-item "todo-mode"
;;  "Add TODO item." t)
;;(global-set-key "\C-ct" 'todo-show) ;; switch to TODO buffer
;;(global-set-key "\C-cn" 'todo-insert-item) ;; insert new item
;;(setq
;; todo-prefix "&%%(todo-cp)"
;; todo-file-do (expand-file-name ".todo-do" (getenv "HOME"))
;; todo-file-done (expand-file-name ".todo-done" (getenv "HOME"))
;; todo-file-top (expand-file-name ".todo-top" (getenv "HOME"))
;; todo-time-string-format "%3b, %d")

;:*=======================
;:* Fancy Diary with perdy colours!
(defun sy-hide-fancy-dashes ()
  "Hides the long lines of dashes from todo-mode in fancy diary display."
  (save-excursion
    (goto-char (point-min))
    (while (re-search-forward "-----" nil t)
      (set-extent-property
       (make-extent (match-beginning 0) (1+ (match-end 0)))
       'invisible t))))

(define-derived-mode fancy-diary-display-mode fundamental-mode "Diary"
  "Minor mode for displaying Fancy Diary entries buffer."
  (set (make-local-variable 'font-lock-defaults)
       '(fancy-diary-font-lock-keywords t))
  (sy-hide-fancy-dashes)
  (font-lock-mode)
  (define-key (current-local-map) "o" 'other-window)
  (define-key (current-local-map) [space] 'scroll-up-command)
  (define-key (current-local-map) [backspace] 'scroll-down-command))

(defadvice fancy-diary-display (after set-mode activate)
  "Give the Fancy Diary Entries buffer a mode of its own.

It has the ever-so-original name of: `fancy-diary-display-mode', adds
a couple of motion keybindings, and lets you set up font lock keywords
for a fontified Diary buffer."
  (save-excursion
    (set-buffer (get-buffer-create fancy-diary-buffer))
    (fancy-diary-display-mode)))

(defun fancy-diary-font-lock-keywords ()
  (let* ((today (regexp-opt (list (calendar-date-string (calendar-current-date)))))
	 (keywords `(("^---\\s-\\(.*$\\)" (1 font-lock-function-name-face))
		     ("^.*SY:" . font-lock-keyword-face)
		     ("\"\\(.*\\)\"" (1 font-lock-string-face))
		     ("`\\(.*?\\)'" (1 font-lock-reference-face))
		     ("[0-9]+:[0-9]+" . font-lock-warning-face)
		     (,today . font-lock-warning-face)
		     ("\\(^.*\\)\n=" (1 font-lock-comment-face)))))
    keywords))

(defvar fancy-diary-font-lock-keywords (fancy-diary-font-lock-keywords))

;:*=======================
;:* Display ISO week numbers
;;
;; I saw this code mentioned on c.e.x.  I just snarfed what I needed
;; and SXEmacserised it.
(require 'cal-iso)

(defvar calendar-use-colours t
  "Tries to fontify Calendar if non-nil.")

(defvar calendar-week-string "WK"
  "String (up to three chars) used in calendar header to identify week numbers.")

(defun sy-generate-calendar-month (month year indent)
  "Produce a calendar for ISO-week, month, year on the Gregorian calendar.
The calendar is inserted in the buffer starting at the line on which point
is currently located, but indented INDENT spaces.  The indentation is done
from the first character on the line and does not disturb the first INDENT
characters on the line."
  (let* ((blank-days			; At start of month
          (mod
           (- (calendar-day-of-week (list month 1 year))
              calendar-week-start-day)
           7))
	 (last (calendar-last-day-of-month month year)))
    (goto-char (point-min))
    (calendar-insert-indented
     (calendar-string-spread
      (list (format "%s %d" (calendar-month-name month) year)) ?  20)
     indent t)
    ;; Add colour to month name
    (if calendar-use-colours
	(set-extent-property (make-extent (point-min) (1- (point)))
		     'face 'calendar-header-face))
    (calendar-insert-indented "" indent) ; Go to proper spot
    (calendar-for-loop
     i from 0 to 6 do
     (insert (substring (aref calendar-day-name-array
			      (mod (+ calendar-week-start-day i) 7)) 0 2))
     ;; Add colour to week day names and sundays
     (if calendar-use-colours
	 (set-extent-property (make-extent  (- (point) 2) (point)) 'face
		      (if (= 0 (mod (+ calendar-week-start-day i) 7))
			  'calendar-sunday-face
			'calendar-header-face)))
     (insert " "))
    ;; Add week-string after week dates
    (insert (concat calendar-week-string 
		    (make-string (- 3 (length calendar-week-string)) ? )))
    ;; Add colour to week-string
    (if calendar-use-colours
	(set-extent-property (make-extent  (- (point) 3) (point))
		     'face 'calendar-week-face))
    (calendar-insert-indented "" 0 t);; Force onto following line
    (calendar-insert-indented "" indent);; Go to proper spot
    ;; Add blank days before the first of the month
    (calendar-for-loop i from 1 to blank-days do (insert "   "))
    ;; Put in the days of the month
    (calendar-for-loop
     i from 1 to last do
     (insert (format "%2d " i))
     (if (not calendar-use-colours)
	 nil
       (put-text-property (- (point) 3) (1- (point)) 'mouse-face 'highlight)
       ;; Add colour to sunday
       (if (= 1 (mod (+ blank-days calendar-week-start-day i) 7))
	   (set-extent-property (make-extent  (- (point) 3) (1- (point)))
			'face 'calendar-sunday-face)))
     (and (zerop (mod (+ i blank-days) 7))
	  ;; Add ISO-week # at the end each week entry
	  (not (insert
		(format "%2d " (extract-calendar-month
				(calendar-iso-from-absolute
				 (calendar-absolute-from-gregorian
				  (list month i year)))))))
	  ;; Add colour to week #
	  (if calendar-use-colours
	      (set-extent-property (make-extent  (- (point) 3) (1- (point)))
			   'face 'calendar-week-face)
	    t)
	  (/= i last)
	  (calendar-insert-indented "" 0 t);; Force onto following line
	  (calendar-insert-indented "" indent)))));; Go to proper spot

(defalias 'generate-calendar-month #'sy-generate-calendar-month)

;:*=======================
;:* Hooks
(add-hook 'diary-display-hook #'fancy-diary-display)
(add-hook 'diary-hook #'appt-make-list)
(add-hook 'list-diary-entries-hook
	  #'(lambda ()
	     (sort-diary-entries)
	     (include-other-diary-files)))
(add-hook 'mark-diary-entries-hook #'mark-included-diary-files)
(add-hook 'today-visible-calendar-hook #'calendar-mark-today)
(add-hook 'calendar-move-hook #'(lambda () (diary-view-entries 1)))
(add-hook 'calendar-mode-hook
	  #'(lambda ()
	      (setq fancy-diary-font-lock-keywords
		    (fancy-diary-font-lock-keywords))))

;:*=======================
;:* Appointments
(require 'appt)
(require 'balloon-help)
(balloon-help-mode 1)
(setq 
 balloon-help-background "BlanchedAlmond"
 balloon-help-foreground "Black"
 display-time-24hr-format t
 display-time-day-and-date t
 display-time-no-mail-balloon "What! No mail? That can't be right."
 display-time-mail-balloon-show-gnus-group t
 display-time-mail-balloon-max-displayed 20
 display-time-mail-balloon-gnus-split-width 19
 display-time-mail-balloon-enhance-gnus-group
 '("private.*")
 display-time-mail-balloon-suppress-gnus-group
 '("\\(SPAM.*\\|returned\\.mail\\)"))
(display-time)
(appt-initialize)
(setq 
 appt-message-warning-time 30
 appt-display-format 'echo
 appt-audible t
 appt-display-mode-line t
 appt-announce-method 'appt-persistent-message-announce)
(appt-activate 1)
;:*=======================
;:* Holidays
(defvar displayed-month)
(defvar displayed-year)
(require 'holidays)

;; First up, a slightly re-written easter-holiday function
(defun sy-easter-holidays ()
  "List of dates related to Easter, as visible in calendar window.
Ever-so-slightly modified to include the Easter Monday holiday."
 (if (and (> displayed-month 5) (not all-christian-calendar-holidays))
     nil;; Ash Wednesday, Good Friday, and Easter are not visible.
   (let* ((century (1+ (/ displayed-year 100)))
          (shifted-epact        ;; Age of moon for April 5...
           (% (+ 14 (* 11 (% displayed-year 19));;     ...by Nicaean rule
                 (-           ;; ...corrected for the Gregorian century rule
                  (/ (* 3 century) 4))
                 (/    ;; ...corrected for Metonic cycle inaccuracy.
                  (+ 5 (* 8 century)) 25)
                 (* 30 century));;              Keeps value positive.
              30))
          (adjusted-epact       ;;  Adjust for 29.5 day month.
           (if (or (= shifted-epact 0)
                   (and (= shifted-epact 1) (< 10 (% displayed-year 19))))
               (1+ shifted-epact)
             shifted-epact))
          (paschal-moon       ;; Day after the full moon on or after March 21.
           (- (calendar-absolute-from-gregorian (list 4 19 displayed-year))
              adjusted-epact))
          (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7)))
          (mandatory
           (list
            (list (calendar-gregorian-from-absolute abs-easter)
                  "Easter Sunday")
            (list (calendar-gregorian-from-absolute (- abs-easter 2))
                  "Good Friday")
	    (list (calendar-gregorian-from-absolute (+ abs-easter 1))
		  "Easter Monday")
            (list (calendar-gregorian-from-absolute (- abs-easter 46))
                  "Ash Wednesday")
            (list (calendar-gregorian-from-absolute (- abs-easter 47))
                  "Shrove Tuesday \(Pancake Tuesday\)")))
          (optional
           (list
            (list (calendar-gregorian-from-absolute (- abs-easter 63))
                  "Septuagesima Sunday")
            (list (calendar-gregorian-from-absolute (- abs-easter 56))
                  "Sexagesima Sunday")
            (list (calendar-gregorian-from-absolute (- abs-easter 49))
                  "Shrove Sunday")
            (list (calendar-gregorian-from-absolute (- abs-easter 48))
                  "Shrove Monday")
            (list (calendar-gregorian-from-absolute (- abs-easter 14))
                  "Passion Sunday")
            (list (calendar-gregorian-from-absolute (- abs-easter 7))
                  "Palm Sunday")
            (list (calendar-gregorian-from-absolute (- abs-easter 3))
                  "Maundy Thursday")
            (list (calendar-gregorian-from-absolute (+ abs-easter 35))
                  "Rogation Sunday")
            (list (calendar-gregorian-from-absolute (+ abs-easter 39))
                  "Ascension Day")
            (list (calendar-gregorian-from-absolute (+ abs-easter 49))
                  "Pentecost (Whitsunday)")
            (list (calendar-gregorian-from-absolute (+ abs-easter 50))
                  "Whitmonday")
            (list (calendar-gregorian-from-absolute (+ abs-easter 56))
                  "Trinity Sunday")
            (list (calendar-gregorian-from-absolute (+ abs-easter 60))
                  "Corpus Christi")))
          (output-list
           (filter-visible-calendar-holidays mandatory)))
     (if all-christian-calendar-holidays
         (setq output-list
               (append 
                (filter-visible-calendar-holidays optional)
                output-list)))
     output-list)))

;; Get rid of all the Americanised holidays
(setq
 christian-holidays nil
 hebrew-holidays nil
 islamic-holidays nil
 general-holidays nil
 local-holidays nil
 other-holidays nil)

;; Set up standard Aussie holidays
(setq calendar-holidays
      '((holiday-fixed 1 1 "New Year's Day")
	;; If New Year's day is on a weekend the public
	;; holiday is the following Monday
	(if (or (eq 0 (calendar-day-of-week (list 1 1 displayed-year)))
		(eq 6 (calendar-day-of-week (list 1 1 displayed-year))))
	    (holiday-float 1 1 1 "New Year's Day Public Holiday"))
	(holiday-fixed 1 26 "Australia Day")
	;; If Australia Day falls on a weekend, the
	;; holiday is the following Monday
	(if (eq 0 (calendar-day-of-week (list 1 26 displayed-year)))
	    (holiday-fixed 1 27 "Australia Day Public Holiday"))
	(if (eq 6 (calendar-day-of-week (list 1 26 displayed-year)))
	    (holiday-fixed 1 28 "Australia Day Public Holiday"))
	(holiday-fixed 2 14 "Valentine's Day")
	(holiday-fixed 3 17 "St. Patrick's Day")
	(holiday-fixed 4 1 "April Fools' Day")
	(holiday-fixed 4 25 "Anzac Day")
	;; If Anzac Day falls on a weekend, the holiday
	;; is the following Monday
	(if (eq 0 (calendar-day-of-week (list 4 25 displayed-year)))
	    (holiday-fixed 4 26 "Anzac Day Public Holiday"))
	(if (eq 6 (calendar-day-of-week (list 4 25 displayed-year)))
	    (holiday-fixed 4 27 "Anzac Day Public Holiday"))
	(holiday-float 5 1 1 "Labour Day")
	(holiday-float 5 0 2 "Mother's Day")
	(holiday-float 6 1 2 "Queen's Birthday")
	;; Brisbane Ekka holiday is on the 2nd Wednesday
	;; in August, unless there are 5 Wednesdays in
	;; August, then it is the 3rd Wednesday.
	(if (eq 8 (car (calendar-nth-named-day 5 3 8 displayed-year)))
	    (holiday-float 8 3 3 "Brisbane Show Day")
	  (holiday-float 8 3 2 "Brisbane Show Day"))
	(holiday-float 9 0 1 "Father's Day")
	(holiday-fixed 12 25 "Christmas Day")
	(holiday-fixed 12 26 "Boxing Day")
	;; If Xmas falls on weekend, the public holiday
	;; is the following Mon/Tue
	(if (or (eq 0 (calendar-day-of-week (list 12 25 displayed-year)))
		(eq 6 (calendar-day-of-week (list 12 25 displayed-year))))
	    (holiday-fixed 12 27 "Xmas Day Public Holiday"))
	(if (or (eq 0 (calendar-day-of-week (list 12 26 displayed-year)))
		(eq 6 (calendar-day-of-week (list 12 26 displayed-year))))
	    (holiday-fixed 12 28 "Boxing Day Public Holiday"))
	(solar-equinoxes-solstices)
	(sy-easter-holidays)))
(setq mark-holidays-in-calendar t)

;:*=======================
;:* Howm integration
(setq
 calendar-date-display-form
 '("[" year "-" (format "%02d" (string-to-int month))
   "-" (format "%02d" (string-to-int day)) "] "
   (if dayname (concat dayname ", ")) day " " monthname " " year))

(defun howm-mark-calendar-date ()
  (interactive)
  (let* ((howm-schedule-types
	  howm-schedule-menu-types)
	 (raw (howm-reminder-search
	       howm-schedule-types))
	 (str nil) (yy nil) (mm nil) (dd nil))
    (while raw
      (setq str (nth 1 (car raw)))
      (when
	  (string-match
	   "\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)"
	   str)
	(setq yy (match-string 1 str))
	(setq mm (match-string 2 str))
	(setq dd (match-string 3 str)))
      (when (and yy mm dd)
	(mark-calendar-date-pattern
	 (string-to-int mm)
	 (string-to-int dd)
	 (string-to-int yy)))
      (setq mm nil)
      (setq dd nil)
      (setq yy nil)
      (setq raw (cdr raw)))))

(defadvice mark-diary-entries
  (after mark-howm-entry activate)
  (howm-mark-calendar-date))

(and-boundp 'howm-menu-display-rules
  (setq
   howm-menu-display-rules
   (cons
    (cons "%hdiary[\n]?" 'howm-menu-diary)
    howm-menu-display-rules)))

(defun howm-menu-diary ()
  (message "scanning diary...")
  (delete-region
   (match-beginning 0) (match-end 0))
  (let* ((now (decode-time (current-time)))
	 (diary-date
	  (list (nth 4 now) (nth 3 now) (nth 5 now)))
	 (diary-display-hook 'ignore)
	 (howm-diary-entry nil)
	 (howm-diary-entry-day nil)
	 (str nil)
	 yy mm dd)
    (unwind-protect
	(setq howm-diary-entry
	      (diary-list-entries
	       diary-date howm-menu-schedule-days))
      (save-excursion
	(set-buffer
	 (find-buffer-visiting diary-file))
	(subst-char-in-region
	 (point-min) (point-max) ?\^M ?\n t)
	(setq selective-display nil)))
    (while howm-diary-entry
      (setq howm-diary-entry-day (car howm-diary-entry))
      (setq mm (nth 0 (car howm-diary-entry-day)))
      (setq dd (nth 1 (car howm-diary-entry-day)))
      (setq yy (nth 2 (car howm-diary-entry-day)))
      (setq str (nth 1 howm-diary-entry-day))
      (setq howm-diary-entry (cdr howm-diary-entry))
      (insert
       (format
	">>d [%04d-%02d-%02d] %s\n" yy mm dd str))))
  (message "scanning diary...done"))

(setq diary-date-forms
      '((month "/" day "[^/0-9]")
	(month "/" day "/" year "[^0-9]")
	("\\[" year "-" month "-" day "\\]" "[^0-9]")
	(monthname " *" day "[^,0-9]")
	(monthname " *" day ", *" year "[^0-9]")
	(dayname "\\W")))

(defun howm-open-diary (&optional dummy)
  (interactive)
  (let ((date-str nil) (str nil))
    (save-excursion
      (beginning-of-line)
      (when (re-search-forward
	     ">>d \\(\\[[-0-9]+\\]\\) " nil t)
	(setq str
	      (concat
	       "^.+"
	       (buffer-substring-no-properties
		(point) (line-end-position))))
	(setq date-str
	      (concat
	       "^.+"
	       (buffer-substring-no-properties
		(match-beginning 1)
		(match-end 1))
	       " " str))
	(find-file
	 (substitute-in-file-name diary-file))
	(howm-mode t)
	(goto-char (point-min))
	(if (re-search-forward date-str nil t)
	    ()
	  (re-search-forward str nil t))))))

(defun add-diary-action-lock-rule ()
  (let ((rule
	 (action-lock-general
	  'howm-open-diary
	  "^\\(>>d\\) "
	  1 1)))
    (if (not (member rule action-lock-default-rules))
	(progn
	  (setq action-lock-default-rules
		(cons rule action-lock-default-rules))
	  (action-lock-set-rules
	   action-lock-default-rules)))))

(add-hook 'action-lock-mode-on-hook
	  'add-diary-action-lock-rule)

(defadvice make-diary-entry
  (after howm-mode activate)
  (text-mode)
  (howm-mode t))

;;; ;;;;;;;;;;

;;; ;; M-x calendar, move cursor to a certain date, and
;;; ;; M-x howm-from-calendar to search that date in howm notes.
(defun howm-from-calendar ()
  (interactive)
  (let* ((mdy (calendar-cursor-to-date t))
	 (m (car mdy))
	 (d (second mdy))
	 (y (third mdy))
	 (key (format-time-string
	       howm-date-format
	       (encode-time 0 0 0 d m y))))
    (howm-keyword-search key)))

;; Bind howm-from-calendar to "H-d" key.
(add-hook 'initial-calendar-window-hook
	  #'(lambda ()
	    (local-set-key [(hyper ?d)] 'howm-from-calendar)))

       

;; Type "H-d" in howm menu to open calendar.
(add-hook 'howm-menu-hook
	  #'(lambda ()
	    (local-set-key [(hyper ?d)] 'calendar)))

;:*=======================
;:* Get the show on the road
(defun sy-calendar-setup ()
  (mark-diary-entries)
  (mark-calendar-holidays)
  (diary-show-all-entries))

(add-hook 'calendar-load-hook 'sy-calendar-setup)
;:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::*
(message "Calendar settings loaded")