home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / progs / hebcalen.icn < prev    next >
Text File  |  2000-07-29  |  18KB  |  616 lines
  1. ############################################################################
  2. #
  3. #    File:     hebcalen.icn
  4. #
  5. #    Subject:  Program for combination Jewish/Civil calendar
  6. #
  7. #    Author:   Alan D. Corre
  8. #
  9. #    Date:     January 3, 1993
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #  This work is respectfully devoted to the authors of two books
  18. #  consulted with much profit: "A Guide to the Solar-Lunar Calendar"
  19. #  by B. Elihu Rothblatt published by our sister Hebrew Dept. in
  20. #  Madison, Wis., and "Kiddush HaHodesh" by Rabbenu Moses ben Maimon,
  21. #  on whom be peace.
  22. #
  23. #  The Jewish year harmonizes the solar and lunar cycle, using the
  24. #  19-year cycle of Meton (c. 432 BCE). It corrects so that certain
  25. #  dates shall not fall on certain days for religious convenience. The
  26. #  Jewish year has six possible lengths, 353, 354, 355, 383, 384, and
  27. #  385 days, according to day and time of new year lunation and
  28. #  position in Metonic cycle.  Time figures from 6pm previous night.
  29. #  The lunation of year 1 is calculated to be on a Monday (our Sunday
  30. #  night) at ll:11:20pm. Our data table begins with a hypothetical
  31. #  year 0, corresponding to 3762 B.C.E.  Calculations in this program
  32. #  are figured in the ancient Babylonian unit of halaqim "parts" of
  33. #  the hour = 1/1080 hour.
  34. #
  35. #  Startup syntax is simply hebcalen [date], where date is a year
  36. #  specification of the form 5750 for a Jewish year, +1990 or 1990AD
  37. #  or 1990CE or -1990 or 1990BC or 1990BCE for a civil year.
  38. #
  39. ############################################################################
  40. #
  41. #  Revised October 25, 1993 by Ralph E. Griswold to use dopen() to
  42. #  find data files.
  43. #
  44. ############################################################################
  45. #
  46. #  Links: io
  47. #
  48. ############################################################################
  49. #
  50. #  Requires: keyboard functions, hebcalen.dat, hebcalen.hlp
  51. #
  52. ############################################################################
  53. #
  54. #  See also: hcal4unx.icn
  55. #
  56. ############################################################################
  57.  
  58. link io
  59.  
  60. record date(yr,mth,day)
  61. record molad(day,halaqim)
  62. global cyr,jyr,days_in_jyr,current_molad,current_day,infolist
  63.  
  64. procedure main(cmd)
  65.   local n, p
  66.  
  67.   clear()
  68.   banner("PERPETUAL JEWISH/CIVIL CALENDAR","","by","","ALAN D. CORRE")
  69.   if *cmd = 0 then {
  70. #putting an asterisk indicates that user might need help
  71.     n := 1; put(cmd,"*")} else
  72.     n := *cmd
  73.     every p := 1 to n do {
  74.   initialize(cmd[p])
  75.   process()}
  76. end
  77.  
  78. procedure banner(l[])
  79. #Creates a banner to begin programs. If you don't have the extended ASCII
  80. #character set, replace each char(n) with some character that you have
  81. #such as " " or "-"
  82. #Does not work well if your screen has variable spacing.
  83. local n
  84.   write();write();write()
  85.   writes(char(201)) #top left right angle
  86.   writes(repl(char(205),78)) #straight line
  87.   writes(char(187)) #top right right angle
  88.   writes(char(186)) #upright line at left
  89.   writes(right(char(186),79)) #upright line at right
  90.   every n := 1 to *l do {
  91.     writes(char(186)) #upright line at left
  92.     writes(center(l[n],78),char(186)) #string centered followed by upright line
  93.     writes(char(186)) #upright line at left
  94.     writes(right(char(186),79)) #upright line at right
  95. }
  96.   writes(char(200)) #bottom left right angle
  97.   writes(repl(char(205),78)) #straight line
  98.   write(char(188)) #bottom right right angle
  99.   write()
  100. return
  101. end
  102.  
  103. procedure instructions(filename)
  104. #Gives user access to a help file which is printed out in chunks.
  105. local filvar,counter,line
  106.   writes("Do you need instructions? y/n ")
  107.   if upto('yY',read()) then {
  108. #The following if-statement fails if the file is not available
  109.   counter := 0
  110.   if filvar := dopen(filename) then
  111. #Read the help file. 
  112.     while line := read(filvar) do {
  113. #Write out a line and increment the counter
  114.       write(line)
  115.       counter +:= 1
  116. #Now we have a screenful; ask if we should continue
  117.       if counter >22 then {
  118.         write()
  119.         writes ("More? y/n ")
  120. #User has had enough; break out of loop
  121.         if upto('nN',read()) then break  else
  122. #User wants more; reset counter and continue
  123.           counter := 0}} else
  124. #This else goes with the second if-statement; the attempt to open the
  125. #help file failed:
  126.       write("Sorry, instructions not available.")}
  127.     write ("Press return to continue.")
  128.     read()
  129. #Close the file if it existed and was opened. If it was never opened
  130. #the value of filvar will be null. This check has to be made because
  131. #an attempt to use close() on a variable NOT valued at a file would
  132. #cause an error. 
  133. /filvar | close(filvar)
  134. end
  135.  
  136. procedure clear()
  137. #clears the screen. If you don't have ANSI omit the next line
  138.   writes("\e[2J")
  139. end
  140.  
  141. procedure initialize_list()
  142. #while user views banner, put info of hebcalen.dat into a global list
  143. local infile,n
  144.   infolist := list(301)
  145.   if not (infile := dopen("hebcalen.dat")) then
  146.     stop("This program must have the file hebcalend.dat line in order to _
  147.           function properly.")    
  148. #the table is arranged arbitrarily at twenty year intervals with 301 entries.
  149.   every n := 1 to 301 do
  150.     infolist[n] := read(infile)
  151.   close(infile)
  152. end
  153.  
  154. procedure initialize_variables()
  155. #get the closest previous year in the table
  156. local line,quotient
  157.   quotient := jyr.yr / 20 + 1
  158. #only 301 entries. Figure from last if necessary.
  159.   if quotient > 301 then quotient := 301
  160. #pull the appropriate info, put into global variables
  161.   line := infolist[quotient]
  162.   line ? { current_molad.day := tab(upto('%'))
  163.          move(1)
  164.      current_molad.halaqim := tab(upto('%'))
  165.      move(1)
  166.      cyr.mth := tab(upto('%'))
  167.      move(1)
  168.      cyr.day := tab(upto('%'))
  169.      move(1)
  170.      cyr.yr := tab(upto('%'))
  171.      days_in_jyr := line[-3:0]
  172.      }
  173. #begin at rosh hashana
  174.   jyr.day := 1
  175.   jyr.mth := 7
  176. return
  177. end
  178.  
  179. procedure initialize(yr)
  180. local year
  181. #initialize global variables
  182. initial {  cyr := date(0,0,0)
  183.   jyr := date(0,0,0)
  184.   current_molad := molad(0,0)
  185.   initialize_list()}
  186.   clear()
  187. #user may need help
  188.   if yr == "*" then {
  189.   instructions("hebcalen.hlp")
  190.   clear()
  191.   writes("Please enter the year. If you are entering a CIVIL year, precede _
  192.          by + for \ncurrent era, - (the minus sign) for before current era. ")
  193.   year := read()} else
  194.   year := yr
  195.   while not (jyr.yr := cleanup(year)) do {
  196.     writes("I do not understand ",year,". Please try again ")
  197.     year := read()}
  198.   clear()
  199.   initialize_variables()
  200. return
  201. end
  202.  
  203. procedure cleanup(str)
  204. #tidy up the string. Bugs still possible.
  205.   if (not upto('.+-',str)) & integer(str) & (str > 0) then return str
  206.   if upto('-bB',str) then return (0 < (3761 - checkstr(str)))
  207.   if upto('+cCaA',str) then return (checkstr(str) + 3760)
  208. fail
  209. end
  210.  
  211. procedure checkstr(s)
  212. #does preliminary work on string before cleanup() cleans it up
  213. local letter,n,newstr
  214.   newstr := ""
  215.   every n := 1 to *s do
  216.     if integer(s[n]) then
  217.       newstr ||:= s[n]
  218.   if (*newstr = 0) | (newstr = 0) then fail
  219. return newstr
  220. end
  221.  
  222. procedure process()
  223.   local ans, yj, n
  224.  
  225. #gets out the information
  226. local limit,dj,dc
  227. #this contains a correction
  228. #6039 is last year handled by the table in the usual way
  229. #The previous line should read 6019. Code has been corrected to erase
  230. #this mistake. 
  231.   if jyr.yr <= 6019 then {
  232.     limit := jyr.yr % 20 
  233.     jyr.yr := ((jyr.yr / 20) * 20)} else {
  234. #otherwise figure from 6020 and good luck
  235. #This has been corrected to 6000
  236.     limit := jyr.yr - 6000
  237.     jyr.yr := 6000}
  238.   ans := "y"
  239.   establish_jyr()
  240.   every 1 to limit do {
  241. #tell user something is going on
  242.     writes(" .")
  243. #increment the years, establish the type of Jewish year
  244.     cyr_augment()
  245.     jyr_augment()
  246.     establish_jyr()}
  247.   clear() 
  248.   while upto('Yy',ans) do {
  249.   yj := jyr.yr
  250.   dj := days_in_jyr
  251.   every n := 1 to 4 do {
  252.     clear()
  253.     every 1 to 3 do
  254.       write_a_month()
  255.     write("Press the space bar to continue")
  256.     write()
  257.     writes(status_line(yj,dj))
  258. #be sure that your version of Icon recognises the function getch()
  259.     getch()}
  260.     if jyr.mth = 6 then {
  261.       clear()
  262.       write_a_month()
  263.       every 1 to 15 do write()
  264.       write(status_line(yj,dj))}
  265.     write()
  266.     writes("Do you wish to continue? Enter y<es> or n<o>. ")
  267. #be sure that your version of Icon recognises the function getch()
  268.     ans := getch()}
  269. return
  270. end
  271.  
  272. procedure cyr_augment()
  273. #Make civil year a year later, we only need consider Aug,Sep,Oct.
  274. local days,newmonth,newday
  275.  if cyr.mth = 8 then
  276.    days := 0 else
  277.  if cyr.mth = 9 then
  278.    days := 31 else
  279.  if cyr.mth = 10 then
  280.    days := 61 else
  281.  stop("Error in cyr_augment")
  282.   writes(" .")
  283.   days := (days + cyr.day-365+days_in_jyr)
  284.   if isleap(cyr.yr + 1) then days -:= 1
  285. #cos it takes longer to get there
  286.   if days <= 31 then {newmonth := 8; newday := days} else
  287.   if days <= 61 then {newmonth := 9; newday := days-31} else
  288.   {newmonth := 10; newday := days-61} 
  289.   cyr.mth := newmonth
  290.   cyr.day := newday
  291.   cyr.yr +:= 1
  292.   if cyr.yr = 0 then cyr.yr := 1
  293. return
  294. end
  295.  
  296.  
  297. procedure header()
  298. #creates the header for Jewish and English side. If ANSI not available,
  299. #substitute "S" for "\e[7mS\e[0m" each time.
  300.   write(repl(" ",7),"S",repl(" ",2),"M",repl(" ",2),"T",repl(" ",2),"W",
  301.         repl(" ",2),"T",repl(" ",2),"F",repl(" ",2),"\e[7mS\e[0m",repl(" ",27),
  302.         "S",repl(" ",2),"M",repl(" ",2),"T",repl(" ",2),"W",
  303.         repl(" ",2),"T",repl(" ",2),"F",repl(" ",2),"\e[7mS\e[0m")
  304. end
  305.  
  306. procedure write_a_month()
  307. #writes a month on the screen
  308.   header()
  309.   every 1 to 5 do 
  310.     write(make_a_line())
  311.   if jyr.day ~= 1 then
  312.     write(make_a_line())
  313.   write()
  314. return
  315. end
  316.  
  317. procedure status_line(a,b)
  318. #create the status line at the bottom of screen
  319. local sline,c,d
  320.   c := cyr.yr
  321.   if (cyr.day = 1) & (cyr.mth = 1) then c -:= 1
  322.   d := 365
  323.   if isleap(c) then d := 366
  324. #if ANSI not available omit "\e[7m" and "|| "\e[0m""
  325.   sline := ("\e[7mYear of Creation: " || a || "  Days in year: " || b ||
  326.     "  Civil year: " || c || "  Days in year: " || d || "\e[0m")
  327. return sline
  328. end
  329.  
  330. procedure make_a_line()
  331. #make a single line of the months
  332. local line,blanks1,blanks2,start_point,end_point,flag,fm
  333.  
  334. #consider the first line of the month
  335.   if jyr.day = 1 then {
  336.     line := mth_table(jyr.mth,1)
  337. #setting flag means insert civil month at end of line    
  338.     flag := 1 } else
  339.     line := repl(" ",3)
  340. #consider the case where first day of civil month is on Sunday    
  341.   if (cyr.day = 1) & (current_day = 1) then flag := 1
  342. #space between month name and beginning of calendar
  343.   line ||:= repl(" ",2)
  344. #measure indentation for first line
  345.   line ||:= blanks1 := repl(" ",3*(current_day-1))
  346. #establish start point for Hebrew loop
  347.   start_point := current_day
  348. #establish end point for Hebrew loop and run civil loop
  349.   every end_point := start_point to 7 do {
  350.     line ||:= right(jyr.day,3)
  351.     if not j_augment() then {jyr_augment(); establish_jyr(); current_day -:= 1; if current_day = 0 then current_day := 7}
  352.     d_augment()
  353.     if jyr.day = 1 then break }
  354. #measure indentation for last line
  355.   blanks2 := repl(" ",3*(7-end_point))
  356.   line ||:= blanks2; line ||:= repl(" ",25); line ||:= blanks1
  357.   every start_point to end_point do {
  358.     line ||:= right(cyr.day,3)
  359.     if (cyr.day = 1) then flag := 1 
  360.     augment()}
  361.   line ||:= blanks2 ||:= repl(" ",3)
  362.   fm := cyr.mth
  363.   if cyr.day = 1 then
  364.     if cyr.mth = 1 then fm := 12 else fm := cyr.mth - 1
  365.   if \flag then line ||:= mth_table(fm,2) else
  366.     line ||:= repl(" ",3)
  367. return line
  368. end
  369.  
  370. procedure mth_table(n,p)
  371. #generates the short names of Jewish and Civil months. Get to civil side
  372. #by adding 13 (=max no of Jewish months)
  373. static corresp
  374. initial corresp := ["NIS","IYA","SIV","TAM","AV ","ELU","TIS","HES","KIS",
  375. "TEV","SHE","ADA","AD2","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP",
  376. "OCT","NOV","DEC"]
  377.   if (p ~= 1) & (p ~= 2) then stop("ERROR IN MTH-TABLE") else
  378.     if p = 2 then n +:= 13
  379. return corresp[n]
  380. end
  381.  
  382. procedure d_augment()
  383. #increment the day of the week
  384.   current_day +:= 1
  385.   if current_day = 8 then current_day := 1
  386. return
  387. end
  388.  
  389. procedure augment()
  390. #increments civil day, modifies month and year if necessary, stores in
  391. #global variable cyr
  392.   if cyr.day < 28 then
  393.     cyr.day +:= 1 else
  394.   if cyr.day = 28 then {
  395.     if (cyr.mth ~= 2) | ((cyr.mth = 2) & isleap(cyr.yr)) then
  396.       cyr.day := 29 else {
  397.         cyr.mth := 3
  398.     cyr.day  := 1}} else
  399.   if cyr.day = 29 then {
  400.     if cyr.mth ~= 2 then
  401.       cyr.day := 30 else {
  402.       cyr.mth := 3
  403.       cyr.day := 1}} else
  404.   if cyr.day = 30 then {
  405.     if is_31(cyr.mth) then
  406.       cyr.day := 31 else {
  407.       cyr.mth +:= 1
  408.       cyr.day := 1}} else {
  409.       cyr.day := 1
  410.       if cyr.mth ~= 12 then
  411.         cyr.mth +:= 1 else {
  412.         cyr.mth := 1
  413.         cyr.yr +:= 1
  414.         if cyr.yr = 0
  415.       then cyr.yr := 1}}
  416. return
  417. end
  418.  
  419. procedure is_31(n)
  420. #civil months with 31 days
  421. return n = 1 | n = 3 | n = 5 | n = 7 | n = 8 | n = 10 | n = 12
  422. end
  423.  
  424. procedure isleap(n)
  425. #checks for civil leap year
  426.   if n > 0 then
  427. return (n % 400 = 0) | ((n % 4 = 0) & (n % 100 ~= 0)) else
  428. return (n % 400 = -1) | ((n % 4 = -1) & (n % 100 ~= -1))
  429. end
  430.  
  431. procedure j_augment()
  432. #increments jewish day. months are numbered from nisan, adar sheni is 13.
  433. #procedure fails at elul to allow determination of type of new year
  434.   if jyr.day < 29 then
  435.     jyr.day +:= 1 else
  436.   if (jyr.day = 30) | always_29(jyr.mth) | ((jyr.mth = 8) & 
  437.     (days_in_jyr % 5 ~= 0)) | ((jyr.mth = 9) & ((days_in_jyr = 353) |
  438.     (days_in_jyr = 383))) then
  439.     jyr.mth +:= jyr.day := 1 else
  440.   if jyr.mth = 6 then fail else
  441.   if ((jyr.mth = 12) & (days_in_jyr < 383)) | (jyr.mth = 13) then
  442.     jyr.mth := jyr.day := 1 else
  443.   jyr.day := 30
  444. return
  445. end
  446.  
  447. procedure always_29(n)
  448. #uncomplicated jewish months with 29 days
  449. return n = 2 | n = 4 | n = 10
  450. end
  451.  
  452. procedure jyr_augment()
  453. #determines the current time of lunation, using the ancient babylonian unit
  454. #of 1/1080 of an hour. lunation of tishri determines type of year. allows
  455. #for leap year. halaqim = parts of the hour
  456. local days, halaqim
  457.   days := current_molad.day + 4
  458.   if days_in_jyr <= 355 then {
  459.     halaqim :=  current_molad.halaqim + 9516
  460.     days := ((days +:= halaqim / 25920) % 7)
  461.     if days = 0 then days := 7
  462.     halaqim := halaqim % 25920} else {
  463.     days +:= 1
  464.     halaqim := current_molad.halaqim + 23269
  465.     days := ((days +:= halaqim / 25920) % 7)
  466.     if days = 0 then days := 7
  467.     halaqim := halaqim % 25920}
  468.   current_molad.day := days
  469.   current_molad.halaqim := halaqim
  470. #reset the global variable which holds the current jewish date
  471.   jyr.yr +:= 1 #increment year
  472.   jyr.day := 1
  473.   jyr.mth := 7
  474.   establish_jyr()
  475. return
  476. end
  477.  
  478. procedure establish_jyr()
  479. #establish the jewish year from get_rh
  480. local res
  481.   res := get_rh(current_molad.day,current_molad.halaqim,no_lunar_yr(jyr.yr))
  482.   days_in_jyr := res[2]
  483.   current_day := res[1]
  484. return
  485. end    
  486.  
  487. procedure isin1(i)
  488. #the isin procedures are sets of years in the Metonic cycle
  489. return i = (1 | 4 | 7 | 9 | 12 | 15 | 18)
  490. end
  491.  
  492. procedure isin2(i)
  493. return i = (2 | 5 | 10 | 13 | 16)
  494. end
  495.  
  496. procedure isin3(i)
  497. return i = (3 | 6 | 8 | 11 | 14 | 17 | 0)
  498. end
  499.  
  500. procedure isin4(i)
  501. return i = (1 | 2 | 4 | 5 | 7 | 9 | 10 | 12 | 13 | 15 | 16 | 18)
  502. end
  503.  
  504. procedure isin5(i)
  505. return i = (1 | 4 | 9 | 12 | 15)
  506. end
  507.  
  508. procedure isin6(i)
  509. return i = (2 | 5 | 7 | 10 | 13 | 16 | 18)
  510. end
  511.  
  512. procedure no_lunar_yr(i)
  513. #what year in the metonic cycle is it?
  514. return i % 19
  515. end
  516.  
  517. procedure get_rh(d,h,yr)
  518. #this is the heart of the program. check the day of lunation of tishri
  519. #and determine where breakpoint is that sets the new moon day in parts
  520. #of the hour. return result in a list where 1 is day of rosh hashana and
  521. #2 is length of jewish year
  522. local c,result
  523.   c := no_lunar_yr(yr)
  524.   result := list(2)
  525.   if d = 1 then {
  526.           result[1] := 2
  527.                 if (h < 9924) & isin4(c) then result[2] := 353 else
  528.         if (h < 22091) & isin3(c) then result[2] := 383 else
  529.         if (h > 9923) & (isin1(c) | isin2(c)) then result[2] := 355 else
  530.         if (h > 22090) & isin3(c) then result[2] := 385
  531.         } else
  532.   if d = 2 then {
  533.           if ((h < 16789) & isin1(c)) |
  534.            ((h < 19440) & isin2(c)) then {
  535.                                  result[1] := 2
  536.                              result[2] := 355
  537.                              } else
  538.         if (h < 19440) & isin3(c) then  {
  539.                                  result[1] := 2
  540.                              result[2] := 385
  541.                              } else
  542.           if ((h > 16788) & isin1(c)) |
  543.            ((h > 19439) & isin2(c)) then {
  544.                                  result[1] := 3
  545.                              result[2] := 354
  546.                              } else
  547.                 if (h > 19439) & isin3(c) then  {
  548.                                  result[1] := 3
  549.                              result[2] := 384
  550.                              }
  551.         } else
  552.   if d = 3 then {
  553.           if (h < 9924) & (isin1(c) | isin2(c)) then {
  554.                                result[1] := 3
  555.                                result[2] := 354
  556.                                } else
  557.         if (h < 19440) & isin3(c) then {
  558.                            result[1] := 3
  559.                            result[2] := 384
  560.                            } else
  561.         if (h > 9923) & isin4(c) then {
  562.                           result[1] := 5
  563.                           result[2] := 354
  564.                           } else
  565.         if (h > 19439) & isin3(c) then {
  566.                            result[1] := 5
  567.                            result[2] := 383}
  568.         } else
  569.   if d = 4 then {
  570.           result[1] := 5
  571.         if isin4(c) then result[2] := 354 else
  572.         if h < 12575 then result[2] := 383 else
  573.         result[2] := 385
  574.         } else
  575.   if d = 5 then {
  576.                 if (h < 9924) & isin4(c) then {
  577.                           result[1] := 5
  578.                           result[2] := 354} else
  579.         if (h < 19440) & isin3(c) then {
  580.                            result[1] := 5
  581.                            result[2] := 385
  582.                            } else
  583.         if (9923 < h < 19440) & isin4(c) then {
  584.                               result[1] := 5
  585.                               result[2] := 355
  586.                               } else
  587.         if h > 19439 then {
  588.                     result[1] := 7
  589.                           if isin3(c) then result[2] := 383 else
  590.                             result[2] := 353
  591.                   }
  592.         } else
  593.   if d = 6 then {
  594.             result[1] := 7
  595.             if ((h < 408) & isin5(c)) | ((h < 9924) & isin6(c)) then
  596.                               result[2] := 353 else
  597.             if ((h < 22091) & isin3(c)) then result[2] := 383 else
  598.             if ((h > 407) & isin5(c)) | ((h > 9923) & isin6(c)) then
  599.                               result[2] := 355 else
  600.             if (h > 22090) & isin3(c) then result[2] := 385
  601.             } else
  602.   if d = 7 then    if (h < 19440) & (isin5(c) | isin6(c)) then {
  603.                               result[1] := 7
  604.                               result[2] := 355
  605.                               } else
  606.         if (h < 19440) & isin3(c) then {
  607.                            result[1] := 7
  608.                            result[2] := 385
  609.                            } else {
  610.                                   result[1] := 2
  611.                               if isin4(c) then
  612.                                 result[2] := 353 else
  613.                             result[2] := 383}
  614. return result
  615. end
  616.