[Summary view] [Print] [Text view]

   1  ;
   2  ;  yahr.cl  calculate yahrzeit dates
   3  ;
   4  ;  adapted from calendar.el
   5  ;
   6  ;(setq lisp:*floating-point-contagion-ansi* t)
   7  ;(setq lisp:*default-float-format* 'double-float)
   8  (defvar calendar-latitude +45.44)
   9  (defvar calendar-longitude -75.695)
  10  (defvar calendar-location-name "Ottawa, Ont.")
  11  (defvar calendar-time-zone -300)
  12  (defvar calendar-standard-time-zone-name "EST")
  13  (defvar calendar-daylight-time-zone-name "EDT")
  14  
  15  (setq date (multiple-value-bind (sec min hr day mon year dow dstp tz) 
  16             (get-decoded-time) (list mon day year)))
  17  (defvar year (multiple-value-bind (sec min hr day mon year dow dstp tz)
  18           (get-decoded-time) year))
  19  (defvar month (multiple-value-bind (sec min hr day mon year dow dstp tz)
  20           (get-decoded-time) mon))
  21  
  22  (setq calendar-daylight-savings-starts  
  23        '(calendar-nth-named-day 1 0 4 year))
  24  (setq calendar-daylight-savings-ends  
  25        '(calendar-nth-named-day -1 0 10 year))
  26  (setq all-hebrew-calendar-holidays t)
  27  
  28  (defvar calendar-day-name-array
  29    (vector "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
  30  
  31  (defvar calendar-day-name-abbr-array
  32    (vector "Sun" "Mon" "Tues" "Wed" "Thurs" "Fri" "Sat"))
  33  
  34  (defun calendar-day-name (date)
  35    "Returns a string with the name of the day of the week of DATE."
  36    (aref calendar-day-name-array (calendar-day-of-week date)))
  37  
  38  (defvar calendar-month-name-array
  39    (vector "January" "February" "March"     "April"   "May"      "June"
  40     "July"    "August"   "September" "October" "November" "December"))
  41  
  42  (defmacro % ( n d )
  43    "Redefine % as the REM function."
  44    `(rem ,n ,d))
  45  
  46    
  47  (defvar european-calendar-style nil
  48    "*Use the European style of dates in the diary and in any displays.
  49  If this variable is t, a date 1/2/1990 would be interpreted as February 1,
  50  1990.  The accepted European date styles are
  51  
  52              DAY/MONTH
  53              DAY/MONTH/YEAR
  54              DAY MONTHNAME
  55              DAY MONTHNAME YEAR
  56              DAYNAME
  57  
  58  Names can be capitalized or not, written in full, or abbreviated to three
  59  characters with or without a period." )
  60  
  61  (defmacro calendar-sum (index initial condition expression)
  62    "For INDEX = INITIAL et seq, as long as CONDITION holds, sum EXPRESSION."
  63    `(do ((sum 0)
  64      (,index  ,initial (1+ ,index)))
  65      ((not ,condition) sum)
  66       (setq sum (+ sum ,expression ))))
  67  
  68  (declaim (inline extract-calendar-month))
  69  (defun extract-calendar-month (date)
  70    "Extract the month part of DATE which has the form (month day year)."
  71    (car date))
  72  
  73  (declaim (inline extract-calendar-day))
  74  (defun extract-calendar-day (date)
  75    "Extract the day part of DATE which has the form (month day year)."
  76    (car (cdr date)))
  77  
  78  (declaim (inline extract-calendar-year))
  79  (defun extract-calendar-year (date)
  80    "Extract the year part of DATE which has the form (month day year)."
  81    (car (cdr (cdr date))))
  82  
  83  (declaim (inline calendar-leap-year-p))
  84  (defun calendar-leap-year-p (year)
  85    "Returns t if YEAR is a Gregorian leap year."
  86    (and (zerop (% year 4))
  87         (or (not (zerop (% year 100)))
  88             (zerop (% year 400)))))
  89  
  90  (declaim (inline calendar-last-day-of-month))
  91  (defun calendar-last-day-of-month (month year)
  92    "The last day in MONTH during YEAR."
  93    (if (and (= month 2) (calendar-leap-year-p year))
  94        29
  95      (aref (vector 31 28 31 30 31 30 31 31 30 31 30 31) (1- month))))
  96  
  97  (declaim (inline calendar-day-number))
  98  (defun calendar-day-number (date)
  99    "Return the day number within the year of the date DATE.
 100  For example, (calendar-day-number '(1 1 1987)) returns the value 1,
 101  while (calendar-day-number '(12 31 1980)) returns 366."
 102      (let* ((month (extract-calendar-month date))
 103             (day (extract-calendar-day date))
 104             (year (extract-calendar-year date))
 105           (day-of-year (+ day (* 31 (1- month)))))
 106        (if (> month 2)
 107            (progn
 108              (setq day-of-year (- day-of-year (truncate (+ 23 (* 4 month)) 10)))
 109              (if (calendar-leap-year-p year)
 110                  (setq day-of-year (1+ day-of-year)))))
 111        day-of-year))
 112  
 113  (declaim (inline calendar-absolute-from-gregorian))
 114  (defun calendar-absolute-from-gregorian (date)
 115    "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
 116  The Gregorian date Sunday, December 31, 1 BC is imaginary."
 117    (let ((prior-years (1- (extract-calendar-year date))))
 118      (+ (calendar-day-number date);; Days this year
 119         (* 365 prior-years);;        + Days in prior years
 120         (truncate prior-years 4);;          + Julian leap years
 121         (- (truncate prior-years 100));;    - century years
 122         (truncate prior-years 400))));;     + Gregorian leap years
 123  
 124  (defvar european-calendar-display-form
 125    '((list 'if dayname (concatenate (format nil "~A" dayname) ", ")) day " " monthname " " year)
 126    "*Pseudo-pattern governing the way a date appears in the European style.
 127  See the documentation of calendar-date-display-form for an explanation.")
 128  
 129  
 130  (defvar american-calendar-display-form
 131    '((if dayname (concatenate dayname ", ")) monthname " " day ", " year)
 132  ;  '((list 'if dayname (concatenate (format nil "~A" dayname) ", ")) monthname " " day ", " year)
 133    "*Pseudo-pattern governing the way a date appears in the American style.
 134  See the documentation of `calendar-date-display-form' for an explanation.")
 135  
 136  (defvar calendar-date-display-form
 137    (if european-calendar-style
 138        european-calendar-display-form
 139      american-calendar-display-form)
 140    "*Pseudo-pattern governing the way a date appears.
 141  
 142  Used by the function `calendar-date-string', a pseudo-pattern is a list of
 143  expressions that can involve the keywords `month', `day', and `year', all
 144  numbers in string form, and `monthname' and `dayname', both alphabetic
 145  strings.  For example, the ISO standard would use the pseudo- pattern
 146  
 147         '(year \"-\" month \"-\" day)
 148  
 149  while a typical American form would be
 150  
 151         '(month \"/\" day \"/\" (substring year -2))
 152  
 153  and
 154  
 155         '((format \"%9s, %9s %2s, %4s\" dayname monthname day year))
 156  
 157  would give the usual American style in fixed-length fields.
 158  
 159  See the documentation of the function `calendar-date-string'.")
 160  
 161  (defun european-calendar ()
 162    "Set the interpretation and display of dates to the European style."
 163    (interactive)
 164    (setq european-calendar-style t)
 165    (setq calendar-date-display-form european-calendar-display-form)
 166    (setq diary-date-forms european-date-diary-pattern)
 167    (update-calendar-mode-line))
 168  
 169  (defun american-calendar ()
 170    "Set the interpretation and display of dates to the American style."
 171    (interactive)
 172    (setq european-calendar-style nil)
 173    (setq calendar-date-display-form american-calendar-display-form)
 174    (setq diary-date-forms american-date-diary-pattern)
 175    (update-calendar-mode-line))
 176  
 177  (defun calendar-current-date ()
 178    "Returns the current date in a list (month day year)."
 179    (multiple-value-bind(s m h d mo yr)(get-decoded-time)
 180      (list mo  d  yr)))
 181  (defun calendar-date-equal (date1 date2)
 182    "Returns t if the DATE1 and DATE2 are the same."
 183    (and
 184     (= (extract-calendar-month date1) (extract-calendar-month date2))
 185     (= (extract-calendar-day date1) (extract-calendar-day date2))
 186     (= (extract-calendar-year date1) (extract-calendar-year date2))))
 187  
 188  (defun calendar-dayname-on-or-before (dayname date)
 189    "Returns the absolute date of the DAYNAME on or before absolute DATE.
 190  DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on.
 191  
 192  Note: Applying this function to d+6 gives us the DAYNAME on or after an
 193  absolute day d.  Similarly, applying it to d+3 gives the DAYNAME nearest to
 194  absolute date d, applying it to d-1 gives the DAYNAME previous to absolute
 195  date d, and applying it to d+7 gives the DAYNAME following absolute date d."
 196    (- date (% (- date dayname) 7)))
 197  
 198  (defun calendar-gregorian-from-absolute (date)
 199    "Compute the list (month day year) corresponding to the absolute DATE.
 200  The absolute date is the number of days elapsed since the (imaginary)
 201  Gregorian date Sunday, December 31, 1 BC."
 202  ;; See the footnote on page 384 of ``Calendrical Calculations, Part II:
 203  ;; Three Historical Calendars'' by E. M. Reingold,  N. Dershowitz, and S. M.
 204  ;; Clamen, Software--Practice and Experience, Volume 23, Number 4
 205  ;; (April, 1993), pages 383-404 for an explanation.
 206    (let* ((d0 (1- date))
 207           (n400 (truncate d0 146097))
 208           (d1 (% d0 146097))
 209           (n100 (truncate d1 36524))
 210           (d2 (% d1 36524))
 211           (n4 (truncate d2 1461))
 212           (d3 (% d2 1461))
 213           (n1 (truncate d3 365))
 214           (day (1+ (% d3 365)))
 215           (year (+ (* 400 n400) (* 100 n100) (* n4 4) n1)))
 216      (if (or (= n100 4) (= n1 4))
 217          (list 12 31 year)
 218        (let ((year (1+ year))
 219              (month 1))
 220          (loop
 221          (let (( mdays (calendar-last-day-of-month month year)))
 222            (when (not  (and (< mdays day)
 223                     (setq day (- day mdays))))
 224              (return))
 225             (setq month (1+ month))))
 226      (list month day year)))))
 227  
 228  (defun calendar-month-name (month)
 229    "The name of MONTH."
 230    (aref calendar-month-name-array (1- month)))
 231  
 232  (defun calendar-day-of-week (date)
 233    "Returns the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc."
 234    (% (calendar-absolute-from-gregorian date) 7))
 235  
 236  (defun calendar-print-hebrew-date ()
 237    "Show the Hebrew calendar equivalent of the date under the cursor."
 238     (format t "Hebrew date (until sunset): ~A"
 239             (calendar-hebrew-date-string (calendar-cursor-to-date t))))
 240  
 241  (defun hebrew-calendar-last-month-of-year (year)
 242    "The last month of the Hebrew calendar YEAR."
 243    (if (hebrew-calendar-leap-year-p year)
 244        13
 245      12))
 246  (defun calendar-hebrew-from-absolute (date)
 247    "Compute the Hebrew date (month day year) corresponding to absolute DATE.
 248  The absolute date is the number of days elapsed since the (imaginary)
 249  Gregorian date Sunday, December 31, 1 BC."
 250    (let* ((greg-date (calendar-gregorian-from-absolute date))
 251           (month (aref (vector 9 10 11 12 1 2 3 4 7 7 7 8 )
 252                   (1- (extract-calendar-month greg-date))))
 253           (day)
 254           (year (+ 3760 (extract-calendar-year greg-date))))
 255      (loop (when (not (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year)))))
 256          (return))        
 257        (setq year (1+ year)))
 258      (let ((length (hebrew-calendar-last-month-of-year year)))
 259        (loop (when (not (> date (calendar-absolute-from-hebrew
 260                   (list month
 261                         (hebrew-calendar-last-day-of-month month year) year))))
 262            (return))
 263          (setq month (1+ (% month length)))))
 264      (setq day (1+
 265                 (- date (calendar-absolute-from-hebrew (list month 1 year)))))
 266      (list month day year)))
 267  
 268  (defun hebrew-calendar-leap-year-p (year)
 269    "t if YEAR is a Hebrew calendar leap year."
 270    (< (% (1+ (* 7 year)) 19) 7))
 271  
 272  (defun hebrew-calendar-last-day-of-month (month year)
 273    "The last day of MONTH in YEAR."
 274    (if (or (member month (list 2 4 6 10 13))
 275            (and (= month 12) (not (hebrew-calendar-leap-year-p year)))
 276            (and (= month 8) (not (hebrew-calendar-long-heshvan-p year)))
 277            (and (= month 9) (hebrew-calendar-short-kislev-p year)))
 278        29
 279      30))
 280  
 281  (defun hebrew-calendar-elapsed-days (year)
 282    "Days from Sun. prior to start of Hebrew calendar to mean conjunction of Tishri of Hebrew YEAR."
 283    (let* ((months-elapsed
 284            (+ (* 235 (truncate (1- year) 19));; Months in complete cycles so far.
 285               (* 12 (% (1- year) 19))      ;; Regular months in this cycle
 286               (truncate (1+ (* 7 (% (1- year) 19))) 19)));; Leap months this cycle
 287           (parts-elapsed (+ 204 (* 793 (% months-elapsed 1080))))
 288           (hours-elapsed (+ 5
 289                             (* 12 months-elapsed)
 290                             (* 793 (truncate months-elapsed 1080))
 291                             (truncate parts-elapsed 1080)))
 292           (parts                                  ;; Conjunction parts
 293            (+ (* 1080 (% hours-elapsed 24)) (% parts-elapsed 1080)))
 294           (day                                    ;; Conjunction day
 295            (+ 1 (* 29 months-elapsed) (truncate hours-elapsed 24)))
 296           (alternative-day
 297            (if (or (>= parts 19440)    ;; If the new moon is at or after midday,
 298                    (and (= (% day 7) 2);; ...or is on a Tuesday...
 299                         (>= parts 9924)  ;;    at 9 hours, 204 parts or later...
 300                         (not (hebrew-calendar-leap-year-p year)));; of a
 301                                                                  ;; common year,
 302                    (and (= (% day 7) 1);; ...or is on a Monday...
 303                         (>= parts 16789) ;;   at 15 hours, 589 parts or later...
 304                         (hebrew-calendar-leap-year-p (1- year))));; at the end
 305                                                       ;; of a leap year
 306         ;; Then postpone Rosh HaShanah one day
 307                (1+ day)
 308         ;; Else
 309              day)))
 310      (if ;; If Rosh HaShanah would occur on Sunday, Wednesday, or Friday
 311          (member (% alternative-day 7) (list 0 3 5))
 312    ;; Then postpone it one (more) day and return        
 313          (1+ alternative-day)
 314    ;; Else return        
 315        alternative-day)))
 316  
 317  (defun hebrew-calendar-days-in-year (year)
 318    "Number of days in Hebrew YEAR."
 319    (- (hebrew-calendar-elapsed-days (1+ year))
 320       (hebrew-calendar-elapsed-days year)))
 321  
 322  (defun hebrew-calendar-long-heshvan-p (year)
 323    "t if Heshvan is long in Hebrew YEAR."
 324    (= (% (hebrew-calendar-days-in-year year) 10) 5))
 325  
 326  (defun hebrew-calendar-short-kislev-p (year)
 327    "t if Kislev is short in Hebrew YEAR."
 328    (= (% (hebrew-calendar-days-in-year year) 10) 3))
 329  
 330  (defun calendar-absolute-from-hebrew (date)
 331    "Absolute date of Hebrew DATE.
 332  The absolute date is the number of days elapsed since the (imaginary)
 333  Gregorian date Sunday, December 31, 1 BC."
 334    (let* ((month (extract-calendar-month date))
 335           (day (extract-calendar-day date))
 336           (year (extract-calendar-year date)))
 337      (+ day                            ;; Days so far this month.
 338         (if (< month 7);; before Tishri
 339       ;; Then add days in prior months this year before and after Nisan
 340             (+ (calendar-sum
 341                 m 7 (<= m (hebrew-calendar-last-month-of-year year))
 342                 (hebrew-calendar-last-day-of-month m year))
 343                (calendar-sum
 344                 m 1 (< m month)
 345                 (hebrew-calendar-last-day-of-month m year)))
 346       ;; Else add days in prior months this year
 347           (calendar-sum
 348            m 7 (< m month)
 349            (hebrew-calendar-last-day-of-month m year)))
 350      (hebrew-calendar-elapsed-days year);; Days in prior years.
 351      -1373429)))                        ;; Days elapsed before absolute date 1.
 352  
 353  (defvar calendar-hebrew-month-name-array-common-year
 354    (vector "Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
 355     "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"))
 356  
 357  (defvar calendar-hebrew-month-name-array-leap-year
 358    (vector "Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
 359     "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"))
 360  
 361  (defun calendar-date-display-form
 362    (if european-calendar-style
 363        european-calendar-display-form
 364      american-calendar-display-form)
 365    "*Pseudo-pattern governing the way a date appears.
 366  
 367  Used by the function `calendar-date-string', a pseudo-pattern is a list of
 368  expressions that can involve the keywords `month', `day', and `year', all
 369  numbers in string form, and `monthname' and `dayname', both alphabetic
 370  strings.  For example, the ISO standard would use the pseudo- pattern
 371  
 372         '(year \"-\" month \"-\" day)
 373  
 374  while a typical American form would be
 375  
 376         '(month \"/\" day \"/\" (substring year -2))
 377  
 378  and
 379  
 380         '((format \"%9s, %9s %2s, %4s\" dayname monthname day year))
 381  
 382  would give the usual American style in fixed-length fields.
 383  
 384  See the documentation of the function `calendar-date-string'.")
 385  
 386  
 387  (defun calendar-date-string (date &optional abbreviate nodayname)
 388    "A string form of DATE, driven by the variable `calendar-date-display-form'.
 389  An optional parameter ABBREVIATE, when t, causes the month and day names to be
 390  abbreviated to three characters.  An optional parameter NODAYNAME, when t,
 391  omits the name of the day of the week."
 392    (let* ((dayname
 393            (if nodayname
 394                nil
 395              (if abbreviate
 396                  (substring (calendar-day-name date) 0 3)
 397                (calendar-day-name date))))
 398           (month (extract-calendar-month date))
 399           (monthname
 400            (if abbreviate
 401                (substring
 402                 (calendar-month-name month) 0 3)
 403              (calendar-month-name month)))
 404           (day (format nil "~A" (extract-calendar-day date)))
 405           (month (format nil "~A" month))
 406           (year (format nil "~A" (extract-calendar-year date))))
 407      (concatenate 'string (and (boundp 'dayname)
 408                    dayname
 409                    (concatenate 'string dayname ", "))
 410           monthname " " day ", " year)))
 411  
 412  (defun calendar-dayname-on-or-before (dayname date)
 413    "Returns the absolute date of the DAYNAME on or before absolute DATE.
 414  DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on.
 415  
 416  Note: Applying this function to d+6 gives us the DAYNAME on or after an
 417  absolute day d.  Similarly, applying it to d+3 gives the DAYNAME nearest to
 418  absolute date d, applying it to d-1 gives the DAYNAME previous to absolute
 419  date d, and applying it to d+7 gives the DAYNAME following absolute date d."
 420    (- date (% (- date dayname) 7)))
 421  
 422  (defun calendar-nth-named-absday (n dayname month year &optional day)
 423    "The absolute date of Nth DAYNAME in MONTH, YEAR before/after optional DAY.
 424  A DAYNAME of 0 means Sunday, 1 means Monday, and so on.  If N<0,
 425  return the Nth DAYNAME before MONTH DAY, YEAR (inclusive).
 426  If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive).
 427  
 428  If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise."
 429    (if (> n 0)
 430        (+ (* 7 (1- n))
 431       (calendar-dayname-on-or-before
 432        dayname
 433        (+ 6 (calendar-absolute-from-gregorian
 434          (list month (or day 1) year)))))
 435      (+ (* 7 (1+ n))
 436         (calendar-dayname-on-or-before
 437      dayname
 438      (calendar-absolute-from-gregorian
 439       (list month
 440             (or day (calendar-last-day-of-month month year))
 441             year))))))
 442  
 443  (defun calendar-nth-named-day (n dayname month year &optional day)
 444    "The date of Nth DAYNAME in MONTH, YEAR before/after optional DAY.
 445  A DAYNAME of 0 means Sunday, 1 means Monday, and so on.  If N<0,
 446  return the Nth DAYNAME before MONTH DAY, YEAR (inclusive).
 447  If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive).
 448  
 449  If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise."
 450    (calendar-gregorian-from-absolute
 451     (calendar-nth-named-absday n dayname month year day)))
 452     
 453  
 454  (defun calendar-hebrew-date-string (&optional date)
 455    "String of Hebrew date before sunset of Gregorian DATE.
 456  Defaults to today's date if DATE is not given.
 457  Driven by the variable `calendar-date-display-form'."
 458    (let* ((hebrew-date (calendar-hebrew-from-absolute
 459                         (calendar-absolute-from-gregorian
 460                          (or date (calendar-current-date)))))
 461           (calendar-month-name-array
 462            (if (hebrew-calendar-leap-year-p (extract-calendar-year hebrew-date))
 463                calendar-hebrew-month-name-array-leap-year
 464              calendar-hebrew-month-name-array-common-year)))
 465      (calendar-date-string hebrew-date nil t)))
 466  ;;;
 467  ;;;   functions from diary-lib.el
 468  ;;;
 469  
 470  (defun diary-day-of-year ()
 471    "Day of year and number of days remaining in the year of date diary entry."
 472    (calendar-day-of-year-string date))
 473  
 474  (defun diary-iso-date ()
 475    "ISO calendar equivalent of date diary entry."
 476    (format nil "ISO date: ~A" (calendar-iso-date-string date)))
 477  
 478  (defun diary-islamic-date ()
 479    "Islamic calendar equivalent of date diary entry."
 480    (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
 481      (if (string-equal i "")
 482          "Date is pre-Islamic"
 483        (format nil "Islamic date (until sunset): ~A" i))))
 484  
 485  (defun diary-hebrew-date ()
 486    "Hebrew calendar equivalent of date diary entry."
 487    (format nil "Today's date (until sunset): ~A" (calendar-hebrew-date-string date)))
 488  
 489  (defun diary-julian-date ()
 490    "Julian calendar equivalent of date diary entry."
 491    (format nil "Julian date: ~A" (calendar-julian-date-string date)))
 492  
 493  (defun diary-astro-day-number ()
 494    "Astronomical (Julian) day number diary entry."
 495    (format nil "Astronomical (Julian) day number ~A"
 496            (calendar-astro-date-string date)))
 497  
 498  (defun all-holidays ()
 499    "Check date against all Jewish Calendar Holidays"
 500    (let ((l (append
 501        (holiday-rosh-hashanah-etc)
 502        (holiday-hanukkah)
 503        (holiday-passover-etc)
 504        (holiday-tisha-b-av-etc))))
 505      l))
 506        
 507  (defun holiday-rosh-hashanah-etc ()
 508    "List of dates related to Rosh Hashanah, as visible in calendar window."
 509    (let* ((abs-r-h (calendar-absolute-from-hebrew
 510             (list 7 1 (+ year 3761))))
 511       (mandatory
 512        (list
 513         (list (calendar-gregorian-from-absolute abs-r-h)
 514           (format nil "Rosh HaShanah ~d" (+ 3761 year)))
 515         (list (calendar-gregorian-from-absolute (+ abs-r-h 9))
 516           "Yom Kippur")
 517         (list (calendar-gregorian-from-absolute (+ abs-r-h 14))
 518           "Succos")
 519         (list (calendar-gregorian-from-absolute (+ abs-r-h 21))
 520           "Shemini Atzeres")
 521         (list (calendar-gregorian-from-absolute (+ abs-r-h 22))
 522           "Simchas Torah")))
 523       (optional
 524        (list 
 525         (list (calendar-gregorian-from-absolute
 526            (calendar-dayname-on-or-before 6 (- abs-r-h 4)))
 527           "Selichos (night)")
 528         (list (calendar-gregorian-from-absolute (1- abs-r-h))
 529           "Erev Rosh HaShannah")
 530         (list (calendar-gregorian-from-absolute (1+ abs-r-h))
 531           "Rosh HaShanah (second day)")
 532         (list (calendar-gregorian-from-absolute
 533            (if (= (% abs-r-h 7) 4) (+ abs-r-h 3) (+ abs-r-h 2)))
 534           "Tzom Gedaliah")
 535         (list (calendar-gregorian-from-absolute
 536            (calendar-dayname-on-or-before 6 (+ 7 abs-r-h)))
 537           "Shabbos Shuvah")
 538         (list (calendar-gregorian-from-absolute (+ abs-r-h 8))
 539           "Erev Yom Kippur")
 540         (list (calendar-gregorian-from-absolute (+ abs-r-h 13))
 541           "Erev Succos")
 542         (list (calendar-gregorian-from-absolute (+ abs-r-h 15))
 543           "Succos (second day)")
 544         (list (calendar-gregorian-from-absolute (+ abs-r-h 16))
 545           "Chol Hamoed Succos (first day)")
 546         (list (calendar-gregorian-from-absolute (+ abs-r-h 17))
 547           "Chol Hamoed Succos (second day)")
 548         (list (calendar-gregorian-from-absolute (+ abs-r-h 18))
 549           "Chol Hamoed Succos (third day)")
 550         (list (calendar-gregorian-from-absolute (+ abs-r-h 19))
 551           "Chol Hamoed Succos (fourth day)")
 552         (list (calendar-gregorian-from-absolute (+ abs-r-h 20))
 553           "Hoshannah Rabbah")))
 554       (output-list
 555        (filter-visible-calendar-holidays mandatory)))
 556      (if all-hebrew-calendar-holidays
 557      (setq output-list
 558            (append 
 559             (filter-visible-calendar-holidays optional)
 560             output-list)))
 561      output-list))
 562  
 563  (defmacro increment-calendar-month (mon yr n)
 564    "Move the variables MON and YR to the month and year by N months.
 565  Forward if N is positive or backward if N is negative."
 566    `(let (( macro-y (+ (* ,yr 12) , mon -1 ,n)) )
 567         (setq  ,mon (1+ (% macro-y 12) ))
 568         (setq  ,yr (floor macro-y 12))))
 569  
 570  
 571  (defun holiday-hanukkah ()
 572    "List of dates related to Hanukkah, as visible in calendar window."
 573    (let ((m month)
 574      (y year))
 575      (increment-calendar-month m y 1)
 576      (let* ((h-y (extract-calendar-year
 577           (calendar-hebrew-from-absolute
 578            (calendar-absolute-from-gregorian
 579             (list m (calendar-last-day-of-month m y) y)))))
 580         (abs-h (calendar-absolute-from-hebrew (list 9 25 h-y))))
 581        (filter-visible-calendar-holidays
 582         (list
 583      (list (calendar-gregorian-from-absolute (1- abs-h))
 584            "Erev Chanuka")
 585      (list (calendar-gregorian-from-absolute abs-h)
 586            "Chanuka (first day)")
 587      (list (calendar-gregorian-from-absolute (1+ abs-h))
 588            "Chanuka (second day)")
 589      (list (calendar-gregorian-from-absolute (+ abs-h 2))
 590            "Chanuka (third day)")
 591      (list (calendar-gregorian-from-absolute (+ abs-h 3))
 592            "Chanuka (fourth day)")
 593      (list (calendar-gregorian-from-absolute (+ abs-h 4))
 594            "Chanuka (fifth day)")
 595      (list (calendar-gregorian-from-absolute (+ abs-h 5))
 596            "Chanuka (sixth day)")
 597      (list (calendar-gregorian-from-absolute (+ abs-h 6))
 598            "Chanuka (seventh day)")
 599      (list (calendar-gregorian-from-absolute (+ abs-h 7))
 600            "Chanuka (eighth day)"))))))
 601  
 602  (defun holiday-passover-etc ()
 603    "List of dates related to Passover, as visible in calendar window."
 604       (let* ((abs-p (calendar-absolute-from-hebrew
 605                        (list 1 15 (+ year 3760))))
 606             (mandatory
 607              (list
 608               (list (calendar-gregorian-from-absolute abs-p)
 609                     "Pesach")
 610               (list (calendar-gregorian-from-absolute (+ abs-p 50))
 611                     "Shavuot")))
 612             (optional
 613              (list 
 614               (list (calendar-gregorian-from-absolute
 615                      (calendar-dayname-on-or-before 6 (- abs-p 43)))
 616                     "Shabbos Shekalim")
 617               (list (calendar-gregorian-from-absolute
 618                      (calendar-dayname-on-or-before 6 (- abs-p 30)))
 619                     "Shabbos Zachor")
 620               (list (calendar-gregorian-from-absolute
 621                      (if (= (% abs-p 7) 2) (- abs-p 33) (- abs-p 31)))
 622                     "Fast of Esther")
 623               (list (calendar-gregorian-from-absolute (- abs-p 31))
 624                     "Erev Purim")
 625               (list (calendar-gregorian-from-absolute (- abs-p 30))
 626                     "Purim")
 627               (list (calendar-gregorian-from-absolute
 628                      (if (zerop (% abs-p 7)) (- abs-p 28) (- abs-p 29)))
 629                     "Shushan Purim")
 630               (list (calendar-gregorian-from-absolute
 631                      (- (calendar-dayname-on-or-before 6 (- abs-p 14)) 7))
 632                     "Shabbos Parah")
 633               (list (calendar-gregorian-from-absolute
 634                      (calendar-dayname-on-or-before 6 (- abs-p 14)))
 635                     "Shabbos HaHodesh")
 636               (list (calendar-gregorian-from-absolute
 637                      (calendar-dayname-on-or-before 6 (1- abs-p)))
 638                     "Shabbos HaGadol")
 639               (list (calendar-gregorian-from-absolute (1- abs-p))
 640                     "Erev Pesach")
 641               (list (calendar-gregorian-from-absolute (1+ abs-p))
 642                     "Pesach (second day)")
 643               (list (calendar-gregorian-from-absolute (+ abs-p 2))
 644                     "Chol Hamoed Pesach (first day)")
 645               (list (calendar-gregorian-from-absolute (+ abs-p 3))
 646                     "Chol Hamoed Pesach (second day)")
 647               (list (calendar-gregorian-from-absolute (+ abs-p 4))
 648                     "Chol Hamoed Pesach (third day)")
 649               (list (calendar-gregorian-from-absolute (+ abs-p 5))
 650                     "Chol Hamoed Pesach (fourth day)")
 651               (list (calendar-gregorian-from-absolute (+ abs-p 6))
 652                     "Pesach (seventh day)")
 653               (list (calendar-gregorian-from-absolute (+ abs-p 7))
 654                     "Pesach (eighth day)")
 655               (list (calendar-gregorian-from-absolute (+ abs-p 12))
 656                     "Yom HaShoah")
 657               (list (calendar-gregorian-from-absolute
 658                      (if (zerop (% abs-p 7))
 659                          (+ abs-p 18)
 660                        (if (= (% abs-p 7) 6)
 661                            (+ abs-p 19)
 662                          (+ abs-p 20))))
 663                     "Yom HaAtzma'ut")
 664               (list (calendar-gregorian-from-absolute (+ abs-p 33))
 665                     "Lag BaOmer")
 666               (list (calendar-gregorian-from-absolute (+ abs-p 43))
 667                     "Yom Yerushalim")
 668               (list (calendar-gregorian-from-absolute (+ abs-p 49))
 669                     "Erev Shavuos")
 670               (list (calendar-gregorian-from-absolute (+ abs-p 51))
 671                     "Shavuos (second day)")))
 672             (output-list
 673               (filter-visible-calendar-holidays mandatory)))
 674        (if all-hebrew-calendar-holidays
 675            (setq output-list
 676                  (append 
 677                   (filter-visible-calendar-holidays optional)
 678                   output-list)))
 679        output-list))
 680  
 681  (defun holiday-tisha-b-av-etc ()
 682    "List of dates around Tisha B'Av, as visible in calendar window."
 683          nil;; None of the dates is visible
 684      (let* ((abs-t-a (calendar-absolute-from-hebrew
 685                        (list 5 9 (+ year 3760)))))
 686        (filter-visible-calendar-holidays
 687         (list 
 688          (list (calendar-gregorian-from-absolute
 689                 (if (= (% abs-t-a 7) 6) (- abs-t-a 20) (- abs-t-a 21)))
 690                "Tzom Tammuz")
 691          (list (calendar-gregorian-from-absolute
 692                 (calendar-dayname-on-or-before 6 abs-t-a))
 693                "Shabbos Chazon")
 694          (list (calendar-gregorian-from-absolute
 695                 (if (= (% abs-t-a 7) 6) (1+ abs-t-a) abs-t-a))
 696                "Tisha B'Av")
 697          (list (calendar-gregorian-from-absolute
 698                 (calendar-dayname-on-or-before 6 (+ abs-t-a 7)))
 699                "Shabbos Nachamu")))))
 700  
 701  (defun filter-visible-calendar-holidays (l)
 702    "Return a list of all visible holidays of those on L."
 703    (let ((visible)
 704          (p l)
 705      (abs-date (calendar-absolute-from-gregorian date)))
 706      (loop while p do
 707        (and (car (car p))
 708             (eql abs-date (calendar-absolute-from-gregorian (car (car p))))
 709             (setq visible (append (list (car p)) visible)))
 710        (setq p (cdr p)))
 711      visible))
 712  
 713  (defun diary-omer ()
 714    "Omer count diary entry.
 715  Entry applies if date is within 50 days after Passover."
 716    (let* ((passover
 717            (calendar-absolute-from-hebrew
 718             (list 1 15 (+ (extract-calendar-year date) 3760))))
 719           (omer (- (calendar-absolute-from-gregorian date) passover))
 720           (week (truncate omer 7))
 721           (day (% omer 7)))
 722      (if (and (> omer 0) (< omer 50))
 723          (format nil "Day ~D~A of the omer."
 724                  omer
 725                  (if (zerop week)
 726                      ""
 727                    (format nil ", that is, ~D week~A~A"
 728                            week
 729                            (if (= week 1) "" "s")
 730                            (if (zerop day)
 731                                ""
 732                              (format nil " and ~D day~A"
 733                                      day (if (= day 1) "" "s")))))))))
 734  
 735  (defun diary-yahrzeit (death-month death-day death-year)
 736    "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.
 737  Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed
 738  to be the name of the person.  Date of death is on the *civil* calendar;
 739  although the date of death is specified by the civil calendar, the proper
 740  Hebrew calendar yahrzeit is determined.  If `european-calendar-style' is t, the
 741  order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR."
 742    (let* ((h-date (calendar-hebrew-from-absolute
 743                    (calendar-absolute-from-gregorian
 744                     (if european-calendar-style
 745                         (list death-day death-month death-year)
 746                     (list death-month death-day death-year)))))
 747           (h-month (extract-calendar-month h-date))
 748           (h-day (extract-calendar-day h-date))
 749           (h-year (extract-calendar-year h-date))
 750           (d (calendar-absolute-from-gregorian date))
 751           (yr (extract-calendar-year (calendar-hebrew-from-absolute d)))
 752           (diff (- yr h-year))
 753           (y (hebrew-calendar-yahrzeit h-date yr)))
 754      (if (and (> diff 0) (or (= y d) (= y (1+ d))))
 755          (format nil "Yahrzeit of ~A~A: ~d~A anniversary"
 756                  entry
 757                  (if (= y d) "" " (evening)")
 758                  diff
 759                  (cond ((= (% diff 10) 1) "st")
 760                        ((= (% diff 10) 2) "nd")
 761                        ((= (% diff 10) 3) "rd")
 762                        (t "th"))))))
 763  
 764  (defun diary-rosh-hodesh ()
 765    "Rosh Hodesh diary entry.
 766  Entry applies if date is Rosh Hodesh, the day before, or the Saturday before."
 767    (let* ((d (calendar-absolute-from-gregorian date))
 768           (h-date (calendar-hebrew-from-absolute d))
 769           (h-month (extract-calendar-month h-date))
 770           (h-day (extract-calendar-day h-date))
 771           (h-year (extract-calendar-year h-date))
 772           (leap-year (hebrew-calendar-leap-year-p h-year))
 773           (last-day (hebrew-calendar-last-day-of-month h-month h-year))
 774           (h-month-names
 775            (if leap-year
 776                calendar-hebrew-month-name-array-leap-year
 777              calendar-hebrew-month-name-array-common-year))
 778           (this-month (aref h-month-names (1- h-month)))
 779           (h-yesterday (extract-calendar-day
 780                         (calendar-hebrew-from-absolute (1- d)))))
 781      (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7)))
 782          (format nil
 783           "Rosh Hodesh ~A"
 784           (if (= h-day 30)
 785               (format nil
 786                "~A (first day)"
 787                ;; next month must be in the same year since this
 788                ;; month can't be the last month of the year since
 789                ;; it has 30 days
 790                (aref h-month-names h-month))
 791             (if (= h-yesterday 30)
 792                 (format nil "~A (second day)" this-month)
 793               this-month)))
 794        (if (= (% d 7) 6);; Saturday--check for Shabbos Mevarhim
 795            (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
 796                   (format nil "Mevarhim Rosh Hodesh ~A (~A)"
 797                           (aref h-month-names
 798                                 (if (= h-month
 799                                        (hebrew-calendar-last-month-of-year
 800                                         h-year))
 801                                     0 h-month))
 802                           (aref calendar-day-name-array (- 29 h-day))))
 803                  ((and (< h-day 30) (> h-day 22) (= 30 last-day))
 804                   (format nil "Mevarhim Rosh Hodesh ~A (~A-~A)"
 805                           (aref h-month-names h-month)
 806                           (if (= h-day 29)
 807                               "tomorrow"
 808                             (aref calendar-day-name-array (- 29 h-day)))
 809                           (aref calendar-day-name-array
 810                                 (% (- 30 h-day) 7)))))
 811          (if (and (= h-day 29) (/= h-month 6))
 812              (format nil "Erev Rosh Hodesh ~A"
 813                      (aref h-month-names
 814                            (if (= h-month
 815                                   (hebrew-calendar-last-month-of-year
 816                                    h-year))
 817                                0 h-month))))))))
 818  
 819  (defun diary-parasha ()
 820    "Parasha diary entry--entry applies if date is a Saturday."
 821    (let ((d (calendar-absolute-from-gregorian date)))
 822      (if (= (% d 7) 6);;  Saturday
 823          (let*
 824              ((h-year (extract-calendar-year
 825                        (calendar-hebrew-from-absolute d)))
 826               (rosh-hashannah
 827                (calendar-absolute-from-hebrew (list 7 1 h-year)))
 828               (passover
 829                (calendar-absolute-from-hebrew (list 1 15 h-year)))
 830               (rosh-hashannah-day
 831                (aref calendar-day-name-array (% rosh-hashannah 7)))
 832               (passover-day
 833                (aref calendar-day-name-array (% passover 7)))
 834               (long-h (hebrew-calendar-long-heshvan-p h-year))
 835               (short-k (hebrew-calendar-short-kislev-p h-year))
 836               (type (cond ((and long-h (not short-k)) "complete")
 837                           ((and (not long-h) short-k) "incomplete")
 838                           (t "regular")))
 839               (year-format
 840                (symbol-value
 841                 (intern (string-upcase (format nil "hebrew-calendar-year-~A-~A-~A";; keviah
 842                                 rosh-hashannah-day type passover-day)))))
 843               (first-saturday;; of Hebrew year
 844                (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah)))
 845               (saturday;; which Saturday of the Hebrew year
 846                (truncate (- d first-saturday) 7))
 847               (parasha (aref year-format saturday)))
 848            (if parasha
 849                (format nil
 850                 "~A"
 851                 (if (listp parasha);; Israel differs from diaspora
 852                     (if (car parasha)
 853                         (format nil "Shabbos Parashas ~A"
 854                                 (hebrew-calendar-parasha-name (car parasha)) )
 855                       (format nil "Yom Tov"))
 856                    (format nil "Shabbos Parashas ~A"
 857                   (hebrew-calendar-parasha-name parasha)))))))))
 858  
 859  (defun add-to-diary-list (date string)
 860    "Add the entry (DATE STRING) to `diary-entries-list'.
 861  Do nothing if DATE or STRING is nil."
 862    (and date string
 863         (setq diary-entries-list 
 864               (append diary-entries-list (list (list date string))))))
 865  
 866  (defvar hebrew-calendar-parashiot-names
 867  (vector "Bereshith"   "Noah"      "Lech L'cha" "Vayera"    "Hayei Sarah" 
 868  "Toldos"
 869   "Vayetze"     "Vayishlach" "Vayeshev"   "Mikketz"   "Vayiggash"   "Vayhi"
 870   "Shemoth"     "Vaera"     "Bo"         "Beshallah" "Yithro"      "Mishpatim"
 871   "Terumah"     "Tetzavveh" "Ki Tissa"   "Vayakhel"  "Pekudei"     "Vayikra"
 872   "Tzav"        "Shemini"   "Tazria"     "Metzora"   "Aharei Mos" "Kedoshim"
 873   "Emor"        "Behar"     "Behukkosai" "Bamidbar"  "Naso"       "Behaalot'cha"
 874   "Shelach L'cha" "Korah"    "Chukas"    "Balak"     "Pinhas"      "Mattos"
 875   "Masei"       "Devarim"   "Vaethanan"  "Ekev"      "Reeh"        "Shofetim"
 876   "Ki Tetze"    "Ki Tavo"   "Nitzavim"   "Vayelech"  "Haazinu")
 877    "The names of the parashiot in the Torah.")
 878  
 879  ;; The seven ordinary year types (keviot)
 880  
 881  (setq  hebrew-calendar-year-Saturday-incomplete-Sunday
 882    (vector 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 (vector 21 22)
 883      23 24 nil 25 (vector 26 27) (vector 28 29) 30 (vector 31 32) 33 34 35 36 37 38 39 40 (vector 41 42)
 884      43 44 45 46 47 48 49 50))
 885  ;  "The structure of the parashiot.
 886  ;Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have
 887  ;29 days), and has Passover start on Sunday.")
 888  
 889  (setq hebrew-calendar-year-Saturday-complete-Tuesday
 890    (vector 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 (vector 21 22)
 891      23 24 nil 25 (vector 26 27) (vector 28 29) 30 (vector 31 32) 33 34 35 36 37 38 39 40 (vector 41 42)
 892      43 44 45 46 47 48 49 (vector 50 51)))
 893  ;  "The structure of the parashiot.
 894  ;Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
 895  ;have 30 days), and has Passover start on Tuesday.")
 896  
 897  (setq  hebrew-calendar-year-Monday-incomplete-Tuesday
 898    (vector 51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 (vector 21 22)
 899      23 24 nil 25 (vector 26 27) (vector 28 29) 30 (vector 31 32) 33 34 35 36 37 38 39 40 (vector 41 42)
 900      43 44 45 46 47 48 49 (vector 50 51)))
 901  ;  "The structure of the parashiot.
 902  ;Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
 903  ;have 29 days), and has Passover start on Tuesday.")
 904  
 905  (setq hebrew-calendar-year-Monday-complete-Thursday
 906    (vector 51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 (vector 21 22)
 907     23 24 nil 25 (vector 26 27) (vector 28 29) 30 (vector 31 32) 33 (cons nil  34) (cons 34  35) (cons 35  36)
 908     (cons 36  37) (cons 37  38) (cons (vector 38 39) 39) 40 (vector 41 42) 43 44 45 46 47 48 49 (vector 50 51)))
 909  ;  "The structure of the parashiot.
 910  ;Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
 911  ;30 days), and has Passover start on Thursday.")
 912  
 913  (setq hebrew-calendar-year-Tuesday-regular-Thursday
 914    (vector 51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 (vector 21 22)
 915     23 24 nil 25 (vector 26 27) (vector 28 29) 30 (vector 31 32) 33 (cons nil  34) (cons 34  35) (cons 35  36)
 916     (cons 36  37) (cons 37  38) (cons (vector 38 39)  39) 40 (vector 41 42) 43 44 45 46 47 48 49 (vector 50 51)))
 917  ;  "The structure of the parashiot.
 918  ;Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
 919  ;Kislev has 30 days), and has Passover start on Thursday.")
 920  
 921  (setq hebrew-calendar-year-Thursday-regular-Saturday
 922    (vector 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 (vector 21 22) 23
 923     24 nil (cons nil  25) (cons 25  (vector 26 27)) (cons (vector 26 27)  (vector 28 29)) (cons (vector 28 29)  30)
 924     (cons 30  31) (cons (vector 31 32)  32) 33 34 35 36 37 38 39 40 (vector 41 42) 43 44 45 46 47 48
 925     49 50))
 926  ;  "The structure of the parashiot.
 927  ;Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and
 928  ;Kislev has 30 days), and has Passover start on Saturday.")
 929  
 930  (setq hebrew-calendar-year-Thursday-complete-Sunday
 931    (vector 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
 932      23 24 nil 25 (vector 26 27) (vector 28 29) 30 (vector 31 32) 33 34 35 36 37 38 39 40 (vector 41 42)
 933      43 44 45 46 47 48 49 50))
 934  ;  "The structure of the parashiot.
 935  ;Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each
 936  ;have 30 days), and has Passover start on Sunday.")
 937  
 938  ;; The seven leap year types (keviot)
 939  
 940  (setq hebrew-calendar-year-Saturday-incomplete-Tuesday
 941    (vector 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
 942      23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 (vector 41 42)
 943      43 44 45 46 47 48 49 (vector 50 51)))
 944  ;  "The structure of the parashiot.
 945  ;Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each
 946  ;have 29 days), and has Passover start on Tuesday.")
 947  
 948  (setq hebrew-calendar-year-Saturday-complete-Thursday
 949    (vector 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
 950     23 24 25 26 27 nil 28 29 30 31 32 33 (cons nil  34) (cons 34  35) (cons 35  36)
 951     (cons 36  37) (cons 37  38) (cons (vector 38  39)  39) 40 (vector 41 42) 43 44 45 46 47 48 49 (vector 50 51)))
 952  ;  "The structure of the parashiot
 953  ; Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
 954  ; have 30 days), and has Passover start on Thursday.")
 955  
 956  (setq hebrew-calendar-year-Monday-incomplete-Thursday
 957    (vector 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
 958     23 24 25 26 27 nil 28 29 30 31 32 33 (cons nil  34) (cons 34  35) (cons 35  36)
 959     (cons 36  37) (cons 37  38) (cons (vector 38 39)  39) 40 (vector 41 42) 43 44 45 46 47 48 49 (vector 50 51)))
 960  ;  "The structure of the parashiot.
 961  ;Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
 962  ;have 29 days), and has Passover start on Thursday.")
 963  
 964  (setq hebrew-calendar-year-Monday-complete-Saturday
 965    (vector 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
 966     23 24 25 26 27 nil (cons nil  28) (cons 28  29) (cons 29  30) (cons 30  31) (cons 31  32)
 967     (cons 32  33) (cons 33  34) (cons 34  35) (cons 35  36) (cons 36  37) (cons 37  38) (cons 38  39)
 968     (cons 39  40) (cons 40  41) (cons (vector 41 42)  42) 43 44 45 46 47 48 49 50))
 969  
 970  ;  "The structure of the parashiot.
 971  ; Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
 972  ; 30 days), and has Passover start on Saturday.")
 973  
 974  (setq hebrew-calendar-year-Tuesday-regular-Saturday
 975    (vector 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
 976     23 24 25 26 27 nil (cons nil  28) (cons 28  29) (cons 29  30) (cons 30  31) (cons 31  32)
 977     (cons 32  33) (cons 33  34) (cons 34  35) (cons 35  36) (cons 36  37) (cons 37  38) (cons 38  39)
 978     (cons 39  40) (cons 40  41) (cons (vector 41 42)  42) 43 44 45 46 47 48 49 50))
 979  ;  "The structure of the parashiot.
 980  ; Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
 981  ; Kislev has 30 days), and has Passover start on Saturday.")
 982  
 983  (setq hebrew-calendar-year-Thursday-incomplete-Sunday
 984    (vector 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
 985      23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
 986      43 44 45 46 47 48 49 50))
 987  ;  "The structure of the parashiot.
 988  ;Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both
 989  ;have 29 days), and has Passover start on Sunday.")
 990  
 991  (setq hebrew-calendar-year-Thursday-complete-Tuesday
 992    (vector 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
 993      23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
 994      43 44 45 46 47 48 49 (vector 50 51)))
 995  ;  "The structure of the parashiot.
 996  ; Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
 997  ; have 30 days), and has Passover start on Tuesday.")
 998  
 999  (defun hebrew-calendar-parasha-name (p)
1000    "Name(s) corresponding to parasha P."
1001    (if (arrayp p);; combined parasha
1002        (format nil "~A/~A"
1003                (aref hebrew-calendar-parashiot-names (aref p 0))
1004                (aref hebrew-calendar-parashiot-names (aref p 1)))
1005      (aref hebrew-calendar-parashiot-names p)))
1006  
1007  
1008  
1009  
1010  (defun hebrew-calendar-yahrzeit (death-date year)
1011    "Absolute date of the anniversary of Hebrew DEATH-DATE in Hebrew YEAR."
1012    (let* ((death-day (extract-calendar-day death-date))
1013           (death-month (extract-calendar-month death-date))
1014           (death-year (extract-calendar-year death-date)))
1015      (cond
1016       ;; If it's Heshvan 30 it depends on the first anniversary; if
1017       ;; that was not Heshvan 30, use the day before Kislev 1.
1018       ((and (= death-month 8)
1019             (= death-day 30)
1020             (not (hebrew-calendar-long-heshvan-p (1+ death-year))))
1021        (1- (calendar-absolute-from-hebrew (list 9 1 year))))
1022       ;; If it's Kislev 30 it depends on the first anniversary; if
1023       ;; that was not Kislev 30, use the day before Teveth 1.
1024       ((and (= death-month 9)
1025             (= death-day 30)
1026             (hebrew-calendar-short-kislev-p (1+ death-year)))
1027        (1- (calendar-absolute-from-hebrew (list 10 1 year))))
1028       ;; If it's Adar II, use the same day in last month of
1029       ;; year (Adar or Adar II).
1030       ((= death-month 13)
1031        (calendar-absolute-from-hebrew
1032         (list (hebrew-calendar-last-month-of-year year) death-day year)))
1033       ;; If it's the 30th in Adar I and year is not a leap year
1034       ;; (so Adar has only 29 days), use the last day in Shevat.
1035       ((and (= death-day 30)
1036             (= death-month 12)
1037             (not (hebrew-calendar-leap-year-p year)))
1038        (calendar-absolute-from-hebrew (list 11 30 year)))
1039       ;; In all other cases, use the normal anniversary of the date of death.
1040       (t (calendar-absolute-from-hebrew
1041           (list death-month death-day year))))))
1042  
1043  (defun calendar-make-alist (sequence &optional start-index filter)
1044    "Make an assoc list corresponding to SEQUENCE.
1045  Start at index 1, unless optional START-INDEX is provided.
1046  If FILTER is provided, apply it to each item in the list."
1047    (let ((index (if start-index (1- start-index) 0)))
1048      (mapcar
1049       '(lambda (x)
1050          (setq index (1+ index))
1051          (cons (if filter (funcall filter x) x)
1052                index))
1053       (append sequence nil))))
1054  
1055  (defun list-yahrzeit-dates (death-date start-year)
1056    "List Yahrzeit dates for *Gregorian* DEATH-DATE from START-YEAR to END-YEAR.
1057  When called interactively from the calendar window, the date of death is taken
1058  from the cursor position."
1059    
1060    ;(format t "~A~%" "Computing yahrzeits...")
1061    (let* ((h-date (calendar-hebrew-from-absolute
1062                    (calendar-absolute-from-gregorian death-date)))
1063           (h-month (extract-calendar-month h-date))
1064           (h-day (extract-calendar-day h-date))
1065           (h-year (extract-calendar-year h-date))
1066       
1067      )
1068  
1069     
1070      (do ((p-date nil)
1071       (y-date-abs nil)
1072       (i start-year (1+ i)))
1073      ((> i start-year ))
1074  ;      (format t "~% i: ~D start-year: ~D end-year: ~D~%" i start-year end-year)
1075        (setq p-date (calendar-date-string
1076              (calendar-gregorian-from-absolute
1077               (setq y-date-abs (hebrew-calendar-yahrzeit
1078                         h-date
1079                         (extract-calendar-year
1080                      (calendar-hebrew-from-absolute
1081                       (calendar-absolute-from-gregorian (list 1 1 i)))))))))
1082        (format t "~A  which is observed until sunset on ~A~%"
1083            (calendar-hebrew-date-string
1084             (calendar-gregorian-from-absolute y-date-abs)) p-date))))
1085  
1086  
1087  
1088  
1089  
1090  
1091  ;(trace (calendar-date-string :step-if t))
1092  ;(trace calendar-absolute-from-hebrew)
1093  ;(setq dd (list 1 9 5735))
1094  ;(setq dyr 5760)
1095  ;(hebrew-calendar-yahrzeit dd dyr)
1096  ;(setq month 1)
1097  ;(setq day 1)
1098  ;(setq year 1990)
1099  ;(list-yahrzeit-dates (list 10 17 1974) 1995 2000) 
1100  ;(calendar-gregorian-from-absolute 720913)
1101  
1102  ;(defun test-do (a b)
1103  ;  (do (( i a (1+ i)))
1104  ;      ((>= i b) nil)
1105  ;    (print i)))
1106         
1107  (load 'solar.cl)
1108  (load 'lunar.cl)
1109  (load 'cal-dst.cl)
1110  
1111  ;(trace (solar-adj-time-for-dst :step-if t))
1112  ;(trace (solar-sunset :step-if t))
1113  ;(trace (solar-sunrise-sunset :step-if t))
1114  ;(trace (diary-sabbath-candles :step-if t))