--- /dev/null
+;;; cal-chinese.el --- calendar functions for the Chinese calendar.
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+
+;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
+;; Keywords: calendar
+;; Human-Keywords: Chinese calendar, calendar, holidays, diary
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This collection of functions implements the features of calendar.el,
+;; diary.el, and holidays.el that deal with the Chinese calendar. It was
+;; written by
+
+;; Edward M. Reingold Department of Computer Science
+;; (217) 333-6733 University of Illinois at Urbana-Champaign
+;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
+;; Urbana, Illinois 61801
+
+;;; Code:
+
+(require 'lunar)
+
+(defvar chinese-calendar-terrestrial-branch
+ ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"])
+
+(defvar chinese-calendar-celestial-stem
+ ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"])
+
+(defvar chinese-calendar-time-zone
+ '(if (< year 1928)
+ (+ 465 (/ 40.0 60.0))
+ 480)
+ "*Number of minutes difference between local standard time for Chinese
+calendar and Coordinated Universal (Greenwich) Time. Default is for Beijing.
+This is an expression in `year' since it changed at 1928-01-01 00:00:00 from
+UT+7:45:40 to UT+8.")
+
+(defvar chinese-calendar-location-name "Beijing"
+ "*Name of location used for calculation of Chinese calendar.")
+
+(defvar chinese-calendar-daylight-time-offset 0
+; The correct value is as follows, but I don't believe the Chinese calendrical
+; authorities would use DST in determining astronomical events:
+; 60
+ "*Number of minutes difference between daylight savings and standard time
+for Chinese calendar. Default is for no daylight savings time.")
+
+(defvar chinese-calendar-standard-time-zone-name
+ '(if (< year 1928)
+ "PMT"
+ "CST")
+ "*Abbreviated name of standard time zone used for Chinese calendar.")
+
+(defvar chinese-calendar-daylight-time-zone-name "CDT"
+ "*Abbreviated name of daylight-savings time zone used for Chinese calendar.")
+
+(defvar chinese-calendar-daylight-savings-starts nil
+; The correct value is as follows, but I don't believe the Chinese calendrical
+; authorities would use DST in determining astronomical events:
+; '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10))
+; ((= 1986 year) '(5 4 1986))
+; (t nil))
+ "*Sexp giving the date on which daylight savings time starts for Chinese
+calendar. Default is for no daylight savings time. See documentation of
+`calendar-daylight-savings-starts'.")
+
+(defvar chinese-calendar-daylight-savings-ends nil
+; The correct value is as follows, but I don't believe the Chinese calendrical
+; authorities would use DST in determining astronomical events:
+; '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11))
+ "*Sexp giving the date on which daylight savings time ends for Chinese
+calendar. Default is for no daylight savings time. See documentation of
+`calendar-daylight-savings-ends'.")
+
+(defvar chinese-calendar-daylight-savings-starts-time 0
+ "*Number of minutes after midnight that daylight savings time starts for
+Chinese calendar. Default is for no daylight savings time.")
+
+(defvar chinese-calendar-daylight-savings-ends-time 0
+ "*Number of minutes after midnight that daylight savings time ends for
+Chinese calendar. Default is for no daylight savings time.")
+
+(defun chinese-zodiac-sign-on-or-after (d)
+ "Absolute date of first new Zodiac sign on or after absolute date d.
+The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
+ (let* ((year (extract-calendar-year
+ (calendar-gregorian-from-absolute
+ (floor (calendar-absolute-from-astro d)))))
+ (calendar-time-zone (eval chinese-calendar-time-zone))
+ (calendar-daylight-time-offset
+ chinese-calendar-daylight-time-offset)
+ (calendar-standard-time-zone-name
+ chinese-calendar-standard-time-zone-name)
+ (calendar-daylight-time-zone-name
+ chinese-calendar-daylight-time-zone-name)
+ (calendar-calendar-daylight-savings-starts
+ chinese-calendar-daylight-savings-starts)
+ (calendar-daylight-savings-ends
+ chinese-calendar-daylight-savings-ends)
+ (calendar-daylight-savings-starts-time
+ chinese-calendar-daylight-savings-starts-time)
+ (calendar-daylight-savings-ends-time
+ chinese-calendar-daylight-savings-ends-time))
+ (floor
+ (calendar-absolute-from-astro
+ (solar-date-next-longitude
+ (calendar-astro-from-absolute d)
+ 30)))))
+
+(defun chinese-new-moon-on-or-after (d)
+ "Absolute date of first new moon on or after absolute date d."
+ (let* ((year (extract-calendar-year
+ (calendar-gregorian-from-absolute d)))
+ (calendar-time-zone (eval chinese-calendar-time-zone))
+ (calendar-daylight-time-offset
+ chinese-calendar-daylight-time-offset)
+ (calendar-standard-time-zone-name
+ chinese-calendar-standard-time-zone-name)
+ (calendar-daylight-time-zone-name
+ chinese-calendar-daylight-time-zone-name)
+ (calendar-calendar-daylight-savings-starts
+ chinese-calendar-daylight-savings-starts)
+ (calendar-daylight-savings-ends
+ chinese-calendar-daylight-savings-ends)
+ (calendar-daylight-savings-starts-time
+ chinese-calendar-daylight-savings-starts-time)
+ (calendar-daylight-savings-ends-time
+ chinese-calendar-daylight-savings-ends-time))
+ (floor
+ (calendar-absolute-from-astro
+ (lunar-new-moon-on-or-after
+ (calendar-astro-from-absolute d))))))
+
+(defun calendar-absolute-from-chinese (date)
+ "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
+The Gregorian date Sunday, December 31, 1 BC is imaginary."
+ (let* ((cycle (car date))
+ (year (car (cdr date)))
+ (month (car (cdr (cdr date))))
+ (day (car (cdr (cdr (cdr date)))))
+ (g-year (+ (* (1- cycle) 60);; years in prior cycles
+ (1- year);; prior years this cycle
+ -2636));; years before absolute date 0
+ (new-year (chinese-new-year g-year))
+ (current-month new-year)
+ (current-month-number 1)
+ (next-month (chinese-new-moon-on-or-after (1+ new-year)))
+ (next-sign (chinese-zodiac-sign-on-or-after
+ (1+ (chinese-zodiac-sign-on-or-after current-month))))
+ (had-leap-month nil))
+ (while (< current-month-number month)
+ ;; current-month < next-month <= next-sign
+ (setq current-month next-month)
+ (setq next-month (chinese-new-moon-on-or-after (1+ current-month)))
+ (if (and (<= next-month next-sign) (not had-leap-month))
+ (progn;; leap month
+ (setq current-month-number (+ current-month-number 0.5))
+ (setq had-leap-month t))
+ (setq current-month-number (floor (1+ current-month-number)))
+ (setq next-sign (chinese-zodiac-sign-on-or-after (1+ next-sign)))))
+ (+ current-month (1- day))))
+
+(defun calendar-chinese-from-absolute (date)
+ "Compute Chinese date (cycle year month day) corresponding to absolute DATE.
+The absolute date is the number of days elapsed since the (imaginary)
+Gregorian date Sunday, December 31, 1 BC."
+ (let* ((greg-date (calendar-gregorian-from-absolute date))
+ (greg-year (1- (extract-calendar-year greg-date)))
+ (greg-year
+ (+ greg-year
+ (calendar-sum y greg-year
+ (>= date (chinese-new-year (1+ y))) 1)) )
+ (chinese-year (+ greg-year 2697))
+ (cycle (/ (1- chinese-year) 60)) ;; previous cycles
+ (year (calendar-mod chinese-year 60));; years this cycle
+ (current-month (chinese-new-year greg-year))
+ (month 1)
+ (next-month (chinese-new-moon-on-or-after (1+ current-month)))
+ (next-sign (chinese-zodiac-sign-on-or-after
+ (1+ (chinese-zodiac-sign-on-or-after current-month))))
+ (had-leap-month nil))
+ (while (<= next-month date)
+ ;; current-month < next-month <= next-sign
+ (setq current-month next-month)
+ (setq next-month (chinese-new-moon-on-or-after (1+ current-month)))
+ (if (and (<= next-month next-sign) (not had-leap-month))
+ (progn;; leap month
+ (setq month (+ month 0.5))
+ (setq had-leap-month t))
+ (setq month (floor (1+ month)))
+ (setq next-sign (chinese-zodiac-sign-on-or-after (1+ next-sign)))))
+ (list cycle year month (1+ (- date current-month)))))
+
+(defun chinese-new-year (year)
+ "The absolute date of Chinese New Year in Gregorian YEAR."
+ (let* ((last-solstice (chinese-zodiac-sign-on-or-after
+ (calendar-absolute-from-gregorian
+ (list 12 15 (1- year)))))
+ (twelfth-new-moon;; twelfth month of previous year
+ (chinese-new-moon-on-or-after (1+ last-solstice)))
+ (thirteenth-new-moon;; maybe leap month, maybe New Year
+ (chinese-new-moon-on-or-after (1+ twelfth-new-moon)))
+ (fourteenth-new-moon;; maybe New Year, maybe second month
+ (chinese-new-moon-on-or-after (1+ thirteenth-new-moon)))
+ (next-solstice (chinese-zodiac-sign-on-or-after
+ (calendar-absolute-from-gregorian (list 12 15 year))))
+ (new-moons (+ 3 (calendar-sum m 0
+ (< (chinese-new-moon-on-or-after
+ (+ fourteenth-new-moon (* 29 m)))
+ next-solstice)
+ 1))))
+ (if (and (= new-moons 14)
+ (< (chinese-zodiac-sign-on-or-after
+ (calendar-absolute-from-gregorian (list 2 15 year)))
+ thirteenth-new-moon)
+ (<= fourteenth-new-moon
+ (chinese-zodiac-sign-on-or-after
+ (calendar-absolute-from-gregorian (list 3 15 year)))))
+ fourteeth-new-moon
+ thirteenth-new-moon)))
+
+(defun holiday-chinese-new-year ()
+ "Date of Chinese New Year."
+ (let ((m displayed-month)
+ (y displayed-year))
+ (increment-calendar-month m y 1)
+ (if (< m 5)
+ (let ((chinese-new-year
+ (calendar-gregorian-from-absolute
+ (chinese-new-year y))))
+ (if (calendar-date-is-visible-p chinese-new-year)
+ (list (list chinese-new-year
+ (format "Chinese New Year (%s-%s)"
+ (aref chinese-calendar-celestial-stem
+ (% (+ y 6) 10))
+ (aref chinese-calendar-terrestrial-branch
+ (% (+ y 8) 12))))))))))
+
+(defun calendar-chinese-date-string (&optional date)
+ "String of Chinese date of Gregorian DATE.
+Defaults to today's date if DATE is not given."
+ (let* ((a-date (calendar-absolute-from-gregorian
+ (or date (calendar-current-date))))
+ (c-date (calendar-chinese-from-absolute a-date))
+ (cycle (car c-date))
+ (year (car (cdr c-date)))
+ (month (car (cdr (cdr c-date))))
+ (day (car (cdr (cdr (cdr c-date)))))
+ (this-month (calendar-absolute-from-chinese
+ (list cycle year month 1)))
+ (next-month (calendar-absolute-from-chinese
+ (list cycle year (1+ month) 1)))
+ (month (floor month))
+ (m-cycle (% (+ (* year 5) month) 60)))
+ (format "Cycle %s, year %s (%s-%s), %smonth %s, day %s (%s-%s)"
+ cycle
+ year
+ (aref chinese-calendar-celestial-stem (% (+ year 9) 10))
+ (aref chinese-calendar-terrestrial-branch (% (+ year 11) 12))
+ (if (not (integerp month))
+ "second "
+ (if (< 30 (- next-month this-month))
+ "first "
+ ""))
+ month
+ day
+ (aref chinese-calendar-celestial-stem (% (+ a-date 4) 10))
+ (aref chinese-calendar-terrestrial-branch (% (+ a-date 2) 12)))))
+
+(defun calendar-print-chinese-date ()
+ "Show the Chinese date equivalents of date."
+ (interactive)
+ (message "Computing Chinese date...")
+ (message "Chinese date: %s"
+ (calendar-chinese-date-string (calendar-cursor-to-date t))))
+
+(defun calendar-goto-chinese-date (date &optional noecho)
+ "Move cursor to Chinese date DATE.
+Echo Chinese date unless NOECHO is t."
+ (interactive
+ (let* ((c (calendar-chinese-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-current-date))))
+ (cycle (calendar-read
+ "Cycle number (>44): "
+ '(lambda (x) (> x 44))
+ (int-to-string (car c))))
+ (year (calendar-read
+ "Year in cycle (1..60): "
+ '(lambda (x) (and (<= 1 x) (<= x 60)))
+ (int-to-string (car (cdr c)))))
+ (month (read-minibuffer "Month: "))
+ (day (read-minibuffer "Day: ")))
+ (list (list cycle year month day))))
+ (calendar-goto-date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-chinese date)))
+ (or noecho (calendar-print-chinese-date)))
+
+(defun diary-chinese-date ()
+ "Chinese calendar equivalent of date diary entry."
+ (format "Chinese date: %s" (calendar-chinese-date-string date)))
+
+(provide 'cal-chinese)
+
+;;; cal-chinese ends here
--- /dev/null
+;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars.
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+
+;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
+;; Keywords: calendar
+;; Human-Keywords: Coptic calendar, Ethiopic calendar, calendar, diary
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This collection of functions implements the features of calendar.el and
+;; diary.el that deal with the Coptic and Ethiopic calendars.
+
+;; Comments, corrections, and improvements should be sent to
+;; Edward M. Reingold Department of Computer Science
+;; (217) 333-6733 University of Illinois at Urbana-Champaign
+;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
+;; Urbana, Illinois 61801
+
+;;; Code:
+
+(require 'cal-julian)
+
+(defvar coptic-calendar-month-name-array
+ ["Tot" "Babe" "Hatur" "Kihak" "Tube" "Amshir" "Baramhat" "Barmuda"
+ "Bashnas" "Bauna" "Abib" "Misra" "Nisi"])
+
+(defvar coptic-calendar-epoch (calendar-absolute-from-julian '(8 29 284))
+ "Absolute date of start of Coptic calendar = August 29, 284 A.D. (Julian).")
+
+(defconst coptic-name "Coptic")
+
+(defun coptic-calendar-leap-year-p (year)
+ "True if YEAR is a leap year on the Coptic calendar."
+ (zerop (mod (1+ year) 4)))
+
+(defun coptic-calendar-last-day-of-month (month year)
+ "Return last day of MONTH, YEAR on the Coptic calendar.
+The 13th month is not really a month, but the 5 (6 in leap years) day period of
+Nisi (Kebus) at the end of the year."
+ (if (< month 13)
+ 30
+ (if (coptic-calendar-leap-year-p year)
+ 6
+ 5)))
+
+(defun calendar-absolute-from-coptic (date)
+ "Compute absolute date from Coptic date DATE.
+The absolute date is the number of days elapsed since the (imaginary)
+Gregorian date Sunday, December 31, 1 BC."
+ (let ((month (extract-calendar-month date))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date)))
+ (+ (1- coptic-calendar-epoch);; Days before start of calendar
+ (* 365 (1- year)) ;; Days in prior years
+ (/ year 4) ;; Leap days in prior years
+ (* 30 (1- month)) ;; Days in prior months this year
+ day))) ;; Days so far this month
+
+
+(defun calendar-coptic-from-absolute (date)
+ "Compute the Coptic equivalent for absolute date DATE.
+The result is a list of the form (MONTH DAY YEAR).
+The absolute date is the number of days elapsed since the imaginary
+Gregorian date Sunday, December 31, 1 BC."
+ (if (< date coptic-calendar-epoch)
+ (list 0 0 0);; pre-Coptic date
+ (let* ((approx (/ (- date coptic-calendar-epoch)
+ 366)) ;; Approximation from below.
+ (year ;; Search forward from the approximation.
+ (+ approx
+ (calendar-sum y approx
+ (>= date (calendar-absolute-from-coptic (list 1 1 (1+ y))))
+ 1)))
+ (month ;; Search forward from Tot.
+ (1+ (calendar-sum m 1
+ (> date
+ (calendar-absolute-from-coptic
+ (list m
+ (coptic-calendar-last-day-of-month m year)
+ year)))
+ 1)))
+ (day ;; Calculate the day by subtraction.
+ (- date
+ (1- (calendar-absolute-from-coptic (list month 1 year))))))
+ (list month day year))))
+
+(defun calendar-coptic-date-string (&optional date)
+ "String of Coptic date of Gregorian DATE.
+Returns the empty string if DATE is pre-Coptic calendar.
+Defaults to today's date if DATE is not given."
+ (let* ((coptic-date (calendar-coptic-from-absolute
+ (calendar-absolute-from-gregorian
+ (or date (calendar-current-date)))))
+ (y (extract-calendar-year coptic-date))
+ (m (extract-calendar-month coptic-date)))
+ (if (< y 1)
+ ""
+ (let ((monthname (aref coptic-calendar-month-name-array (1- m)))
+ (day (int-to-string (extract-calendar-day coptic-date)))
+ (dayname nil)
+ (month (int-to-string m))
+ (year (int-to-string y)))
+ (mapconcat 'eval calendar-date-display-form "")))))
+
+(defun calendar-print-coptic-date ()
+ "Show the Coptic calendar equivalent of the selected date."
+ (interactive)
+ (let ((f (calendar-coptic-date-string (calendar-cursor-to-date t))))
+ (if (string-equal f "")
+ (message "Date is pre-%s calendar" coptic-name)
+ (message f))))
+
+(defun calendar-goto-coptic-date (date &optional noecho)
+ "Move cursor to Coptic date DATE.
+Echo Coptic date unless NOECHO is t."
+ (interactive (coptic-prompt-for-date))
+ (calendar-goto-date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-coptic date)))
+ (or noecho (calendar-print-coptic-date)))
+
+(defun coptic-prompt-for-date ()
+ "Ask for a Coptic date."
+ (let* ((today (calendar-current-date))
+ (year (calendar-read
+ (format "%s calendar year (>0): " coptic-name)
+ '(lambda (x) (> x 0))
+ (int-to-string
+ (extract-calendar-year
+ (calendar-coptic-from-absolute
+ (calendar-absolute-from-gregorian today))))))
+ (completion-ignore-case t)
+ (month (cdr (assoc
+ (capitalize
+ (completing-read
+ (format "%s calendar month name: " coptic-name)
+ (mapcar 'list
+ (append coptic-calendar-month-name-array nil))
+ nil t))
+ (calendar-make-alist coptic-calendar-month-name-array
+ 1 'capitalize))))
+ (last (coptic-calendar-last-day-of-month month year))
+ (day (calendar-read
+ (format "%s calendar day (1-%d): " coptic-name last)
+ '(lambda (x) (and (< 0 x) (<= x last))))))
+ (list (list month day year))))
+
+(defun diary-coptic-date ()
+ "Coptic calendar equivalent of date diary entry."
+ (let ((f (calendar-coptic-date-string (calendar-cursor-to-date t))))
+ (if (string-equal f "")
+ (format "Date is pre-%s calendar" coptic-name)
+ f)))
+
+(defconst ethiopic-calendar-month-name-array
+ ["Maskarram" "Tekemt" "Hadar" "Tahsas" "Tarr" "Yekatit" "Magawit" "Miaziah"
+ "Genbot" "Sanni" "Hamle" "Nas'hi" "Pagnem"])
+
+(defconst ethiopic-calendar-epoch (calendar-absolute-from-julian '(8 29 7))
+ "Absolute date of start of Ethiopic calendar = August 29, 7 A.D. (Julian).")
+
+(defconst ethiopic-name "Ethiopic")
+
+(defun calendar-absolute-from-ethiopic (date)
+ "Compute absolute date from Ethiopic date DATE.
+The absolute date is the number of days elapsed since the (imaginary)
+Gregorian date Sunday, December 31, 1 BC."
+ (let ((coptic-calendar-epoch ethiopic-calendar-epoch))
+ (calendar-absolute-from-coptic date)))
+
+(defun calendar-ethiopic-from-absolute (date)
+ "Compute the Ethiopic equivalent for absolute date DATE.
+The result is a list of the form (MONTH DAY YEAR).
+The absolute date is the number of days elapsed since the imaginary
+Gregorian date Sunday, December 31, 1 BC."
+ (let ((coptic-calendar-epoch ethiopic-calendar-epoch))
+ (calendar-coptic-from-absolute date)))
+
+(defun calendar-ethiopic-date-string (&optional date)
+ "String of Ethiopic date of Gregorian DATE.
+Returns the empty string if DATE is pre-Ethiopic calendar.
+Defaults to today's date if DATE is not given."
+ (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
+ (coptic-name ethiopic-name)
+ (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
+ (calendar-coptic-date-string date)))
+
+(defun calendar-print-ethiopic-date ()
+ "Show the Ethiopic calendar equivalent of the selected date."
+ (interactive)
+ (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
+ (coptic-name ethiopic-name)
+ (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
+ (call-interactively 'calendar-print-coptic-date)))
+
+(defun calendar-goto-ethiopic-date (date &optional noecho)
+ "Move cursor to Ethiopic date DATE.
+Echo Ethiopic date unless NOECHO is t."
+ (interactive
+ (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
+ (coptic-name ethiopic-name)
+ (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
+ (coptic-prompt-for-date)))
+ (calendar-goto-date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-ethiopic date)))
+ (or noecho (calendar-print-ethiopic-date)))
+
+(defun diary-ethiopic-date ()
+ "Ethiopic calendar equivalent of date diary entry."
+ (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
+ (coptic-name ethiopic-name)
+ (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
+ (diary-coptic-date)))
+
+(provide 'cal-coptic)
+
+;;; cal-coptic.el ends here
--- /dev/null
+;;; cal-islamic.el --- calendar functions for the Islamic calendar.
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+
+;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
+;; Keywords: calendar
+;; Human-Keywords: Islamic calendar, calendar, diary
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This collection of functions implements the features of calendar.el and
+;; diary.el that deal with the Islamic calendar.
+
+;; Comments, corrections, and improvements should be sent to
+;; Edward M. Reingold Department of Computer Science
+;; (217) 333-6733 University of Illinois at Urbana-Champaign
+;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
+;; Urbana, Illinois 61801
+
+;;; Code:
+
+(require 'cal-julian)
+
+(defvar calendar-islamic-month-name-array
+ ["Muharram" "Safar" "Rabi I" "Rabi II" "Jumada I" "Jumada II"
+ "Rajab" "Sha'ban" "Ramadan" "Shawwal" "Dhu al-Qada" "Dhu al-Hijjah"])
+
+(defvar calendar-islamic-epoch (calendar-absolute-from-julian '(7 16 622))
+ "Absolute date of start of Islamic calendar = August 29, 284 A.D. (Julian).")
+
+(defun islamic-calendar-leap-year-p (year)
+ "Returns t if YEAR is a leap year on the Islamic calendar."
+ (memq (% year 30)
+ (list 2 5 7 10 13 16 18 21 24 26 29)))
+
+(defun islamic-calendar-last-day-of-month (month year)
+ "The last day in MONTH during YEAR on the Islamic calendar."
+ (cond
+ ((memq month (list 1 3 5 7 9 11)) 30)
+ ((memq month (list 2 4 6 8 10)) 29)
+ (t (if (islamic-calendar-leap-year-p year) 30 29))))
+
+(defun islamic-calendar-day-number (date)
+ "Return the day number within the year of the Islamic date DATE."
+ (let* ((month (extract-calendar-month date))
+ (day (extract-calendar-day date)))
+ (+ (* 30 (/ month 2))
+ (* 29 (/ (1- month) 2))
+ day)))
+
+(defun calendar-absolute-from-islamic (date)
+ "Absolute date of Islamic DATE.
+The absolute date is the number of days elapsed since the (imaginary)
+Gregorian date Sunday, December 31, 1 BC."
+ (let* ((month (extract-calendar-month date))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date))
+ (y (% year 30))
+ (leap-years-in-cycle
+ (cond
+ ((< y 3) 0) ((< y 6) 1) ((< y 8) 2) ((< y 11) 3) ((< y 14) 4)
+ ((< y 17) 5) ((< y 19) 6) ((< y 22) 7) ((< y 25) 8) ((< y 27) 9)
+ (t 10))))
+ (+ (islamic-calendar-day-number date);; days so far this year
+ (* (1- year) 354) ;; days in all non-leap years
+ (* 11 (/ year 30)) ;; leap days in complete cycles
+ leap-years-in-cycle ;; leap days this cycle
+ (1- calendar-islamic-epoch)))) ;; days before start of calendar
+
+(defun calendar-islamic-from-absolute (date)
+ "Compute the Islamic date (month day year) corresponding to absolute DATE.
+The absolute date is the number of days elapsed since the (imaginary)
+Gregorian date Sunday, December 31, 1 BC."
+ (if (< date calendar-islamic-epoch)
+ (list 0 0 0);; pre-Islamic date
+ (let* ((approx (/ (- date calendar-islamic-epoch)
+ 355));; Approximation from below.
+ (year ;; Search forward from the approximation.
+ (+ approx
+ (calendar-sum y approx
+ (>= date (calendar-absolute-from-islamic
+ (list 1 1 (1+ y))))
+ 1)))
+ (month ;; Search forward from Muharram.
+ (1+ (calendar-sum m 1
+ (> date
+ (calendar-absolute-from-islamic
+ (list m
+ (islamic-calendar-last-day-of-month
+ m year)
+ year)))
+ 1)))
+ (day ;; Calculate the day by subtraction.
+ (- date
+ (1- (calendar-absolute-from-islamic (list month 1 year))))))
+ (list month day year))))
+
+(defun calendar-islamic-date-string (&optional date)
+ "String of Islamic date before sunset of Gregorian DATE.
+Returns the empty string if DATE is pre-Islamic.
+Defaults to today's date if DATE is not given.
+Driven by the variable `calendar-date-display-form'."
+ (let ((calendar-month-name-array calendar-islamic-month-name-array)
+ (islamic-date (calendar-islamic-from-absolute
+ (calendar-absolute-from-gregorian
+ (or date (calendar-current-date))))))
+ (if (< (extract-calendar-year islamic-date) 1)
+ ""
+ (calendar-date-string islamic-date nil t))))
+
+(defun calendar-print-islamic-date ()
+ "Show the Islamic calendar equivalent of the date under the cursor."
+ (interactive)
+ (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
+ (if (string-equal i "")
+ (message "Date is pre-Islamic")
+ (message "Islamic date (until sunset): %s" i))))
+
+(defun calendar-goto-islamic-date (date &optional noecho)
+ "Move cursor to Islamic DATE; echo Islamic date unless NOECHO is t."
+ (interactive
+ (let* ((today (calendar-current-date))
+ (year (calendar-read
+ "Islamic calendar year (>0): "
+ '(lambda (x) (> x 0))
+ (int-to-string
+ (extract-calendar-year
+ (calendar-islamic-from-absolute
+ (calendar-absolute-from-gregorian today))))))
+ (month-array calendar-islamic-month-name-array)
+ (completion-ignore-case t)
+ (month (cdr (assoc
+ (capitalize
+ (completing-read
+ "Islamic calendar month name: "
+ (mapcar 'list (append month-array nil))
+ nil t))
+ (calendar-make-alist month-array 1 'capitalize))))
+ (last (islamic-calendar-last-day-of-month month year))
+ (day (calendar-read
+ (format "Islamic calendar day (1-%d): " last)
+ '(lambda (x) (and (< 0 x) (<= x last))))))
+ (list (list month day year))))
+ (calendar-goto-date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-islamic date)))
+ (or noecho (calendar-print-islamic-date)))
+
+(defun diary-islamic-date ()
+ "Islamic calendar equivalent of date diary entry."
+ (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
+ (if (string-equal i "")
+ "Date is pre-Islamic"
+ (format "Islamic date (until sunset): %s" i))))
+
+(defun holiday-islamic (month day string)
+ "Holiday on MONTH, DAY (Islamic) called STRING.
+If MONTH, DAY (Islamic) is visible, the value returned is corresponding
+Gregorian date in the form of the list (((month day year) STRING)). Returns
+nil if it is not visible in the current calendar window."
+ (let* ((islamic-date (calendar-islamic-from-absolute
+ (calendar-absolute-from-gregorian
+ (list displayed-month 15 displayed-year))))
+ (m (extract-calendar-month islamic-date))
+ (y (extract-calendar-year islamic-date))
+ (date))
+ (if (< m 1)
+ nil;; Islamic calendar doesn't apply.
+ (increment-calendar-month m y (- 10 month))
+ (if (> m 7);; Islamic date might be visible
+ (let ((date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-islamic (list month day y)))))
+ (if (calendar-date-is-visible-p date)
+ (list (list date string))))))))
+
+(defun list-islamic-diary-entries ()
+ "Add any Islamic date entries from the diary file to `diary-entries-list'.
+Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol'
+\(normally an `I'). The same diary date forms govern the style of the Islamic
+calendar entries, except that the Islamic month names must be spelled in full.
+The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
+Dhu al-Hijjah. If an Islamic date diary entry begins with a
+`diary-nonmarking-symbol', the entry will appear in the diary listing, but will
+not be marked in the calendar. This function is provided for use with the
+`nongregorian-diary-listing-hook'."
+ (if (< 0 number)
+ (let ((buffer-read-only nil)
+ (diary-modified (buffer-modified-p))
+ (gdate original-date)
+ (mark (regexp-quote diary-nonmarking-symbol)))
+ (calendar-for-loop i from 1 to number do
+ (let* ((d diary-date-forms)
+ (idate (calendar-islamic-from-absolute
+ (calendar-absolute-from-gregorian gdate)))
+ (month (extract-calendar-month idate))
+ (day (extract-calendar-day idate))
+ (year (extract-calendar-year idate)))
+ (while d
+ (let*
+ ((date-form (if (equal (car (car d)) 'backup)
+ (cdr (car d))
+ (car d)))
+ (backup (equal (car (car d)) 'backup))
+ (dayname
+ (concat
+ (calendar-day-name gdate) "\\|"
+ (substring (calendar-day-name gdate) 0 3) ".?"))
+ (calendar-month-name-array
+ calendar-islamic-month-name-array)
+ (monthname
+ (concat
+ "\\*\\|"
+ (calendar-month-name month)))
+ (month (concat "\\*\\|0*" (int-to-string month)))
+ (day (concat "\\*\\|0*" (int-to-string day)))
+ (year
+ (concat
+ "\\*\\|0*" (int-to-string year)
+ (if abbreviated-calendar-year
+ (concat "\\|" (int-to-string (% year 100)))
+ "")))
+ (regexp
+ (concat
+ "\\(\\`\\|\^M\\|\n\\)" mark "?"
+ (regexp-quote islamic-diary-entry-symbol)
+ "\\("
+ (mapconcat 'eval date-form "\\)\\(")
+ "\\)"))
+ (case-fold-search t))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (if backup (re-search-backward "\\<" nil t))
+ (if (and (or (char-equal (preceding-char) ?\^M)
+ (char-equal (preceding-char) ?\n))
+ (not (looking-at " \\|\^I")))
+ ;; Diary entry that consists only of date.
+ (backward-char 1)
+ ;; Found a nonempty diary entry--make it visible and
+ ;; add it to the list.
+ (let ((entry-start (point))
+ (date-start))
+ (re-search-backward "\^M\\|\n\\|\\`")
+ (setq date-start (point))
+ (re-search-forward "\^M\\|\n" nil t 2)
+ (while (looking-at " \\|\^I")
+ (re-search-forward "\^M\\|\n" nil t))
+ (backward-char 1)
+ (subst-char-in-region date-start (point) ?\^M ?\n t)
+ (add-to-diary-list
+ gdate (buffer-substring entry-start (point)))))))
+ (setq d (cdr d))))
+ (setq gdate
+ (calendar-gregorian-from-absolute
+ (1+ (calendar-absolute-from-gregorian gdate)))))
+ (set-buffer-modified-p diary-modified))
+ (goto-char (point-min))))
+
+(defun mark-islamic-diary-entries ()
+ "Mark days in the calendar window that have Islamic date diary entries.
+Each entry in diary-file (or included files) visible in the calendar window
+is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol
+\(normally an `I'). The same diary-date-forms govern the style of the Islamic
+calendar entries, except that the Islamic month names must be spelled in full.
+The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
+Dhu al-Hijjah. Islamic date diary entries that begin with a
+diary-nonmarking-symbol will not be marked in the calendar. This function is
+provided for use as part of the nongregorian-diary-marking-hook."
+ (let ((d diary-date-forms))
+ (while d
+ (let*
+ ((date-form (if (equal (car (car d)) 'backup)
+ (cdr (car d))
+ (car d)));; ignore 'backup directive
+ (dayname (diary-name-pattern calendar-day-name-array))
+ (monthname
+ (concat
+ (diary-name-pattern calendar-islamic-month-name-array t)
+ "\\|\\*"))
+ (month "[0-9]+\\|\\*")
+ (day "[0-9]+\\|\\*")
+ (year "[0-9]+\\|\\*")
+ (l (length date-form))
+ (d-name-pos (- l (length (memq 'dayname date-form))))
+ (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
+ (m-name-pos (- l (length (memq 'monthname date-form))))
+ (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
+ (d-pos (- l (length (memq 'day date-form))))
+ (d-pos (if (/= l d-pos) (+ 2 d-pos)))
+ (m-pos (- l (length (memq 'month date-form))))
+ (m-pos (if (/= l m-pos) (+ 2 m-pos)))
+ (y-pos (- l (length (memq 'year date-form))))
+ (y-pos (if (/= l y-pos) (+ 2 y-pos)))
+ (regexp
+ (concat
+ "\\(\\`\\|\^M\\|\n\\)"
+ (regexp-quote islamic-diary-entry-symbol)
+ "\\("
+ (mapconcat 'eval date-form "\\)\\(")
+ "\\)"))
+ (case-fold-search t))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (let* ((dd-name
+ (if d-name-pos
+ (buffer-substring
+ (match-beginning d-name-pos)
+ (match-end d-name-pos))))
+ (mm-name
+ (if m-name-pos
+ (buffer-substring
+ (match-beginning m-name-pos)
+ (match-end m-name-pos))))
+ (mm (string-to-int
+ (if m-pos
+ (buffer-substring
+ (match-beginning m-pos)
+ (match-end m-pos))
+ "")))
+ (dd (string-to-int
+ (if d-pos
+ (buffer-substring
+ (match-beginning d-pos)
+ (match-end d-pos))
+ "")))
+ (y-str (if y-pos
+ (buffer-substring
+ (match-beginning y-pos)
+ (match-end y-pos))))
+ (yy (if (not y-str)
+ 0
+ (if (and (= (length y-str) 2)
+ abbreviated-calendar-year)
+ (let* ((current-y
+ (extract-calendar-year
+ (calendar-islamic-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-current-date)))))
+ (y (+ (string-to-int y-str)
+ (* 100 (/ current-y 100)))))
+ (if (> (- y current-y) 50)
+ (- y 100)
+ (if (> (- current-y y) 50)
+ (+ y 100)
+ y)))
+ (string-to-int y-str)))))
+ (if dd-name
+ (mark-calendar-days-named
+ (cdr (assoc (capitalize (substring dd-name 0 3))
+ (calendar-make-alist
+ calendar-day-name-array
+ 0
+ '(lambda (x) (substring x 0 3))))))
+ (if mm-name
+ (if (string-equal mm-name "*")
+ (setq mm 0)
+ (setq mm
+ (cdr (assoc
+ (capitalize mm-name)
+ (calendar-make-alist
+ calendar-islamic-month-name-array))))))
+ (mark-islamic-calendar-date-pattern mm dd yy)))))
+ (setq d (cdr d)))))
+
+(defun mark-islamic-calendar-date-pattern (month day year)
+ "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.
+A value of 0 in any position is a wildcard."
+ (save-excursion
+ (set-buffer calendar-buffer)
+ (if (and (/= 0 month) (/= 0 day))
+ (if (/= 0 year)
+ ;; Fully specified Islamic date.
+ (let ((date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-islamic
+ (list month day year)))))
+ (if (calendar-date-is-visible-p date)
+ (mark-visible-calendar-date date)))
+ ;; Month and day in any year--this taken from the holiday stuff.
+ (let* ((islamic-date (calendar-islamic-from-absolute
+ (calendar-absolute-from-gregorian
+ (list displayed-month 15 displayed-year))))
+ (m (extract-calendar-month islamic-date))
+ (y (extract-calendar-year islamic-date))
+ (date))
+ (if (< m 1)
+ nil;; Islamic calendar doesn't apply.
+ (increment-calendar-month m y (- 10 month))
+ (if (> m 7);; Islamic date might be visible
+ (let ((date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-islamic
+ (list month day y)))))
+ (if (calendar-date-is-visible-p date)
+ (mark-visible-calendar-date date)))))))
+ ;; Not one of the simple cases--check all visible dates for match.
+ ;; Actually, the following code takes care of ALL of the cases, but
+ ;; it's much too slow to be used for the simple (common) cases.
+ (let ((m displayed-month)
+ (y displayed-year)
+ (first-date)
+ (last-date))
+ (increment-calendar-month m y -1)
+ (setq first-date
+ (calendar-absolute-from-gregorian
+ (list m 1 y)))
+ (increment-calendar-month m y 2)
+ (setq last-date
+ (calendar-absolute-from-gregorian
+ (list m (calendar-last-day-of-month m y) y)))
+ (calendar-for-loop date from first-date to last-date do
+ (let* ((i-date (calendar-islamic-from-absolute date))
+ (i-month (extract-calendar-month i-date))
+ (i-day (extract-calendar-day i-date))
+ (i-year (extract-calendar-year i-date)))
+ (and (or (zerop month)
+ (= month i-month))
+ (or (zerop day)
+ (= day i-day))
+ (or (zerop year)
+ (= year i-year))
+ (mark-visible-calendar-date
+ (calendar-gregorian-from-absolute date)))))))))
+
+(defun insert-islamic-diary-entry (arg)
+ "Insert a diary entry.
+For the Islamic date corresponding to the date indicated by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (let* ((calendar-month-name-array calendar-islamic-month-name-array))
+ (make-diary-entry
+ (concat
+ islamic-diary-entry-symbol
+ (calendar-date-string
+ (calendar-islamic-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-cursor-to-date t)))
+ nil t))
+ arg)))
+
+(defun insert-monthly-islamic-diary-entry (arg)
+ "Insert a monthly diary entry.
+For the day of the Islamic month corresponding to the date indicated by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (let* ((calendar-date-display-form
+ (if european-calendar-style '(day " * ") '("* " day )))
+ (calendar-month-name-array calendar-islamic-month-name-array))
+ (make-diary-entry
+ (concat
+ islamic-diary-entry-symbol
+ (calendar-date-string
+ (calendar-islamic-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-cursor-to-date t)))))
+ arg)))
+
+(defun insert-yearly-islamic-diary-entry (arg)
+ "Insert an annual diary entry.
+For the day of the Islamic year corresponding to the date indicated by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (let* ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " " monthname)
+ '(monthname " " day)))
+ (calendar-month-name-array calendar-islamic-month-name-array))
+ (make-diary-entry
+ (concat
+ islamic-diary-entry-symbol
+ (calendar-date-string
+ (calendar-islamic-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-cursor-to-date t)))))
+ arg)))
+
+(provide 'cal-islamic)
+
+;;; cal-islamic.el ends here
--- /dev/null
+;;; cal-iso.el --- calendar functions for the ISO calendar.
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+
+;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
+;; Keywords: calendar
+;; Human-Keywords: ISO calendar, calendar, diary
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This collection of functions implements the features of calendar.el and
+;; diary.el that deal with the ISO calendar.
+
+;; Comments, corrections, and improvements should be sent to
+;; Edward M. Reingold Department of Computer Science
+;; (217) 333-6733 University of Illinois at Urbana-Champaign
+;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
+;; Urbana, Illinois 61801
+
+;;; Code:
+
+(require 'calendar)
+
+(defun calendar-absolute-from-iso (date)
+ "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
+The `ISO year' corresponds approximately to the Gregorian year, but
+weeks start on Monday and end on Sunday. The first week of the ISO year is
+the first such week in which at least 4 days are in a year. The ISO
+commercial DATE has the form (week day year) in which week is in the range
+1..52 and day is in the range 0..6 (1 = Monday, 2 = Tuesday, ..., 0 =
+Sunday). The Gregorian date Sunday, December 31, 1 BC is imaginary."
+ (let* ((week (extract-calendar-month date))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date)))
+ (+ (calendar-dayname-on-or-before
+ 1 (+ 3 (calendar-absolute-from-gregorian (list 1 1 year))))
+ (* 7 (1- week))
+ (if (= day 0) 6 (1- day)))))
+
+(defun calendar-iso-from-absolute (date)
+ "Compute the `ISO commercial date' corresponding to the absolute DATE.
+The ISO year corresponds approximately to the Gregorian year, but weeks
+start on Monday and end on Sunday. The first week of the ISO year is the
+first such week in which at least 4 days are in a year. The ISO commercial
+date has the form (week day year) in which week is in the range 1..52 and
+day is in the range 0..6 (1 = Monday, 2 = Tuesday, ..., 0 = Sunday). The
+absolute date is the number of days elapsed since the (imaginary) Gregorian
+date Sunday, December 31, 1 BC."
+ (let* ((approx (extract-calendar-year
+ (calendar-gregorian-from-absolute (- date 3))))
+ (year (+ approx
+ (calendar-sum y approx
+ (>= date (calendar-absolute-from-iso (list 1 1 (1+ y))))
+ 1))))
+ (list
+ (1+ (/ (- date (calendar-absolute-from-iso (list 1 1 year))) 7))
+ (% date 7)
+ year)))
+
+(defun calendar-iso-date-string (&optional date)
+ "String of ISO date of Gregorian DATE.
+Defaults to today's date if DATE is not given."
+ (let* ((d (calendar-absolute-from-gregorian
+ (or date (calendar-current-date))))
+ (day (% d 7))
+ (iso-date (calendar-iso-from-absolute d)))
+ (format "Day %s of week %d of %d"
+ (if (zerop day) 7 day)
+ (extract-calendar-month iso-date)
+ (extract-calendar-year iso-date))))
+
+(defun calendar-print-iso-date ()
+ "Show equivalent ISO date for the date under the cursor."
+ (interactive)
+ (message "ISO date: %s"
+ (calendar-iso-date-string (calendar-cursor-to-date t))))
+
+(defun calendar-goto-iso-date (date &optional noecho)
+ "Move cursor to ISO DATE; echo ISO date unless NOECHO is t."
+ (interactive
+ (let* ((today (calendar-current-date))
+ (year (calendar-read
+ "ISO calendar year (>0): "
+ '(lambda (x) (> x 0))
+ (int-to-string (extract-calendar-year today))))
+ (no-weeks (extract-calendar-month
+ (calendar-iso-from-absolute
+ (1-
+ (calendar-dayname-on-or-before
+ 1 (calendar-absolute-from-gregorian
+ (list 1 4 (1+ year))))))))
+ (week (calendar-read
+ (format "ISO calendar week (1-%d): " no-weeks)
+ '(lambda (x) (and (> x 0) (<= x no-weeks)))))
+ (day (calendar-read
+ "ISO day (1-7): "
+ '(lambda (x) (and (<= 1 x) (<= x 7))))))
+ (list (list week day year))))
+ (calendar-goto-date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-iso date)))
+ (or noecho (calendar-print-iso-date)))
+
+(defun diary-iso-date ()
+ "ISO calendar equivalent of date diary entry."
+ (format "ISO date: %s" (calendar-iso-date-string date)))
+
+(provide 'cal-iso)
+
+;;; cal-iso.el ends here
--- /dev/null
+;;; cal-julian.el --- calendar functions for the Julian calendar.
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+
+;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
+;; Keywords: calendar
+;; Human-Keywords: Julian calendar, Julian day number, calendar, diary
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This collection of functions implements the features of calendar.el and
+;; diary.el that deal with the Julian calendar.
+
+;; Comments, corrections, and improvements should be sent to
+;; Edward M. Reingold Department of Computer Science
+;; (217) 333-6733 University of Illinois at Urbana-Champaign
+;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
+;; Urbana, Illinois 61801
+
+;;; Code:
+
+(require 'calendar)
+
+(defun calendar-julian-from-absolute (date)
+ "Compute the Julian (month day year) corresponding to the absolute DATE.
+The absolute date is the number of days elapsed since the (imaginary)
+Gregorian date Sunday, December 31, 1 BC."
+ (let* ((approx (/ (+ date 2) 366));; Approximation from below.
+ (year ;; Search forward from the approximation.
+ (+ approx
+ (calendar-sum y approx
+ (>= date (calendar-absolute-from-julian (list 1 1 (1+ y))))
+ 1)))
+ (month ;; Search forward from January.
+ (1+ (calendar-sum m 1
+ (> date
+ (calendar-absolute-from-julian
+ (list m
+ (if (and (= m 2) (= (% year 4) 0))
+ 29
+ (aref [31 28 31 30 31 30 31 31 30 31 30 31]
+ (1- m)))
+ year)))
+ 1)))
+ (day ;; Calculate the day by subtraction.
+ (- date (1- (calendar-absolute-from-julian (list month 1 year))))))
+ (list month day year)))
+
+(defun calendar-absolute-from-julian (date)
+ "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
+The Gregorian date Sunday, December 31, 1 BC is imaginary."
+ (let ((month (extract-calendar-month date))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date)))
+ (+ (calendar-day-number date)
+ (if (and (= (% year 100) 0)
+ (/= (% year 400) 0)
+ (> month 2))
+ 1 0);; Correct for Julian but not Gregorian leap year.
+ (* 365 (1- year))
+ (/ (1- year) 4)
+ -2)))
+
+(defun calendar-julian-date-string (&optional date)
+ "String of Julian date of Gregorian DATE.
+Defaults to today's date if DATE is not given.
+Driven by the variable `calendar-date-display-form'."
+ (calendar-date-string
+ (calendar-julian-from-absolute
+ (calendar-absolute-from-gregorian
+ (or date (calendar-current-date))))
+ nil t))
+
+(defun calendar-print-julian-date ()
+ "Show the Julian calendar equivalent of the date under the cursor."
+ (interactive)
+ (message "Julian date: %s"
+ (calendar-julian-date-string (calendar-cursor-to-date t))))
+
+(defun calendar-goto-julian-date (date &optional noecho)
+ "Move cursor to Julian DATE; echo Julian date unless NOECHO is t."
+ (interactive
+ (let* ((today (calendar-current-date))
+ (year (calendar-read
+ "Julian calendar year (>0): "
+ '(lambda (x) (> x 0))
+ (int-to-string
+ (extract-calendar-year
+ (calendar-julian-from-absolute
+ (calendar-absolute-from-gregorian
+ today))))))
+ (month-array calendar-month-name-array)
+ (completion-ignore-case t)
+ (month (cdr (assoc
+ (capitalize
+ (completing-read
+ "Julian calendar month name: "
+ (mapcar 'list (append month-array nil))
+ nil t))
+ (calendar-make-alist month-array 1 'capitalize))))
+ (last
+ (if (and (zerop (% year 4)) (= month 2))
+ 29
+ (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
+ (day (calendar-read
+ (format "Julian calendar day (%d-%d): "
+ (if (and (= year 1) (= month 1)) 3 1) last)
+ '(lambda (x)
+ (and (< (if (and (= year 1) (= month 1)) 2 0) x)
+ (<= x last))))))
+ (list (list month day year))))
+ (calendar-goto-date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-julian date)))
+ (or noecho (calendar-print-julian-date)))
+
+(defun holiday-julian (month day string)
+ "Holiday on MONTH, DAY (Julian) called STRING.
+If MONTH, DAY (Julian) is visible, the value returned is corresponding
+Gregorian date in the form of the list (((month day year) STRING)). Returns
+nil if it is not visible in the current calendar window."
+ (let ((m1 displayed-month)
+ (y1 displayed-year)
+ (m2 displayed-month)
+ (y2 displayed-year)
+ (year))
+ (increment-calendar-month m1 y1 -1)
+ (increment-calendar-month m2 y2 1)
+ (let* ((start-date (calendar-absolute-from-gregorian
+ (list m1 1 y1)))
+ (end-date (calendar-absolute-from-gregorian
+ (list m2 (calendar-last-day-of-month m2 y2) y2)))
+ (julian-start (calendar-julian-from-absolute start-date))
+ (julian-end (calendar-julian-from-absolute end-date))
+ (julian-y1 (extract-calendar-year julian-start))
+ (julian-y2 (extract-calendar-year julian-end)))
+ (setq year (if (< 10 month) julian-y1 julian-y2))
+ (let ((date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-julian
+ (list month day year)))))
+ (if (calendar-date-is-visible-p date)
+ (list (list date string)))))))
+
+(defun diary-julian-date ()
+ "Julian calendar equivalent of date diary entry."
+ (format "Julian date: %s" (calendar-julian-date-string date)))
+
+(defun calendar-absolute-from-astro (d)
+ "Absolute date of astronical (Julian) day number D."
+ (- d 1721424.5))
+
+(defun calendar-astro-from-absolute (d)
+ "Astronomical (Julian) day number of absolute date D."
+ (+ d 1721424.5))
+
+(defun calendar-astro-date-string (&optional date)
+ "String of astronomical (Julian) day number after noon UTC of Gregorian DATE.
+Defaults to today's date if DATE is not given."
+ (int-to-string
+ (ceiling
+ (calendar-astro-from-absolute
+ (calendar-absolute-from-gregorian
+ (or date (calendar-current-date)))))))
+
+(defun calendar-print-astro-day-number ()
+ "Show astronomical (Julian) day number after noon UTC on date shown by cursor."
+ (interactive)
+ (message
+ "Astronomical (Julian) day number (after noon UTC): %s"
+ (calendar-astro-date-string (calendar-cursor-to-date t))))
+
+(defun calendar-goto-astro-day-number (daynumber &optional noecho)
+ "Move cursor to astronomical (Julian) DAYNUMBER.
+Echo astronomical (Julian) day number unless NOECHO is t."
+ (interactive (list (calendar-read
+ "Astronomical (Julian) day number (>1721425): "
+ '(lambda (x) (> x 1721425)))))
+ (calendar-goto-date
+ (calendar-gregorian-from-absolute
+ (floor
+ (calendar-absolute-from-astro daynumber))))
+ (or noecho (calendar-print-astro-day-number)))
+
+(defun diary-astro-day-number ()
+ "Astronomical (Julian) day number diary entry."
+ (format "Astronomical (Julian) day number %s"
+ (calendar-astro-date-string date)))
+
+(provide 'cal-julian)
+
+;;; cal-julian.el ends here
--- /dev/null
+;;; cal-move.el --- calendar functions for movement in the calendar
+
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+
+;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
+;; Keywords: calendar
+;; Human-Keywords: calendar
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This collection of functions implements movement in the calendar for
+;; calendar.el.
+
+;; Comments, corrections, and improvements should be sent to
+;; Edward M. Reingold Department of Computer Science
+;; (217) 333-6733 University of Illinois at Urbana-Champaign
+;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
+;; Urbana, Illinois 61801
+
+;;; Code:
+
+(defun calendar-goto-today ()
+ "Reposition the calendar window so the current date is visible."
+ (interactive)
+ (let ((today (calendar-current-date)));; The date might have changed.
+ (if (not (calendar-date-is-visible-p today))
+ (generate-calendar-window)
+ (update-calendar-mode-line)
+ (calendar-cursor-to-visible-date today))))
+
+(defun calendar-forward-month (arg)
+ "Move the cursor forward ARG months.
+Movement is backward if ARG is negative."
+ (interactive "p")
+ (calendar-cursor-to-nearest-date)
+ (let* ((cursor-date (calendar-cursor-to-date t))
+ (month (extract-calendar-month cursor-date))
+ (day (extract-calendar-day cursor-date))
+ (year (extract-calendar-year cursor-date)))
+ (increment-calendar-month month year arg)
+ (let ((last (calendar-last-day-of-month month year)))
+ (if (< last day)
+ (setq day last)))
+ ;; Put the new month on the screen, if needed, and go to the new date.
+ (let ((new-cursor-date (list month day year)))
+ (if (not (calendar-date-is-visible-p new-cursor-date))
+ (calendar-other-month month year))
+ (calendar-cursor-to-visible-date new-cursor-date))))
+
+(defun calendar-forward-year (arg)
+ "Move the cursor forward by ARG years.
+Movement is backward if ARG is negative."
+ (interactive "p")
+ (calendar-forward-month (* 12 arg)))
+
+(defun calendar-backward-month (arg)
+ "Move the cursor backward by ARG months.
+Movement is forward if ARG is negative."
+ (interactive "p")
+ (calendar-forward-month (- arg)))
+
+(defun calendar-backward-year (arg)
+ "Move the cursor backward ARG years.
+Movement is forward is ARG is negative."
+ (interactive "p")
+ (calendar-forward-month (* -12 arg)))
+
+(defun scroll-calendar-left (arg)
+ "Scroll the displayed calendar left by ARG months.
+If ARG is negative the calendar is scrolled right. Maintains the relative
+position of the cursor with respect to the calendar as well as possible."
+ (interactive "p")
+ (calendar-cursor-to-nearest-date)
+ (let ((old-date (calendar-cursor-to-date))
+ (today (calendar-current-date)))
+ (if (/= arg 0)
+ (progn
+ (increment-calendar-month displayed-month displayed-year arg)
+ (generate-calendar-window displayed-month displayed-year)
+ (calendar-cursor-to-visible-date
+ (cond
+ ((calendar-date-is-visible-p old-date) old-date)
+ ((calendar-date-is-visible-p today) today)
+ (t (list displayed-month 1 displayed-year))))))))
+
+(defun scroll-calendar-right (arg)
+ "Scroll the displayed calendar window right by ARG months.
+If ARG is negative the calendar is scrolled left. Maintains the relative
+position of the cursor with respect to the calendar as well as possible."
+ (interactive "p")
+ (scroll-calendar-left (- arg)))
+
+(defun scroll-calendar-left-three-months (arg)
+ "Scroll the displayed calendar window left by 3*ARG months.
+If ARG is negative the calendar is scrolled right. Maintains the relative
+position of the cursor with respect to the calendar as well as possible."
+ (interactive "p")
+ (scroll-calendar-left (* 3 arg)))
+
+(defun scroll-calendar-right-three-months (arg)
+ "Scroll the displayed calendar window right by 3*ARG months.
+If ARG is negative the calendar is scrolled left. Maintains the relative
+position of the cursor with respect to the calendar as well as possible."
+ (interactive "p")
+ (scroll-calendar-left (* -3 arg)))
+
+(defun calendar-cursor-to-nearest-date ()
+ "Move the cursor to the closest date.
+The position of the cursor is unchanged if it is already on a date.
+Returns the list (month day year) giving the cursor position."
+ (let ((date (calendar-cursor-to-date))
+ (column (current-column)))
+ (if date
+ date
+ (if (> 3 (count-lines (point-min) (point)))
+ (progn
+ (goto-line 3)
+ (move-to-column column)))
+ (if (not (looking-at "[0-9]"))
+ (if (and (not (looking-at " *$"))
+ (or (< column 25)
+ (and (> column 27)
+ (< column 50))
+ (and (> column 52)
+ (< column 75))))
+ (progn
+ (re-search-forward "[0-9]" nil t)
+ (backward-char 1))
+ (re-search-backward "[0-9]" nil t)))
+ (calendar-cursor-to-date))))
+
+(defun calendar-forward-day (arg)
+ "Move the cursor forward ARG days.
+Moves backward if ARG is negative."
+ (interactive "p")
+ (if (/= 0 arg)
+ (let*
+ ((cursor-date (calendar-cursor-to-date))
+ (cursor-date (if cursor-date
+ cursor-date
+ (if (> arg 0) (setq arg (1- arg)))
+ (calendar-cursor-to-nearest-date)))
+ (new-cursor-date
+ (calendar-gregorian-from-absolute
+ (+ (calendar-absolute-from-gregorian cursor-date) arg)))
+ (new-display-month (extract-calendar-month new-cursor-date))
+ (new-display-year (extract-calendar-year new-cursor-date)))
+ ;; Put the new month on the screen, if needed, and go to the new date.
+ (if (not (calendar-date-is-visible-p new-cursor-date))
+ (calendar-other-month new-display-month new-display-year))
+ (calendar-cursor-to-visible-date new-cursor-date))))
+
+(defun calendar-backward-day (arg)
+ "Move the cursor back ARG days.
+Moves forward if ARG is negative."
+ (interactive "p")
+ (calendar-forward-day (- arg)))
+
+(defun calendar-forward-week (arg)
+ "Move the cursor forward ARG weeks.
+Moves backward if ARG is negative."
+ (interactive "p")
+ (calendar-forward-day (* arg 7)))
+
+(defun calendar-backward-week (arg)
+ "Move the cursor back ARG weeks.
+Moves forward if ARG is negative."
+ (interactive "p")
+ (calendar-forward-day (* arg -7)))
+
+(defun calendar-beginning-of-week (arg)
+ "Move the cursor back ARG calendar-week-start-day's."
+ (interactive "p")
+ (calendar-cursor-to-nearest-date)
+ (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
+ (calendar-backward-day
+ (if (= day calendar-week-start-day)
+ (* 7 arg)
+ (+ (mod (- day calendar-week-start-day) 7)
+ (* 7 (1- arg)))))))
+
+(defun calendar-end-of-week (arg)
+ "Move the cursor forward ARG calendar-week-start-day+6's."
+ (interactive "p")
+ (calendar-cursor-to-nearest-date)
+ (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
+ (calendar-forward-day
+ (if (= day (mod (1- calendar-week-start-day) 7))
+ (* 7 arg)
+ (+ (- 6 (mod (- day calendar-week-start-day) 7))
+ (* 7 (1- arg)))))))
+
+(defun calendar-beginning-of-month (arg)
+ "Move the cursor backward ARG month beginnings."
+ (interactive "p")
+ (calendar-cursor-to-nearest-date)
+ (let* ((date (calendar-cursor-to-date))
+ (month (extract-calendar-month date))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date)))
+ (if (= day 1)
+ (calendar-backward-month arg)
+ (calendar-cursor-to-visible-date (list month 1 year))
+ (calendar-backward-month (1- arg)))))
+
+(defun calendar-end-of-month (arg)
+ "Move the cursor forward ARG month ends."
+ (interactive "p")
+ (calendar-cursor-to-nearest-date)
+ (let* ((date (calendar-cursor-to-date))
+ (month (extract-calendar-month date))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date))
+ (last-day (calendar-last-day-of-month month year)))
+ (if (/= day last-day)
+ (progn
+ (calendar-cursor-to-visible-date (list month last-day year))
+ (setq arg (1- arg))))
+ (increment-calendar-month month year arg)
+ (let ((last-day (list
+ month
+ (calendar-last-day-of-month month year)
+ year)))
+ (if (not (calendar-date-is-visible-p last-day))
+ (calendar-other-month month year)
+ (calendar-cursor-to-visible-date last-day)))))
+
+(defun calendar-beginning-of-year (arg)
+ "Move the cursor backward ARG year beginnings."
+ (interactive "p")
+ (calendar-cursor-to-nearest-date)
+ (let* ((date (calendar-cursor-to-date))
+ (month (extract-calendar-month date))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date))
+ (jan-first (list 1 1 year)))
+ (if (and (= day 1) (= 1 month))
+ (calendar-backward-month (* 12 arg))
+ (if (and (= arg 1)
+ (calendar-date-is-visible-p jan-first))
+ (calendar-cursor-to-visible-date jan-first)
+ (calendar-other-month 1 (- year (1- arg)))))))
+
+(defun calendar-end-of-year (arg)
+ "Move the cursor forward ARG year beginnings."
+ (interactive "p")
+ (calendar-cursor-to-nearest-date)
+ (let* ((date (calendar-cursor-to-date))
+ (month (extract-calendar-month date))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date))
+ (dec-31 (list 12 31 year)))
+ (if (and (= day 31) (= 12 month))
+ (calendar-forward-month (* 12 arg))
+ (if (and (= arg 1)
+ (calendar-date-is-visible-p dec-31))
+ (calendar-cursor-to-visible-date dec-31)
+ (calendar-other-month 12 (- year (1- arg)))
+ (calendar-cursor-to-visible-date (list 12 31 displayed-year))))))
+
+(defun calendar-cursor-to-visible-date (date)
+ "Move the cursor to DATE that is on the screen."
+ (let* ((month (extract-calendar-month date))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date))
+ (first-of-month-weekday (calendar-day-of-week (list month 1 year))))
+ (goto-line (+ 3
+ (/ (+ day -1
+ (mod
+ (- (calendar-day-of-week (list month 1 year))
+ calendar-week-start-day)
+ 7))
+ 7)))
+ (move-to-column (+ 6
+ (* 25
+ (1+ (calendar-interval
+ displayed-month displayed-year month year)))
+ (* 3 (mod
+ (- (calendar-day-of-week date)
+ calendar-week-start-day)
+ 7))))))
+
+(defun calendar-goto-date (date)
+ "Move cursor to DATE."
+ (interactive (list (calendar-read-date)))
+ (let ((month (extract-calendar-month date))
+ (year (extract-calendar-year date)))
+ (if (not (calendar-date-is-visible-p date))
+ (calendar-other-month
+ (if (and (= month 1) (= year 1))
+ 2
+ month)
+ year)))
+ (calendar-cursor-to-visible-date date))
+
+(provide 'cal-move)
+
+;;; cal-move.el ends here
--- /dev/null
+;;; diary.el --- diary functions.
+
+;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995 Free Software Foundation,
+;; Inc.
+
+;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
+;; Keywords: calendar
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This collection of functions implements the diary features as described
+;; in calendar.el.
+
+;; Comments, corrections, and improvements should be sent to
+;; Edward M. Reingold Department of Computer Science
+;; (217) 333-6733 University of Illinois at Urbana-Champaign
+;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
+;; Urbana, Illinois 61801
+
+;;; Code:
+
+(require 'calendar)
+
+;;;###autoload
+(defun diary (&optional arg)
+ "Generate the diary window for ARG days starting with the current date.
+If no argument is provided, the number of days of diary entries is governed
+by the variable `number-of-diary-entries'. This function is suitable for
+execution in a `.emacs' file."
+ (interactive "P")
+ (let ((d-file (substitute-in-file-name diary-file))
+ (date (calendar-current-date)))
+ (if (and d-file (file-exists-p d-file))
+ (if (file-readable-p d-file)
+ (list-diary-entries
+ date
+ (cond
+ (arg (prefix-numeric-value arg))
+ ((vectorp number-of-diary-entries)
+ (aref number-of-diary-entries (calendar-day-of-week date)))
+ (t number-of-diary-entries)))
+ (error "Your diary file is not readable!"))
+ (error "You don't have a diary file!"))))
+
+(defun view-diary-entries (arg)
+ "Prepare and display a buffer with diary entries.
+Searches the file named in `diary-file' for entries that
+match ARG days starting with the date indicated by the cursor position
+in the displayed three-month calendar."
+ (interactive "p")
+ (let ((d-file (substitute-in-file-name diary-file)))
+ (if (and d-file (file-exists-p d-file))
+ (if (file-readable-p d-file)
+ (list-diary-entries (calendar-cursor-to-date t) arg)
+ (error "Diary file is not readable!"))
+ (error "You don't have a diary file!"))))
+
+(defun view-other-diary-entries (arg diary-file)
+ "Prepare and display buffer of diary entries from an alternative diary file.
+Prompts for a file name and searches that file for entries that match ARG
+days starting with the date indicated by the cursor position in the displayed
+three-month calendar."
+ (interactive
+ (list (cond ((null current-prefix-arg) 1)
+ ((listp current-prefix-arg) (car current-prefix-arg))
+ (t current-prefix-arg))
+ (setq diary-file (read-file-name "Enter diary file name: "
+ default-directory nil t))))
+ (view-diary-entries arg))
+
+(autoload 'check-calendar-holidays "holidays"
+ "Check the list of holidays for any that occur on DATE.
+The value returned is a list of strings of relevant holiday descriptions.
+The holidays are those in the list `calendar-holidays'."
+ t)
+
+(autoload 'calendar-holiday-list "holidays"
+ "Form the list of holidays that occur on dates in the calendar window.
+The holidays are those in the list `calendar-holidays'."
+ t)
+
+(autoload 'diary-french-date "cal-french"
+ "French calendar equivalent of date diary entry."
+ t)
+
+(autoload 'diary-mayan-date "cal-mayan"
+ "Mayan calendar equivalent of date diary entry."
+ t)
+
+(autoload 'diary-julian-date "cal-julian"
+ "Julian calendar equivalent of date diary entry."
+ t)
+
+(autoload 'diary-astro-day-number "cal-julian"
+ "Astronomical (Julian) day number diary entry."
+ t)
+
+(autoload 'diary-chinese-date "cal-chinese"
+ "Chinese calendar equivalent of date diary entry."
+ t)
+
+(autoload 'diary-islamic-date "cal-islamic"
+ "Islamic calendar equivalent of date diary entry."
+ t)
+
+(autoload 'list-islamic-diary-entries "cal-islamic"
+ "Add any Islamic date entries from the diary file to `diary-entries-list'."
+ t)
+
+(autoload 'mark-islamic-diary-entries "cal-islamic"
+ "Mark days in the calendar window that have Islamic date diary entries."
+ t)
+
+(autoload 'mark-islamic-calendar-date-pattern "cal-islamic"
+ "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR."
+ t)
+
+(autoload 'diary-hebrew-date "cal-hebrew"
+ "Hebrew calendar equivalent of date diary entry."
+ t)
+
+(autoload 'diary-omer "cal-hebrew"
+ "Omer count diary entry."
+ t)
+
+(autoload 'diary-yahrzeit "cal-hebrew"
+ "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before."
+ t)
+
+(autoload 'diary-parasha "cal-hebrew"
+ "Parasha diary entry--entry applies if date is a Saturday."
+ t)
+
+(autoload 'diary-rosh-hodesh "cal-hebrew"
+ "Rosh Hodesh diary entry."
+ t)
+
+(autoload 'list-hebrew-diary-entries "cal-hebrew"
+ "Add any Hebrew date entries from the diary file to `diary-entries-list'."
+ t)
+
+(autoload 'mark-hebrew-diary-entries "cal-hebrew"
+ "Mark days in the calendar window that have Hebrew date diary entries."
+ t)
+
+(autoload 'mark-hebrew-calendar-date-pattern "cal-hebrew"
+ "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR."
+ t)
+
+(autoload 'diary-coptic-date "cal-coptic"
+ "Coptic calendar equivalent of date diary entry."
+ t)
+
+(autoload 'diary-ethiopic-date "cal-coptic"
+ "Ethiopic calendar equivalent of date diary entry."
+ t)
+
+(autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t)
+
+(autoload 'diary-sunrise-sunset "solar"
+ "Local time of sunrise and sunset as a diary entry."
+ t)
+
+(autoload 'diary-sabbath-candles "solar"
+ "Local time of candle lighting diary entry--applies if date is a Friday.
+No diary entry if there is no sunset on that date."
+ t)
+
+(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))
+ "The syntax table used when parsing dates in the diary file.
+It is the standard syntax table used in Fundamental mode, but with the
+syntax of `*' changed to be a word constituent.")
+
+(modify-syntax-entry ?* "w" diary-syntax-table)
+
+(defun list-diary-entries (date number)
+ "Create and display a buffer containing the relevant lines in diary-file.
+The arguments are DATE and NUMBER; the entries selected are those
+for NUMBER days starting with date DATE. The other entries are hidden
+using selective display.
+
+Returns a list of all relevant diary entries found, if any, in order by date.
+The list entries have the form ((month day year) string). If the variable
+`diary-list-include-blanks' is t, this list includes a dummy diary entry
+\(consisting of the empty string) for a date with no diary entries.
+
+After the list is prepared, the hooks `nongregorian-diary-listing-hook',
+`list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run.
+These hooks have the following distinct roles:
+
+ `nongregorian-diary-listing-hook' can cull dates from the diary
+ and each included file. Usually used for Hebrew or Islamic
+ diary entries in files. Applied to *each* file.
+
+ `list-diary-entries-hook' adds or manipulates diary entries from
+ external sources. Used, for example, to include diary entries
+ from other files or to sort the diary entries. Invoked *once* only,
+ before the display hook is run.
+
+ `diary-display-hook' does the actual display of information. If this is
+ nil, simple-diary-display will be used. Use add-hook to set this to
+ fancy-diary-display, if desired. If you want no diary display, use
+ add-hook to set this to ignore.
+
+ `diary-hook' is run last. This can be used for an appointment
+ notification function."
+
+ (if (< 0 number)
+ (let* ((original-date date);; save for possible use in the hooks
+ (old-diary-syntax-table)
+ (diary-entries-list)
+ (date-string (calendar-date-string date))
+ (d-file (substitute-in-file-name diary-file)))
+ (message "Preparing diary...")
+ (save-excursion
+ (let ((diary-buffer (get-file-buffer d-file)))
+ (set-buffer (if diary-buffer
+ diary-buffer
+ (find-file-noselect d-file t))))
+ (setq selective-display t)
+ (setq selective-display-ellipses nil)
+ (setq old-diary-syntax-table (syntax-table))
+ (set-syntax-table diary-syntax-table)
+ (unwind-protect
+ (let ((buffer-read-only nil)
+ (diary-modified (buffer-modified-p))
+ (mark (regexp-quote diary-nonmarking-symbol)))
+ (goto-char (1- (point-max)))
+ (if (not (looking-at "\^M\\|\n"))
+ (progn
+ (forward-char 1)
+ (insert-string "\^M")))
+ (goto-char (point-min))
+ (if (not (looking-at "\^M\\|\n"))
+ (insert-string "\^M"))
+ (subst-char-in-region (point-min) (point-max) ?\n ?\^M t)
+ (calendar-for-loop i from 1 to number do
+ (let ((d diary-date-forms)
+ (month (extract-calendar-month date))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date))
+ (entry-found (list-sexp-diary-entries date)))
+ (while d
+ (let*
+ ((date-form (if (equal (car (car d)) 'backup)
+ (cdr (car d))
+ (car d)))
+ (backup (equal (car (car d)) 'backup))
+ (dayname
+ (concat
+ (calendar-day-name date) "\\|"
+ (substring (calendar-day-name date) 0 3) ".?"))
+ (monthname
+ (concat
+ "\\*\\|"
+ (calendar-month-name month) "\\|"
+ (substring (calendar-month-name month) 0 3) ".?"))
+ (month (concat "\\*\\|0*" (int-to-string month)))
+ (day (concat "\\*\\|0*" (int-to-string day)))
+ (year
+ (concat
+ "\\*\\|0*" (int-to-string year)
+ (if abbreviated-calendar-year
+ (concat "\\|" (int-to-string (% year 100)))
+ "")))
+ (regexp
+ (concat
+ "\\(\\`\\|\^M\\|\n\\)" mark "?\\("
+ (mapconcat 'eval date-form "\\)\\(")
+ "\\)"))
+ (case-fold-search t))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (if backup (re-search-backward "\\<" nil t))
+ (if (and (or (char-equal (preceding-char) ?\^M)
+ (char-equal (preceding-char) ?\n))
+ (not (looking-at " \\|\^I")))
+ ;; Diary entry that consists only of date.
+ (backward-char 1)
+ ;; Found a nonempty diary entry--make it visible and
+ ;; add it to the list.
+ (setq entry-found t)
+ (let ((entry-start (point))
+ (date-start))
+ (re-search-backward "\^M\\|\n\\|\\`")
+ (setq date-start (point))
+ (re-search-forward "\^M\\|\n" nil t 2)
+ (while (looking-at " \\|\^I")
+ (re-search-forward "\^M\\|\n" nil t))
+ (backward-char 1)
+ (subst-char-in-region date-start
+ (point) ?\^M ?\n t)
+ (add-to-diary-list
+ date (buffer-substring entry-start (point)))))))
+ (setq d (cdr d)))
+ (or entry-found
+ (not diary-list-include-blanks)
+ (setq diary-entries-list
+ (append diary-entries-list
+ (list (list date "")))))
+ (setq date
+ (calendar-gregorian-from-absolute
+ (1+ (calendar-absolute-from-gregorian date))))
+ (setq entry-found nil)))
+ (set-buffer-modified-p diary-modified))
+ (set-syntax-table old-diary-syntax-table))
+ (goto-char (point-min))
+ (run-hooks 'nongregorian-diary-listing-hook
+ 'list-diary-entries-hook)
+ (if diary-display-hook
+ (run-hooks 'diary-display-hook)
+ (simple-diary-display))
+ (run-hooks 'diary-hook)
+ diary-entries-list))))
+
+(defun include-other-diary-files ()
+ "Include the diary entries from other diary files with those of diary-file.
+This function is suitable for use in `list-diary-entries-hook';
+it enables you to use shared diary files together with your own.
+The files included are specified in the diaryfile by lines of this form:
+ #include \"filename\"
+This is recursive; that is, #include directives in diary files thus included
+are obeyed. You can change the `#include' to some other string by
+changing the variable `diary-include-string'."
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat
+ "\\(\\`\\|\^M\\|\n\\)"
+ (regexp-quote diary-include-string)
+ " \"\\([^\"]*\\)\"")
+ nil t)
+ (let ((diary-file (substitute-in-file-name
+ (buffer-substring (match-beginning 2) (match-end 2))))
+ (diary-list-include-blanks nil)
+ (list-diary-entries-hook 'include-other-diary-files)
+ (diary-display-hook 'ignore)
+ (diary-hook nil))
+ (if (file-exists-p diary-file)
+ (if (file-readable-p diary-file)
+ (unwind-protect
+ (setq diary-entries-list
+ (append diary-entries-list
+ (list-diary-entries original-date number)))
+ (kill-buffer (get-file-buffer diary-file)))
+ (beep)
+ (message "Can't read included diary file %s" diary-file)
+ (sleep-for 2))
+ (beep)
+ (message "Can't find included diary file %s" diary-file)
+ (sleep-for 2))))
+ (goto-char (point-min)))
+
+(defun simple-diary-display ()
+ "Display the diary buffer if there are any relevant entries or holidays."
+ (let* ((holiday-list (if holidays-in-diary-buffer
+ (check-calendar-holidays original-date)))
+ (msg (format "No diary entries for %s %s"
+ (concat date-string (if holiday-list ":" ""))
+ (mapconcat 'identity holiday-list "; "))))
+ (if (or (not diary-entries-list)
+ (and (not (cdr diary-entries-list))
+ (string-equal (car (cdr (car diary-entries-list))) "")))
+ (if (<= (length msg) (frame-width))
+ (message msg)
+ (set-buffer (get-buffer-create holiday-buffer))
+ (setq buffer-read-only nil)
+ (calendar-set-mode-line date-string)
+ (erase-buffer)
+ (insert (mapconcat 'identity holiday-list "\n"))
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (display-buffer holiday-buffer)
+ (message "No diary entries for %s" date-string))
+ (calendar-set-mode-line
+ (concat "Diary for " date-string
+ (if holiday-list ": " "")
+ (mapconcat 'identity holiday-list "; ")))
+ (display-buffer (get-file-buffer d-file))
+ (message "Preparing diary...done"))))
+
+(defun fancy-diary-display ()
+ "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
+This function is provided for optional use as the `diary-display-hook'."
+ (save-excursion;; Turn off selective-display in the diary file's buffer.
+ (set-buffer (get-file-buffer (substitute-in-file-name diary-file)))
+ (let ((diary-modified (buffer-modified-p)))
+ (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
+ (setq selective-display nil)
+ (kill-local-variable 'mode-line-format)
+ (set-buffer-modified-p diary-modified)))
+ (if (or (not diary-entries-list)
+ (and (not (cdr diary-entries-list))
+ (string-equal (car (cdr (car diary-entries-list))) "")))
+ (let* ((holiday-list (if holidays-in-diary-buffer
+ (check-calendar-holidays original-date)))
+ (msg (format "No diary entries for %s %s"
+ (concat date-string (if holiday-list ":" ""))
+ (mapconcat 'identity holiday-list "; "))))
+ (if (<= (length msg) (frame-width))
+ (message msg)
+ (set-buffer (get-buffer-create holiday-buffer))
+ (setq buffer-read-only nil)
+ (calendar-set-mode-line date-string)
+ (erase-buffer)
+ (insert (mapconcat 'identity holiday-list "\n"))
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (display-buffer holiday-buffer)
+ (message "No diary entries for %s" date-string)))
+ (save-excursion;; Prepare the fancy diary buffer.
+ (set-buffer (make-fancy-diary-buffer))
+ (setq buffer-read-only nil)
+ (let ((entry-list diary-entries-list)
+ (holiday-list)
+ (holiday-list-last-month 1)
+ (holiday-list-last-year 1)
+ (date (list 0 0 0)))
+ (while entry-list
+ (if (not (calendar-date-equal date (car (car entry-list))))
+ (progn
+ (setq date (car (car entry-list)))
+ (and holidays-in-diary-buffer
+ (calendar-date-compare
+ (list (list holiday-list-last-month
+ (calendar-last-day-of-month
+ holiday-list-last-month
+ holiday-list-last-year)
+ holiday-list-last-year))
+ (list date))
+ ;; We need to get the holidays for the next 3 months.
+ (setq holiday-list-last-month
+ (extract-calendar-month date))
+ (setq holiday-list-last-year
+ (extract-calendar-year date))
+ (increment-calendar-month
+ holiday-list-last-month holiday-list-last-year 1)
+ (setq holiday-list
+ (let ((displayed-month holiday-list-last-month)
+ (displayed-year holiday-list-last-year))
+ (calendar-holiday-list)))
+ (increment-calendar-month
+ holiday-list-last-month holiday-list-last-year 1))
+ (let* ((date-string (calendar-date-string date))
+ (date-holiday-list
+ (let ((h holiday-list)
+ (d))
+ ;; Make a list of all holidays for date.
+ (while h
+ (if (calendar-date-equal date (car (car h)))
+ (setq d (append d (cdr (car h)))))
+ (setq h (cdr h)))
+ d)))
+ (insert (if (= (point) (point-min)) "" ?\n) date-string)
+ (if date-holiday-list (insert ": "))
+ (let ((l (current-column)))
+ (insert (mapconcat 'identity date-holiday-list
+ (concat "\n" (make-string l ? )))))
+ (let ((l (current-column)))
+ (insert ?\n (make-string l ?=) ?\n)))))
+ (if (< 0 (length (car (cdr (car entry-list)))))
+ (insert (car (cdr (car entry-list))) ?\n))
+ (setq entry-list (cdr entry-list))))
+ (set-buffer-modified-p nil)
+ (goto-char (point-min))
+ (setq buffer-read-only t)
+ (display-buffer fancy-diary-buffer)
+ (message "Preparing diary...done"))))
+
+(defun make-fancy-diary-buffer ()
+ "Create and return the initial fancy diary buffer."
+ (save-excursion
+ (set-buffer (get-buffer-create fancy-diary-buffer))
+ (setq buffer-read-only nil)
+ (make-local-variable 'mode-line-format)
+ (calendar-set-mode-line "Diary Entries")
+ (erase-buffer)
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (get-buffer fancy-diary-buffer)))
+
+(defun print-diary-entries ()
+ "Print a hard copy of the diary display.
+
+If the simple diary display is being used, prepare a temp buffer with the
+visible lines of the diary buffer, add a heading line composed from the mode
+line, print the temp buffer, and destroy it.
+
+If the fancy diary display is being used, just print the buffer.
+
+The hooks given by the variable `print-diary-entries-hook' are called to do
+the actual printing."
+ (interactive)
+ (if (bufferp (get-buffer fancy-diary-buffer))
+ (save-excursion
+ (set-buffer (get-buffer fancy-diary-buffer))
+ (run-hooks 'print-diary-entries-hook))
+ (let ((diary-buffer
+ (get-file-buffer (substitute-in-file-name diary-file))))
+ (if diary-buffer
+ (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))
+ (heading))
+ (save-excursion
+ (set-buffer diary-buffer)
+ (setq heading
+ (if (not (stringp mode-line-format))
+ "All Diary Entries"
+ (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format)
+ (substring mode-line-format
+ (match-beginning 1) (match-end 1))))
+ (copy-to-buffer temp-buffer (point-min) (point-max))
+ (set-buffer temp-buffer)
+ (while (re-search-forward "\^M.*$" nil t)
+ (replace-match ""))
+ (goto-char (point-min))
+ (insert heading "\n"
+ (make-string (length heading) ?=) "\n")
+ (run-hooks 'print-diary-entries-hook)
+ (kill-buffer temp-buffer)))
+ (error "You don't have a diary buffer!")))))
+
+(defun show-all-diary-entries ()
+ "Show all of the diary entries in the diary file.
+This function gets rid of the selective display of the diary file so that
+all entries, not just some, are visible. If there is no diary buffer, one
+is created."
+ (interactive)
+ (let ((d-file (substitute-in-file-name diary-file)))
+ (if (and d-file (file-exists-p d-file))
+ (if (file-readable-p d-file)
+ (save-excursion
+ (let ((diary-buffer (get-file-buffer d-file)))
+ (set-buffer (if diary-buffer
+ diary-buffer
+ (find-file-noselect d-file t)))
+ (let ((buffer-read-only nil)
+ (diary-modified (buffer-modified-p)))
+ (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
+ (setq selective-display nil)
+ (make-local-variable 'mode-line-format)
+ (setq mode-line-format default-mode-line-format)
+ (display-buffer (current-buffer))
+ (set-buffer-modified-p diary-modified))))
+ (error "Your diary file is not readable!"))
+ (error "You don't have a diary file!"))))
+
+(defun diary-name-pattern (string-array &optional fullname)
+ "Convert an STRING-ARRAY, an array of strings to a pattern.
+The pattern will match any of the strings, either entirely or abbreviated
+to three characters. An abbreviated form will match with or without a period;
+If the optional FULLNAME is t, abbreviations will not match, just the full
+name."
+ (let ((pattern ""))
+ (calendar-for-loop i from 0 to (1- (length string-array)) do
+ (setq pattern
+ (concat
+ pattern
+ (if (string-equal pattern "") "" "\\|")
+ (aref string-array i)
+ (if fullname
+ ""
+ (concat
+ "\\|"
+ (substring (aref string-array i) 0 3) ".?")))))
+ pattern))
+
+(defvar marking-diary-entries nil
+ "True during the marking of diary entries, nil otherwise.")
+
+(defvar marking-diary-entry nil
+ "True during the marking of diary entries, if current entry is marking.")
+
+(defun mark-diary-entries ()
+ "Mark days in the calendar window that have diary entries.
+Each entry in the diary file visible in the calendar window is marked.
+After the entries are marked, the hooks `nongregorian-diary-marking-hook' and
+`mark-diary-entries-hook' are run."
+ (interactive)
+ (setq mark-diary-entries-in-calendar t)
+ (let ((d-file (substitute-in-file-name diary-file))
+ (marking-diary-entries t))
+ (if (and d-file (file-exists-p d-file))
+ (if (file-readable-p d-file)
+ (save-excursion
+ (message "Marking diary entries...")
+ (set-buffer (find-file-noselect d-file t))
+ (let ((d diary-date-forms)
+ (old-diary-syntax-table))
+ (setq old-diary-syntax-table (syntax-table))
+ (set-syntax-table diary-syntax-table)
+ (while d
+ (let*
+ ((date-form (if (equal (car (car d)) 'backup)
+ (cdr (car d))
+ (car d)));; ignore 'backup directive
+ (dayname (diary-name-pattern calendar-day-name-array))
+ (monthname
+ (concat
+ (diary-name-pattern calendar-month-name-array)
+ "\\|\\*"))
+ (month "[0-9]+\\|\\*")
+ (day "[0-9]+\\|\\*")
+ (year "[0-9]+\\|\\*")
+ (l (length date-form))
+ (d-name-pos (- l (length (memq 'dayname date-form))))
+ (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
+ (m-name-pos (- l (length (memq 'monthname date-form))))
+ (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
+ (d-pos (- l (length (memq 'day date-form))))
+ (d-pos (if (/= l d-pos) (+ 2 d-pos)))
+ (m-pos (- l (length (memq 'month date-form))))
+ (m-pos (if (/= l m-pos) (+ 2 m-pos)))
+ (y-pos (- l (length (memq 'year date-form))))
+ (y-pos (if (/= l y-pos) (+ 2 y-pos)))
+ (regexp
+ (concat
+ "\\(\\`\\|\^M\\|\n\\)\\("
+ (mapconcat 'eval date-form "\\)\\(")
+ "\\)"))
+ (case-fold-search t))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (let* ((dd-name
+ (if d-name-pos
+ (buffer-substring
+ (match-beginning d-name-pos)
+ (match-end d-name-pos))))
+ (mm-name
+ (if m-name-pos
+ (buffer-substring
+ (match-beginning m-name-pos)
+ (match-end m-name-pos))))
+ (mm (string-to-int
+ (if m-pos
+ (buffer-substring
+ (match-beginning m-pos)
+ (match-end m-pos))
+ "")))
+ (dd (string-to-int
+ (if d-pos
+ (buffer-substring
+ (match-beginning d-pos)
+ (match-end d-pos))
+ "")))
+ (y-str (if y-pos
+ (buffer-substring
+ (match-beginning y-pos)
+ (match-end y-pos))))
+ (yy (if (not y-str)
+ 0
+ (if (and (= (length y-str) 2)
+ abbreviated-calendar-year)
+ (let* ((current-y
+ (extract-calendar-year
+ (calendar-current-date)))
+ (y (+ (string-to-int y-str)
+ (* 100
+ (/ current-y 100)))))
+ (if (> (- y current-y) 50)
+ (- y 100)
+ (if (> (- current-y y) 50)
+ (+ y 100)
+ y)))
+ (string-to-int y-str)))))
+ (if dd-name
+ (mark-calendar-days-named
+ (cdr (assoc (capitalize (substring dd-name 0 3))
+ (calendar-make-alist
+ calendar-day-name-array
+ 0
+ '(lambda (x) (substring x 0 3))))))
+ (if mm-name
+ (if (string-equal mm-name "*")
+ (setq mm 0)
+ (setq mm
+ (cdr (assoc
+ (capitalize
+ (substring mm-name 0 3))
+ (calendar-make-alist
+ calendar-month-name-array
+ 1
+ '(lambda (x) (substring x 0 3)))
+ )))))
+ (mark-calendar-date-pattern mm dd yy))))
+ (setq d (cdr d))))
+ (mark-sexp-diary-entries)
+ (run-hooks 'nongregorian-diary-marking-hook
+ 'mark-diary-entries-hook)
+ (set-syntax-table old-diary-syntax-table)
+ (message "Marking diary entries...done")))
+ (error "Your diary file is not readable!"))
+ (error "You don't have a diary file!"))))
+
+(defun mark-sexp-diary-entries ()
+ "Mark days in the calendar window that have sexp diary entries.
+Each entry in the diary file (or included files) visible in the calendar window
+is marked. See the documentation for the function `list-sexp-diary-entries'."
+ (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
+ (s-entry (concat "\\(\\`\\|\^M\\|\n\\)\\("
+ (regexp-quote sexp-mark) "(\\)\\|\\("
+ (regexp-quote diary-nonmarking-symbol)
+ (regexp-quote sexp-mark) "(diary-remind\\)"))
+ (m)
+ (y)
+ (first-date)
+ (last-date))
+ (save-excursion
+ (set-buffer calendar-buffer)
+ (setq m displayed-month)
+ (setq y displayed-year))
+ (increment-calendar-month m y -1)
+ (setq first-date
+ (calendar-absolute-from-gregorian (list m 1 y)))
+ (increment-calendar-month m y 2)
+ (setq last-date
+ (calendar-absolute-from-gregorian
+ (list m (calendar-last-day-of-month m y) y)))
+ (goto-char (point-min))
+ (while (re-search-forward s-entry nil t)
+ (if (char-equal (preceding-char) ?()
+ (setq marking-diary-entry t)
+ (setq marking-diary-entry nil))
+ (re-search-backward "(")
+ (let ((sexp-start (point))
+ (sexp)
+ (entry)
+ (entry-start)
+ (line-start))
+ (forward-sexp)
+ (setq sexp (buffer-substring sexp-start (point)))
+ (save-excursion
+ (re-search-backward "\^M\\|\n\\|\\`")
+ (setq line-start (point)))
+ (forward-char 1)
+ (if (and (or (char-equal (preceding-char) ?\^M)
+ (char-equal (preceding-char) ?\n))
+ (not (looking-at " \\|\^I")))
+ (progn;; Diary entry consists only of the sexp
+ (backward-char 1)
+ (setq entry ""))
+ (setq entry-start (point))
+ (re-search-forward "\^M\\|\n" nil t)
+ (while (looking-at " \\|\^I")
+ (re-search-forward "\^M\\|\n" nil t))
+ (backward-char 1)
+ (setq entry (buffer-substring entry-start (point)))
+ (while (string-match "[\^M]" entry)
+ (aset entry (match-beginning 0) ?\n )))
+ (calendar-for-loop date from first-date to last-date do
+ (if (diary-sexp-entry sexp entry
+ (calendar-gregorian-from-absolute date))
+ (mark-visible-calendar-date
+ (calendar-gregorian-from-absolute date))))))))
+
+(defun mark-included-diary-files ()
+ "Mark the diary entries from other diary files with those of the diary file.
+This function is suitable for use as the `mark-diary-entries-hook'; it enables
+you to use shared diary files together with your own. The files included are
+specified in the diary-file by lines of this form:
+ #include \"filename\"
+This is recursive; that is, #include directives in diary files thus included
+are obeyed. You can change the `#include' to some other string by
+changing the variable `diary-include-string'."
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat
+ "\\(\\`\\|\^M\\|\n\\)"
+ (regexp-quote diary-include-string)
+ " \"\\([^\"]*\\)\"")
+ nil t)
+ (let ((diary-file (substitute-in-file-name
+ (buffer-substring (match-beginning 2) (match-end 2))))
+ (mark-diary-entries-hook 'mark-included-diary-files))
+ (if (file-exists-p diary-file)
+ (if (file-readable-p diary-file)
+ (progn
+ (mark-diary-entries)
+ (kill-buffer (get-file-buffer diary-file)))
+ (beep)
+ (message "Can't read included diary file %s" diary-file)
+ (sleep-for 2))
+ (beep)
+ (message "Can't find included diary file %s" diary-file)
+ (sleep-for 2))))
+ (goto-char (point-min)))
+
+(defun mark-calendar-days-named (dayname)
+ "Mark all dates in the calendar window that are day DAYNAME of the week.
+0 means all Sundays, 1 means all Mondays, and so on."
+ (save-excursion
+ (set-buffer calendar-buffer)
+ (let ((prev-month displayed-month)
+ (prev-year displayed-year)
+ (succ-month displayed-month)
+ (succ-year displayed-year)
+ (last-day)
+ (day))
+ (increment-calendar-month succ-month succ-year 1)
+ (increment-calendar-month prev-month prev-year -1)
+ (setq day (calendar-absolute-from-gregorian
+ (calendar-nth-named-day 1 dayname prev-month prev-year)))
+ (setq last-day (calendar-absolute-from-gregorian
+ (calendar-nth-named-day -1 dayname succ-month succ-year)))
+ (while (<= day last-day)
+ (mark-visible-calendar-date (calendar-gregorian-from-absolute day))
+ (setq day (+ day 7))))))
+
+(defun mark-calendar-date-pattern (month day year)
+ "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
+A value of 0 in any position is a wildcard."
+ (save-excursion
+ (set-buffer calendar-buffer)
+ (let ((m displayed-month)
+ (y displayed-year))
+ (increment-calendar-month m y -1)
+ (calendar-for-loop i from 0 to 2 do
+ (mark-calendar-month m y month day year)
+ (increment-calendar-month m y 1)))))
+
+(defun mark-calendar-month (month year p-month p-day p-year)
+ "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
+A value of 0 in any position of the pattern is a wildcard."
+ (if (or (and (= month p-month)
+ (or (= p-year 0) (= year p-year)))
+ (and (= p-month 0)
+ (or (= p-year 0) (= year p-year))))
+ (if (= p-day 0)
+ (calendar-for-loop
+ i from 1 to (calendar-last-day-of-month month year) do
+ (mark-visible-calendar-date (list month i year)))
+ (mark-visible-calendar-date (list month p-day year)))))
+
+(defun sort-diary-entries ()
+ "Sort the list of diary entries by time of day."
+ (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
+
+(defun diary-entry-compare (e1 e2)
+ "Returns t if E1 is earlier than E2."
+ (or (calendar-date-compare e1 e2)
+ (and (calendar-date-equal (car e1) (car e2))
+ (< (diary-entry-time (car (cdr e1)))
+ (diary-entry-time (car (cdr e2)))))))
+
+(defun diary-entry-time (s)
+ "Time at the beginning of the string S in a military-style integer.
+For example, returns 1325 for 1:25pm. Returns -9999 if no time is recognized.
+The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm,
+and XX:XXam or XX:XXpm."
+ (cond ((string-match;; Military time
+ "^[ \t]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
+ (+ (* 100 (string-to-int
+ (substring s (match-beginning 1) (match-end 1))))
+ (string-to-int (substring s (match-beginning 2) (match-end 2)))))
+ ((string-match;; Hour only XXam or XXpm
+ "^[ \t]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
+ (+ (* 100 (% (string-to-int
+ (substring s (match-beginning 1) (match-end 1)))
+ 12))
+ (if (string-equal "a"
+ (substring s (match-beginning 2) (match-end 2)))
+ 0 1200)))
+ ((string-match;; Hour and minute XX:XXam or XX:XXpm
+ "^[ \t]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
+ (+ (* 100 (% (string-to-int
+ (substring s (match-beginning 1) (match-end 1)))
+ 12))
+ (string-to-int (substring s (match-beginning 2) (match-end 2)))
+ (if (string-equal "a"
+ (substring s (match-beginning 3) (match-end 3)))
+ 0 1200)))
+ (t -9999)));; Unrecognizable
+
+(defun list-sexp-diary-entries (date)
+ "Add sexp entries for DATE from the diary file to `diary-entries-list'.
+Also, Make them visible in the diary file. Returns t if any entries were
+found.
+
+Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally
+`%%'). The form of a sexp diary entry is
+
+ %%(SEXP) ENTRY
+
+Both ENTRY and DATE are globally available when the SEXP is evaluated. If the
+SEXP yields the value nil, the diary entry does not apply. If it yields a
+non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a
+string, that string will be the diary entry in the fancy diary display.
+
+For example, the following diary entry will apply to the 21st of the month
+if it is a weekday and the Friday before if the 21st is on a weekend:
+
+ &%%(let ((dayname (calendar-day-of-week date))
+ (day (extract-calendar-day date)))
+ (or
+ (and (= day 21) (memq dayname '(1 2 3 4 5)))
+ (and (memq day '(19 20)) (= dayname 5)))
+ ) UIUC pay checks deposited
+
+A number of built-in functions are available for this type of diary entry:
+
+ %%(diary-date MONTH DAY YEAR) text
+ Entry applies if date is MONTH, DAY, YEAR if
+ `european-calendar-style' is nil, and DAY, MONTH, YEAR if
+ `european-calendar-style' is t. DAY, MONTH, and YEAR
+ can be lists of integers, the constant t, or an integer.
+ The constant t means all values.
+
+ %%(diary-float MONTH DAYNAME N) text
+ Entry will appear on the Nth DAYNAME of MONTH.
+ (DAYNAME=0 means Sunday, 1 means Monday, and so on;
+ if N is negative it counts backward from the end of
+ the month. MONTH can be a list of months, a single
+ month, or t to specify all months.
+
+ %%(diary-block M1 D1 Y1 M2 D2 Y2) text
+ Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
+ inclusive. (If `european-calendar-style' is t, the
+ order of the parameters should be changed to D1, M1, Y1,
+ D2, M2, Y2.)
+
+ %%(diary-anniversary MONTH DAY YEAR) text
+ Entry will appear on anniversary dates of MONTH DAY, YEAR.
+ (If `european-calendar-style' is t, the order of the
+ parameters should be changed to DAY, MONTH, YEAR.) Text
+ can contain %d or %d%s; %d will be replaced by the number
+ of years since the MONTH DAY, YEAR and %s will be replaced
+ by the ordinal ending of that number (that is, `st', `nd',
+ `rd' or `th', as appropriate. The anniversary of February
+ 29 is considered to be March 1 in a non-leap year.
+
+ %%(diary-cyclic N MONTH DAY YEAR) text
+ Entry will appear every N days, starting MONTH DAY, YEAR.
+ (If `european-calendar-style' is t, the order of the
+ parameters should be changed to N, DAY, MONTH, YEAR.) Text
+ can contain %d or %d%s; %d will be replaced by the number
+ of repetitions since the MONTH DAY, YEAR and %s will
+ be replaced by the ordinal ending of that number (that is,
+ `st', `nd', `rd' or `th', as appropriate.
+
+ %%(diary-remind SEXP DAYS &optional MARKING) text
+ Entry is a reminder for diary sexp SEXP. DAYS is either a
+ single number or a list of numbers indicating the number(s)
+ of days before the event that the warning(s) should occur.
+ If the current date is (one of) DAYS before the event
+ indicated by EXPR, then a suitable message (as specified
+ by `diary-remind-message') appears. In addition to the
+ reminders beforehand, the diary entry also appears on
+ the date itself. If optional MARKING is non-nil then the
+ *reminders* are marked on the calendar. Marking of
+ reminders is independent of whether the entry *itself* is
+ a marking or nonmarking one.
+
+ %%(diary-day-of-year)
+ Diary entries giving the day of the year and the number of
+ days remaining in the year will be made every day. Note
+ that since there is no text, it makes sense only if the
+ fancy diary display is used.
+
+ %%(diary-iso-date)
+ Diary entries giving the corresponding ISO commercial date
+ will be made every day. Note that since there is no text,
+ it makes sense only if the fancy diary display is used.
+
+ %%(diary-french-date)
+ Diary entries giving the corresponding French Revolutionary
+ date will be made every day. Note that since there is no
+ text, it makes sense only if the fancy diary display is used.
+
+ %%(diary-islamic-date)
+ Diary entries giving the corresponding Islamic date will be
+ made every day. Note that since there is no text, it
+ makes sense only if the fancy diary display is used.
+
+ %%(diary-hebrew-date)
+ Diary entries giving the corresponding Hebrew date will be
+ made every day. Note that since there is no text, it
+ makes sense only if the fancy diary display is used.
+
+ %%(diary-astro-day-number) Diary entries giving the corresponding
+ astronomical (Julian) day number will be made every day.
+ Note that since there is no text, it makes sense only if the
+ fancy diary display is used.
+
+ %%(diary-julian-date) Diary entries giving the corresponding
+ Julian date will be made every day. Note that since
+ there is no text, it makes sense only if the fancy diary
+ display is used.
+
+ %%(diary-sunrise-sunset)
+ Diary entries giving the local times of sunrise and sunset
+ will be made every day. Note that since there is no text,
+ it makes sense only if the fancy diary display is used.
+ Floating point required.
+
+ %%(diary-phases-of-moon)
+ Diary entries giving the times of the phases of the moon
+ will be when appropriate. Note that since there is no text,
+ it makes sense only if the fancy diary display is used.
+ Floating point required.
+
+ %%(diary-yahrzeit MONTH DAY YEAR) text
+ Text is assumed to be the name of the person; the date is
+ the date of death on the *civil* calendar. The diary entry
+ will appear on the proper Hebrew-date anniversary and on the
+ day before. (If `european-calendar-style' is t, the order
+ of the parameters should be changed to DAY, MONTH, YEAR.)
+
+ %%(diary-rosh-hodesh)
+ Diary entries will be made on the dates of Rosh Hodesh on
+ the Hebrew calendar. Note that since there is no text, it
+ makes sense only if the fancy diary display is used.
+
+ %%(diary-parasha)
+ Diary entries giving the weekly parasha will be made on
+ every Saturday. Note that since there is no text, it
+ makes sense only if the fancy diary display is used.
+
+ %%(diary-omer)
+ Diary entries giving the omer count will be made every day
+ from Passover to Shavuoth. Note that since there is no text,
+ it makes sense only if the fancy diary display is used.
+
+Marking these entries is *extremely* time consuming, so these entries are
+best if they are nonmarking."
+ (let* ((mark (regexp-quote diary-nonmarking-symbol))
+ (sexp-mark (regexp-quote sexp-diary-entry-symbol))
+ (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))
+ (entry-found))
+ (goto-char (point-min))
+ (while (re-search-forward s-entry nil t)
+ (backward-char 1)
+ (let ((sexp-start (point))
+ (sexp)
+ (entry)
+ (entry-start)
+ (line-start))
+ (forward-sexp)
+ (setq sexp (buffer-substring sexp-start (point)))
+ (save-excursion
+ (re-search-backward "\^M\\|\n\\|\\`")
+ (setq line-start (point)))
+ (forward-char 1)
+ (if (and (or (char-equal (preceding-char) ?\^M)
+ (char-equal (preceding-char) ?\n))
+ (not (looking-at " \\|\^I")))
+ (progn;; Diary entry consists only of the sexp
+ (backward-char 1)
+ (setq entry ""))
+ (setq entry-start (point))
+ (re-search-forward "\^M\\|\n" nil t)
+ (while (looking-at " \\|\^I")
+ (re-search-forward "\^M\\|\n" nil t))
+ (backward-char 1)
+ (setq entry (buffer-substring entry-start (point)))
+ (while (string-match "[\^M]" entry)
+ (aset entry (match-beginning 0) ?\n )))
+ (let ((diary-entry (diary-sexp-entry sexp entry date)))
+ (if diary-entry
+ (subst-char-in-region line-start (point) ?\^M ?\n t))
+ (add-to-diary-list date diary-entry)
+ (setq entry-found (or entry-found diary-entry)))))
+ entry-found))
+
+(defun diary-sexp-entry (sexp entry date)
+ "Process a SEXP diary ENTRY for DATE."
+ (let ((result (if calendar-debug-sexp
+ (let ((stack-trace-on-error t))
+ (eval (car (read-from-string sexp))))
+ (condition-case nil
+ (eval (car (read-from-string sexp)))
+ (error
+ (beep)
+ (message "Bad sexp at line %d in %s: %s"
+ (save-excursion
+ (save-restriction
+ (narrow-to-region 1 (point))
+ (goto-char (point-min))
+ (let ((lines 1))
+ (while (re-search-forward "\n\\|\^M" nil t)
+ (setq lines (1+ lines)))
+ lines)))
+ diary-file sexp)
+ (sleep-for 2))))))
+ (if (stringp result)
+ result
+ (if result
+ entry
+ nil))))
+
+(defun diary-date (month day year)
+ "Specific date(s) diary entry.
+Entry applies if date is MONTH, DAY, YEAR if `european-calendar-style' is nil,
+and DAY, MONTH, YEAR if `european-calendar-style' is t. DAY, MONTH, and YEAR
+can be lists of integers, the constant t, or an integer. The constant t means
+all values."
+ (let* ((dd (if european-calendar-style
+ month
+ day))
+ (mm (if european-calendar-style
+ day
+ month))
+ (m (extract-calendar-month date))
+ (y (extract-calendar-year date))
+ (d (extract-calendar-day date)))
+ (if (and
+ (or (and (listp dd) (memq d dd))
+ (equal d dd)
+ (eq dd t))
+ (or (and (listp mm) (memq m mm))
+ (equal m mm)
+ (eq mm t))
+ (or (and (listp year) (memq y year))
+ (equal y year)
+ (eq year t)))
+ entry)))
+
+(defun diary-block (m1 d1 y1 m2 d2 y2)
+ "Block diary entry.
+Entry applies if date is between two dates. Order of the parameters is
+M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and
+D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."
+ (let ((date1 (calendar-absolute-from-gregorian
+ (if european-calendar-style
+ (list d1 m1 y1)
+ (list m1 d1 y1))))
+ (date2 (calendar-absolute-from-gregorian
+ (if european-calendar-style
+ (list d2 m2 y2)
+ (list m2 d2 y2))))
+ (d (calendar-absolute-from-gregorian date)))
+ (if (and (<= date1 d) (<= d date2))
+ entry)))
+
+(defun diary-float (month dayname n)
+ "Floating diary entry--entry applies if date is the nth dayname of month.
+Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant
+t, or an integer. The constant t means all months. If N is negative, count
+backward from the end of the month."
+ (let ((m (extract-calendar-month date))
+ (y (extract-calendar-year date)))
+ (if (and
+ (or (and (listp month) (memq m month))
+ (equal m month)
+ (eq month t))
+ (calendar-date-equal date (calendar-nth-named-day n dayname m y)))
+ entry)))
+
+(defun diary-anniversary (month day year)
+ "Anniversary diary entry.
+Entry applies if date is the anniversary of MONTH, DAY, YEAR if
+`european-calendar-style' is nil, and DAY, MONTH, YEAR if
+`european-calendar-style' is t. Diary entry can contain `%d' or `%d%s'; the
+%d will be replaced by the number of years since the MONTH DAY, YEAR and the
+%s will be replaced by the ordinal ending of that number (that is, `st', `nd',
+`rd' or `th', as appropriate. The anniversary of February 29 is considered
+to be March 1 in non-leap years."
+ (let* ((d (if european-calendar-style
+ month
+ day))
+ (m (if european-calendar-style
+ day
+ month))
+ (y (extract-calendar-year date))
+ (diff (- y year)))
+ (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y)))
+ (setq m 3
+ d 1))
+ (if (and (> diff 0) (calendar-date-equal (list m d y) date))
+ (format entry diff (diary-ordinal-suffix diff)))))
+
+(defun diary-cyclic (n month day year)
+ "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
+If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
+ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
+years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal
+ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
+ (let* ((d (if european-calendar-style
+ month
+ day))
+ (m (if european-calendar-style
+ day
+ month))
+ (diff (- (calendar-absolute-from-gregorian date)
+ (calendar-absolute-from-gregorian
+ (list m d year))))
+ (cycle (/ diff n)))
+ (if (and (>= diff 0) (zerop (% diff n)))
+ (format entry cycle (diary-ordinal-suffix cycle)))))
+
+(defun diary-ordinal-suffix (n)
+ "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
+ (if (or (memq (% n 100) '(11 12 13))
+ (< 3 (% n 10)))
+ "th"
+ (aref ["th" "st" "nd" "rd"] (% n 10))))
+
+(defun diary-day-of-year ()
+ "Day of year and number of days remaining in the year of date diary entry."
+ (calendar-day-of-year-string date))
+
+(defvar diary-remind-message
+ '("Reminder: Only "
+ (if (= 0 (% days 7))
+ (concat (int-to-string (/ days 7)) (if (= 7 days) " week" " weeks"))
+ (concat (int-to-string days) (if (= 1 days) " day" " days")))
+ " until "
+ diary-entry)
+ "*Pseudo-pattern giving form of reminder messages in the fancy diary
+display.
+
+Used by the function `diary-remind', a pseudo-pattern is a list of
+expressions that can involve the keywords `days' (a number), `date' (a list of
+month, day, year), and `diary-entry' (a string).")
+
+(defun diary-remind (sexp days &optional marking)
+ "Provide a reminder of a diary entry.
+SEXP is a diary-sexp. DAYS is either a single number or a list of numbers
+indicating the number(s) of days before the event that the warning(s) should
+occur on. If the current date is (one of) DAYS before the event indicated by
+SEXP, then a suitable message (as specified by `diary-remind-message' is
+returned.
+
+In addition to the reminders beforehand, the diary entry also appears on
+the date itself.
+
+If optional parameter MARKING is non-nil then the reminders are marked on the
+calendar. Marking of reminders is independent of whether the entry itself is
+a marking or nonmarking one."
+ (let ((diary-entry))
+ (if (or (not marking-diary-entries) marking)
+ (cond
+ ((integerp days)
+ (let ((date (calendar-gregorian-from-absolute
+ (+ (calendar-absolute-from-gregorian date) days))))
+ (if (setq diary-entry (eval sexp))
+ (setq diary-entry (mapconcat 'eval diary-remind-message "")))))
+ ((and (listp days) days)
+ (setq diary-entry (diary-remind sexp (car days) marking))
+ (if (not diary-entry)
+ (setq diary-entry (diary-remind sexp (cdr days) marking))))))
+ (or diary-entry
+ (and (or (not marking-diary-entries) marking-diary-entry)
+ (eval sexp)))))
+
+(defun add-to-diary-list (date string)
+ "Add the entry (DATE STRING) to `diary-entries-list'.
+Do nothing if DATE or STRING is nil."
+ (and date string
+ (setq diary-entries-list
+ (append diary-entries-list (list (list date string))))))
+
+(defun make-diary-entry (string &optional nonmarking file)
+ "Insert a diary entry STRING which may be NONMARKING in FILE.
+If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."
+ (find-file-other-window
+ (substitute-in-file-name (if file file diary-file)))
+ (goto-char (point-max))
+ (insert
+ (if (bolp) "" "\n")
+ (if nonmarking diary-nonmarking-symbol "")
+ string " "))
+
+(defun insert-diary-entry (arg)
+ "Insert a diary entry for the date indicated by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t t)
+ arg))
+
+(defun insert-weekly-diary-entry (arg)
+ "Insert a weekly diary entry for the day of the week indicated by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (make-diary-entry (calendar-day-name (calendar-cursor-to-date t))
+ arg))
+
+(defun insert-monthly-diary-entry (arg)
+ "Insert a monthly diary entry for the day of the month indicated by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (let* ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " * ")
+ '("* " day))))
+ (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
+ arg)))
+
+(defun insert-yearly-diary-entry (arg)
+ "Insert an annual diary entry for the day of the year indicated by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (let* ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " " monthname)
+ '(monthname " " day))))
+ (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
+ arg)))
+
+(defun insert-anniversary-diary-entry (arg)
+ "Insert an anniversary diary entry for the date given by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (let* ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " " month " " year)
+ '(month " " day " " year))))
+ (make-diary-entry
+ (format "%s(diary-anniversary %s)"
+ sexp-diary-entry-symbol
+ (calendar-date-string (calendar-cursor-to-date t) nil t))
+ arg)))
+
+(defun insert-block-diary-entry (arg)
+ "Insert a block diary entry for the days between the point and marked date.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (let* ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " " month " " year)
+ '(month " " day " " year)))
+ (cursor (calendar-cursor-to-date t))
+ (mark (or (car calendar-mark-ring)
+ (error "No mark set in this buffer")))
+ (start)
+ (end))
+ (if (< (calendar-absolute-from-gregorian mark)
+ (calendar-absolute-from-gregorian cursor))
+ (setq start mark
+ end cursor)
+ (setq start cursor
+ end mark))
+ (make-diary-entry
+ (format "%s(diary-block %s %s)"
+ sexp-diary-entry-symbol
+ (calendar-date-string start nil t)
+ (calendar-date-string end nil t))
+ arg)))
+
+(defun insert-cyclic-diary-entry (arg)
+ "Insert a cyclic diary entry starting at the date given by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (let* ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " " month " " year)
+ '(month " " day " " year))))
+ (make-diary-entry
+ (format "%s(diary-cyclic %d %s)"
+ sexp-diary-entry-symbol
+ (calendar-read "Repeat every how many days: "
+ '(lambda (x) (> x 0)))
+ (calendar-date-string (calendar-cursor-to-date t) nil t))
+ arg)))
+
+(provide 'diary)
+
+;;; diary.el ends here
projects / emacs.git / commitdiff