/[emacs]/emacs/lisp/calendar/cal-hebrew.el
ViewVC logotype

Diff of /emacs/lisp/calendar/cal-hebrew.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12.2.1 by miles, Fri Apr 4 06:20:15 2003 UTC revision 1.12.2.2 by miles, Tue Oct 14 23:42:13 2003 UTC
# Line 1  Line 1 
1  ;;; cal-hebrew.el --- calendar functions for the Hebrew calendar  ;;; cal-hebrew.el --- calendar functions for the Hebrew calendar
2    
3  ;; Copyright (C) 1995, 1997 Free Software Foundation, Inc.  ;; Copyright (C) 1995, 1997, 2003 Free Software Foundation, Inc.
4    
5  ;; Author: Nachum Dershowitz <nachum@cs.uiuc.edu>  ;; Author: Nachum Dershowitz <nachum@cs.uiuc.edu>
6  ;;      Edward M. Reingold <reingold@cs.uiuc.edu>  ;;      Edward M. Reingold <reingold@cs.uiuc.edu>
# Line 41  Line 41 
41    
42  ;;; Code:  ;;; Code:
43    
44  (require 'calendar)  (defvar displayed-month)
45    (defvar displayed-year)
46    
47  (defun calendar-hebrew-from-absolute (date)  (require 'calendar)
   "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)))  
48    
49  (defun hebrew-calendar-leap-year-p (year)  (defun hebrew-calendar-leap-year-p (year)
50    "t if YEAR is a Hebrew calendar leap year."    "t if YEAR is a Hebrew calendar leap year."
# Line 75  Gregorian date Sunday, December 31, 1 BC Line 56  Gregorian date Sunday, December 31, 1 BC
56        13        13
57      12))      12))
58    
 (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))  
   
