Commit 40802b08 authored by Glenn Morris's avatar Glenn Morris
Browse files

(european-calendar-style, calendar-for-loop)

(calendar-sum, calendar-insert-indented, mouse-calendar-other-month)
(calendar-cursor-to-date): Doc fix.
(hebrew-holidays-1, hebrew-holidays-4): Simplify.
(extract-calendar-day, extract-calendar-year): Use cadr, nth.
(calendar-day-number): Use when.
(generate-calendar-month): Use dotimes.
(exit-calendar, calendar-print-other-dates): Use let rather than let*.
(calendar-set-mark): Reverse conditional.
(calendar-make-alist): Move definition before use.
parent 35471668
...@@ -91,6 +91,24 @@ ...@@ -91,6 +91,24 @@
;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and ;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and
;; the message BODY containing your mailing address (snail). ;; the message BODY containing your mailing address (snail).
;; A note on free variables:
;; The calendar passes around a few dynamically bound variables, which
;; unfortunately have rather common names. They are meant to be
;; available for external functions, so the names can't be changed.
;; displayed-month, displayed-year: bound in generate-calendar, the
;; central month of the 3 month calendar window
;; original-date, number: bound in diary-list-entries, the arguments
;; with which that function was called.
;; date, entry: bound in list-sexp-diary-entries (qv)
;; Bound in diary-list-entries:
;; diary-entries-list: use in d-l, appt.el, and by add-to-diary-list
;; diary-saved-point: only used in diary-lib.el, passed to the display func
;; date-string: only used in diary-lib.el FIXME could be removed?
;;; Code: ;;; Code:
;; (elisp) Eval During Compile: "Effectively `require' is ;; (elisp) Eval During Compile: "Effectively `require' is
...@@ -457,9 +475,9 @@ full." ...@@ -457,9 +475,9 @@ full."
;;;###autoload ;;;###autoload
(defcustom european-calendar-style nil (defcustom european-calendar-style nil
"Use the European style of dates in the diary and in any displays. "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, If this variable is non-nil, a date 1/2/1990 would be interpreted as
1990. The default European date styles (see `european-date-diary-pattern') February 1, 1990. The default European date styles (see
are `european-date-diary-pattern') are
DAY/MONTH DAY/MONTH
DAY/MONTH/YEAR DAY/MONTH/YEAR
...@@ -746,17 +764,16 @@ calendar." ...@@ -746,17 +764,16 @@ calendar."
(if all-hebrew-calendar-holidays (if all-hebrew-calendar-holidays
(holiday-julian (holiday-julian
11 11
(let* ((m displayed-month) (let ((m displayed-month)
(y displayed-year) (y displayed-year)
(year)) year)
(increment-calendar-month m y -1) (increment-calendar-month m y -1)
(let ((year (extract-calendar-year (setq year (extract-calendar-year
(calendar-julian-from-absolute (calendar-julian-from-absolute
(calendar-absolute-from-gregorian (calendar-absolute-from-gregorian (list m 1 y)))))
(list m 1 y)))))) (if (zerop (% (1+ year) 4))
(if (zerop (% (1+ year) 4)) 22
22 21)) "\"Tal Umatar\" (evening)")))
21))) "\"Tal Umatar\" (evening)")))
"Component of the default value of `hebrew-holidays'.") "Component of the default value of `hebrew-holidays'.")
;;;###autoload ;;;###autoload
(put 'hebrew-holidays-1 'risky-local-variable t) (put 'hebrew-holidays-1 'risky-local-variable t)
...@@ -773,9 +790,8 @@ calendar." ...@@ -773,9 +790,8 @@ calendar."
(calendar-hebrew-from-absolute (calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian (calendar-absolute-from-gregorian
(list displayed-month 28 displayed-year)))))) (list displayed-month 28 displayed-year))))))
(if (= (% (calendar-absolute-from-hebrew (list 10 10 h-year)) (if (= 6 (% (calendar-absolute-from-hebrew (list 10 10 h-year))
7) 7))
6)
11 10)) 11 10))
"Tzom Teveth")) "Tzom Teveth"))
(if all-hebrew-calendar-holidays (if all-hebrew-calendar-holidays
...@@ -800,11 +816,10 @@ calendar." ...@@ -800,11 +816,10 @@ calendar."
y))))) y)))))
(s-s (s-s
(calendar-hebrew-from-absolute (calendar-hebrew-from-absolute
(if (= (if (= 6
(% (calendar-absolute-from-hebrew (% (calendar-absolute-from-hebrew
(list 7 1 h-year)) (list 7 1 h-year))
7) 7))
6)
(calendar-dayname-on-or-before (calendar-dayname-on-or-before
6 (calendar-absolute-from-hebrew 6 (calendar-absolute-from-hebrew
(list 11 17 h-year))) (list 11 17 h-year)))
...@@ -822,15 +837,15 @@ calendar." ...@@ -822,15 +837,15 @@ calendar."
(defvar hebrew-holidays-4 (defvar hebrew-holidays-4
'((holiday-passover-etc) '((holiday-passover-etc)
(if (and all-hebrew-calendar-holidays (if (and all-hebrew-calendar-holidays
(let* ((m displayed-month) (let ((m displayed-month)
(y displayed-year) (y displayed-year)
(year)) year)
(increment-calendar-month m y -1) (increment-calendar-month m y -1)
(let ((year (extract-calendar-year (setq year (extract-calendar-year
(calendar-julian-from-absolute (calendar-julian-from-absolute
(calendar-absolute-from-gregorian (calendar-absolute-from-gregorian
(list m 1 y)))))) (list m 1 y)))))
(= 21 (% year 28))))) (= 21 (% year 28))))
(holiday-julian 3 26 "Kiddush HaHamah")) (holiday-julian 3 26 "Kiddush HaHamah"))
(if all-hebrew-calendar-holidays (if all-hebrew-calendar-holidays
(holiday-tisha-b-av-etc))) (holiday-tisha-b-av-etc)))
...@@ -1191,20 +1206,20 @@ MON defaults to `displayed-month'. YR defaults to `displayed-year'." ...@@ -1191,20 +1206,20 @@ MON defaults to `displayed-month'. YR defaults to `displayed-year'."
(defmacro calendar-for-loop (var from init to final do &rest body) (defmacro calendar-for-loop (var from init to final do &rest body)
"Execute a for loop. "Execute a for loop.
Evaluate BODY with VAR bound to successive integers from INIT to FINAL, Evaluate BODY with VAR bound to successive integers from INIT to FINAL,
inclusive." inclusive. The standard macro `dotimes' is preferable in most cases."
(declare (debug (symbolp "from" form "to" form "do" body))) (declare (debug (symbolp "from" form "to" form "do" body)))
`(let ((,var (1- ,init))) `(let ((,var (1- ,init)))
(while (>= ,final (setq ,var (1+ ,var))) (while (>= ,final (setq ,var (1+ ,var)))
,@body))) ,@body)))
(defmacro calendar-sum (index initial condition expression) (defmacro calendar-sum (index initial condition expression)
"For INDEX = INITIAL et seq, as long as CONDITION holds, sum EXPRESSION." "For INDEX = INITIAL, +1, ... (as long as CONDITION holds), sum EXPRESSION."
(declare (debug (symbolp form form form))) (declare (debug (symbolp form form form)))
`(let ((,index ,initial) `(let ((,index ,initial)
(sum 0)) (sum 0))
(while ,condition (while ,condition
(setq sum (+ sum ,expression)) (setq sum (+ sum ,expression)
(setq ,index (1+ ,index))) ,index (1+ ,index)))
sum)) sum))
;; The following are in-line for speed; they can be called thousands of times ;; The following are in-line for speed; they can be called thousands of times
...@@ -1242,11 +1257,11 @@ inclusive." ...@@ -1242,11 +1257,11 @@ inclusive."
;; Note gives wrong answer for result of (calendar-read-date 'noday). ;; Note gives wrong answer for result of (calendar-read-date 'noday).
(defsubst extract-calendar-day (date) (defsubst extract-calendar-day (date)
"Extract the day part of DATE which has the form (month day year)." "Extract the day part of DATE which has the form (month day year)."
(car (cdr date))) (cadr date))
(defsubst extract-calendar-year (date) (defsubst extract-calendar-year (date)
"Extract the year part of DATE which has the form (month day year)." "Extract the year part of DATE which has the form (month day year)."
(car (cdr (cdr date)))) (nth 2 date))
(defsubst calendar-leap-year-p (year) (defsubst calendar-leap-year-p (year)
"Return t if YEAR is a Gregorian leap year. "Return t if YEAR is a Gregorian leap year.
...@@ -1279,16 +1294,15 @@ A negative year is interpreted as BC; -1 being 1 BC, and so on." ...@@ -1279,16 +1294,15 @@ A negative year is interpreted as BC; -1 being 1 BC, and so on."
"Return the day number within the year of the date DATE. "Return the day number within the year of the date DATE.
For example, (calendar-day-number '(1 1 1987)) returns the value 1, For example, (calendar-day-number '(1 1 1987)) returns the value 1,
while (calendar-day-number '(12 31 1980)) returns 366." while (calendar-day-number '(12 31 1980)) returns 366."
(let* ((month (extract-calendar-month date)) (let* ((month (extract-calendar-month date))
(day (extract-calendar-day date)) (day (extract-calendar-day date))
(year (extract-calendar-year date)) (year (extract-calendar-year date))
(day-of-year (+ day (* 31 (1- month))))) (day-of-year (+ day (* 31 (1- month)))))
(if (> month 2) (when (> month 2)
(progn (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
(setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) (if (calendar-leap-year-p year)
(if (calendar-leap-year-p year) (setq day-of-year (1+ day-of-year))))
(setq day-of-year (1+ day-of-year))))) day-of-year))
day-of-year))
(defsubst calendar-absolute-from-gregorian (date) (defsubst calendar-absolute-from-gregorian (date)
"The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
...@@ -1378,8 +1392,7 @@ to be replaced by asterisks to highlight it whenever it is in the window." ...@@ -1378,8 +1392,7 @@ to be replaced by asterisks to highlight it whenever it is in the window."
(calendar-mode) (calendar-mode)
(let* ((pop-up-windows t) (let* ((pop-up-windows t)
(split-height-threshold 1000) (split-height-threshold 1000)
(date (if arg (date (if arg (calendar-read-date t)
(calendar-read-date t)
(calendar-current-date))) (calendar-current-date)))
(month (extract-calendar-month date)) (month (extract-calendar-month date))
(year (extract-calendar-year date))) (year (extract-calendar-year date)))
...@@ -1465,11 +1478,11 @@ The calendar is inserted at the top of the buffer in which point is currently ...@@ -1465,11 +1478,11 @@ 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 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 character on the line and does not disturb the first INDENT characters on the
line." line."
(let* ((blank-days ; at start of month (let ((blank-days ; at start of month
(mod (mod
(- (calendar-day-of-week (list month 1 year)) (- (calendar-day-of-week (list month 1 year))
calendar-week-start-day) calendar-week-start-day)
7)) 7))
(last (calendar-last-day-of-month month year))) (last (calendar-last-day-of-month month year)))
(goto-char (point-min)) (goto-char (point-min))
(calendar-insert-indented (calendar-insert-indented
...@@ -1491,22 +1504,22 @@ line." ...@@ -1491,22 +1504,22 @@ line."
;; Add blank days before the first of the month. ;; Add blank days before the first of the month.
(dotimes (idummy blank-days) (insert " ")) (dotimes (idummy blank-days) (insert " "))
;; Put in the days of the month. ;; Put in the days of the month.
(calendar-for-loop i from 1 to last do (dotimes (i last)
(insert (format "%2d " i)) (insert (format "%2d " (1+ i)))
(add-text-properties (add-text-properties
(- (point) 3) (1- (point)) (- (point) 3) (1- (point))
'(mouse-face highlight '(mouse-face highlight
help-echo "mouse-2: menu of operations for this date")) help-echo "mouse-2: menu of operations for this date"))
(and (zerop (mod (+ i blank-days) 7)) (and (zerop (mod (+ i 1 blank-days) 7))
(/= i last) (/= i (1- last))
(calendar-insert-indented "" 0 t) ; force onto following line (calendar-insert-indented "" 0 t) ; force onto following line
(calendar-insert-indented "" indent))))) ; go to proper spot (calendar-insert-indented "" indent))))) ; go to proper spot
(defun calendar-insert-indented (string indent &optional newline) (defun calendar-insert-indented (string indent &optional newline)
"Insert STRING at column INDENT. "Insert STRING at column INDENT.
If the optional parameter NEWLINE is t, leave point at start of next line, If the optional parameter NEWLINE is non-nil, leave point at start of next
inserting a newline if there was no next line; otherwise, leave point after line, inserting a newline if there was no next line; otherwise, leave point
the inserted text. Returns t." after the inserted text. Returns t."
;; Try to move to that column. ;; Try to move to that column.
(move-to-column indent) (move-to-column indent)
;; If line is too short, indent out to that column. ;; If line is too short, indent out to that column.
...@@ -1758,7 +1771,8 @@ under the cursor: ...@@ -1758,7 +1771,8 @@ under the cursor:
:group 'calendar) :group 'calendar)
(defun mouse-calendar-other-month (event) (defun mouse-calendar-other-month (event)
"Display a three-month calendar centered around a specified month and year." "Display a three-month calendar centered around a specified month and year.
EVENT is the last mouse event."
(interactive "e") (interactive "e")
(save-selected-window (save-selected-window
(select-window (posn-window (event-start event))) (select-window (posn-window (event-start event)))
...@@ -1864,7 +1878,7 @@ the STRINGS are just concatenated and the result truncated." ...@@ -1864,7 +1878,7 @@ the STRINGS are just concatenated and the result truncated."
(defun exit-calendar () (defun exit-calendar ()
"Get out of the calendar window and hide it and related buffers." "Get out of the calendar window and hide it and related buffers."
(interactive) (interactive)
(let* ((diary-buffer (get-file-buffer diary-file))) (let ((diary-buffer (get-file-buffer diary-file)))
(if (or (not diary-buffer) (if (or (not diary-buffer)
(not (buffer-modified-p diary-buffer)) (not (buffer-modified-p diary-buffer))
(yes-or-no-p (yes-or-no-p
...@@ -1902,7 +1916,7 @@ the STRINGS are just concatenated and the result truncated." ...@@ -1902,7 +1916,7 @@ the STRINGS are just concatenated and the result truncated."
(defun calendar-cursor-to-date (&optional error) (defun calendar-cursor-to-date (&optional error)
"Return a list (month day year) of current cursor position. "Return a list (month day year) of current cursor position.
If cursor is not on a specific date, signals an error if optional parameter If cursor is not on a specific date, signals an error if optional parameter
ERROR is t, otherwise just returns nil." ERROR is non-nil, otherwise just returns nil."
(let* ((segment (/ (current-column) 25)) (let* ((segment (/ (current-column) 25))
(month (% (+ displayed-month segment -1) 12)) (month (% (+ displayed-month segment -1) 12))
(month (if (zerop month) 12 month)) (month (if (zerop month) 12 month))
...@@ -2002,20 +2016,19 @@ With no prefix argument, push current date onto marked date ring. ...@@ -2002,20 +2016,19 @@ With no prefix argument, push current date onto marked date ring.
With argument ARG, jump to mark, pop it, and put point at end of ring." With argument ARG, jump to mark, pop it, and put point at end of ring."
(interactive "P") (interactive "P")
(let ((date (calendar-cursor-to-date t))) (let ((date (calendar-cursor-to-date t)))
(if (null arg) (if arg
(progn (if (null calendar-mark-ring)
(push date calendar-mark-ring) (error "No mark set in this buffer")
;; Since the top of the mark ring is the marked date in the (calendar-goto-date (car calendar-mark-ring))
;; calendar, the mark ring in the calendar is one longer than (setq calendar-mark-ring
;; in other buffers to get the same effect. (cdr (nconc calendar-mark-ring (list date)))))
(if (> (length calendar-mark-ring) (1+ mark-ring-max)) (push date calendar-mark-ring)
(setcdr (nthcdr mark-ring-max calendar-mark-ring) nil)) ;; Since the top of the mark ring is the marked date in the
(message "Mark set")) ;; calendar, the mark ring in the calendar is one longer than
(if (null calendar-mark-ring) ;; in other buffers to get the same effect.
(error "No mark set in this buffer") (if (> (length calendar-mark-ring) (1+ mark-ring-max))
(calendar-goto-date (car calendar-mark-ring)) (setcdr (nthcdr mark-ring-max calendar-mark-ring) nil))
(setq calendar-mark-ring (message "Mark set"))))
(cdr (nconc calendar-mark-ring (list date))))))))
(defun calendar-exchange-point-and-mark () (defun calendar-exchange-point-and-mark ()
"Exchange the current cursor position with the marked date." "Exchange the current cursor position with the marked date."
...@@ -2096,6 +2109,34 @@ element of this array is nil, then the abbreviation will be ...@@ -2096,6 +2109,34 @@ element of this array is nil, then the abbreviation will be
constructed as the first `calendar-abbrev-length' characters of the constructed as the first `calendar-abbrev-length' characters of the
corresponding full name.") corresponding full name.")
(defun calendar-make-alist (sequence &optional start-index filter abbrevs)
"Make an assoc list corresponding to SEQUENCE.
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 (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-read-date (&optional noday) (defun calendar-read-date (&optional noday)
"Prompt for Gregorian date. Return a list (month day year). "Prompt for Gregorian date. Return a list (month day year).
...@@ -2180,35 +2221,6 @@ the variable `calendar-day-abbrev-array' is used." ...@@ -2180,35 +2221,6 @@ the variable `calendar-day-abbrev-array' is used."
calendar-day-name-array) calendar-day-name-array)
(if absolute date (calendar-day-of-week date)))) (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.
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 (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) (defun calendar-month-name (month &optional abbrev)
"Return a string with the name of month number MONTH. "Return a string with the name of month number MONTH.
Months are numbered from one. Month names are taken from the Months are numbered from one. Month names are taken from the
...@@ -2354,9 +2366,7 @@ and day names to be abbreviated as specified by ...@@ -2354,9 +2366,7 @@ and day names to be abbreviated as specified by
`calendar-month-abbrev-array' and `calendar-day-abbrev-array', `calendar-month-abbrev-array' and `calendar-day-abbrev-array',
respectively. An optional parameter NODAYNAME, when t, omits the respectively. An optional parameter NODAYNAME, when t, omits the
name of the day of the week." name of the day of the week."
(let* ((dayname (let* ((dayname (unless nodayname (calendar-day-name date abbreviate)))
(unless nodayname
(calendar-day-name date abbreviate)))
(month (extract-calendar-month date)) (month (extract-calendar-month date))
(monthname (calendar-month-name month abbreviate)) (monthname (calendar-month-name month abbreviate))
(day (int-to-string (extract-calendar-day date))) (day (int-to-string (extract-calendar-day date)))
...@@ -2418,7 +2428,7 @@ Defaults to today's date if DATE is not given." ...@@ -2418,7 +2428,7 @@ Defaults to today's date if DATE is not given."
(defun calendar-print-other-dates () (defun calendar-print-other-dates ()
"Show dates on other calendars for date under the cursor." "Show dates on other calendars for date under the cursor."
(interactive) (interactive)
(let* ((date (calendar-cursor-to-date t))) (let ((date (calendar-cursor-to-date t)))
(with-current-buffer (get-buffer-create other-calendars-buffer) (with-current-buffer (get-buffer-create other-calendars-buffer)
(let ((inhibit-read-only t) (let ((inhibit-read-only t)
(modified (buffer-modified-p))) (modified (buffer-modified-p)))
...@@ -2473,7 +2483,7 @@ Defaults to today's date if DATE is not given." ...@@ -2473,7 +2483,7 @@ Defaults to today's date if DATE is not given."
"Set mode line to STR, centered, surrounded by dashes." "Set mode line to STR, centered, surrounded by dashes."
(let* ((edges (window-edges)) (let* ((edges (window-edges))
;; As per doc of window-width, total visible mode-line length. ;; As per doc of window-width, total visible mode-line length.
(width (- (nth 2 edges) (nth 0 edges)))) (width (- (nth 2 edges) (car edges))))
(setq mode-line-format (setq mode-line-format
(if buffer-file-name (if buffer-file-name
`("-" mode-line-modified `("-" mode-line-modified
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment