-;;; calendar.el --- Calendar functions.
+;;; calendar.el --- calendar functions
-;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, 2000
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997,
+;; 2000, 2001, 2003 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Keywords: calendar
;;; Code:
-(eval-when-compile
+(eval-when-compile
(defvar displayed-month)
(defvar displayed-year)
(defvar calendar-month-name-array)
:type 'boolean
:group 'view)
-(add-to-list 'facemenu-unlisted-faces 'diary-face)
+(defvar diary-face 'diary-face
+ "Face name to use for diary entries.")
(defface diary-face
'((((class color) (background light))
:foreground "red")
(((class color) (background dark))
:foreground "yellow")
(t
- :bold t))
+ :weight bold))
"Face for highlighting diary entries."
:group 'diary)
-(add-to-list 'facemenu-unlisted-faces 'calendar-today-face)
(defface calendar-today-face
'((t (:underline t)))
"Face for indicating today's date."
:group 'diary)
-(add-to-list 'facemenu-unlisted-faces 'holiday-face)
(defface holiday-face
'((((class color) (background light))
:background "pink")
"Face for indicating dates that have holidays."
:group 'diary)
+(eval-after-load "facemenu"
+ '(progn
+ (add-to-list 'facemenu-unlisted-faces 'diary-face)
+ (add-to-list 'facemenu-unlisted-faces 'calendar-today-face)
+ (add-to-list 'facemenu-unlisted-faces 'holiday-face)))
+
(defcustom diary-entry-marker
(if (not (display-color-p))
"+"
:type 'boolean
:group 'holidays)
+(defcustom diary-file-name-prefix-function (function (lambda (str) str))
+ "*The function that will take a diary file name and return the desired prefix."
+ :type 'function
+ :group 'diary)
+
;;;###autoload
(defcustom calendar-load-hook nil
"*List of functions to be called after the calendar is first loaded.
(defcustom diary-file "~/diary"
"*Name of the file in which one's personal diary of dates is kept.
-The file's entries are lines in any of the forms
+The file's entries are lines beginning with any of the forms
+specified by the variable `american-date-diary-pattern', by default:
MONTH/DAY
MONTH/DAY/YEAR
MONTHNAME DAY, YEAR
DAYNAME
-at the beginning of the line; the remainder of the line is the diary entry
-string for that date. MONTH and DAY are one or two digit numbers, YEAR is
-a number and may be written in full or abbreviated to the final two digits.
-If the date does not contain a year, it is generic and applies to any year.
-DAYNAME entries apply to any date on which is on that day of the week.
-MONTHNAME and DAYNAME can be spelled in full, abbreviated to three
-characters (with or without a period), capitalized or not. Any of DAY,
-MONTH, or MONTHNAME, YEAR can be `*' which matches any day, month, or year,
-respectively.
-
-The European style (in which the day precedes the month) can be used
-instead, if you execute `european-calendar' when in the calendar, or set
-`european-calendar-style' to t in your .emacs file. The European forms are
+with the remainder of the line being the diary entry string for
+that date. MONTH and DAY are one or two digit numbers, YEAR is a
+number and may be written in full or abbreviated to the final two
+digits (if `abbreviated-calendar-year' is non-nil). MONTHNAME
+and DAYNAME can be spelled in full (as specified by the variables
+`calendar-month-name-array' and `calendar-day-name-array'),
+abbreviated (as specified by `calendar-month-abbrev-array' and
+`calendar-day-abbrev-array') with or without a period,
+capitalized or not. Any of DAY, MONTH, or MONTHNAME, YEAR can be
+`*' which matches any day, month, or year, respectively. If the
+date does not contain a year, it is generic and applies to any
+year. A DAYNAME entry applies to the appropriate day of the week
+in every week.
+
+The European style (in which the day precedes the month) can be
+used instead, if you execute `european-calendar' when in the
+calendar, or set `european-calendar-style' to t in your .emacs
+file. The European forms (see `european-date-diary-pattern') are
DAY/MONTH
DAY/MONTH/YEAR
:type 'string
:group 'diary)
+(defcustom diary-glob-file-regexp-prefix "^\\#"
+ "*The regular expression that gets pre-pended to each of the attribute-regexp's for file-wide specifiers."
+ :type 'regexp
+ :group 'diary)
+
+(defcustom diary-face-attrs
+ '((" *\\[foreground:\\([-a-z]+\\)\\]$" 1 :foreground string)
+ (" *\\[background:\\([-a-z]+\\)\\]$" 1 :background string)
+ (" *\\[width:\\([-a-z]+\\)\\]$" 1 :width symbol)
+ (" *\\[height:\\([-0-9a-z]+\\)\\]$" 1 :height int)
+ (" *\\[weight:\\([-a-z]+\\)\\]$" 1 :weight symbol)
+ (" *\\[slant:\\([-a-z]+\\)\\]$" 1 :slant symbol)
+ (" *\\[underline:\\([-a-z]+\\)\\]$" 1 :underline stringtnil)
+ (" *\\[overline:\\([-a-z]+\\)\\]$" 1 :overline stringtnil)
+ (" *\\[strike-through:\\([-a-z]+\\)\\]$" 1 :strike-through stringtnil)
+ (" *\\[inverse-video:\\([-a-z]+\\)\\]$" 1 :inverse-video tnil)
+ (" *\\[face:\\([-0-9a-z]+\\)\\]$" 1 :face string)
+ (" *\\[font:\\([-a-z0-9]+\\)\\]$" 1 :font string)
+ ;; Unsupported.
+;;; (" *\\[box:\\([-a-z]+\\)\\]$" 1 :box)
+;;; (" *\\[stipple:\\([-a-z]+\\)\\]$" 1 :stipple)
+ )
+ "*A list of (regexp regnum attr attrtype) lists where the
+regexp says how to find the tag, the regnum says which
+parenthetical sub-regexp this regexp looks for, and the attr says
+which attribute of the face (or that this _is_ a face) is being
+modified."
+ :type 'sexp
+ :group 'diary)
+
+(defcustom diary-file-name-prefix nil
+ "If non-nil each diary entry is prefixed with the name of the file where it is defined."
+ :type 'boolean
+ :group 'diary)
+
;;;###autoload
(defcustom sexp-diary-entry-symbol "%%"
"*The string used to indicate a sexp diary entry in `diary-file'.
(defcustom european-calendar-style nil
"*Use the European style of dates in the diary and in any displays.
If this variable is t, a date 1/2/1990 would be interpreted as February 1,
-1990. The accepted European date styles are
+1990. The default European date styles (see `european-date-diary-pattern')
+are
DAY/MONTH
DAY/MONTH/YEAR
DAY MONTHNAME YEAR
DAYNAME
-Names can be capitalized or not, written in full, or abbreviated to three
-characters with or without a period."
+Names can be capitalized or not, written in full (as specified by the
+variable `calendar-day-name-array'), or abbreviated (as specified by
+`calendar-day-abbrev-array') with or without a period."
:type 'boolean
:group 'diary)
european-date-diary-pattern
american-date-diary-pattern)
"*List of pseudo-patterns describing the forms of date used in the diary.
-The patterns on the list must be MUTUALLY EXCLUSIVE and must should not match
+The patterns on the list must be MUTUALLY EXCLUSIVE and should not match
any portion of the diary entry itself, just the date component.
A pseudo-pattern is a list of regular expressions and the keywords `month',
`day', `year', `monthname', and `dayname'. The keyword `monthname' will
-match the name of the month, capitalized or not, or its three-letter
-abbreviation, followed by a period or not; it will also match `*'.
-Similarly, `dayname' will match the name of the day, capitalized or not, or
-its three-letter abbreviation, followed by a period or not. The keywords
-`month', `day', and `year' will match those numerical values, preceded by
-arbitrarily many zeros; they will also match `*'.
+match the name of the month (see `calendar-month-name-array'), capitalized
+or not, or its user-specified abbreviation (see `calendar-month-abbrev-array'),
+followed by a period or not; it will also match `*'. Similarly, `dayname'
+will match the name of the day (see `calendar-day-name-array'), capitalized or
+not, or its user-specified abbreviation (see `calendar-day-abbrev-array'),
+followed by a period or not. The keywords `month', `day', and `year' will
+match those numerical values, preceded by arbitrarily many zeros; they will
+also match `*'.
The matching of the diary entries with the date forms is done with the
standard syntax table from Fundamental mode, but with the `*' changed so
(defcustom european-calendar-display-form
'((if dayname (concat dayname ", ")) day " " monthname " " year)
"*Pseudo-pattern governing the way a date appears in the European style.
-See the documentation of calendar-date-display-form for an explanation."
+See the documentation of `calendar-date-display-form' for an explanation."
:type 'sexp
:group 'calendar)
"Move cursor to DATE."
t)
+(autoload 'calendar-only-one-frame-setup "cal-x"
+ "Start calendar and display it in a dedicated frame.")
+
(autoload 'calendar-one-frame-setup "cal-x"
"Start calendar and display it in a dedicated frame together with the diary.")
;;;###autoload
(defun calendar (&optional arg)
"Choose between the one frame, two frame, or basic calendar displays.
-The original function `calendar' has been renamed `calendar-basic-setup'."
+If called with an optional prefix argument, prompts for month and year.
+
+The original function `calendar' has been renamed `calendar-basic-setup'.
+See the documentation of that function for more information."
(interactive "P")
(cond ((equal calendar-setup 'one-frame) (calendar-one-frame-setup arg))
((equal calendar-setup 'two-frames) (calendar-two-frame-setup arg))
"String of ISO date of Gregorian date."
t)
+(autoload 'calendar-goto-islamic-date "cal-islam"
+ "Move cursor to Islamic date."
+ t)
+
(autoload 'calendar-print-islamic-date "cal-islam"
"Show the Islamic date equivalents of date."
t)
;; Adjust the window to exactly fit the displayed calendar
(fit-window-to-buffer))
(sit-for 0)
+ (if (and (boundp 'font-lock-mode)
+ font-lock-mode)
+ (font-lock-fontify-buffer))
(and mark-holidays-in-calendar
(mark-calendar-holidays)
(sit-for 0))
(defun generate-calendar (month year)
"Generate a three-month Gregorian calendar centered around MONTH, YEAR."
(if (< (+ month (* 12 (1- year))) 2)
- (error "Months before February, 1 AD are not available."))
+ (error "Months before February, 1 AD are not available"))
(setq displayed-month month)
(setq displayed-year year)
(erase-buffer)
(defun generate-calendar-month (month year indent)
"Produce a calendar for MONTH, YEAR on the Gregorian calendar.
-The calendar is inserted in the buffer starting at the line on which point
-is currently located, but indented INDENT spaces. The indentation is done
-from the first character on the line and does not disturb the first INDENT
-characters on the line."
+The calendar is inserted at the top of the buffer in which point is currently
+located, but indented INDENT spaces. The indentation is done from the first
+character on the line and does not disturb the first INDENT characters on the
+line."
(let* ((blank-days;; at start of month
(mod
(- (calendar-day-of-week (list month 1 year))
(list (format "%s %d" (calendar-month-name month) year)) ? 20)
indent t)
(calendar-insert-indented "" indent);; Go to proper spot
+ ;; Use the first two characters of each day to head the columns.
(calendar-for-loop i from 0 to 6 do
- (insert (calendar-day-name (mod (+ calendar-week-start-day i) 7)
- 2 t))
- (insert " "))
+ (insert
+ (let ((string
+ (calendar-day-name (mod (+ calendar-week-start-day i) 7) nil t)))
+ (if enable-multibyte-characters
+ (truncate-string-to-width string 2)
+ (substring string 0 2)))
+ " "))
(calendar-insert-indented "" 0 t);; Force onto following line
(calendar-insert-indented "" indent);; Go to proper spot
;; Add blank days before the first of the month
(if calendar-mode-map
nil
(setq calendar-mode-map (make-sparse-keymap))
- (if (display-popup-menus-p) (require 'cal-menu))
+ (require 'cal-menu)
(calendar-for-loop i from 0 to 9 do
(define-key calendar-mode-map (int-to-string i) 'digit-argument))
(let ((l (list 'narrow-to-region 'mark-word 'mark-sexp 'mark-paragraph
(define-key calendar-mode-map "tY" 'cal-tex-cursor-year-landscape))
(defun describe-calendar-mode ()
- "Create a help buffer with a brief description of the calendar-mode."
+ "Create a help buffer with a brief description of the `calendar-mode'."
(interactive)
(with-output-to-temp-buffer "*Help*"
(princ
(propertize (substitute-command-keys
"\\<calendar-mode-map>\\[scroll-calendar-left]")
'help-echo "mouse-2: scroll left"
- 'keymap (make-mode-line-mouse2-map #'scroll-calendar-left))
+ 'keymap (make-mode-line-mouse-map 'mouse-2
+ 'mouse-scroll-calendar-left))
"Calendar"
(concat
(propertize
(substitute-command-keys
"\\<calendar-mode-map>\\[calendar-goto-info-node] info")
'help-echo "mouse-2: read Info on Calendar"
- 'keymap (make-mode-line-mouse2-map #'calendar-goto-info-node))
+ 'keymap (make-mode-line-mouse-map 'mouse-2 'calendar-goto-info-node))
"/"
(propertize
(substitute-command-keys
"\\<calendar-mode-map>\\[calendar-other-month] other")
'help-echo "mouse-2: choose another month"
- 'keymap (make-mode-line-mouse2-map (lambda ()
- (interactive)
- (call-interactively
- 'calendar-other-month))))
+ 'keymap (make-mode-line-mouse-map
+ 'mouse-2 'mouse-calendar-other-month))
"/"
(propertize
(substitute-command-keys
"\\<calendar-mode-map>\\[calendar-goto-today] today")
'help-echo "mouse-2: go to today's date"
- 'keymap (make-mode-line-mouse2-map #'calendar-goto-today)))
+ 'keymap (make-mode-line-mouse-map 'mouse-2 #'calendar-goto-today)))
'(calendar-date-string (calendar-current-date) t)
(propertize (substitute-command-keys
"\\<calendar-mode-map>\\[scroll-calendar-right]")
'help-echo "mouse-2: scroll right"
- 'keymap (make-mode-line-mouse2-map #'scroll-calendar-right)))
- "The mode line of the calendar buffer.")
+ 'keymap (make-mode-line-mouse-map
+ 'mouse-2 'mouse-scroll-calendar-right)))
+ "The mode line of the calendar buffer.
+
+This must be a list of items that evaluate to strings--those strings are
+evaluated and concatenated together, evenly separated by blanks. The variable
+`date' is available for use as the date under (or near) the cursor; `date'
+defaults to the current date if it is otherwise undefined. Here is an example
+value that has the Hebrew date, the day number/days remaining in the year,
+and the ISO week/year numbers in the mode. When calendar-move-hook is set to
+'update-calendar-mode-line, these mode line shows these values for the date
+under the cursor:
+
+ (list
+ \"\"
+ '(calendar-hebrew-date-string date)
+ '(let* ((year (extract-calendar-year date))
+ (d (calendar-day-number date))
+ (days-remaining
+ (- (calendar-day-number (list 12 31 year)) d)))
+ (format \"%d/%d\" d days-remaining))
+ '(let* ((d (calendar-absolute-from-gregorian date))
+ (iso-date (calendar-iso-from-absolute d)))
+ (format \"ISO week %d of %d\"
+ (extract-calendar-month iso-date)
+ (extract-calendar-year iso-date)))
+ \"\"))
+")
+
+(defun mouse-scroll-calendar-left (event)
+ "Scroll the displayed calendar left by one month.
+Maintains the relative position of the cursor
+with respect to the calendar as well as possible."
+ (interactive "e")
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (scroll-calendar-left 1)))
+
+(defun mouse-scroll-calendar-right (event)
+ "Scroll the displayed calendar right by one month.
+Maintains the relative position of the cursor
+with respect to the calendar as well as possible."
+ (interactive "e")
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (scroll-calendar-right 1)))
+
+(defun mouse-calendar-other-month (event)
+ "Display a three-month calendar centered around a specified month and year."
+ (interactive "e")
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (call-interactively 'calendar-other-month)))
(defun calendar-goto-info-node ()
"Go to the info node for the calendar."
(let ((where (save-window-excursion
(Info-find-emacs-command-nodes 'calendar))))
(if (not where)
- (error "Couldn't find documentation for the calendar.")
+ (error "Couldn't find documentation for the calendar")
(let (same-window-buffer-names)
(info))
(Info-find-node (car (car where)) (car (cdr (car where)))))))
+
+
(defun calendar-mode ()
"A major mode for the calendar window.
(setq buffer-read-only t)
(setq indent-tabs-mode nil)
(update-calendar-mode-line)
- (if (display-popup-menus-p)
- (progn
- (make-local-hook 'activate-menubar-hook)
- (add-hook 'activate-menubar-hook 'cal-menu-update nil t)))
+ (add-hook 'activate-menubar-hook 'cal-menu-update nil t)
(make-local-variable 'calendar-mark-ring)
(make-local-variable 'displayed-month);; Month in middle of window.
- (make-local-variable 'displayed-year));; Year in middle of window.
+ (make-local-variable 'displayed-year) ;; Year in middle of window.
+ (set (make-local-variable 'font-lock-defaults)
+ '(calendar-font-lock-keywords t)))
(defun calendar-string-spread (strings char length)
"Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH.
(set-buffer calendar-buffer)
(setq mode-line-format
(calendar-string-spread
- calendar-mode-line-format ? (frame-width))))))
+ (let ((date (condition-case nil
+ (calendar-cursor-to-nearest-date)
+ (error (calendar-current-date)))))
+ (mapcar 'eval calendar-mode-line-format))
+ ? (frame-width)))
+ (force-mode-line-update))))
(defun calendar-window-list ()
"List of all calendar-related windows."
(+ (* 12 (- yr2 yr1))
(- mon2 mon1)))
-(defun calendar-day-name (date &optional width absolute)
- "Return a string with the name of the day of the week of DATE.
-If WIDTH is non-nil, return just the first WIDTH characters of the name.
-If ABSOLUTE is non-nil, then DATE is actually the day-of-the-week
-rather than a date."
- (let ((string (aref calendar-day-name-array
- (if absolute date (calendar-day-of-week date)))))
- (cond ((null width) string)
- (enable-multibyte-characters (truncate-string-to-width string width))
- (t (substring string 0 width)))))
+(defvar calendar-abbrev-length 3
+ "*Length of abbreviations to be used for day and month names.
+See also `calendar-day-abbrev-array' and `calendar-month-abbrev-array'.")
(defvar calendar-day-name-array
["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]
- "Array of capitalized strings giving, in order, the day names.")
+ "*Array of capitalized strings giving, in order, the day names.
+The first two characters of each string will be used to head the
+day columns in the calendar. See also the variable
+`calendar-day-abbrev-array'.")
+
+(defvar calendar-day-abbrev-array
+ [nil nil nil nil nil nil nil]
+ "*Array of capitalized strings giving the abbreviated day names.
+The order should be the same as that of the full names specified
+in `calendar-day-name-array'. These abbreviations may be used
+instead of the full names in the diary file. Do not include a
+trailing `.' in the strings specified in this variable, though
+you may use such in the diary file. If any element of this array
+is nil, then the abbreviation will be constructed as the first
+`calendar-abbrev-length' characters of the corresponding full name.")
(defvar calendar-month-name-array
["January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"]
- "Array of capitalized strings giving, in order, the month names.")
-
-(defun calendar-make-alist (sequence &optional start-index filter)
+ "*Array of capitalized strings giving, in order, the month names.
+See also the variable `calendar-month-abbrev-array'.")
+
+(defvar calendar-month-abbrev-array
+ [nil nil nil nil nil nil nil nil nil nil nil nil]
+ "*Array of capitalized strings giving the abbreviated month names.
+The order should be the same as that of the full names specified
+in `calendar-month-name-array'. These abbreviations are used in
+the calendar menu entries, and can also be used in the diary
+file. Do not include a trailing `.' in the strings specified in
+this variable, though you may use such in the diary file. If any
+element of this array is nil, then the abbreviation will be
+constructed as the first `calendar-abbrev-length' characters of the
+corresponding full name.")
+
+(defun calendar-abbrev-construct (abbrev full &optional period)
+ "Internal calendar function to return a complete abbreviation array.
+ABBREV is an array of abbreviations, FULL the corresponding array
+of full names. The return value is the ABBREV array, with any nil
+elements replaced by the first three characters taken from the
+corresponding element of FULL. If optional argument PERIOD is non-nil,
+each element returned has a final `.' character."
+ (let (elem array)
+ (dotimes (i (length full))
+ (setq elem (or (aref abbrev i)
+ (substring (aref full i) 0 calendar-abbrev-length))
+ elem (format "%s%s" elem (if period "." ""))
+ array (append array (list elem))))
+ (vconcat array)))
+
+(defvar calendar-font-lock-keywords
+ `((,(concat (regexp-opt (mapcar 'identity calendar-month-name-array) t)
+ " -?[0-9]+")
+ . font-lock-function-name-face) ; month and year
+ (,(regexp-opt
+ (list (substring (aref calendar-day-name-array 6) 0 2)
+ (substring (aref calendar-day-name-array 0) 0 2)))
+ ;; Saturdays and Sundays are hilited differently.
+ . font-lock-comment-face)
+ ;; First two chars of each day are used in the calendar.
+ (,(regexp-opt (mapcar (lambda (x) (substring x 0 2)) calendar-day-name-array))
+ . font-lock-reference-face))
+ "Default keywords to highlight in Calendar mode.")
+
+(defun calendar-day-name (date &optional abbrev absolute)
+ "Return a string with the name of the day of the week of DATE.
+DATE should be a list in the format (MONTH DAY YEAR), unless the
+optional argument ABSOLUTE is non-nil, in which case DATE should
+be an integer in the range 0 to 6 corresponding to the day of the
+week. Day names are taken from the variable `calendar-day-name-array',
+unless the optional argument ABBREV is non-nil, in which case
+the variable `calendar-day-abbrev-array' is used."
+ (aref (if abbrev
+ (calendar-abbrev-construct calendar-day-abbrev-array
+ calendar-day-name-array)
+ calendar-day-name-array)
+ (if absolute date (calendar-day-of-week date))))
+
+(defun calendar-make-alist (sequence &optional start-index filter abbrevs)
"Make an assoc list corresponding to SEQUENCE.
-Start at index 1, unless optional START-INDEX is provided.
-If FILTER is provided, apply it to each item in the list."
- (let ((index (if start-index (1- start-index) 0)))
- (mapcar
- (lambda (x)
- (setq index (1+ index))
- (cons (if filter (funcall filter x) x)
- index))
- (append sequence nil))))
-
-(defun calendar-month-name (month &optional width)
- "The name of MONTH.
-If WIDTH is non-nil, return just the first WIDTH characters of the name."
- (let ((string (aref calendar-month-name-array (1- month))))
- (if width
- (let ((i 0) (result "") (pos 0))
- (while (< i width)
- (let ((chartext (char-to-string (aref string pos))))
- (setq pos (+ pos (length chartext)))
- (setq result (concat result chartext)))
- (setq i (1+ i)))
- result)
- string)))
+Each element of sequence will be associated with an integer, starting
+from 1, or from START-INDEX if that is non-nil. If a sequence ABBREVS
+is supplied, the function `calendar-abbrev-construct' is used to
+construct abbreviations corresponding to the elements in SEQUENCE.
+Each abbreviation is entered into the alist with the same
+association index as the full name it represents.
+If FILTER is provided, apply it to each key in the alist."
+ (let ((index 0)
+ (offset (or start-index 1))
+ (aseq (if abbrevs (calendar-abbrev-construct abbrevs sequence)))
+ (aseqp (if abbrevs (calendar-abbrev-construct abbrevs sequence
+ 'period)))
+ alist elem)
+ (dotimes (i (1- (length sequence)) (reverse alist))
+ (setq index (+ i offset)
+ elem (elt sequence i)
+ alist
+ (cons (cons (if filter (funcall filter elem) elem) index) alist))
+ (if aseq
+ (setq elem (elt aseq i)
+ alist (cons (cons (if filter (funcall filter elem) elem)
+ index) alist)))
+ (if aseqp
+ (setq elem (elt aseqp i)
+ alist (cons (cons (if filter (funcall filter elem) elem)
+ index) alist))))))
+
+(defun calendar-month-name (month &optional abbrev)
+ "Return a string with the name of month number MONTH.
+Months are numbered from one. Month names are taken from the
+variable `calendar-month-name-array', unless the optional
+argument ABBREV is non-nil, in which case
+`calendar-month-abbrev-array' is used."
+ (aref (if abbrev
+ (calendar-abbrev-construct calendar-month-abbrev-array
+ calendar-month-name-array)
+ calendar-month-name-array)
+ (1- month)))
(defun calendar-day-of-week (date)
"Return the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc."
(defun mark-visible-calendar-date (date &optional mark)
"Mark DATE in the calendar window with MARK.
-MARK is either a single-character string or a face.
-MARK defaults to diary-entry-marker."
+MARK is a single-character string, a list of face attributes/values, or a face.
+MARK defaults to `diary-entry-marker'."
(if (calendar-date-is-legal-p date)
(save-excursion
(set-buffer calendar-buffer)
(calendar-cursor-to-visible-date date)
- (let ((mark (or mark diary-entry-marker)))
- (if (stringp mark)
- (let ((buffer-read-only nil))
- (forward-char 1)
- (delete-char 1)
- (insert mark)
- (forward-char -2))
- (overlay-put
- (make-overlay (1- (point)) (1+ (point))) 'face mark))))))
+ (let ((mark (or (and (stringp mark) (= (length mark) 1) mark) ; single-char
+ (and (listp mark) (> (length mark) 0) mark) ; attr list
+ (and (facep mark) mark) ; face-name
+ diary-entry-marker)))
+ (if (facep mark)
+ (progn ; face or an attr-list that contained a face
+ (overlay-put
+ (make-overlay (1- (point)) (1+ (point))) 'face mark))
+ (if (and (stringp mark)
+ (= (length mark) 1)) ; single-char
+ (let ((buffer-read-only nil))
+ (forward-char 1)
+ (delete-char 1)
+ (insert mark)
+ (forward-char -2))
+ (progn ; attr list
+ (setq temp-face
+ (make-symbol (apply 'concat "temp-face-"
+ (mapcar '(lambda (sym)
+ (cond ((symbolp sym) (symbol-name sym))
+ ((numberp sym) (int-to-string sym))
+ (t sym))) mark))))
+ (make-face temp-face)
+ ;; Remove :face info from the mark, copy the face info into temp-face
+ (setq faceinfo mark)
+ (while (setq faceinfo (memq :face faceinfo))
+ (copy-face (read (nth 1 faceinfo)) temp-face)
+ (setcar faceinfo nil)
+ (setcar (cdr faceinfo) nil))
+ (setq mark (delq nil mark))
+ ;; Apply the font aspects
+ (apply 'set-face-attribute temp-face nil mark)
+ (overlay-put
+ (make-overlay (1- (point)) (1+ (point))) 'face temp-face))))))))
(defun calendar-star-date ()
"Replace the date under the cursor in the calendar window with asterisks.
(defun calendar-mark-today ()
"Mark the date under the cursor in the calendar window.
-The date is marked with calendar-today-marker. This function can be used with
+The date is marked with `calendar-today-marker'. This function can be used with
the `today-visible-calendar-hook' run after the calendar window has been
prepared."
(mark-visible-calendar-date
(defun calendar-date-string (date &optional abbreviate nodayname)
"A string form of DATE, driven by the variable `calendar-date-display-form'.
-An optional parameter ABBREVIATE, when t, causes the month and day names to be
-abbreviated to three characters. An optional parameter NODAYNAME, when t,
-omits the name of the day of the week."
+An optional parameter ABBREVIATE, when non-nil, causes the month
+and day names to be abbreviated as specified by
+`calendar-month-abbrev-array' and `calendar-day-abbrev-array',
+respectively. An optional parameter NODAYNAME, when t, omits the
+name of the day of the week."
(let* ((dayname
- (if nodayname
- nil
- (if abbreviate
- (calendar-day-name date 3)
- (calendar-day-name date))))
+ (unless nodayname
+ (calendar-day-name date abbreviate)))
(month (extract-calendar-month date))
- (monthname
- (if abbreviate
- (calendar-month-name month 3)
- (calendar-month-name month)))
+ (monthname (calendar-month-name month abbreviate))
(day (int-to-string (extract-calendar-day date)))
(month (int-to-string month))
(year (int-to-string (extract-calendar-year date))))