code.delx.au - gnu-emacs/blob - lisp/calendar/cal-hebrew.el

   1 ;;; cal-hebrew.el --- calendar functions for the Hebrew calendar
   2
   3 ;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: Nachum Dershowitz <nachum@cs.uiuc.edu>
   7 ;;      Edward M. Reingold <reingold@cs.uiuc.edu>
   8 ;; Maintainer: Glenn Morris <rgm@gnu.org>
   9 ;; Keywords: calendar
  10 ;; Human-Keywords: Hebrew calendar, calendar, diary
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; This collection of functions implements the features of calendar.el and
  32 ;; diary.el that deal with the Hebrew calendar.
  33
  34 ;; Technical details of all the calendrical calculations can be found in
  35 ;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold
  36 ;; and Nachum Dershowitz, Cambridge University Press (2001).
  37
  38 ;; Comments, corrections, and improvements should be sent to
  39 ;;  Edward M. Reingold               Department of Computer Science
  40 ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  41 ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  42 ;;                                   Urbana, Illinois 61801
  43
  44 ;;; Code:
  45
  46 (defvar date)
  47 (defvar displayed-month)
  48 (defvar displayed-year)
  49 (defvar entry)
  50 (defvar number)
  51 (defvar original-date)
  52
  53 (require 'calendar)
  54
  55 (defun hebrew-calendar-leap-year-p (year)
  56   "t if YEAR is a Hebrew calendar leap year."
  57   (< (% (1+ (* 7 year)) 19) 7))
  58
  59 (defun hebrew-calendar-last-month-of-year (year)
  60   "The last month of the Hebrew calendar YEAR."
  61   (if (hebrew-calendar-leap-year-p year)
  62       13
  63     12))
  64
  65 (defun hebrew-calendar-elapsed-days (year)
  66   "Days from Sun. prior to start of Hebrew calendar to mean conjunction of Tishri of Hebrew YEAR."
  67   (let* ((months-elapsed
  68           (+ (* 235 (/ (1- year) 19));; Months in complete cycles so far.
  69              (* 12 (% (1- year) 19))      ;; Regular months in this cycle
  70              (/ (1+ (* 7 (% (1- year) 19))) 19)));; Leap months this cycle
  71          (parts-elapsed (+ 204 (* 793 (% months-elapsed 1080))))
  72          (hours-elapsed (+ 5
  73                            (* 12 months-elapsed)
  74                            (* 793 (/ months-elapsed 1080))
  75                            (/ parts-elapsed 1080)))
  76          (parts                                  ;; Conjunction parts
  77           (+ (* 1080 (% hours-elapsed 24)) (% parts-elapsed 1080)))
  78          (day                                    ;; Conjunction day
  79           (+ 1 (* 29 months-elapsed) (/ hours-elapsed 24)))
  80          (alternative-day
  81           (if (or (>= parts 19440)    ;; If the new moon is at or after midday,
  82                   (and (= (% day 7) 2);; ...or is on a Tuesday...
  83                        (>= parts 9924)  ;;    at 9 hours, 204 parts or later...
  84                        (not (hebrew-calendar-leap-year-p year)));; of a
  85                                                                 ;; common year,
  86                   (and (= (% day 7) 1);; ...or is on a Monday...
  87                        (>= parts 16789) ;;   at 15 hours, 589 parts or later...
  88                        (hebrew-calendar-leap-year-p (1- year))));; at the end
  89                                                      ;; of a leap year
  90        ;; Then postpone Rosh HaShanah one day
  91               (1+ day)
  92        ;; Else
  93             day)))
  94     (if ;; If Rosh HaShanah would occur on Sunday, Wednesday, or Friday
  95         (memq (% alternative-day 7) (list 0 3 5))
  96   ;; Then postpone it one (more) day and return
  97         (1+ alternative-day)
  98   ;; Else return
  99       alternative-day)))
 100
 101 (defun hebrew-calendar-days-in-year (year)
 102   "Number of days in Hebrew YEAR."
 103   (- (hebrew-calendar-elapsed-days (1+ year))
 104      (hebrew-calendar-elapsed-days year)))
 105
 106 (defun hebrew-calendar-long-heshvan-p (year)
 107   "t if Heshvan is long in Hebrew YEAR."
 108   (= (% (hebrew-calendar-days-in-year year) 10) 5))
 109
 110 (defun hebrew-calendar-short-kislev-p (year)
 111   "t if Kislev is short in Hebrew YEAR."
 112   (= (% (hebrew-calendar-days-in-year year) 10) 3))
 113
 114 (defun hebrew-calendar-last-day-of-month (month year)
 115   "The last day of MONTH in YEAR."
 116   (if (or (memq month (list 2 4 6 10 13))
 117           (and (= month 12) (not (hebrew-calendar-leap-year-p year)))
 118           (and (= month 8) (not (hebrew-calendar-long-heshvan-p year)))
 119           (and (= month 9) (hebrew-calendar-short-kislev-p year)))
 120       29
 121     30))
 122
 123 (defun calendar-absolute-from-hebrew (date)
 124   "Absolute date of Hebrew DATE.
 125 The absolute date is the number of days elapsed since the (imaginary)
 126 Gregorian date Sunday, December 31, 1 BC."
 127   (let* ((month (extract-calendar-month date))
 128          (day (extract-calendar-day date))
 129          (year (extract-calendar-year date)))
 130     (+ day                            ;; Days so far this month.
 131        (if (< month 7);; before Tishri
 132      ;; Then add days in prior months this year before and after Nisan
 133            (+ (calendar-sum
 134                m 7 (<= m (hebrew-calendar-last-month-of-year year))
 135                (hebrew-calendar-last-day-of-month m year))
 136               (calendar-sum
 137                m 1 (< m month)
 138                (hebrew-calendar-last-day-of-month m year)))
 139      ;; Else add days in prior months this year
 140          (calendar-sum
 141           m 7 (< m month)
 142           (hebrew-calendar-last-day-of-month m year)))
 143     (hebrew-calendar-elapsed-days year);; Days in prior years.
 144     -1373429)))                        ;; Days elapsed before absolute date 1.
 145
 146 (defun calendar-hebrew-from-absolute (date)
 147   "Compute the Hebrew date (month day year) corresponding to absolute DATE.
 148 The absolute date is the number of days elapsed since the (imaginary)
 149 Gregorian date Sunday, December 31, 1 BC."
 150   (let* ((greg-date (calendar-gregorian-from-absolute date))
 151          (month (aref [9 10 11 12 1 2 3 4 7 7 7 8]
 152                  (1- (extract-calendar-month greg-date))))
 153          (day)
 154          (year (+ 3760 (extract-calendar-year greg-date))))
 155     (while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year))))
 156         (setq year (1+ year)))
 157     (let ((length (hebrew-calendar-last-month-of-year year)))
 158       (while (> date
 159                 (calendar-absolute-from-hebrew
 160                  (list month
 161                        (hebrew-calendar-last-day-of-month month year)
 162                        year)))
 163         (setq month (1+ (% month length)))))
 164     (setq day (1+
 165                (- date (calendar-absolute-from-hebrew (list month 1 year)))))
 166     (list month day year)))
 167
 168 (defvar calendar-hebrew-month-name-array-common-year
 169   ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
 170    "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"]
 171 "Array of strings giving the names of the Hebrew months in a common year.")
 172
 173 (defvar calendar-hebrew-month-name-array-leap-year
 174   ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
 175    "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"]
 176 "Array of strings giving the names of the Hebrew months in a leap year.")
 177
 178 (defun calendar-hebrew-date-string (&optional date)
 179   "String of Hebrew date before sunset of Gregorian DATE.
 180 Defaults to today's date if DATE is not given.
 181 Driven by the variable `calendar-date-display-form'."
 182   (let* ((hebrew-date (calendar-hebrew-from-absolute
 183                        (calendar-absolute-from-gregorian
 184                         (or date (calendar-current-date)))))
 185          (calendar-month-name-array
 186           (if (hebrew-calendar-leap-year-p (extract-calendar-year hebrew-date))
 187               calendar-hebrew-month-name-array-leap-year
 188             calendar-hebrew-month-name-array-common-year)))
 189     (calendar-date-string hebrew-date nil t)))
 190
 191 (defun calendar-print-hebrew-date ()
 192   "Show the Hebrew calendar equivalent of the date under the cursor."
 193   (interactive)
 194   (message "Hebrew date (until sunset): %s"
 195            (calendar-hebrew-date-string (calendar-cursor-to-date t))))
 196
 197 (defun hebrew-calendar-yahrzeit (death-date year)
 198   "Absolute date of the anniversary of Hebrew DEATH-DATE in Hebrew YEAR."
 199   (let* ((death-day (extract-calendar-day death-date))
 200          (death-month (extract-calendar-month death-date))
 201          (death-year (extract-calendar-year death-date)))
 202     (cond
 203      ;; If it's Heshvan 30 it depends on the first anniversary; if
 204      ;; that was not Heshvan 30, use the day before Kislev 1.
 205      ((and (= death-month 8)
 206            (= death-day 30)
 207            (not (hebrew-calendar-long-heshvan-p (1+ death-year))))
 208       (1- (calendar-absolute-from-hebrew (list 9 1 year))))
 209      ;; If it's Kislev 30 it depends on the first anniversary; if
 210      ;; that was not Kislev 30, use the day before Teveth 1.
 211      ((and (= death-month 9)
 212            (= death-day 30)
 213            (hebrew-calendar-short-kislev-p (1+ death-year)))
 214       (1- (calendar-absolute-from-hebrew (list 10 1 year))))
 215      ;; If it's Adar II, use the same day in last month of
 216      ;; year (Adar or Adar II).
 217      ((= death-month 13)
 218       (calendar-absolute-from-hebrew
 219        (list (hebrew-calendar-last-month-of-year year) death-day year)))
 220      ;; If it's the 30th in Adar I and year is not a leap year
 221      ;; (so Adar has only 29 days), use the last day in Shevat.
 222      ((and (= death-day 30)
 223            (= death-month 12)
 224            (not (hebrew-calendar-leap-year-p year)))
 225       (calendar-absolute-from-hebrew (list 11 30 year)))
 226      ;; In all other cases, use the normal anniversary of the date of death.
 227      (t (calendar-absolute-from-hebrew
 228          (list death-month death-day year))))))
 229
 230 (defun calendar-goto-hebrew-date (date &optional noecho)
 231   "Move cursor to Hebrew DATE; echo Hebrew date unless NOECHO is t."
 232   (interactive
 233    (let* ((today (calendar-current-date))
 234           (year (calendar-read
 235                  "Hebrew calendar year (>3760): "
 236                  '(lambda (x) (> x 3760))
 237                  (int-to-string
 238                   (extract-calendar-year
 239                    (calendar-hebrew-from-absolute
 240                     (calendar-absolute-from-gregorian today))))))
 241           (month-array (if (hebrew-calendar-leap-year-p year)
 242                            calendar-hebrew-month-name-array-leap-year
 243                          calendar-hebrew-month-name-array-common-year))
 244           (completion-ignore-case t)
 245           (month (cdr (assoc-string
 246                        (completing-read
 247                         "Hebrew calendar month name: "
 248                         (mapcar 'list (append month-array nil))
 249                         (if (= year 3761)
 250                             '(lambda (x)
 251                                (let ((m (cdr
 252                                          (assoc-string
 253                                           (car x)
 254                                           (calendar-make-alist month-array)
 255                                           t))))
 256                                  (< 0
 257                                     (calendar-absolute-from-hebrew
 258                                      (list m
 259                                            (hebrew-calendar-last-day-of-month
 260                                             m year)
 261                                            year))))))
 262                         t)
 263                        (calendar-make-alist month-array 1) t)))
 264           (last (hebrew-calendar-last-day-of-month month year))
 265           (first (if (and (= year 3761) (= month 10))
 266                      18 1))
 267           (day (calendar-read
 268                 (format "Hebrew calendar day (%d-%d): "
 269                         first last)
 270                 '(lambda (x) (and (<= first x) (<= x last))))))
 271      (list (list month day year))))
 272   (calendar-goto-date (calendar-gregorian-from-absolute
 273                        (calendar-absolute-from-hebrew date)))
 274   (or noecho (calendar-print-hebrew-date)))
 275
 276 (defun holiday-hebrew (month day string)
 277   "Holiday on MONTH, DAY (Hebrew) called STRING.
 278 If MONTH, DAY (Hebrew) is visible, the value returned is corresponding
 279 Gregorian date in the form of the list (((month day year) STRING)).  Returns
 280 nil if it is not visible in the current calendar window."
 281   (if (memq displayed-month;;  This test is only to speed things up a bit;
 282             (list          ;;  it works fine without the test too.
 283              (if (< 11 month) (- month 11) (+ month 1))
 284              (if (< 10 month) (- month 10) (+ month 2))
 285              (if (<  9 month) (- month  9) (+ month 3))
 286              (if (<  8 month) (- month  8) (+ month 4))
 287              (if (<  7 month) (- month  7) (+ month 5))))
 288       (let ((m1 displayed-month)
 289             (y1 displayed-year)
 290             (m2 displayed-month)
 291             (y2 displayed-year)
 292             (year))
 293         (increment-calendar-month m1 y1 -1)
 294         (increment-calendar-month m2 y2 1)
 295         (let* ((start-date (calendar-absolute-from-gregorian
 296                             (list m1 1 y1)))
 297                (end-date (calendar-absolute-from-gregorian
 298                           (list m2 (calendar-last-day-of-month m2 y2) y2)))
 299                (hebrew-start (calendar-hebrew-from-absolute start-date))
 300                (hebrew-end (calendar-hebrew-from-absolute end-date))
 301                (hebrew-y1 (extract-calendar-year hebrew-start))
 302                (hebrew-y2 (extract-calendar-year hebrew-end)))
 303           (setq year (if (< 6 month) hebrew-y2 hebrew-y1))
 304           (let ((date (calendar-gregorian-from-absolute
 305                        (calendar-absolute-from-hebrew
 306                         (list month day year)))))
 307             (if (calendar-date-is-visible-p date)
 308                 (list (list date string))))))))
 309
 310 (defun holiday-rosh-hashanah-etc ()
 311   "List of dates related to Rosh Hashanah, as visible in calendar window."
 312   (if (or (< displayed-month 8)
 313           (> displayed-month 11))
 314       nil;; None of the dates is visible
 315     (let* ((abs-r-h (calendar-absolute-from-hebrew
 316                       (list 7 1 (+ displayed-year 3761))))
 317             (mandatory
 318              (list
 319               (list (calendar-gregorian-from-absolute abs-r-h)
 320                     (format "Rosh HaShanah %d" (+ 3761 displayed-year)))
 321               (list (calendar-gregorian-from-absolute (+ abs-r-h 9))
 322                     "Yom Kippur")
 323               (list (calendar-gregorian-from-absolute (+ abs-r-h 14))
 324                     "Sukkot")
 325               (list (calendar-gregorian-from-absolute (+ abs-r-h 21))
 326                     "Shemini Atzeret")
 327               (list (calendar-gregorian-from-absolute (+ abs-r-h 22))
 328                     "Simchat Torah")))
 329            (optional
 330             (list
 331              (list (calendar-gregorian-from-absolute
 332                     (calendar-dayname-on-or-before 6 (- abs-r-h 4)))
 333                    "Selichot (night)")
 334              (list (calendar-gregorian-from-absolute (1- abs-r-h))
 335                    "Erev Rosh HaShanah")
 336              (list (calendar-gregorian-from-absolute (1+ abs-r-h))
 337                    "Rosh HaShanah (second day)")
 338              (list (calendar-gregorian-from-absolute
 339                     (if (= (% abs-r-h 7) 4) (+ abs-r-h 3) (+ abs-r-h 2)))
 340                    "Tzom Gedaliah")
 341              (list (calendar-gregorian-from-absolute
 342                     (calendar-dayname-on-or-before 6 (+ 7 abs-r-h)))
 343                    "Shabbat Shuvah")
 344              (list (calendar-gregorian-from-absolute (+ abs-r-h 8))
 345                    "Erev Yom Kippur")
 346              (list (calendar-gregorian-from-absolute (+ abs-r-h 13))
 347                    "Erev Sukkot")
 348              (list (calendar-gregorian-from-absolute (+ abs-r-h 15))
 349                    "Sukkot (second day)")
 350              (list (calendar-gregorian-from-absolute (+ abs-r-h 16))
 351                    "Hol Hamoed Sukkot (first day)")
 352              (list (calendar-gregorian-from-absolute (+ abs-r-h 17))
 353                    "Hol Hamoed Sukkot (second day)")
 354              (list (calendar-gregorian-from-absolute (+ abs-r-h 18))
 355                    "Hol Hamoed Sukkot (third day)")
 356              (list (calendar-gregorian-from-absolute (+ abs-r-h 19))
 357                    "Hol Hamoed Sukkot (fourth day)")
 358              (list (calendar-gregorian-from-absolute (+ abs-r-h 20))
 359                    "Hoshanah Rabbah")))
 360             (output-list
 361              (filter-visible-calendar-holidays mandatory)))
 362       (if all-hebrew-calendar-holidays
 363           (setq output-list
 364                 (append
 365                  (filter-visible-calendar-holidays optional)
 366                  output-list)))
 367       output-list)))
 368
 369 (defun holiday-hanukkah ()
 370   "List of dates related to Hanukkah, as visible in calendar window."
 371     (if (memq displayed-month;;  This test is only to speed things up a bit;
 372               '(10 11 12 1 2));; it works fine without the test too.
 373         (let ((m displayed-month)
 374               (y displayed-year))
 375           (increment-calendar-month m y 1)
 376           (let* ((h-y (extract-calendar-year
 377                          (calendar-hebrew-from-absolute
 378                           (calendar-absolute-from-gregorian
 379                            (list m (calendar-last-day-of-month m y) y)))))
 380                  (abs-h (calendar-absolute-from-hebrew (list 9 25 h-y))))
 381             (filter-visible-calendar-holidays
 382              (list
 383               (list (calendar-gregorian-from-absolute (1- abs-h))
 384                     "Erev Hanukkah")
 385               (list (calendar-gregorian-from-absolute abs-h)
 386                     "Hanukkah (first day)")
 387               (list (calendar-gregorian-from-absolute (1+ abs-h))
 388                     "Hanukkah (second day)")
 389               (list (calendar-gregorian-from-absolute (+ abs-h 2))
 390                     "Hanukkah (third day)")
 391               (list (calendar-gregorian-from-absolute (+ abs-h 3))
 392                     "Hanukkah (fourth day)")
 393               (list (calendar-gregorian-from-absolute (+ abs-h 4))
 394                     "Hanukkah (fifth day)")
 395               (list (calendar-gregorian-from-absolute (+ abs-h 5))
 396                     "Hanukkah (sixth day)")
 397               (list (calendar-gregorian-from-absolute (+ abs-h 6))
 398                     "Hanukkah (seventh day)")
 399               (list (calendar-gregorian-from-absolute (+ abs-h 7))
 400                     "Hanukkah (eighth day)")))))))
 401
 402 (defun holiday-passover-etc ()
 403   "List of dates related to Passover, as visible in calendar window."
 404  (if (< 7 displayed-month)
 405       nil;; None of the dates is visible
 406     (let* ((abs-p (calendar-absolute-from-hebrew
 407                       (list 1 15 (+ displayed-year 3760))))
 408            (mandatory
 409             (list
 410              (list (calendar-gregorian-from-absolute abs-p)
 411                    "Passover")
 412              (list (calendar-gregorian-from-absolute (+ abs-p 50))
 413                    "Shavuot")))
 414            (optional
 415             (list
 416              (list (calendar-gregorian-from-absolute
 417                     (calendar-dayname-on-or-before 6 (- abs-p 43)))
 418                    "Shabbat Shekalim")
 419              (list (calendar-gregorian-from-absolute
 420                     (calendar-dayname-on-or-before 6 (- abs-p 30)))
 421                    "Shabbat Zachor")
 422              (list (calendar-gregorian-from-absolute
 423                     (if (= (% abs-p 7) 2) (- abs-p 33) (- abs-p 31)))
 424                    "Fast of Esther")
 425              (list (calendar-gregorian-from-absolute (- abs-p 31))
 426                    "Erev Purim")
 427              (list (calendar-gregorian-from-absolute (- abs-p 30))
 428                    "Purim")
 429              (list (calendar-gregorian-from-absolute
 430                     (if (zerop (% abs-p 7)) (- abs-p 28) (- abs-p 29)))
 431                    "Shushan Purim")
 432              (list (calendar-gregorian-from-absolute
 433                     (- (calendar-dayname-on-or-before 6 (- abs-p 14)) 7))
 434                    "Shabbat Parah")
 435              (list (calendar-gregorian-from-absolute
 436                     (calendar-dayname-on-or-before 6 (- abs-p 14)))
 437                    "Shabbat HaHodesh")
 438              (list (calendar-gregorian-from-absolute
 439                     (calendar-dayname-on-or-before 6 (1- abs-p)))
 440                    "Shabbat HaGadol")
 441              (list (calendar-gregorian-from-absolute (1- abs-p))
 442                    "Erev Passover")
 443              (list (calendar-gregorian-from-absolute (1+ abs-p))
 444                    "Passover (second day)")
 445              (list (calendar-gregorian-from-absolute (+ abs-p 2))
 446                    "Hol Hamoed Passover (first day)")
 447              (list (calendar-gregorian-from-absolute (+ abs-p 3))
 448                    "Hol Hamoed Passover (second day)")
 449              (list (calendar-gregorian-from-absolute (+ abs-p 4))
 450                    "Hol Hamoed Passover (third day)")
 451              (list (calendar-gregorian-from-absolute (+ abs-p 5))
 452                    "Hol Hamoed Passover (fourth day)")
 453              (list (calendar-gregorian-from-absolute (+ abs-p 6))
 454                    "Passover (seventh day)")
 455              (list (calendar-gregorian-from-absolute (+ abs-p 7))
 456                    "Passover (eighth day)")
 457              (list (calendar-gregorian-from-absolute
 458                     (if (zerop (% (+ abs-p 12) 7))
 459                         (+ abs-p 13)
 460                       (+ abs-p 12)))
 461                    "Yom HaShoah")
 462              (list (calendar-gregorian-from-absolute
 463                     (if (zerop (% abs-p 7))
 464                         (+ abs-p 18)
 465                       (if (= (% abs-p 7) 6)
 466                           (+ abs-p 19)
 467                         (+ abs-p 20))))
 468                    "Yom HaAtzma'ut")
 469              (list (calendar-gregorian-from-absolute (+ abs-p 33))
 470                    "Lag BaOmer")
 471              (list (calendar-gregorian-from-absolute (+ abs-p 43))
 472                    "Yom Yerushalaim")
 473              (list (calendar-gregorian-from-absolute (+ abs-p 49))
 474                    "Erev Shavuot")
 475              (list (calendar-gregorian-from-absolute (+ abs-p 51))
 476                    "Shavuot (second day)")))
 477            (output-list
 478              (filter-visible-calendar-holidays mandatory)))
 479       (if all-hebrew-calendar-holidays
 480           (setq output-list
 481                 (append
 482                  (filter-visible-calendar-holidays optional)
 483                  output-list)))
 484       output-list)))
 485
 486 (defun holiday-tisha-b-av-etc ()
 487   "List of dates around Tisha B'Av, as visible in calendar window."
 488   (if (or (< displayed-month 5)
 489           (> displayed-month 9))
 490       nil;; None of the dates is visible
 491     (let* ((abs-t-a (calendar-absolute-from-hebrew
 492                       (list 5 9 (+ displayed-year 3760)))))
 493
 494       (filter-visible-calendar-holidays
 495        (list
 496         (list (calendar-gregorian-from-absolute
 497                (if (= (% abs-t-a 7) 6) (- abs-t-a 20) (- abs-t-a 21)))
 498               "Tzom Tammuz")
 499         (list (calendar-gregorian-from-absolute
 500                (calendar-dayname-on-or-before 6 abs-t-a))
 501               "Shabbat Hazon")
 502         (list (calendar-gregorian-from-absolute
 503                (if (= (% abs-t-a 7) 6) (1+ abs-t-a) abs-t-a))
 504               "Tisha B'Av")
 505         (list (calendar-gregorian-from-absolute
 506                (calendar-dayname-on-or-before 6 (+ abs-t-a 7)))
 507               "Shabbat Nahamu"))))))
 508
 509 (defun list-hebrew-diary-entries ()
 510   "Add any Hebrew date entries from the diary file to `diary-entries-list'.
 511 Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol'
 512 \(normally an `H').  The same diary date forms govern the style of the Hebrew
 513 calendar entries, except that the Hebrew month names must be spelled in full.
 514 The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
 515 Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
 516 common Hebrew year.  If a Hebrew date diary entry begins with a
 517 `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
 518 not be marked in the calendar.  This function is provided for use with the
 519 `nongregorian-diary-listing-hook'."
 520   (if (< 0 number)
 521       (let ((buffer-read-only nil)
 522             (diary-modified (buffer-modified-p))
 523             (gdate original-date)
 524             (mark (regexp-quote diary-nonmarking-symbol)))
 525         (calendar-for-loop i from 1 to number do
 526            (let* ((d diary-date-forms)
 527                   (hdate (calendar-hebrew-from-absolute
 528                           (calendar-absolute-from-gregorian gdate)))
 529                   (month (extract-calendar-month hdate))
 530                   (day (extract-calendar-day hdate))
 531                   (year (extract-calendar-year hdate)))
 532              (while d
 533                (let*
 534                    ((date-form (if (equal (car (car d)) 'backup)
 535                                    (cdr (car d))
 536                                  (car d)))
 537                     (backup (equal (car (car d)) 'backup))
 538                     (dayname
 539                      (format "%s\\|%s\\.?"
 540                              (calendar-day-name gdate)
 541                              (calendar-day-name gdate 'abbrev)))
 542                     (calendar-month-name-array
 543                      calendar-hebrew-month-name-array-leap-year)
 544                     (monthname
 545                      (concat
 546                       "\\*\\|"
 547                       (calendar-month-name month)))
 548                     (month (concat "\\*\\|0*" (int-to-string month)))
 549                     (day (concat "\\*\\|0*" (int-to-string day)))
 550                     (year
 551                      (concat
 552                       "\\*\\|0*" (int-to-string year)
 553                       (if abbreviated-calendar-year
 554                           (concat "\\|" (int-to-string (% year 100)))
 555                         "")))
 556                     (regexp
 557                      (concat
 558                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
 559                       (regexp-quote hebrew-diary-entry-symbol)
 560                       "\\("
 561                       (mapconcat 'eval date-form "\\)\\(")
 562                       "\\)"))
 563                     (case-fold-search t))
 564                  (goto-char (point-min))
 565                  (while (re-search-forward regexp nil t)
 566                    (if backup (re-search-backward "\\<" nil t))
 567                    (if (and (or (char-equal (preceding-char) ?\^M)
 568                                 (char-equal (preceding-char) ?\n))
 569                             (not (looking-at " \\|\^I")))
 570                        ;;  Diary entry that consists only of date.
 571                        (backward-char 1)
 572                      ;;  Found a nonempty diary entry--make it visible and
 573                      ;;  add it to the list.
 574                      (let ((entry-start (point))
 575                            (date-start))
 576                        (re-search-backward "\^M\\|\n\\|\\`")
 577                        (setq date-start (point))
 578                        (re-search-forward "\^M\\|\n" nil t 2)
 579                        (while (looking-at " \\|\^I")
 580                          (re-search-forward "\^M\\|\n" nil t))
 581                        (backward-char 1)
 582                        (subst-char-in-region date-start (point) ?\^M ?\n t)
 583                        (add-to-diary-list
 584                         gdate
 585                         (buffer-substring-no-properties entry-start (point))
 586                         (buffer-substring-no-properties
 587                          (1+ date-start) (1- entry-start))
 588                         (copy-marker entry-start))))))
 589                (setq d (cdr d))))
 590            (setq gdate
 591                  (calendar-gregorian-from-absolute
 592                   (1+ (calendar-absolute-from-gregorian gdate)))))
 593            (set-buffer-modified-p diary-modified))
 594         (goto-char (point-min))))
 595
 596 (defun mark-hebrew-calendar-date-pattern (month day year)
 597   "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.
 598 A value of 0 in any position is a wildcard."
 599   (save-excursion
 600     (set-buffer calendar-buffer)
 601     (if (and (/= 0 month) (/= 0 day))
 602         (if (/= 0 year)
 603             ;; Fully specified Hebrew date.
 604             (let ((date (calendar-gregorian-from-absolute
 605                          (calendar-absolute-from-hebrew
 606                           (list month day year)))))
 607               (if (calendar-date-is-visible-p date)
 608                   (mark-visible-calendar-date date)))
 609           ;; Month and day in any year--this taken from the holiday stuff.
 610           (if (memq displayed-month;;  This test is only to speed things up a
 611                     (list          ;;  bit; it works fine without the test too.
 612                      (if (< 11 month) (- month 11) (+ month 1))
 613                      (if (< 10 month) (- month 10) (+ month 2))
 614                      (if (<  9 month) (- month  9) (+ month 3))
 615                      (if (<  8 month) (- month  8) (+ month 4))
 616                      (if (<  7 month) (- month  7) (+ month 5))))
 617               (let ((m1 displayed-month)
 618                     (y1 displayed-year)
 619                     (m2 displayed-month)
 620                     (y2 displayed-year)
 621                     (year))
 622                 (increment-calendar-month m1 y1 -1)
 623                 (increment-calendar-month m2 y2 1)
 624                 (let* ((start-date (calendar-absolute-from-gregorian
 625                                     (list m1 1 y1)))
 626                        (end-date (calendar-absolute-from-gregorian
 627                                   (list m2
 628                                         (calendar-last-day-of-month m2 y2)
 629                                         y2)))
 630                        (hebrew-start
 631                         (calendar-hebrew-from-absolute start-date))
 632                        (hebrew-end (calendar-hebrew-from-absolute end-date))
 633                        (hebrew-y1 (extract-calendar-year hebrew-start))
 634                        (hebrew-y2 (extract-calendar-year hebrew-end)))
 635                   (setq year (if (< 6 month) hebrew-y2 hebrew-y1))
 636                   (let ((date (calendar-gregorian-from-absolute
 637                                (calendar-absolute-from-hebrew
 638                                 (list month day year)))))
 639                     (if (calendar-date-is-visible-p date)
 640                         (mark-visible-calendar-date date)))))))
 641       ;; Not one of the simple cases--check all visible dates for match.
 642       ;; Actually, the following code takes care of ALL of the cases, but
 643       ;; it's much too slow to be used for the simple (common) cases.
 644       (let ((m displayed-month)
 645             (y displayed-year)
 646             (first-date)
 647             (last-date))
 648         (increment-calendar-month m y -1)
 649         (setq first-date
 650               (calendar-absolute-from-gregorian
 651                (list m 1 y)))
 652         (increment-calendar-month m y 2)
 653         (setq last-date
 654               (calendar-absolute-from-gregorian
 655                (list m (calendar-last-day-of-month m y) y)))
 656         (calendar-for-loop date from first-date to last-date do
 657           (let* ((h-date (calendar-hebrew-from-absolute date))
 658                  (h-month (extract-calendar-month h-date))
 659                  (h-day (extract-calendar-day h-date))
 660                  (h-year (extract-calendar-year h-date)))
 661             (and (or (zerop month)
 662                      (= month h-month))
 663                  (or (zerop day)
 664                      (= day h-day))
 665                  (or (zerop year)
 666                      (= year h-year))
 667                  (mark-visible-calendar-date
 668                   (calendar-gregorian-from-absolute date)))))))))
 669
 670 (defun mark-hebrew-diary-entries ()
 671   "Mark days in the calendar window that have Hebrew date diary entries.
 672 Each entry in diary-file (or included files) visible in the calendar window
 673 is marked.  Hebrew date entries are prefaced by a hebrew-diary-entry-symbol
 674 \(normally an `H').  The same diary-date-forms govern the style of the Hebrew
 675 calendar entries, except that the Hebrew month names must be spelled in full.
 676 The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
 677 Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
 678 common Hebrew year.  Hebrew date diary entries that begin with a
 679 diary-nonmarking symbol will not be marked in the calendar.  This function
 680 is provided for use as part of the nongregorian-diary-marking-hook."
 681   (let ((d diary-date-forms))
 682     (while d
 683       (let*
 684           ((date-form (if (equal (car (car d)) 'backup)
 685                           (cdr (car d))
 686                         (car d)));; ignore 'backup directive
 687            (dayname (diary-name-pattern calendar-day-name-array
 688                                         calendar-day-abbrev-array))
 689            (monthname
 690             (format "%s\\|\\*"
 691                     (diary-name-pattern
 692                      calendar-hebrew-month-name-array-leap-year)))
 693            (month "[0-9]+\\|\\*")
 694            (day "[0-9]+\\|\\*")
 695            (year "[0-9]+\\|\\*")
 696            (l (length date-form))
 697            (d-name-pos (- l (length (memq 'dayname date-form))))
 698            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
 699            (m-name-pos (- l (length (memq 'monthname date-form))))
 700            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
 701            (d-pos (- l (length (memq 'day date-form))))
 702            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
 703            (m-pos (- l (length (memq 'month date-form))))
 704            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
 705            (y-pos (- l (length (memq 'year date-form))))
 706            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
 707            (regexp
 708             (concat
 709              "\\(\\`\\|\^M\\|\n\\)"
 710              (regexp-quote hebrew-diary-entry-symbol)
 711              "\\("
 712              (mapconcat 'eval date-form "\\)\\(")
 713              "\\)"))
 714            (case-fold-search t))
 715         (goto-char (point-min))
 716         (while (re-search-forward regexp nil t)
 717           (let* ((dd-name
 718                   (if d-name-pos
 719                       (buffer-substring
 720                        (match-beginning d-name-pos)
 721                        (match-end d-name-pos))))
 722                  (mm-name
 723                   (if m-name-pos
 724                       (buffer-substring
 725                        (match-beginning m-name-pos)
 726                        (match-end m-name-pos))))
 727                  (mm (string-to-number
 728                       (if m-pos
 729                           (buffer-substring
 730                            (match-beginning m-pos)
 731                            (match-end m-pos))
 732                         "")))
 733                  (dd (string-to-number
 734                       (if d-pos
 735                           (buffer-substring
 736                            (match-beginning d-pos)
 737                            (match-end d-pos))
 738                         "")))
 739                  (y-str (if y-pos
 740                             (buffer-substring
 741                              (match-beginning y-pos)
 742                              (match-end y-pos))))
 743                  (yy (if (not y-str)
 744                          0
 745                        (if (and (= (length y-str) 2)
 746                                 abbreviated-calendar-year)
 747                            (let* ((current-y
 748                                    (extract-calendar-year
 749                                     (calendar-hebrew-from-absolute
 750                                      (calendar-absolute-from-gregorian
 751                                       (calendar-current-date)))))
 752                                   (y (+ (string-to-number y-str)
 753                                         (* 100 (/ current-y 100)))))
 754                              (if (> (- y current-y) 50)
 755                                  (- y 100)
 756                                (if (> (- current-y y) 50)
 757                                    (+ y 100)
 758                                  y)))
 759                          (string-to-number y-str)))))
 760             (if dd-name
 761                 (mark-calendar-days-named
 762                  (cdr (assoc-string dd-name
 763                                          (calendar-make-alist
 764                                           calendar-day-name-array
 765                                           0 nil calendar-day-abbrev-array) t)))
 766               (if mm-name
 767                   (setq mm
 768                         (if (string-equal mm-name "*") 0
 769                           (cdr
 770                            (assoc-string
 771                             mm-name
 772                             (calendar-make-alist
 773                              calendar-hebrew-month-name-array-leap-year) t)))))
 774               (mark-hebrew-calendar-date-pattern mm dd yy)))))
 775       (setq d (cdr d)))))
 776
 777 (defun insert-hebrew-diary-entry (arg)
 778   "Insert a diary entry.
 779 For the Hebrew date corresponding to the date indicated by point.
 780 Prefix arg will make the entry nonmarking."
 781   (interactive "P")
 782   (let* ((calendar-month-name-array
 783           calendar-hebrew-month-name-array-leap-year))
 784     (make-diary-entry
 785      (concat
 786       hebrew-diary-entry-symbol
 787       (calendar-date-string
 788        (calendar-hebrew-from-absolute
 789         (calendar-absolute-from-gregorian
 790          (calendar-cursor-to-date t)))
 791        nil t))
 792      arg)))
 793
 794 (defun insert-monthly-hebrew-diary-entry (arg)
 795   "Insert a monthly diary entry.
 796 For the day of the Hebrew month corresponding to the date indicated by point.
 797 Prefix arg will make the entry nonmarking."
 798   (interactive "P")
 799   (let* ((calendar-date-display-form
 800           (if european-calendar-style '(day " * ") '("* " day )))
 801          (calendar-month-name-array
 802           calendar-hebrew-month-name-array-leap-year))
 803     (make-diary-entry
 804      (concat
 805       hebrew-diary-entry-symbol
 806       (calendar-date-string
 807        (calendar-hebrew-from-absolute
 808         (calendar-absolute-from-gregorian
 809          (calendar-cursor-to-date t)))))
 810      arg)))
 811
 812 (defun insert-yearly-hebrew-diary-entry (arg)
 813   "Insert an annual diary entry.
 814 For the day of the Hebrew year corresponding to the date indicated by point.
 815 Prefix arg will make the entry nonmarking."
 816   (interactive "P")
 817   (let* ((calendar-date-display-form
 818           (if european-calendar-style
 819               '(day " " monthname)
 820             '(monthname " " day)))
 821          (calendar-month-name-array
 822           calendar-hebrew-month-name-array-leap-year))
 823     (make-diary-entry
 824      (concat
 825       hebrew-diary-entry-symbol
 826       (calendar-date-string
 827        (calendar-hebrew-from-absolute
 828         (calendar-absolute-from-gregorian
 829          (calendar-cursor-to-date t)))))
 830      arg)))
 831
 832 ;;;###autoload
 833 (defun list-yahrzeit-dates (death-date start-year end-year)
 834   "List Yahrzeit dates for *Gregorian* DEATH-DATE from START-YEAR to END-YEAR.
 835 When called interactively from the calendar window, the date of death is taken
 836 from the cursor position."
 837   (interactive
 838    (let* ((death-date
 839            (if (equal (current-buffer) (get-buffer calendar-buffer))
 840                (calendar-cursor-to-date)
 841              (let* ((today (calendar-current-date))
 842                     (year (calendar-read
 843                            "Year of death (>0): "
 844                            '(lambda (x) (> x 0))
 845                            (int-to-string (extract-calendar-year today))))
 846                     (month-array calendar-month-name-array)
 847                     (completion-ignore-case t)
 848                     (month (cdr (assoc-string
 849                                  (completing-read
 850                                   "Month of death (name): "
 851                                   (mapcar 'list (append month-array nil))
 852                                   nil t)
 853                                  (calendar-make-alist month-array 1) t)))
 854                     (last (calendar-last-day-of-month month year))
 855                     (day (calendar-read
 856                           (format "Day of death (1-%d): " last)
 857                           '(lambda (x) (and (< 0 x) (<= x last))))))
 858                (list month day year))))
 859           (death-year (extract-calendar-year death-date))
 860           (start-year (calendar-read
 861                        (format "Starting year of Yahrzeit table (>%d): "
 862                                death-year)
 863                        '(lambda (x) (> x death-year))
 864                        (int-to-string (1+ death-year))))
 865           (end-year (calendar-read
 866                      (format "Ending year of Yahrzeit table (>=%d): "
 867                              start-year)
 868                        '(lambda (x) (>= x start-year)))))
 869    (list death-date start-year end-year)))
 870   (message "Computing yahrzeits...")
 871   (let* ((yahrzeit-buffer "*Yahrzeits*")
 872          (h-date (calendar-hebrew-from-absolute
 873                   (calendar-absolute-from-gregorian death-date)))
 874          (h-month (extract-calendar-month h-date))
 875          (h-day (extract-calendar-day h-date))
 876          (h-year (extract-calendar-year h-date)))
 877     (set-buffer (get-buffer-create yahrzeit-buffer))
 878     (setq buffer-read-only nil)
 879     (calendar-set-mode-line
 880      (format "Yahrzeit dates for %s = %s"
 881              (calendar-date-string death-date)
 882              (let ((calendar-month-name-array
 883                     (if (hebrew-calendar-leap-year-p h-year)
 884                         calendar-hebrew-month-name-array-leap-year
 885                       calendar-hebrew-month-name-array-common-year)))
 886                (calendar-date-string h-date nil t))))
 887     (erase-buffer)
 888     (goto-char (point-min))
 889     (calendar-for-loop i from start-year to end-year do
 890         (insert
 891          (calendar-date-string
 892           (calendar-gregorian-from-absolute
 893            (hebrew-calendar-yahrzeit
 894             h-date
 895             (extract-calendar-year
 896              (calendar-hebrew-from-absolute
 897               (calendar-absolute-from-gregorian (list 1 1 i))))))) "\n"))
 898     (goto-char (point-min))
 899     (set-buffer-modified-p nil)
 900     (setq buffer-read-only t)
 901     (display-buffer yahrzeit-buffer)
 902     (message "Computing yahrzeits...done")))
 903
 904 (defun diary-hebrew-date ()
 905   "Hebrew calendar equivalent of date diary entry."
 906   (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date)))
 907
 908 (defun diary-omer (&optional mark)
 909   "Omer count diary entry.
 910 Entry applies if date is within 50 days after Passover.
 911
 912 An optional parameter MARK specifies a face or single-character string to
 913 use when highlighting the day in the calendar."
 914   (let* ((passover
 915           (calendar-absolute-from-hebrew
 916            (list 1 15 (+ (extract-calendar-year date) 3760))))
 917          (omer (- (calendar-absolute-from-gregorian date) passover))
 918          (week (/ omer 7))
 919          (day (% omer 7)))
 920     (if (and (> omer 0) (< omer 50))
 921         (cons mark
 922               (format "Day %d%s of the omer (until sunset)"
 923                       omer
 924                       (if (zerop week)
 925                           ""
 926                         (format ", that is, %d week%s%s"
 927                                 week
 928                                 (if (= week 1) "" "s")
 929                                 (if (zerop day)
 930                                     ""
 931                                   (format " and %d day%s"
 932                                           day (if (= day 1) "" "s"))))))))))
 933
 934 (defun diary-yahrzeit (death-month death-day death-year &optional mark)
 935   "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.
 936 Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed
 937 to be the name of the person.  Date of death is on the *civil* calendar;
 938 although the date of death is specified by the civil calendar, the proper
 939 Hebrew calendar yahrzeit is determined.  If `european-calendar-style' is t, the
 940 order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR.
 941
 942 An optional parameter MARK specifies a face or single-character string to
 943 use when highlighting the day in the calendar."
 944   (let* ((h-date (calendar-hebrew-from-absolute
 945                   (calendar-absolute-from-gregorian
 946                    (if european-calendar-style
 947                        (list death-day death-month death-year)
 948                      (list death-month death-day death-year)))))
 949          (h-month (extract-calendar-month h-date))
 950          (h-day (extract-calendar-day h-date))
 951          (h-year (extract-calendar-year h-date))
 952          (d (calendar-absolute-from-gregorian date))
 953          (yr (extract-calendar-year (calendar-hebrew-from-absolute d)))
 954          (diff (- yr h-year))
 955          (y (hebrew-calendar-yahrzeit h-date yr)))
 956     (if (and (> diff 0) (or (= y d) (= y (1+ d))))
 957         (cons mark
 958               (format "Yahrzeit of %s%s: %d%s anniversary"
 959                       entry
 960                       (if (= y d) "" " (evening)")
 961                       diff
 962                       (cond ((= (% diff 10) 1) "st")
 963                             ((= (% diff 10) 2) "nd")
 964                             ((= (% diff 10) 3) "rd")
 965                             (t "th")))))))
 966
 967 (defun diary-rosh-hodesh (&optional mark)
 968   "Rosh Hodesh diary entry.
 969 Entry applies if date is Rosh Hodesh, the day before, or the Saturday before.
 970
 971 An optional parameter MARK specifies a face or single-character string to
 972 use when highlighting the day in the calendar."
 973   (let* ((d (calendar-absolute-from-gregorian date))
 974          (h-date (calendar-hebrew-from-absolute d))
 975          (h-month (extract-calendar-month h-date))
 976          (h-day (extract-calendar-day h-date))
 977          (h-year (extract-calendar-year h-date))
 978          (leap-year (hebrew-calendar-leap-year-p h-year))
 979          (last-day (hebrew-calendar-last-day-of-month h-month h-year))
 980          (h-month-names
 981           (if leap-year
 982               calendar-hebrew-month-name-array-leap-year
 983             calendar-hebrew-month-name-array-common-year))
 984          (this-month (aref h-month-names (1- h-month)))
 985          (h-yesterday (extract-calendar-day
 986                        (calendar-hebrew-from-absolute (1- d)))))
 987     (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7)))
 988         (cons mark
 989               (format
 990                "Rosh Hodesh %s"
 991                (if (= h-day 30)
 992                    (format
 993                     "%s (first day)"
 994                     ;; next month must be in the same year since this
 995                     ;; month can't be the last month of the year since
 996                     ;; it has 30 days
 997                     (aref h-month-names h-month))
 998                  (if (= h-yesterday 30)
 999                      (format "%s (second day)" this-month)
1000                    this-month))))
1001       (if (= (% d 7) 6) ;; Saturday--check for Shabbat Mevarchim
1002           (cons mark
1003                 (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
1004                        (format "Mevarchim Rosh Hodesh %s (%s)"
1005                                (aref h-month-names
1006                                      (if (= h-month
1007                                             (hebrew-calendar-last-month-of-year
1008                                              h-year))
1009                                          0 h-month))
1010                                (aref calendar-day-name-array (- 29 h-day))))
1011                       ((and (< h-day 30) (> h-day 22) (= 30 last-day))
1012                        (format "Mevarchim Rosh Hodesh %s (%s-%s)"
1013                                (aref h-month-names h-month)
1014                                (if (= h-day 29)
1015                                    "tomorrow"
1016                                  (aref calendar-day-name-array (- 29 h-day)))
1017                                (aref calendar-day-name-array
1018                                      (% (- 30 h-day) 7))))))
1019         (if (and (= h-day 29) (/= h-month 6))
1020             (cons mark
1021                   (format "Erev Rosh Hodesh %s"
1022                           (aref h-month-names
1023                                 (if (= h-month
1024                                        (hebrew-calendar-last-month-of-year
1025                                         h-year))
1026                                     0 h-month)))))))))
1027
1028 (defvar hebrew-calendar-parashiot-names
1029 ["Bereshith"   "Noah"      "Lech L'cha" "Vayera"    "Hayei Sarah" "Toledoth"
1030  "Vayetze"     "Vayishlah" "Vayeshev"   "Mikketz"   "Vayiggash"   "Vayhi"
1031  "Shemoth"     "Vaera"     "Bo"         "Beshallah" "Yithro"      "Mishpatim"
1032  "Terumah"     "Tetzavveh" "Ki Tissa"   "Vayakhel"  "Pekudei"     "Vayikra"
1033  "Tzav"        "Shemini"   "Tazria"     "Metzora"   "Aharei Moth" "Kedoshim"
1034  "Emor"        "Behar"     "Behukkotai" "Bemidbar"  "Naso"       "Behaalot'cha"
1035  "Shelah L'cha" "Korah"    "Hukkath"    "Balak"     "Pinhas"      "Mattoth"
1036  "Masei"       "Devarim"   "Vaethanan"  "Ekev"      "Reeh"        "Shofetim"
1037  "Ki Tetze"    "Ki Tavo"   "Nitzavim"   "Vayelech"  "Haazinu"]
1038   "The names of the parashiot in the Torah.")
1039
1040 (defun hebrew-calendar-parasha-name (p)
1041   "Name(s) corresponding to parasha P."
1042   (if (arrayp p);; combined parasha
1043       (format "%s/%s"
1044               (aref hebrew-calendar-parashiot-names (aref p 0))
1045               (aref hebrew-calendar-parashiot-names (aref p 1)))
1046     (aref hebrew-calendar-parashiot-names p)))
1047
1048 (defun diary-parasha (&optional mark)
1049   "Parasha diary entry--entry applies if date is a Saturday.
1050
1051 An optional parameter MARK specifies a face or single-character string to
1052 use when highlighting the day in the calendar."
1053   (let ((d (calendar-absolute-from-gregorian date)))
1054     (if (= (% d 7) 6) ;;  Saturday
1055         (let*
1056             ((h-year (extract-calendar-year
1057                       (calendar-hebrew-from-absolute d)))
1058              (rosh-hashanah
1059               (calendar-absolute-from-hebrew (list 7 1 h-year)))
1060              (passover
1061               (calendar-absolute-from-hebrew (list 1 15 h-year)))
1062              (rosh-hashanah-day
1063               (aref calendar-day-name-array (% rosh-hashanah 7)))
1064              (passover-day
1065               (aref calendar-day-name-array (% passover 7)))
1066              (long-h (hebrew-calendar-long-heshvan-p h-year))
1067              (short-k (hebrew-calendar-short-kislev-p h-year))
1068              (type (cond ((and long-h (not short-k)) "complete")
1069                          ((and (not long-h) short-k) "incomplete")
1070                          (t "regular")))
1071              (year-format
1072               (symbol-value
1073                (intern (format "hebrew-calendar-year-%s-%s-%s" ;; keviah
1074                                rosh-hashanah-day type passover-day))))
1075              (first-saturday ;; of Hebrew year
1076               (calendar-dayname-on-or-before 6 (+ 6 rosh-hashanah)))
1077              (saturday ;; which Saturday of the Hebrew year
1078               (/ (- d first-saturday) 7))
1079              (parasha (aref year-format saturday)))
1080           (if parasha
1081               (cons mark
1082                     (format
1083                      "Parashat %s"
1084                      (if (listp parasha) ;; Israel differs from diaspora
1085                          (if (car parasha)
1086                              (format "%s (diaspora), %s (Israel)"
1087                                      (hebrew-calendar-parasha-name (car parasha))
1088                                      (hebrew-calendar-parasha-name (cdr parasha)))
1089                            (format "%s (Israel)"
1090                                    (hebrew-calendar-parasha-name (cdr parasha))))
1091                        (hebrew-calendar-parasha-name parasha)))))))))
1092
1093 ;; The seven ordinary year types (keviot)
1094
1095 (defconst hebrew-calendar-year-Saturday-incomplete-Sunday
1096   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1097     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1098     43 44 45 46 47 48 49 50]
1099   "The structure of the parashiot.
1100 Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have
1101 29 days), and has Passover start on Sunday.")
1102
1103 (defconst hebrew-calendar-year-Saturday-complete-Tuesday
1104   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1105     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1106     43 44 45 46 47 48 49 [50 51]]
1107   "The structure of the parashiot.
1108 Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
1109 have 30 days), and has Passover start on Tuesday.")
1110
1111 (defconst hebrew-calendar-year-Monday-incomplete-Tuesday
1112   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1113     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1114     43 44 45 46 47 48 49 [50 51]]
1115   "The structure of the parashiot.
1116 Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
1117 have 29 days), and has Passover start on Tuesday.")
1118
1119 (defconst hebrew-calendar-year-Monday-complete-Thursday
1120   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1121    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
1122    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1123   "The structure of the parashiot.
1124 Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
1125 30 days), and has Passover start on Thursday.")
1126
1127 (defconst hebrew-calendar-year-Tuesday-regular-Thursday
1128   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1129    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
1130    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1131   "The structure of the parashiot.
1132 Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
1133 Kislev has 30 days), and has Passover start on Thursday.")
1134
1135 (defconst hebrew-calendar-year-Thursday-regular-Saturday
1136   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23
1137    24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30)
1138    (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48
1139    49 50]
1140   "The structure of the parashiot.
1141 Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and
1142 Kislev has 30 days), and has Passover start on Saturday.")
1143
1144 (defconst hebrew-calendar-year-Thursday-complete-Sunday
1145   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1146     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1147     43 44 45 46 47 48 49 50]
1148   "The structure of the parashiot.
1149 Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each
1150 have 30 days), and has Passover start on Sunday.")
1151
1152 ;; The seven leap year types (keviot)
1153
1154 (defconst hebrew-calendar-year-Saturday-incomplete-Tuesday
1155   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1156     23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
1157     43 44 45 46 47 48 49 [50 51]]
1158   "The structure of the parashiot.
1159 Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each
1160 have 29 days), and has Passover start on Tuesday.")
1161
1162 (defconst hebrew-calendar-year-Saturday-complete-Thursday
1163   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1164    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
1165    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1166   "The structure of the parashiot.
1167 Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
1168 have 30 days), and has Passover start on Thursday.")
1169
1170 (defconst hebrew-calendar-year-Monday-incomplete-Thursday
1171   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1172    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
1173    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1174   "The structure of the parashiot.
1175 Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
1176 have 29 days), and has Passover start on Thursday.")
1177
1178 (defconst hebrew-calendar-year-Monday-complete-Saturday
1179   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1180    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
1181    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
1182    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
1183   "The structure of the parashiot.
1184 Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
1185 30 days), and has Passover start on Saturday.")
1186
1187 (defconst hebrew-calendar-year-Tuesday-regular-Saturday
1188   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1189    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
1190    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
1191    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
1192   "The structure of the parashiot.
1193 Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
1194 Kislev has 30 days), and has Passover start on Saturday.")
1195
1196 (defconst hebrew-calendar-year-Thursday-incomplete-Sunday
1197   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1198     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
1199     43 44 45 46 47 48 49 50]
1200   "The structure of the parashiot.
1201 Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both
1202 have 29 days), and has Passover start on Sunday.")
1203
1204 (defconst hebrew-calendar-year-Thursday-complete-Tuesday
1205   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1206     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
1207     43 44 45 46 47 48 49 [50 51]]
1208   "The structure of the parashiot.
1209 Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
1210 have 30 days), and has Passover start on Tuesday.")
1211
1212 (provide 'cal-hebrew)
1213
1214 ;;; arch-tag: aaab6718-7712-42ac-a32d-28fe1f944f3c
1215 ;;; cal-hebrew.el ends here