59  (defun hebrew-calendar-elapsed-days (year)  (defun hebrew-calendar-elapsed-days (year)
60    "Days from Sun. prior to start of Hebrew calendar to mean conjunction of Tishri of Hebrew YEAR."    "Days from Sun. prior to start of Hebrew calendar to mean conjunction of Tishri of Hebrew YEAR."
61    (let* ((months-elapsed    (let* ((months-elapsed
# Line 133  Gregorian date Sunday, December 31, 1 BC Line 105  Gregorian date Sunday, December 31, 1 BC
105    "t if Kislev is short in Hebrew YEAR."    "t if Kislev is short in Hebrew YEAR."
106    (= (% (hebrew-calendar-days-in-year year) 10) 3))    (= (% (hebrew-calendar-days-in-year year) 10) 3))
107    
108    (defun hebrew-calendar-last-day-of-month (month year)
109      "The last day of MONTH in YEAR."
110      (if (or (memq month (list 2 4 6 10 13))
111              (and (= month 12) (not (hebrew-calendar-leap-year-p year)))
112              (and (= month 8) (not (hebrew-calendar-long-heshvan-p year)))
113              (and (= month 9) (hebrew-calendar-short-kislev-p year)))
114          29
115        30))
116    
117  (defun calendar-absolute-from-hebrew (date)  (defun calendar-absolute-from-hebrew (date)
118    "Absolute date of Hebrew DATE.    "Absolute date of Hebrew DATE.
119  The absolute date is the number of days elapsed since the (imaginary)  The absolute date is the number of days elapsed since the (imaginary)
# Line 156  Gregorian date Sunday, December 31, 1 BC Line 137  Gregorian date Sunday, December 31, 1 BC
137      (hebrew-calendar-elapsed-days year);; Days in prior years.      (hebrew-calendar-elapsed-days year);; Days in prior years.
138      -1373429)))                        ;; Days elapsed before absolute date 1.      -1373429)))                        ;; Days elapsed before absolute date 1.
139    
140    (defun calendar-hebrew-from-absolute (date)
141      "Compute the Hebrew date (month day year) corresponding to absolute DATE.
142    The absolute date is the number of days elapsed since the (imaginary)
143    Gregorian date Sunday, December 31, 1 BC."
144      (let* ((greg-date (calendar-gregorian-from-absolute date))
145             (month (aref [9 10 11 12 1 2 3 4 7 7 7 8]
146                     (1- (extract-calendar-month greg-date))))
147             (day)
148             (year (+ 3760 (extract-calendar-year greg-date))))
149        (while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year))))
150            (setq year (1+ year)))
151        (let ((length (hebrew-calendar-last-month-of-year year)))
152          (while (> date
153                    (calendar-absolute-from-hebrew
154                     (list month
155                           (hebrew-calendar-last-day-of-month month year)
156                           year)))
157            (setq month (1+ (% month length)))))
158        (setq day (1+
159                   (- date (calendar-absolute-from-hebrew (list month 1 year)))))
160        (list month day year)))
161    
162  (defvar calendar-hebrew-month-name-array-common-year  (defvar calendar-hebrew-month-name-array-common-year
163    ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"    ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
164     "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"])     "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"]
165    "Array of strings giving the names of the Hebrew months in a common year.")
166    
167  (defvar calendar-hebrew-month-name-array-leap-year  (defvar calendar-hebrew-month-name-array-leap-year
168    ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"    ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
169     "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"])     "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"]
170    "Array of strings giving the names of the Hebrew months in a leap year.")
171    
172  (defun calendar-hebrew-date-string (&optional date)  (defun calendar-hebrew-date-string (&optional date)
173    "String of Hebrew date before sunset of Gregorian DATE.    "String of Hebrew date before sunset of Gregorian DATE.
# Line 525  not be marked in the calendar.  This fun Line 530  not be marked in the calendar.  This fun
530                                   (car d)))                                   (car d)))
531                      (backup (equal (car (car d)) 'backup))                      (backup (equal (car (car d)) 'backup))
532                      (dayname                      (dayname
533                       (concat                       (format "%s\\|%s\\.?"
534                        (calendar-day-name gdate) "\\|"                               (calendar-day-name gdate)
535                        (substring (calendar-day-name gdate) 0 3) ".?"))                               (calendar-day-name gdate 'abbrev)))
536                      (calendar-month-name-array                      (calendar-month-name-array
537                       calendar-hebrew-month-name-array-leap-year)                       calendar-hebrew-month-name-array-leap-year)
538                      (monthname                      (monthname
# Line 573  not be marked in the calendar.  This fun Line 578  not be marked in the calendar.  This fun
578                          gdate                          gdate
579                          (buffer-substring-no-properties entry-start (point))                          (buffer-substring-no-properties entry-start (point))
580                          (buffer-substring-no-properties                          (buffer-substring-no-properties
581                           (1+ date-start) (1- entry-start)))))))                           (1+ date-start) (1- entry-start))
582                            (copy-marker entry-start))))))
583                 (setq d (cdr d))))                 (setq d (cdr d))))
584             (setq gdate             (setq gdate
585                   (calendar-gregorian-from-absolute                   (calendar-gregorian-from-absolute
# Line 581  not be marked in the calendar.  This fun Line 587  not be marked in the calendar.  This fun
587             (set-buffer-modified-p diary-modified))             (set-buffer-modified-p diary-modified))
588          (goto-char (point-min))))          (goto-char (point-min))))
589    
590    (defun mark-hebrew-calendar-date-pattern (month day year)
591      "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.
592    A value of 0 in any position is a wildcard."
593      (save-excursion
594        (set-buffer calendar-buffer)
595        (if (and (/= 0 month) (/= 0 day))
596            (if (/= 0 year)
597                ;; Fully specified Hebrew date.
598                (let ((date (calendar-gregorian-from-absolute
599                             (calendar-absolute-from-hebrew
600                              (list month day year)))))
601                  (if (calendar-date-is-visible-p date)
602                      (mark-visible-calendar-date date)))
603              ;; Month and day in any year--this taken from the holiday stuff.
604              (if (memq displayed-month;;  This test is only to speed things up a
605                        (list          ;;  bit; it works fine without the test too.
606                         (if (< 11 month) (- month 11) (+ month 1))
607                         (if (< 10 month) (- month 10) (+ month 2))
608                         (if (<  9 month) (- month  9) (+ month 3))
609                         (if (<  8 month) (- month  8) (+ month 4))
610                         (if (<  7 month) (- month  7) (+ month 5))))
611                  (let ((m1 displayed-month)
612                        (y1 displayed-year)
613                        (m2 displayed-month)
614                        (y2 displayed-year)
615                        (year))
616                    (increment-calendar-month m1 y1 -1)
617                    (increment-calendar-month m2 y2 1)
618                    (let* ((start-date (calendar-absolute-from-gregorian
619                                        (list m1 1 y1)))
620                           (end-date (calendar-absolute-from-gregorian
621                                      (list m2
622                                            (calendar-last-day-of-month m2 y2)
623                                            y2)))
624                           (hebrew-start
625                            (calendar-hebrew-from-absolute start-date))
626                           (hebrew-end (calendar-hebrew-from-absolute end-date))
627                           (hebrew-y1 (extract-calendar-year hebrew-start))
628                           (hebrew-y2 (extract-calendar-year hebrew-end)))
629                      (setq year (if (< 6 month) hebrew-y2 hebrew-y1))
630                      (let ((date (calendar-gregorian-from-absolute
631                                   (calendar-absolute-from-hebrew
632                                    (list month day year)))))
633                        (if (calendar-date-is-visible-p date)
634                            (mark-visible-calendar-date date)))))))
635          ;; Not one of the simple cases--check all visible dates for match.
636          ;; Actually, the following code takes care of ALL of the cases, but
637          ;; it's much too slow to be used for the simple (common) cases.
638          (let ((m displayed-month)
639                (y displayed-year)
640                (first-date)
641                (last-date))
642            (increment-calendar-month m y -1)
643            (setq first-date
644                  (calendar-absolute-from-gregorian
645                   (list m 1 y)))
646            (increment-calendar-month m y 2)
647            (setq last-date
648                  (calendar-absolute-from-gregorian
649                   (list m (calendar-last-day-of-month m y) y)))
650            (calendar-for-loop date from first-date to last-date do
651              (let* ((h-date (calendar-hebrew-from-absolute date))
652                     (h-month (extract-calendar-month h-date))
653                     (h-day (extract-calendar-day h-date))
654                     (h-year (extract-calendar-year h-date)))
655                (and (or (zerop month)
656                         (= month h-month))
657                     (or (zerop day)
658                         (= day h-day))
659                     (or (zerop year)
660                         (= year h-year))
661                     (mark-visible-calendar-date
662                      (calendar-gregorian-from-absolute date)))))))))
663    
664  (defun mark-hebrew-diary-entries ()  (defun mark-hebrew-diary-entries ()
665    "Mark days in the calendar window that have Hebrew date diary entries.    "Mark days in the calendar window that have Hebrew date diary entries.
666  Each entry in diary-file (or included files) visible in the calendar window  Each entry in diary-file (or included files) visible in the calendar window
# Line 598  is provided for use as part of the nongr Line 678  is provided for use as part of the nongr
678            ((date-form (if (equal (car (car d)) 'backup)            ((date-form (if (equal (car (car d)) 'backup)
679                            (cdr (car d))                            (cdr (car d))
680                          (car d)));; ignore 'backup directive                          (car d)));; ignore 'backup directive
681             (dayname (diary-name-pattern calendar-day-name-array))             (dayname (diary-name-pattern calendar-day-name-array
682                                            calendar-day-abbrev-array))
683             (monthname             (monthname
684              (concat              (format "%s\\|\\*"
685               (diary-name-pattern calendar-hebrew-month-name-array-leap-year t)                      (diary-name-pattern
686               "\\|\\*"))                       calendar-hebrew-month-name-array-leap-year)))
687             (month "[0-9]+\\|\\*")             (month "[0-9]+\\|\\*")
688             (day "[0-9]+\\|\\*")             (day "[0-9]+\\|\\*")
689             (year "[0-9]+\\|\\*")             (year "[0-9]+\\|\\*")
# Line 672  is provided for use as part of the nongr Line 753  is provided for use as part of the nongr
753                           (string-to-int y-str)))))                           (string-to-int y-str)))))
754              (if dd-name              (if dd-name
755                  (mark-calendar-days-named                  (mark-calendar-days-named
756                   (cdr (assoc-ignore-case                   (cdr (assoc-ignore-case dd-name
757                         (substring dd-name 0 3)                                           (calendar-make-alist
758                         (calendar-make-alist                                            calendar-day-name-array
759                          calendar-day-name-array                                            0 nil calendar-day-abbrev-array))))
                         0  
                         '(lambda (x) (substring x 0 3))))))  
760                (if mm-name                (if mm-name
761                    (if (string-equal mm-name "*")                    (setq mm
762                        (setq mm 0)                          (if (string-equal mm-name "*") 0
763                      (setq                            (cdr
764                        mm                             (assoc-ignore-case
765                        (cdr                              mm-name
766                          (assoc-ignore-case                              (calendar-make-alist
767                           mm-name                               calendar-hebrew-month-name-array-leap-year))))))
                          (calendar-make-alist  
                           calendar-hebrew-month-name-array-leap-year))))))  
768                (mark-hebrew-calendar-date-pattern mm dd yy)))))                (mark-hebrew-calendar-date-pattern mm dd yy)))))
769        (setq d (cdr d)))))        (setq d (cdr d)))))
770    
 (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)))))))))  
   
