home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / OL.LZH / PROGS.LZH / HCAL4UNX.ICN < prev    next >
Text File  |  1991-07-13  |  24KB  |  948 lines
  1. ##########################################################################
  2. #
  3. #    Name:    hcal4unx.icn
  4. #
  5. #    Title:   Combination Jewish/Civil calendar
  6. #
  7. #    Author:  Alan D. Corre (ported to Unix by Richard L. Goerwitz)
  8. #
  9. #    Date:     June 4, 1991
  10. #
  11. #    Version: 1.16
  12. #
  13. ##########################################################################
  14. #
  15. #  This work is respectfully devoted to the authors of two books
  16. #  consulted with much profit: "A Guide to the Solar-Lunar Calendar"
  17. #  by B. Elihu Rothblatt published by our sister Hebrew Dept. in
  18. #  Madison, Wis., and "Kiddush HaHodesh" by Rabbenu Moses ben Maimon,
  19. #  on whom be peace.
  20. #
  21. #  The Jewish year harmonizes the solar and lunar cycle, using the
  22. #  19-year cycle of Meton (c. 432 BCE). It corrects so that certain
  23. #  dates shall not fall on certain days for religious convenience. The
  24. #  Jewish year has six possible lengths, 353, 354, 355, 383, 384, and
  25. #  385 days, according to day and time of new year lunation and
  26. #  position in Metonic cycle.  Time figures from 6pm previous night.
  27. #  The lunation of year 1 is calculated to be on a Monday (our Sunday
  28. #  night) at ll:11:20pm. Our data table begins with a hypothetical
  29. #  year 0, corresponding to 3762 B.C.E.  Calculations in this program
  30. #  are figured in the ancient Babylonian unit of halaqim "parts" of
  31. #  the hour = 1/1080 hour.
  32. #
  33. #  Startup syntax is simply hebcalen [date], where date is a year
  34. #  specification of the form 5750 for a Jewish year, +1990 or 1990AD
  35. #  or 1990CE or -1990 or 1990BC or 1990BCE for a civil year.
  36. #
  37. ##########################################################################
  38. #
  39. #  Links: iolib
  40. #
  41. ##########################################################################
  42. #
  43. #  Requires: UNIX, hebcalen.dat, hebcalen.hlp
  44. #
  45. ##########################################################################
  46. #
  47. #  See also: hebcalen.icn
  48. #
  49. ##########################################################################
  50.  
  51. link iolib
  52.  
  53. record date(yr,mth,day)
  54. record molad(day,halaqim)
  55.  
  56. global cyr,jyr,days_in_jyr,current_molad,current_day,infolist
  57.  
  58.  
  59. #------- the following sections of code have been modified  - RLG -------#
  60.  
  61. procedure main(a)
  62.     local n, p
  63.  
  64.     iputs(getval("ti"))
  65.     display_startup_screen()
  66.  
  67.     if *a = 0 then {
  68.     #put()'ing an asterisk means that user might need help
  69.     n := 1; put(a,"*")
  70.     }
  71.     else n := *a
  72.     every p := 1 to n do {
  73.     initialize(a[p]) | break
  74.     process() | break
  75.     }
  76.     iputs(getval("te"))
  77.  
  78. end
  79.  
  80.  
  81.  
  82. procedure display_startup_screen()
  83.  
  84.     local T
  85.  
  86.     clear()
  87.     banner("PERPETUAL JEWISH/CIVIL CALENDAR","by","ALAN D. CORRE")
  88.     # Use a combination of tricks to be sure it will be up there a sec.
  89.     every 1 to 10000
  90.     T := &time; until &time > (T+450)
  91.  
  92.     return
  93.  
  94. end
  95.  
  96.  
  97.  
  98. procedure banner(l[])
  99.  
  100.     # Creates a banner to begin hebcalen.  Leaves it on the screen for
  101.     # about a second.
  102.  
  103.     local m, n, CM, COLS, LINES
  104.  
  105.     CM    := getval("cm")
  106.     COLS  := getval("co")
  107.     LINES := getval("li")
  108.     (COLS > 55, LINES > 9) |
  109.     stop("\nSorry, your terminal just isn't big enough.")
  110.  
  111.     if LINES > 20 then {
  112.     # Terminal is big enough for banner.
  113.     iputs(igoto(CM,1,3))
  114.     writes("+",repl("-",COLS-3),"+")
  115.     iputs(igoto(CM,1,4))
  116.     writes("|")
  117.     iputs(igoto(CM,COLS-1,4))
  118.     writes("|")
  119.  
  120.     m := 0
  121.     every n := 5 to (*l * 3) + 4 by 3 do {
  122.         iputs(igoto(CM,1,n))
  123.         writes("|",center(l[m+:=1],COLS-3),"|")
  124.         every iputs(igoto(CM,1,n+(1|2))) & writes("|")
  125.         every iputs(igoto(CM,COLS-1,n+(1|2))) & writes("|")
  126.     }
  127.     
  128.     iputs(igoto(CM,1,n+3))
  129.     writes("+",repl("-",COLS-3),"+")
  130.     iputs(igoto(CM,1,n+4))
  131.     write(" Copyright (c) Alan D. Corre, 1990")
  132.     }
  133.     else {
  134.     # Terminal is extremely short
  135.     iputs(igoto(CM,1,(LINES/2)-1))
  136.     write(center(l[1],COLS))
  137.     write(center("Copyright (c) Alan D. Corre, 1990",COLS))
  138.     }    
  139.  
  140.     return
  141.  
  142. end
  143.  
  144.  
  145.  
  146. procedure get_paths()
  147.  
  148.     local paths, p
  149.  
  150.     suspend "./" | "/usr/local/lib/hebcalen/"
  151.     paths := getenv("PATH")
  152.     \paths ? {
  153.     tab(match(":"))
  154.     while p := 1(tab(find(":")), move(1))
  155.     do suspend "" ~== trim(p,'/ ') || "/"
  156.     return "" ~== trim(tab(0) \ 1,'/ ') || "/"
  157.     }
  158.  
  159. end
  160.  
  161.  
  162.  
  163. procedure instructions(filename)
  164.  
  165.     # Gives user access to a help file which is printed out in chunks
  166.     # by "more."
  167.  
  168.     local helpfile, pager, ans, more_file
  169.  
  170.     iputs(igoto(getval("cm"),1,2))
  171.     writes("Do you need instructions? [ny]  ")
  172.     ans := map(read())
  173.     "q" == ans & fail
  174.  
  175.     if "y" == ans then {
  176.     clear()
  177.     write()
  178.     if close(open(helpfile := (get_paths()||filename)))
  179.     then {
  180.         # Kludge, kludge, kludge.
  181.         close(open(
  182.         more_file := (
  183.             ("" ~== getenv("PAGER")) |
  184.             (("/bin/"|"/usr/ucb/"|"/usr/bin/")||"more"))))
  185.         system(more_file || " " || helpfile)
  186.     }
  187.     else write("Can't find your hebcalen.hlp file!")
  188.     iputs(igoto(getval("cm"),1,getval("li")))
  189.     boldface()
  190.     writes("Press return to continue.")
  191.     normal()
  192.     "q" == map(read()) & fail
  193.     }
  194.  
  195.     return \helpfile | "no help"
  196.  
  197. end
  198.  
  199.  
  200.  
  201. procedure clear()
  202.     local i
  203.  
  204.     # Clears the screen.  Tries several methods.
  205.  
  206.     if not iputs(getval("cl"))
  207.     then iputs(igoto(getval("cm"),1,1))
  208.     if not iputs(getval("cd"))
  209.     then {
  210.     every i := 1 to getval("li") do {
  211.         iputs(igoto(getval("cm"),1,i))
  212.         iputs(getval("ce"))
  213.     }
  214.     iputs(igoto(getval("cm"),1,1))
  215.     }
  216.  
  217. end
  218.  
  219.  
  220.  
  221. procedure initialize_list()
  222.  
  223.     # Put info of hebcalen.dat into a global list
  224.  
  225.     local infile,n
  226.  
  227.     infolist := list(301)
  228.     if not (infile := open(get_paths()||"hebcalen.dat")) then
  229.     stop("\nError:  cannot open hebcalen.dat")
  230.  
  231.     # The table is arranged at twenty year intervals with 301 entries.
  232.     every n := 1 to 301 do
  233.     infolist[n] := read(infile)
  234.     close(infile)
  235.  
  236. end
  237.  
  238.  
  239.  
  240. procedure initialize_variables()
  241.  
  242.     # Get the closest previous year in the table.
  243.  
  244.     local line, quotient
  245.  
  246.     quotient := jyr.yr / 20 + 1
  247.     # Only 301 entries. Figure from last if necessary.
  248.     if quotient > 301 then quotient := 301
  249.     # Pull the appropriate info, put into global variables.
  250.     line := infolist[quotient]
  251.  
  252.     line ? {
  253.     current_molad.day := tab(upto('%'))
  254.     move(1)
  255.     current_molad.halaqim := tab(upto('%'))
  256.     move(1)
  257.     cyr.mth := tab(upto('%'))
  258.     move(1)
  259.     cyr.day := tab(upto('%'))
  260.     move(1)
  261.     cyr.yr := tab(upto('%'))
  262.     days_in_jyr := line[-3:0]
  263.     }
  264.  
  265.     # Begin at rosh hashana.
  266.     jyr.day := 1
  267.     jyr.mth := 7
  268.     return
  269.  
  270. end
  271.  
  272.  
  273.  
  274. procedure initialize(yr)
  275.  
  276.     local year
  277.     static current_year
  278.  
  279.     # initialize global variables
  280.     initial {
  281.     cyr := date(0,0,0)
  282.     jyr := date(0,0,0)
  283.     current_molad := molad(0,0)
  284.     initialize_list()
  285.     current_year := get_current_year()
  286.     }
  287.  
  288.     clear()
  289.     #user may need help
  290.     if yr == "*" then {
  291.     instructions("hebcalen.hlp") | fail
  292.     clear()
  293.     iputs(igoto(getval("cm"),1,2))
  294.     write("Enter a year.  By default, all dates are interpreted")
  295.     write("according to the Jewish calendar.  Civil years should")
  296.     write("be preceded by a + or - sign to indicate occurrence")
  297.     write("relative to the beginning of the common era (the cur-")
  298.     writes("rent civil year, ",current_year,", is the default):  ")
  299.     boldface()
  300.     year := read()
  301.     normal()
  302.     "q" == map(year) & fail
  303.     }
  304.     else year := yr
  305.  
  306.     "" == year & year := current_year
  307.     until jyr.yr := cleanup(year) do {
  308.     writes("\nI don't consider ")
  309.     boldface()
  310.     writes(year)
  311.     normal()
  312.     writes(" a valid date.  Try again:  ")
  313.     boldface()
  314.     year := read()
  315.     normal()
  316.     "q" == map(year) & fail
  317.     "" == year & year := current_year
  318.     }
  319.  
  320.     clear()
  321.     initialize_variables()
  322.     return
  323.  
  324. end
  325.  
  326.  
  327.  
  328. procedure get_current_year()
  329.     local c_date
  330.  
  331.     &date ? c_date := tab(find("/"))
  332.     return "+" || c_date
  333. end
  334.  
  335.  
  336.  
  337. procedure cleanup(str)
  338.  
  339.     # Tidy up the string. Bugs still possible.
  340.  
  341.     if "" == trim(str) then return ""
  342.  
  343.     map(Strip(str,~(&digits++'ABCDE+-'))) ? {
  344.  
  345.     if find("-"|"bc"|"bcd")
  346.     then return (0 < (3761 - (0 ~= checkstr(str))))
  347.     else if find("+"|"ad"|"ce")
  348.     then return ((0 ~= checkstr(str)) + 3760)
  349.     else if 0 < integer(str)
  350.     then return str
  351.     else fail
  352.     
  353.     }
  354.  
  355. end
  356.  
  357.  
  358.  
  359. procedure Strip(s,c)
  360.     local s2
  361.  
  362.     s2 := ""
  363.     s ? {
  364.     while s2 ||:= tab(upto(c))
  365.     do tab(many(c))
  366.     s2 ||:= tab(0)
  367.     }
  368.     return s2
  369.  
  370. end
  371.  
  372.  
  373.  
  374. procedure checkstr(s)
  375.  
  376.     # Does preliminary work on string before cleanup() cleans it up.
  377.  
  378.     local letter,n,newstr
  379.  
  380.     newstr := ""
  381.     every newstr ||:= string(integer(!s))
  382.     if 0 = *newstr | "" == newstr
  383.     then fail
  384.     else return newstr
  385.  
  386. end
  387.  
  388.  
  389.  
  390. procedure process()
  391.     local ans, yj, n
  392.  
  393.     # Extracts information about the specified year.
  394.  
  395.     local msg, limit, dj, dc, month_count, done
  396.     static how_many_per_screen, how_many_screens
  397.     initial {
  398.     how_many_per_screen := how_many_can_fit()
  399.     (how_many_screens := seq()) * how_many_per_screen >= 12
  400.     }
  401.  
  402.     # 6019 is last year handled by the table in the usual way.
  403.     if jyr.yr > 6019
  404.     then msg := "Calculating.  Years over 6019 take a long time."
  405.     else msg := "Calculating."
  406.     if jyr.yr <= 6019 then {
  407.     limit := jyr.yr % 20 
  408.     jyr.yr := ((jyr.yr / 20) * 20)
  409.     }
  410.     else {
  411.     limit := jyr.yr - 6000
  412.     jyr.yr := 6000
  413.     }
  414.     
  415.     ans := "y"
  416.     establish_jyr()
  417.     iputs(igoto(getval("cm"),1,2))
  418.     writes(msg)
  419.     every 1 to limit do {
  420.     # Increment the years, establish the type of Jewish year
  421.     cyr_augment()
  422.     jyr_augment()
  423.     establish_jyr()
  424.     }
  425.  
  426.     clear() 
  427.     while ("y"|"") == map(ans) do {
  428.  
  429.     yj := jyr.yr
  430.     dj := days_in_jyr
  431.  
  432.     month_count := 0
  433.     # On the variable how_many_screens, see initial { } above
  434.     every n := 1 to how_many_screens do {
  435.         clear()
  436.         every 1 to how_many_per_screen do {
  437.         write_a_month()
  438.         (month_count +:= 1) = 12 & break
  439.         }
  440.         if month_count < 12 | (12 % (13 > how_many_per_screen)) = 0
  441.         then {
  442.  
  443.         iputs(igoto(getval("cm"),1,getval("li")-2))
  444.         boldface()
  445.         writes(status_line(yj,dj))
  446.         normal()
  447.  
  448.         if month_count < 12 | jyr.mth = 6 then {
  449.             iputs(igoto(getval("cm"),1,getval("li")-1))
  450.             writes("Press return to continue.  ")
  451.             "q" == map(read()) & fail
  452.         }
  453.         }
  454.     }
  455.  
  456.     if jyr.mth = 6 then {
  457.         if (12 % (13 > how_many_per_screen)) = 0
  458.         then clear()
  459.         write_a_month()
  460.     }
  461.     iputs(igoto(getval("cm"),1,getval("li")-2))
  462.     boldface()
  463.     writes(status_line(yj,dj))
  464.     normal()
  465.  
  466.     iputs(igoto(getval("cm"),1,getval("li")-1))
  467.     writes("Display the next year? [yn]  ")
  468.     ans := read()
  469.  
  470.     }
  471.     return
  472.  
  473. end
  474.  
  475.  
  476.  
  477. procedure how_many_can_fit()
  478.  
  479.     local LINES, how_many
  480.  
  481.     LINES := getval("li") + 1
  482.     (((8 * (how_many := 1 to 14)) / LINES) = 1)
  483.  
  484.     return how_many - 1
  485.  
  486. end
  487.  
  488.  
  489.  
  490. procedure cyr_augment()
  491.  
  492.     # Make civil year a year later, we only need consider Aug,Sep,Nov.
  493.  
  494.     local days,newmonth,newday
  495.  
  496.     if cyr.mth = 8 then
  497.     days := 0 else
  498.     if cyr.mth = 9 then
  499.     days := 31 else
  500.     if cyr.mth = 10 then
  501.     days := 61 else
  502.     stop("Error in cyr_augment")
  503.  
  504.     writes(".")
  505.  
  506.     days := (days + cyr.day-365+days_in_jyr)
  507.     if isleap(cyr.yr + 1) then days -:= 1
  508.  
  509.     # Cos it takes longer to get there.
  510.     if days <= 31 then {newmonth := 8; newday := days} else
  511.     if days <= 61 then {newmonth := 9; newday := days-31} else
  512.     {newmonth := 10; newday := days-61} 
  513.  
  514.     cyr.mth := newmonth
  515.     cyr.day := newday
  516.     cyr.yr +:= 1
  517.     if cyr.yr = 0 then cyr.yr := 1
  518.  
  519.     return
  520.  
  521. end
  522.  
  523.  
  524.  
  525. procedure header()
  526.     local COLS
  527.  
  528.     # Creates the header for Jewish and English side.  Bug:  This
  529.     # routine, as it stands, has to rewrite the entire screen, in-
  530.     # cluding blank spaces.  Many of these could be elminated by
  531.     # judicious line clears and/or cursor movement commands.  Do-
  532.     # ing so would certainly speed up screen refresh for lower
  533.     # baud rates.  I've utilized the ch command where available,
  534.     # but in most cases, plain old spaces must be output.
  535.  
  536.     static make_whitespace, whitespace
  537.     initial {
  538.     COLS := getval("co")
  539.     if getval("ch") then {
  540.         # Untested, but it would offer a BIG speed advantage!
  541.         make_whitespace := create |iputs(igoto(getval("ch"),(COLS-53)+25))
  542.     }
  543.     else {
  544.         # Have to do things this way, since we don't know what line
  545.         # we are on (cm commands usually default to row/col 1).
  546.         whitespace := repl(" ",COLS-53)
  547.         make_whitespace := create |writes(whitespace)
  548.     }
  549.     }
  550.  
  551.     writes(repl(" ",7),"S",repl(" ",2),"M",repl(" ",2),"T",repl(" ",2),"W",
  552.        repl(" ",2),"T",repl(" ",2),"F",repl(" ",2))
  553.     boldface()
  554.     writes("S")
  555.     normal()
  556.     @make_whitespace
  557.     writes("S",repl(" ",2),"M",repl(" ",2),"T",repl(" ",2),"W",
  558.         repl(" ",2),"T",repl(" ",2),"F",repl(" ",2))
  559.     boldface()
  560.     writes("S")
  561.     normal()
  562.     iputs(getval("ce"))
  563.     write()
  564.  
  565. end
  566.  
  567.  
  568.  
  569. procedure write_a_month()
  570.  
  571.     # Writes a month on the screen
  572.  
  573.     header()
  574.     every 1 to 5 do {
  575.     writes(make_a_line())
  576.     iputs(getval("ce"))
  577.     write()
  578.     }
  579.     if jyr.day ~= 1 then {
  580.     writes(make_a_line())
  581.     iputs(getval("ce"))
  582.     write()
  583.     }
  584.     iputs(getval("ce"))
  585.     write()
  586.  
  587.     return
  588.  
  589. end
  590.  
  591.  
  592.  
  593. procedure status_line(a,b)
  594.  
  595.     # Create the status line at the bottom of screen.
  596.  
  597.     local sline,c,d
  598.  
  599.     c := cyr.yr
  600.     if (cyr.day = 1) & (cyr.mth = 1) then c -:= 1
  601.     d := { if isleap(c) then 366 else 365 }
  602.     if getval("co") > 79 then {
  603.     sline := ("Year of Creation: " || a || "  Days in year: " || b ||
  604.           "  Civil year: " || c || "  Days in year: " || d)
  605.     }
  606.     else {
  607.     sline := ("Jewish year " || a || " (" || b || " days)," ||
  608.           " Civil year " || c || " (" || d || " days)")
  609.     }
  610.  
  611.     return center(sline,getval("co"))
  612.  
  613. end
  614.  
  615.  
  616.  
  617. procedure boldface()
  618.     
  619.     static bold_str, cookie_str
  620.     initial {
  621.     if bold_str := getval("so")
  622.     then cookie_str := repl(getval("bc") | "\b", getval("sg"))
  623.     else {
  624.         if bold_str := getval("ul")
  625.         then cookie_str := repl(getval("bc") | "\b", getval("ug"))
  626.     }
  627.     }        
  628.     
  629.     iputs(\bold_str)
  630.     iputs(\cookie_str)
  631.     return
  632.  
  633. end
  634.  
  635.  
  636.  
  637. procedure normal()
  638.  
  639.     static UN_bold_str, cookie_str
  640.     initial {
  641.     if UN_bold_str := getval("se")
  642.     then cookie_str := repl(getval("bc") | "\b", getval("sg"))
  643.     else {
  644.         if UN_bold_str := getval("ue")
  645.         then cookie_str := repl(getval("bc") | "\b", getval("ug"))
  646.     }
  647.     }        
  648.     
  649.     iputs(\UN_bold_str)
  650.     iputs(\cookie_str)
  651.     return
  652.  
  653. end
  654.  
  655.  
  656. #--------------------- end modified sections of code ----------------------#
  657.  
  658. # Okay, okay a couple of things have been modified below, but nothing major.
  659.  
  660. procedure make_a_line()
  661. #make a single line of the months
  662. local line,blanks1,blanks2,start_point,end_point,flag,fm
  663. static number_of_spaces
  664. initial number_of_spaces := getval("co")-55
  665.  
  666. #consider the first line of the month
  667.   if jyr.day = 1 then {
  668.     line := mth_table(jyr.mth,1)
  669. #setting flag means insert civil month at end of line    
  670.     flag := 1 } else
  671.     line := repl(" ",3)
  672. #consider the case where first day of civil month is on Sunday    
  673.   if (cyr.day = 1) & (current_day = 1) then flag := 1
  674. #space between month name and beginning of calendar
  675.   line ||:= repl(" ",2)
  676. #measure indentation for first line
  677.   line ||:= blanks1 := repl(" ",3*(current_day-1))
  678. #establish start point for Hebrew loop
  679.   start_point := current_day
  680. #establish end point for Hebrew loop and run civil loop
  681.   every end_point := start_point to 7 do {
  682.     line ||:= right(jyr.day,3)
  683.     if not j_augment() then {jyr_augment(); establish_jyr(); current_day -:= 1; if current_day = 0 then current_day := 7}
  684.     d_augment()
  685.     if jyr.day = 1 then break }
  686. #measure indentation for last line
  687.   blanks2 := repl(" ",3*(7-end_point))
  688.   line ||:= blanks2; line ||:= repl(" ",number_of_spaces); line ||:= blanks1
  689.   every start_point to end_point do {
  690.     line ||:= right(cyr.day,3)
  691.     if (cyr.day = 1) then flag := 1 
  692.     augment()}
  693.   line ||:= blanks2 ||:= repl(" ",3)
  694.   fm := cyr.mth
  695.   if cyr.day = 1 then
  696.     if cyr.mth = 1 then fm := 12 else fm := cyr.mth - 1
  697.   if \flag then line ||:= mth_table(fm,2) else
  698.     line ||:= repl(" ",3)
  699. return line
  700. end
  701.  
  702. procedure mth_table(n,p)
  703. #generates the short names of Jewish and Civil months. Get to civil side
  704. #by adding 13 (=max no of Jewish months)
  705. static corresp
  706. initial corresp := ["NIS","IYA","SIV","TAM","AV ","ELU","TIS","HES","KIS",
  707. "TEV","SHE","ADA","AD2","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP",
  708. "OCT","NOV","DEC"]
  709.   if (p ~= 1) & (p ~= 2) then stop("ERROR IN MTH-TABLE") else
  710.     if p = 2 then n +:= 13
  711. return corresp[n]
  712. end
  713.  
  714. procedure d_augment()
  715. #increment the day of the week
  716.   current_day +:= 1
  717.   if current_day = 8 then current_day := 1
  718. return
  719. end
  720.  
  721. procedure augment()
  722. #increments civil day, modifies month and year if necessary, stores in
  723. #global variable cyr
  724.   if cyr.day < 28 then
  725.     cyr.day +:= 1 else
  726.   if cyr.day = 28 then {
  727.     if (cyr.mth ~= 2) | ((cyr.mth = 2) & isleap(cyr.yr)) then
  728.       cyr.day := 29 else {
  729.         cyr.mth := 3
  730.     cyr.day  := 1}} else
  731.   if cyr.day = 29 then {
  732.     if cyr.mth ~= 2 then
  733.       cyr.day := 30 else {
  734.       cyr.mth := 3
  735.       cyr.day := 1}} else
  736.   if cyr.day = 30 then {
  737.     if is_31(cyr.mth) then
  738.       cyr.day := 31 else {
  739.       cyr.mth +:= 1
  740.       cyr.day := 1}} else {
  741.       cyr.day := 1
  742.       if cyr.mth ~= 12 then
  743.         cyr.mth +:= 1 else {
  744.         cyr.mth := 1
  745.         cyr.yr +:= 1
  746.         if cyr.yr = 0
  747.       then cyr.yr := 1}}
  748. return
  749. end
  750.  
  751. procedure is_31(n)
  752. #civil months with 31 days
  753. return n = 1 | n = 3 | n = 5 | n = 7 | n = 8 | n = 10 | n = 12
  754. end
  755.  
  756. procedure isleap(n)
  757. #checks for civil leap year
  758.   if n > 0 then
  759. return (n % 400 = 0) | ((n % 4 = 0) & (n % 100 ~= 0)) else
  760. return (n % 400 = -1) | ((n % 4 = -1) & (n % 100 ~= -1))
  761. end
  762.  
  763. procedure j_augment()
  764. #increments jewish day. months are numbered from nisan, adar sheni is 13.
  765. #procedure fails at elul to allow determination of type of new year
  766.   if jyr.day < 29 then
  767.     jyr.day +:= 1 else
  768.   if (jyr.day = 30) | always_29(jyr.mth) | ((jyr.mth = 8) & 
  769.     (days_in_jyr % 5 ~= 0)) | ((jyr.mth = 9) & ((days_in_jyr = 353) |
  770.     (days_in_jyr = 383))) then
  771.     jyr.mth +:= jyr.day := 1 else
  772.   if jyr.mth = 6 then fail else
  773.   if ((jyr.mth = 12) & (days_in_jyr < 383)) | (jyr.mth = 13) then
  774.     jyr.mth := jyr.day := 1 else
  775.   jyr.day := 30
  776. return
  777. end
  778.  
  779. procedure always_29(n)
  780. #uncomplicated jewish months with 29 days
  781. return n = 2 | n = 4 | n = 10
  782. end
  783.  
  784. procedure jyr_augment()
  785. #determines the current time of lunation, using the ancient babylonian unit
  786. #of 1/1080 of an hour. lunation of tishri determines type of year. allows
  787. #for leap year. halaqim = parts of the hour
  788. local days, halaqim
  789.   days := current_molad.day + 4
  790.   if days_in_jyr <= 355 then {
  791.     halaqim :=  current_molad.halaqim + 9516
  792.     days := ((days +:= halaqim / 25920) % 7)
  793.     if days = 0 then days := 7
  794.     halaqim := halaqim % 25920} else {
  795.     days +:= 1
  796.     halaqim := current_molad.halaqim + 23269
  797.     days := ((days +:= halaqim / 25920) % 7)
  798.     if days = 0 then days := 7
  799.     halaqim := halaqim % 25920}
  800.   current_molad.day := days
  801.   current_molad.halaqim := halaqim
  802. #reset the global variable which holds the current jewish date
  803.   jyr.yr +:= 1 #increment year
  804.   jyr.day := 1
  805.   jyr.mth := 7
  806.   establish_jyr()
  807. return
  808. end
  809.  
  810. procedure establish_jyr()
  811. #establish the jewish year from get_rh
  812. local res
  813.   res := get_rh(current_molad.day,current_molad.halaqim,no_lunar_yr(jyr.yr))
  814.   days_in_jyr := res[2]
  815.   current_day := res[1]
  816. return
  817. end    
  818.  
  819. procedure isin1(i)
  820. #the isin procedures are sets of years in the Metonic cycle
  821. return i = (1 | 4 | 7 | 9 | 12 | 15 | 18)
  822. end
  823.  
  824. procedure isin2(i)
  825. return i = (2 | 5 | 10 | 13 | 16)
  826. end
  827.  
  828. procedure isin3(i)
  829. return i = (3 | 6 | 8 | 11 | 14 | 17 | 0)
  830. end
  831.  
  832. procedure isin4(i)
  833. return i = (1 | 2 | 4 | 5 | 7 | 9 | 10 | 12 | 13 | 15 | 16 | 18)
  834. end
  835.  
  836. procedure isin5(i)
  837. return i = (1 | 4 | 9 | 12 | 15)
  838. end
  839.  
  840. procedure isin6(i)
  841. return i = (2 | 5 | 7 | 10 | 13 | 16 | 18)
  842. end
  843.  
  844. procedure no_lunar_yr(i)
  845. #what year in the metonic cycle is it?
  846. return i % 19
  847. end
  848.  
  849. procedure get_rh(d,h,yr)
  850. #this is the heart of the program. check the day of lunation of tishri
  851. #and determine where breakpoint is that sets the new moon day in parts
  852. #of the hour. return result in a list where 1 is day of rosh hashana and
  853. #2 is length of jewish year
  854. local c,result
  855.   c := no_lunar_yr(yr)
  856.   result := list(2)
  857.   if d = 1 then {
  858.           result[1] := 2
  859.                 if (h < 9924) & isin4(c) then result[2] := 353 else
  860.         if (h < 22091) & isin3(c) then result[2] := 383 else
  861.         if (h > 9923) & (isin1(c) | isin2(c)) then result[2] := 355 else
  862.         if (h > 22090) & isin3(c) then result[2] := 385
  863.         } else
  864.   if d = 2 then {
  865.           if ((h < 16789) & isin1(c)) |
  866.            ((h < 19440) & isin2(c)) then {
  867.                                  result[1] := 2
  868.                              result[2] := 355
  869.                              } else
  870.         if (h < 19440) & isin3(c) then  {
  871.                                  result[1] := 2
  872.                              result[2] := 385
  873.                              } else
  874.           if ((h > 16788) & isin1(c)) |
  875.            ((h > 19439) & isin2(c)) then {
  876.                                  result[1] := 3
  877.                              result[2] := 354
  878.                              } else
  879.                 if (h > 19439) & isin3(c) then  {
  880.                                  result[1] := 3
  881.                              result[2] := 384
  882.                              }
  883.         } else
  884.   if d = 3 then {
  885.           if (h < 9924) & (isin1(c) | isin2(c)) then {
  886.                                result[1] := 3
  887.                                result[2] := 354
  888.                                } else
  889.         if (h < 19440) & isin3(c) then {
  890.                            result[1] := 3
  891.                            result[2] := 384
  892.                            } else
  893.         if (h > 9923) & isin4(c) then {
  894.                           result[1] := 5
  895.                           result[2] := 354
  896.                           } else
  897.         if (h > 19439) & isin3(c) then {
  898.                            result[1] := 5
  899.                            result[2] := 383}
  900.         } else
  901.   if d = 4 then {
  902.           result[1] := 5
  903.         if isin4(c) then result[2] := 354 else
  904.         if h < 12575 then result[2] := 383 else
  905.         result[2] := 385
  906.         } else
  907.   if d = 5 then {
  908.                 if (h < 9924) & isin4(c) then {
  909.                           result[1] := 5
  910.                           result[2] := 354} else
  911.         if (h < 19440) & isin3(c) then {
  912.                            result[1] := 5
  913.                            result[2] := 385
  914.                            } else
  915.         if (9923 < h < 19440) & isin4(c) then {
  916.                               result[1] := 5
  917.                               result[2] := 355
  918.                               } else
  919.         if h > 19439 then {
  920.                     result[1] := 7
  921.                           if isin3(c) then result[2] := 383 else
  922.                             result[2] := 353
  923.                   }
  924.         } else
  925.   if d = 6 then {
  926.             result[1] := 7
  927.             if ((h < 408) & isin5(c)) | ((h < 9924) & isin6(c)) then
  928.                               result[2] := 353 else
  929.             if ((h < 22091) & isin3(c)) then result[2] := 383 else
  930.             if ((h > 407) & isin5(c)) | ((h > 9923) & isin6(c)) then
  931.                               result[2] := 355 else
  932.             if (h > 22090) & isin3(c) then result[2] := 385
  933.             } else
  934.   if d = 7 then    if (h < 19440) & (isin5(c) | isin6(c)) then {
  935.                               result[1] := 7
  936.                               result[2] := 355
  937.                               } else
  938.         if (h < 19440) & isin3(c) then {
  939.                            result[1] := 7
  940.                            result[2] := 385
  941.                            } else {
  942.                                   result[1] := 2
  943.                               if isin4(c) then
  944.                                 result[2] := 353 else
  945.                             result[2] := 383}
  946. return result
  947. end
  948.