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