771  (defun insert-hebrew-diary-entry (arg)  (defun insert-hebrew-diary-entry (arg)
772    "Insert a diary entry.    "Insert a diary entry.
773  For the Hebrew date corresponding to the date indicated by point.  For the Hebrew date corresponding to the date indicated by point.
# Line 1016  use when highlighting the day in the cal Line 1019  use when highlighting the day in the cal
1019                                          h-year))                                          h-year))
1020                                      0 h-month)))))))))                                      0 h-month)))))))))
1021    
1022    (defvar hebrew-calendar-parashiot-names
1023    ["Bereshith"   "Noah"      "Lech L'cha" "Vayera"    "Hayei Sarah" "Toledoth"
1024     "Vayetze"     "Vayishlah" "Vayeshev"   "Mikketz"   "Vayiggash"   "Vayhi"
1025     "Shemoth"     "Vaera"     "Bo"         "Beshallah" "Yithro"      "Mishpatim"
1026     "Terumah"     "Tetzavveh" "Ki Tissa"   "Vayakhel"  "Pekudei"     "Vayikra"
1027     "Tzav"        "Shemini"   "Tazria"     "Metzora"   "Aharei Moth" "Kedoshim"
1028     "Emor"        "Behar"     "Behukkotai" "Bemidbar"  "Naso"       "Behaalot'cha"
1029     "Shelah L'cha" "Korah"    "Hukkath"    "Balak"     "Pinhas"      "Mattoth"
1030     "Masei"       "Devarim"   "Vaethanan"  "Ekev"      "Reeh"        "Shofetim"
1031     "Ki Tetze"    "Ki Tavo"   "Nitzavim"   "Vayelech"  "Haazinu"]
1032      "The names of the parashiot in the Torah.")
1033    
1034    (defun hebrew-calendar-parasha-name (p)
1035      "Name(s) corresponding to parasha P."
1036      (if (arrayp p);; combined parasha
1037          (format "%s/%s"
1038                  (aref hebrew-calendar-parashiot-names (aref p 0))
1039                  (aref hebrew-calendar-parashiot-names (aref p 1)))
1040        (aref hebrew-calendar-parashiot-names p)))
1041    
1042  (defun diary-parasha (&optional mark)  (defun diary-parasha (&optional mark)
1043    "Parasha diary entry--entry applies if date is a Saturday.    "Parasha diary entry--entry applies if date is a Saturday.
1044    
# Line 1061  use when highlighting the day in the cal Line 1084  use when highlighting the day in the cal
1084                                     (hebrew-calendar-parasha-name (cdr parasha))))                                     (hebrew-calendar-parasha-name (cdr parasha))))
1085                         (hebrew-calendar-parasha-name parasha)))))))))                         (hebrew-calendar-parasha-name parasha)))))))))
1086    
 (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.")  
   
1087  ;; The seven ordinary year types (keviot)  ;; The seven ordinary year types (keviot)
1088    
1089  (defconst hebrew-calendar-year-Saturday-incomplete-Sunday  (defconst hebrew-calendar-year-Saturday-incomplete-Sunday
# Line 1192  have 29 days), and has Passover start on Line 1203  have 29 days), and has Passover start on
1203  Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both  Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
1204  have 30 days), and has Passover start on Tuesday.")  have 30 days), and has Passover start on Tuesday.")
1205    
 (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)))  
   
1206  (provide 'cal-hebrew)  (provide 'cal-hebrew)
1207    
1208    ;;; arch-tag: aaab6718-7712-42ac-a32d-28fe1f944f3c
1209  ;;; cal-hebrew.el ends here  ;;; cal-hebrew.el ends here

Legend:
Removed from v.1.12.2.1  
changed lines
  Added in v.1.12.2.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26