Skip to content

GitLab

Commit da3fc020 authored by Glenn Morris's avatar Glenn Morris
Browse files

Reposition some code so defined before used. 

(displayed-month, displayed-year): Define for compiler.
(calendar-hebrew-month-name-array-common-year)
(calendar-hebrew-month-name-array-leap-year): Add doc strings.
(list-hebrew-diary-entries): Adapt for new behaviours of
`calendar-day-name' and `add-to-diary-list' functions.
(mark-hebrew-diary-entries): Adapt for new behaviours of
`diary-name-pattern' and `calendar-make-alist' functions.
parent ca2a5950
Hide whitespace changes
Inline Side-by-side
Showing with 154 additions and 151 deletions
lisp/calendar/cal-hebrew.el
View file @ da3fc020
;;; cal-hebrew.el --- calendar functions for the Hebrew calendar
;; Copyright (C) 1995, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1997, 2003 Free Software Foundation, Inc.
;; Author: Nachum Dershowitz <nachum@cs.uiuc.edu>
;; Edward M. Reingold <reingold@cs.uiuc.edu>
......@@ -41,29 +41,10 @@
;;; Code:
(require 'calendar)
(defvar displayed-month)
(defvar displayed-year)
(defun calendar-hebrew-from-absolute (date)
"Compute the Hebrew 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."
(let* ((greg-date (calendar-gregorian-from-absolute date))
(month (aref [9 10 11 12 1 2 3 4 7 7 7 8]
(1- (extract-calendar-month greg-date))))
(day)
(year (+ 3760 (extract-calendar-year greg-date))))
(while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year))))
(setq year (1+ year)))
(let ((length (hebrew-calendar-last-month-of-year year)))
(while (> date
(calendar-absolute-from-hebrew
(list month
(hebrew-calendar-last-day-of-month month year)
year)))
(setq month (1+ (% month length)))))
(setq day (1+
(- date (calendar-absolute-from-hebrew (list month 1 year)))))
(list month day year)))
(require 'calendar)
(defun hebrew-calendar-leap-year-p (year)
"t if YEAR is a Hebrew calendar leap year."
......@@ -75,15 +56,6 @@ Gregorian date Sunday, December 31, 1 BC."
13
12))
(defun hebrew-calendar-last-day-of-month (month year)
"The last day of MONTH in YEAR."
(if (or (memq month (list 2 4 6 10 13))
(and (= month 12) (not (hebrew-calendar-leap-year-p year)))
(and (= month 8) (not (hebrew-calendar-long-heshvan-p year)))
(and (= month 9) (hebrew-calendar-short-kislev-p year)))
29
30))
(defun hebrew-calendar-elapsed-days (year)
"Days from Sun. prior to start of Hebrew calendar to mean conjunction of Tishri of Hebrew YEAR."
(let* ((months-elapsed
......@@ -133,6 +105,15 @@ Gregorian date Sunday, December 31, 1 BC."
"t if Kislev is short in Hebrew YEAR."
(= (% (hebrew-calendar-days-in-year year) 10) 3))
(defun hebrew-calendar-last-day-of-month (month year)
"The last day of MONTH in YEAR."
(if (or (memq month (list 2 4 6 10 13))
(and (= month 12) (not (hebrew-calendar-leap-year-p year)))
(and (= month 8) (not (hebrew-calendar-long-heshvan-p year)))
(and (= month 9) (hebrew-calendar-short-kislev-p year)))
29
30))
(defun calendar-absolute-from-hebrew (date)
"Absolute date of Hebrew DATE.
The absolute date is the number of days elapsed since the (imaginary)
......@@ -156,13 +137,37 @@ Gregorian date Sunday, December 31, 1 BC."
(hebrew-calendar-elapsed-days year);; Days in prior years.
-1373429))) ;; Days elapsed before absolute date 1.
(defun calendar-hebrew-from-absolute (date)
"Compute the Hebrew 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."
(let* ((greg-date (calendar-gregorian-from-absolute date))
(month (aref [9 10 11 12 1 2 3 4 7 7 7 8]
(1- (extract-calendar-month greg-date))))
(day)
(year (+ 3760 (extract-calendar-year greg-date))))
(while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year))))
(setq year (1+ year)))
(let ((length (hebrew-calendar-last-month-of-year year)))
(while (> date
(calendar-absolute-from-hebrew
(list month
(hebrew-calendar-last-day-of-month month year)
year)))
(setq month (1+ (% month length)))))
(setq day (1+
(- date (calendar-absolute-from-hebrew (list month 1 year)))))
(list month day year)))
(defvar calendar-hebrew-month-name-array-common-year
["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
"Heshvan" "Kislev" "Teveth" "Shevat" "Adar"])
"Heshvan" "Kislev" "Teveth" "Shevat" "Adar"]
"Array of strings giving the names of the Hebrew months in a common year.")
(defvar calendar-hebrew-month-name-array-leap-year
["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
"Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"])
"Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"]
"Array of strings giving the names of the Hebrew months in a leap year.")
(defun calendar-hebrew-date-string (&optional date)
"String of Hebrew date before sunset of Gregorian DATE.
......@@ -525,9 +530,9 @@ not be marked in the calendar. This function is provided for use with the
(car d)))
(backup (equal (car (car d)) 'backup))
(dayname
(concat
(calendar-day-name gdate) "\\|"
(substring (calendar-day-name gdate) 0 3) ".?"))
(format "%s\\|%s\\.?"
(calendar-day-name gdate)
(calendar-day-name gdate 'abbrev)))
(calendar-month-name-array
calendar-hebrew-month-name-array-leap-year)
(monthname
......@@ -573,7 +578,8 @@ not be marked in the calendar. This function is provided for use with the
gdate
(buffer-substring-no-properties entry-start (point))
(buffer-substring-no-properties
(1+ date-start) (1- entry-start)))))))
(1+ date-start) (1- entry-start))
(copy-marker entry-start))))))
(setq d (cdr d))))
(setq gdate
(calendar-gregorian-from-absolute
......@@ -581,6 +587,80 @@ not be marked in the calendar. This function is provided for use with the
(set-buffer-modified-p diary-modified))
(goto-char (point-min))))
(defun mark-hebrew-calendar-date-pattern (month day year)
"Mark dates in calendar window that conform to Hebrew 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 Hebrew date.
(let ((date (calendar-gregorian-from-absolute
(calendar-absolute-from-hebrew
(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.
(if (memq displayed-month;; This test is only to speed things up a
(list ;; bit; it works fine without the test too.
(if (< 11 month) (- month 11) (+ month 1))
(if (< 10 month) (- month 10) (+ month 2))
(if (< 9 month) (- month 9) (+ month 3))
(if (< 8 month) (- month 8) (+ month 4))
(if (< 7 month) (- month 7) (+ month 5))))
(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)))
(hebrew-start
(calendar-hebrew-from-absolute start-date))
(hebrew-end (calendar-hebrew-from-absolute end-date))
(hebrew-y1 (extract-calendar-year hebrew-start))
(hebrew-y2 (extract-calendar-year hebrew-end)))
(setq year (if (< 6 month) hebrew-y2 hebrew-y1))
(let ((date (calendar-gregorian-from-absolute
(calendar-absolute-from-hebrew
(list month day year)))))
(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* ((h-date (calendar-hebrew-from-absolute date))
(h-month (extract-calendar-month h-date))
(h-day (extract-calendar-day h-date))
(h-year (extract-calendar-year h-date)))
(and (or (zerop month)
(= month h-month))
(or (zerop day)
(= day h-day))
(or (zerop year)
(= year h-year))
(mark-visible-calendar-date
(calendar-gregorian-from-absolute date)))))))))
(defun mark-hebrew-diary-entries ()
"Mark days in the calendar window that have Hebrew date diary entries.
Each entry in diary-file (or included files) visible in the calendar window
......@@ -598,11 +678,12 @@ is provided for use as part of the nongregorian-diary-marking-hook."
((date-form (if (equal (car (car d)) 'backup)
(cdr (car d))
(car d)));; ignore 'backup directive
(dayname (diary-name-pattern calendar-day-name-array))
(dayname (diary-name-pattern calendar-day-name-array
calendar-day-abbrev-array))
(monthname
(concat
(diary-name-pattern calendar-hebrew-month-name-array-leap-year t)
"\\|\\*"))
(format "%s\\|\\*"
(diary-name-pattern
calendar-hebrew-month-name-array-leap-year)))
(month "[0-9]+\\|\\*")
(day "[0-9]+\\|\\*")
(year "[0-9]+\\|\\*")
......@@ -672,99 +753,21 @@ is provided for use as part of the nongregorian-diary-marking-hook."
(string-to-int y-str)))))
(if dd-name
(mark-calendar-days-named
(cdr (assoc-ignore-case
(substring dd-name 0 3)
(calendar-make-alist
calendar-day-name-array
0
'(lambda (x) (substring x 0 3))))))
(cdr (assoc-ignore-case dd-name
(calendar-make-alist
calendar-day-name-array
0 nil calendar-day-abbrev-array))))
(if mm-name
(if (string-equal mm-name "*")
(setq mm 0)
(setq
mm
(cdr
(assoc-ignore-case
mm-name
(calendar-make-alist
calendar-hebrew-month-name-array-leap-year))))))
(setq mm
(if (string-equal mm-name "*") 0
(cdr
(assoc-ignore-case
mm-name
(calendar-make-alist
calendar-hebrew-month-name-array-leap-year))))))
(mark-hebrew-calendar-date-pattern mm dd yy)))))
(setq d (cdr d)))))
(defun mark-hebrew-calendar-date-pattern (month day year)
"Mark dates in calendar window that conform to Hebrew 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 Hebrew date.
(let ((date (calendar-gregorian-from-absolute
(calendar-absolute-from-hebrew
(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.
(if (memq displayed-month;; This test is only to speed things up a
(list ;; bit; it works fine without the test too.
(if (< 11 month) (- month 11) (+ month 1))
(if (< 10 month) (- month 10) (+ month 2))
(if (< 9 month) (- month 9) (+ month 3))
(if (< 8 month) (- month 8) (+ month 4))
(if (< 7 month) (- month 7) (+ month 5))))
(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)))
(hebrew-start
(calendar-hebrew-from-absolute start-date))
(hebrew-end (calendar-hebrew-from-absolute end-date))
(hebrew-y1 (extract-calendar-year hebrew-start))
(hebrew-y2 (extract-calendar-year hebrew-end)))
(setq year (if (< 6 month) hebrew-y2 hebrew-y1))
(let ((date (calendar-gregorian-from-absolute
(calendar-absolute-from-hebrew
(list month day year)))))
(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* ((h-date (calendar-hebrew-from-absolute date))
(h-month (extract-calendar-month h-date))
(h-day (extract-calendar-day h-date))
(h-year (extract-calendar-year h-date)))
(and (or (zerop month)
(= month h-month))
(or (zerop day)
(= day h-day))
(or (zerop year)
(= year h-year))
(mark-visible-calendar-date
(calendar-gregorian-from-absolute date)))))))))
(defun insert-hebrew-diary-entry (arg)
"Insert a diary entry.
For the Hebrew date corresponding to the date indicated by point.
......@@ -1016,6 +1019,26 @@ use when highlighting the day in the calendar."
h-year))
0 h-month)))))))))
(defvar hebrew-calendar-parashiot-names
["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth"
"Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi"
"Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim"
"Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra"
"Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim"
"Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha"
"Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth"
"Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim"
"Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"]
"The names of the parashiot in the Torah.")
(defun hebrew-calendar-parasha-name (p)
"Name(s) corresponding to parasha P."
(if (arrayp p);; combined parasha
(format "%s/%s"
(aref hebrew-calendar-parashiot-names (aref p 0))
(aref hebrew-calendar-parashiot-names (aref p 1)))
(aref hebrew-calendar-parashiot-names p)))
(defun diary-parasha (&optional mark)
"Parasha diary entry--entry applies if date is a Saturday.
......@@ -1061,18 +1084,6 @@ use when highlighting the day in the calendar."
(hebrew-calendar-parasha-name (cdr parasha))))
(hebrew-calendar-parasha-name parasha)))))))))
(defvar hebrew-calendar-parashiot-names
["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth"
"Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi"
"Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim"
"Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra"
"Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim"
"Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha"
"Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth"
"Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim"
"Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"]
"The names of the parashiot in the Torah.")
;; The seven ordinary year types (keviot)
(defconst hebrew-calendar-year-Saturday-incomplete-Sunday
......@@ -1192,14 +1203,6 @@ have 29 days), and has Passover start on Sunday.")
Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
have 30 days), and has Passover start on Tuesday.")
(defun hebrew-calendar-parasha-name (p)
"Name(s) corresponding to parasha P."
(if (arrayp p);; combined parasha
(format "%s/%s"
(aref hebrew-calendar-parashiot-names (aref p 0))
(aref hebrew-calendar-parashiot-names (aref p 1)))
(aref hebrew-calendar-parashiot-names p)))
(provide 'cal-hebrew)
;;; cal-hebrew.el ends here
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