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