diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..69fa449 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +_build/ diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..d37a808 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,3 @@ +profile = default +version = 0.24.1 +exp-grouping=preserve diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..60549be --- /dev/null +++ b/LICENSE @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19yy name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/README.md b/README.md new file mode 100644 index 0000000..ff0ff32 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ += Calendars = + +OCaml library to convert dates between ([Gregorian], [Julian], [French republican], [Hebrew]) calendars. + +This code was originally from [Geneweb]. + +[Gregorian]: https://en.wikipedia.org/wiki/Gregorian_calendar +[Julian]: https://en.wikipedia.org/wiki/Julian_calendar +[French republican]: https://en.wikipedia.org/wiki/French_Republican_calendar +[Hebrew]: https://en.wikipedia.org/wiki/Hebrew_calendar +[Geneweb]: https://github.com/geneweb/geneweb/ diff --git a/calendars.opam b/calendars.opam index 2bc8c4a..c1db6d4 100644 --- a/calendars.opam +++ b/calendars.opam @@ -1,26 +1,46 @@ +# This file is generated by dune, edit dune-project instead opam-version: "2.0" - -name: "calendars" - version: "1.0.0" - synopsis: "Convert dates between gregorian/julian/french/hebrew calendars" - -authors: [ "Daniel de Rauglaudre" ] - -maintainer: "Julien Sagot " - -license: "GNU GPL" - +description: + "OCaml library to convert dates between gregorian/julian/french/hebrew calendars. Code is originally from Geneweb." +maintainer: [ + "Elie Canonici-Merle " + "Olivier Pierre " +] +authors: ["Daniel de Rauglaudre"] +license: "GPL-2.0-only" +tags: [ + "moon-phase" + "gregorian" + "julian" + "hebrew" + "french-republican" + "calendar" + "date" +] homepage: "https://github.com/geneweb/calendars" - bug-reports: "https://github.com/geneweb/calendars/issues" - -dev-repo: "git+https://github.com/geneweb/calendars.git" - depends: [ - "dune" { >= "1.11" } - "ocaml" { >= "4.05" } + "dune" {>= "2.9"} + "ocaml" {>= "4.08"} + "ounit2" {with-test} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "--promote-install-files=false" + "@install" + "@runtest" {with-test} + "@doc" {with-doc} ] - -build: [ [ "dune" "build" "-p" name "-j" jobs] ] + ["dune" "install" "-p" name "--create-install-files" name] +] +dev-repo: "git+https://github.com/geneweb/calendars.git" diff --git a/dune-project b/dune-project index 4e18cf9..bdbfca9 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,19 @@ -(lang dune 1.11) +(lang dune 2.9) (name calendars) +(version 1.0.0) + +(generate_opam_files true) +(license GPL-2.0-only) +(authors "Daniel de Rauglaudre") +(maintainers "Elie Canonici-Merle " "Olivier Pierre ") +(source (github geneweb/calendars)) + +(package + (name calendars) + (synopsis "Convert dates between gregorian/julian/french/hebrew calendars") + (description "OCaml library to convert dates between gregorian/julian/french/hebrew calendars. Code is originally from Geneweb.") + (tags (moon-phase gregorian julian hebrew french-republican calendar date)) + (depends + (ocaml (>= 4.08)) + (ounit2 :with-test) + )) diff --git a/lib/calendars.ml b/lib/calendars.ml index 10895cb..8f78451 100644 --- a/lib/calendars.ml +++ b/lib/calendars.ml @@ -4,10 +4,29 @@ (* Changed gregorian and julian to work always with negative years (Scott's version worked only for years > -4800 *) -type d = { day : int ; month : int ; year : int ; delta : int } +type gregorian +type julian +type french +type hebrew + +type _ kind = + | Gregorian : gregorian kind + | Julian : julian kind + | French : french kind + | Hebrew : hebrew kind + +type 'a date = { + day : int; + month : int; + year : int; + delta : int; + kind : 'a kind; +} + +type sdn = int let mydiv x y = if x >= 0 then x / y else (x - y + 1) / y -let mymod x y = if x >= 0 then x mod y else (x + 1) mod y + y - 1 +let mymod x y = if x >= 0 then x mod y else ((x + 1) mod y) + y - 1 (* gregorian *) @@ -18,27 +37,28 @@ let days_per_400_years = 146097 let sdn_of_gregorian d = let year = if d.year < 0 then d.year + 1 else d.year in - let (month, year) = - if d.month > 2 then d.month - 3, year else d.month + 9, year - 1 + let month, year = + if d.month > 2 then (d.month - 3, year) else (d.month + 9, year - 1) in - mydiv (mydiv year 100 * days_per_400_years) 4 + - mydiv (mymod year 100 * days_per_4_years) 4 + - (month * days_per_5_months + 2) / 5 + d.day + sdn_offset + mydiv (mydiv year 100 * days_per_400_years) 4 + + mydiv (mymod year 100 * days_per_4_years) 4 + + (((month * days_per_5_months) + 2) / 5) + + d.day + sdn_offset let gregorian_of_sdn sdn = - let temp = (sdn - sdn_offset) * 4 - 1 in + let temp = ((sdn - sdn_offset) * 4) - 1 in let century = mydiv temp days_per_400_years in - let temp = mydiv (mymod temp days_per_400_years) 4 * 4 + 3 in - let year = century * 100 + mydiv temp days_per_4_years in + let temp = (mydiv (mymod temp days_per_400_years) 4 * 4) + 3 in + let year = (century * 100) + mydiv temp days_per_4_years in let dayOfYear = mydiv (mymod temp days_per_4_years) 4 + 1 in - let temp = dayOfYear * 5 - 3 in + let temp = (dayOfYear * 5) - 3 in let month = mydiv temp days_per_5_months in let day = mydiv (mymod temp days_per_5_months) 5 + 1 in - let (month, year) = - if month < 10 then month + 3, year else month - 9, year + 1 + let month, year = + if month < 10 then (month + 3, year) else (month - 9, year + 1) in let year = if year <= 0 then year - 1 else year in - {day = day; month = month; year = year; delta = 0} + { day; month; year; delta = 0; kind = Gregorian } (* julian *) @@ -48,33 +68,37 @@ let days_per_4_years = 1461 let sdn_of_julian d = let year = if d.year < 0 then d.year + 1 else d.year in - let (month, year) = - if d.month > 2 then d.month - 3, year else d.month + 9, year - 1 + let month, year = + if d.month > 2 then (d.month - 3, year) else (d.month + 9, year - 1) in - mydiv (year * days_per_4_years) 4 + (month * days_per_5_months + 2) / 5 + - d.day + sdn_offset + mydiv (year * days_per_4_years) 4 + + (((month * days_per_5_months) + 2) / 5) + + d.day + sdn_offset let julian_of_sdn sdn = - let temp = (sdn - sdn_offset) * 4 - 1 in + let temp = ((sdn - sdn_offset) * 4) - 1 in let year = mydiv temp days_per_4_years in let dayOfYear = mydiv (mymod temp days_per_4_years) 4 + 1 in - let temp = dayOfYear * 5 - 3 in + let temp = (dayOfYear * 5) - 3 in let month = mydiv temp days_per_5_months in let day = mydiv (mymod temp days_per_5_months) 5 + 1 in - let (month, year) = - if month < 10 then month + 3, year else month - 9, year + 1 + let month, year = + if month < 10 then (month + 3, year) else (month - 9, year + 1) in let year = if year <= 0 then year - 1 else year in - {day = day; month = month; year = year; delta = 0} + { day; month; year; delta = 0; kind = Julian } (* french revolution *) (* this code comes from Remy Pialat; thanks to him *) let modulo pAngle pVal = - let x = truncate (pAngle /. pVal) in let y = float x *. pVal in pAngle -. y + let x = truncate (pAngle /. pVal) in + let y = float x *. pVal in + pAngle -. y let degVersRad pAngle = - let a = modulo pAngle 360.0 in a *. 3.141592653589793 /. 180.0 + let a = modulo pAngle 360.0 in + a *. 3.141592653589793 /. 180.0 let sinDeg pAngle = sin (degVersRad pAngle) @@ -87,7 +111,7 @@ let equinoxeAutomne pAnnee = let q = 30.0 in let i = 0 in let k = 6.0 in - let jd = (float pAnnee +. k /. f) *. 365.2422 +. 1721141.3 in + let jd = ((float pAnnee +. (k /. f)) *. 365.2422) +. 1721141.3 in let rec loop i jd jdn = if abs_float (jd -. jdn) > 1.0E-12 && i + 1 < 20 then let i = i + 1 in @@ -95,144 +119,172 @@ let equinoxeAutomne pAnnee = let t = (jd -. 2415020.0) /. 36525.0 in let t2 = t *. t in let t3 = t2 *. t in - let l = 279.69688 +. 36000.76892 *. t +. 3.025E-4 *. t2 in - let m = 358.47583 +. 35999.04975 *. t -. 1.5E-4 *. t2 -. 3.3E-6 *. t3 in + let l = 279.69688 +. (36000.76892 *. t) +. (3.025E-4 *. t2) in + let m = + 358.47583 +. (35999.04975 *. t) -. (1.5E-4 *. t2) -. (3.3E-6 *. t3) + in + let ll = + l + +. ((1.91946 -. (0.004789 *. t) -. (1.4E-5 *. t2)) *. sinDeg m) + +. ((0.020094 -. (1.0E-4 *. t)) *. sinDeg (2.0 *. m)) + +. (0.00293 *. sinDeg (3.0 *. m)) + in let ll = - l +. (1.91946 -. 0.004789 *. t -. 1.4E-5 *. t2) *. sinDeg m +. - (0.020094 -. 1.0E-4 *. t) *. sinDeg (2.0 *. m) +. - 0.00293 *. sinDeg (3.0 *. m) + ll -. 0.00569 -. (0.00479 *. sinDeg (259.18 -. (1934.142 *. t))) in - let ll = ll -. 0.00569 -. 0.00479 *. sinDeg (259.18 -. 1934.142 *. t) in let ll = modulo360 ll in let ll = if ll > 350.0 then ll -. 360.0 else ll in - let jd = jd +. 1.014 *. (k *. q -. ll) in loop i jd jdn + let jd = jd +. (1.014 *. ((k *. q) -. ll)) in + loop i jd jdn else let d = jd -. floor jd in - let j = truncate jd in if d >= 0.5 then j + 1 else j + let j = truncate jd in + if d >= 0.5 then j + 1 else j in loop i jd (-1.0) let french_of_sdn sdn = let greg_date = gregorian_of_sdn sdn in let fst_vend_sdn = equinoxeAutomne greg_date.year in - let (year, fst_vend_sdn) = + let year, fst_vend_sdn = if sdn < fst_vend_sdn then let fst_vend_sdn = equinoxeAutomne (greg_date.year - 1) in - let year = greg_date.year - 1792 in year, fst_vend_sdn - else let year = greg_date.year - 1791 in year, fst_vend_sdn + let year = greg_date.year - 1792 in + (year, fst_vend_sdn) + else + let year = greg_date.year - 1791 in + (year, fst_vend_sdn) in let ndays = sdn - fst_vend_sdn in - let month = ndays / 30 + 1 in - let day = ndays mod 30 + 1 in - {day = day; month = month; year = year; delta = 0} + let month = (ndays / 30) + 1 in + let day = (ndays mod 30) + 1 in + { day; month; year; delta = 0; kind = French } let sdn_of_french d = let greg_year = d.year + 1791 in - equinoxeAutomne greg_year + (d.month - 1) * 30 + d.day - 1 + equinoxeAutomne greg_year + ((d.month - 1) * 30) + d.day - 1 (* hebrew *) let halakim_per_hour = 1080 let halakim_per_day = 25920 -let halakim_per_lunar_cycle = 29 * halakim_per_day + 13753 -let halakim_per_metonic_cycle = halakim_per_lunar_cycle * (12 * 19 + 7) - -let sdn_offset = 347997 +let halakim_per_lunar_cycle = (29 * halakim_per_day) + 13753 +let halakim_per_metonic_cycle = halakim_per_lunar_cycle * ((12 * 19) + 7) +let sdn_hebrew_anno_mundi = 347997 let new_moon_of_creation = 31524 - let sunday = 0 let monday = 1 let tuesday = 2 let wednesday = 3 + (* let thursday = 4 *) let friday = 5 (* let saturday = 6 *) let noon = 18 * halakim_per_hour -let am3_11_20 = 9 * halakim_per_hour + 204 -let am9_32_43 = 15 * halakim_per_hour + 589 +let am3_11_20 = (9 * halakim_per_hour) + 204 +let am9_32_43 = (15 * halakim_per_hour) + 589 let monthsPerYear = - [| 12; 12; 13; 12; 12; 13; 12; 13; 12; 12; 13; 12; 12; 13; 12; 12; 13; 12; - 13 |] + [| + 12; 12; 13; 12; 12; 13; 12; 13; 12; 12; 13; 12; 12; 13; 12; 12; 13; 12; 13; + |] let yearOffset = - [| 0; 12; 24; 37; 49; 61; 74; 86; 99; 111; 123; 136; 148; 160; 173; 185; - 197; 210; 222 |] + [| + 0; + 12; + 24; + 37; + 49; + 61; + 74; + 86; + 99; + 111; + 123; + 136; + 148; + 160; + 173; + 185; + 197; + 210; + 222; + |] let fTishri1 metonicYear moladDay moladHalakim = let tishri1 = moladDay in let dow = tishri1 mod 7 in let leapYear = - match metonicYear with - 2 | 5 | 7 | 10 | 13 | 16 | 18 -> true - | _ -> false + match metonicYear with 2 | 5 | 7 | 10 | 13 | 16 | 18 -> true | _ -> false in let lastWasLeapYear = - match metonicYear with - 3 | 6 | 8 | 11 | 14 | 17 | 0 -> true - | _ -> false + match metonicYear with 3 | 6 | 8 | 11 | 14 | 17 | 0 -> true | _ -> false in - let (tishri1, dow) = - if moladHalakim >= noon || - not leapYear && dow = tuesday && moladHalakim >= am3_11_20 || - lastWasLeapYear && dow = monday && moladHalakim >= am9_32_43 + let tishri1, dow = + if + moladHalakim >= noon + || ((not leapYear) && dow = tuesday && moladHalakim >= am3_11_20) + || (lastWasLeapYear && dow = monday && moladHalakim >= am9_32_43) then let tishri1 = tishri1 + 1 in let dow = dow + 1 in - let dow = if dow = 7 then 0 else dow in tishri1, dow - else tishri1, dow + let dow = if dow = 7 then 0 else dow in + (tishri1, dow) + else (tishri1, dow) in if dow = wednesday || dow = friday || dow = sunday then tishri1 + 1 else tishri1 let moladOfMetonicCycle metonicCycle = let r1 = new_moon_of_creation in - let r1 = r1 + metonicCycle * (halakim_per_metonic_cycle land 0xFFFF) in + let r1 = r1 + (metonicCycle * (halakim_per_metonic_cycle land 0xFFFF)) in let r2 = r1 lsr 16 in let r2 = - r2 + metonicCycle * (halakim_per_metonic_cycle lsr 16 land 0xFFFF) + r2 + (metonicCycle * ((halakim_per_metonic_cycle lsr 16) land 0xFFFF)) in let d2 = r2 / halakim_per_day in - let r2 = r2 - d2 * halakim_per_day in - let r1 = 4. *. float (r2 lsl 14) +. float (r1 land 0xFFFF) in - let d1 = truncate (r1 /. float halakim_per_day +. 0.5) in - let r1 = truncate (r1 -. float d1 *. float halakim_per_day +. 0.5) in - let pMoladDay = d2 lsl 16 lor d1 in - let pMoladHalakim = r1 in pMoladDay, pMoladHalakim + let r2 = r2 - (d2 * halakim_per_day) in + let r1 = (4. *. float (r2 lsl 14)) +. float (r1 land 0xFFFF) in + let d1 = truncate ((r1 /. float halakim_per_day) +. 0.5) in + let r1 = truncate (r1 -. (float d1 *. float halakim_per_day) +. 0.5) in + let pMoladDay = (d2 lsl 16) lor d1 in + let pMoladHalakim = r1 in + (pMoladDay, pMoladHalakim) let findStartOfYear year = let pMetonicCycle = (year - 1) / 19 in (* On prend la valeur absolue parce que (0 - 1) mod 19 = -1 *) (* et après, on fait un 'index out of bounds' dans yearOffset. *) let pMetonicYear = abs ((year - 1) mod 19) in - let (pMoladDay, pMoladHalakim) = moladOfMetonicCycle pMetonicCycle in + let pMoladDay, pMoladHalakim = moladOfMetonicCycle pMetonicCycle in let pMoladHalakim = - pMoladHalakim + halakim_per_lunar_cycle * yearOffset.(pMetonicYear) + pMoladHalakim + (halakim_per_lunar_cycle * yearOffset.(pMetonicYear)) in - let pMoladDay = pMoladDay + pMoladHalakim / halakim_per_day in + let pMoladDay = pMoladDay + (pMoladHalakim / halakim_per_day) in let pMoladHalakim = pMoladHalakim mod halakim_per_day in let pTishri1 = fTishri1 pMetonicYear pMoladDay pMoladHalakim in - pMetonicCycle, pMetonicYear, pMoladDay, pMoladHalakim, pTishri1 + (pMetonicCycle, pMetonicYear, pMoladDay, pMoladHalakim, pTishri1) let sdn_of_hebrew d = (* correction possible ? *) (* let d = { (d) with year = if d.year <= 0 then 1 else d.year } in *) let sdn = match d.month with - 1 | 2 -> - let (_metonicCycle, _metonicYear, _moladDay, _moladHalakim, tishri1) = + | 1 | 2 -> + let _metonicCycle, _metonicYear, _moladDay, _moladHalakim, tishri1 = findStartOfYear d.year in if d.month = 1 then tishri1 + d.day - 1 else tishri1 + d.day + 29 | 3 -> - let (_metonicCycle, metonicYear, moladDay, moladHalakim, tishri1) = + let _metonicCycle, metonicYear, moladDay, moladHalakim, tishri1 = findStartOfYear d.year in let moladHalakim = - moladHalakim + halakim_per_lunar_cycle * monthsPerYear.(metonicYear) + moladHalakim + (halakim_per_lunar_cycle * monthsPerYear.(metonicYear)) in - let moladDay = moladDay + moladHalakim / halakim_per_day in + let moladDay = moladDay + (moladHalakim / halakim_per_day) in let moladHalakim = moladHalakim mod halakim_per_day in let tishri1After = fTishri1 ((metonicYear + 1) mod 19) moladDay moladHalakim @@ -241,8 +293,8 @@ let sdn_of_hebrew d = if yearLength = 355 || yearLength = 385 then tishri1 + d.day + 59 else tishri1 + d.day + 58 | 4 | 5 | 6 -> - let (_metonicCycle, _metonicYear, _moladDay, _moladHalakim, - tishri1After) = + let _metonicCycle, _metonicYear, _moladDay, _moladHalakim, tishri1After + = findStartOfYear (d.year + 1) in (* On prend la valeur absolue parce que (0 - 1) mod 19 = -1 *) @@ -251,194 +303,146 @@ let sdn_of_hebrew d = if monthsPerYear.(abs ((d.year - 1) mod 19)) = 12 then 29 else 59 in if d.month = 4 then tishri1After + d.day - lengthOfAdarIAndII - 237 - else if d.month = 5 then - tishri1After + d.day - lengthOfAdarIAndII - 208 + else if d.month = 5 then tishri1After + d.day - lengthOfAdarIAndII - 208 else tishri1After + d.day - lengthOfAdarIAndII - 178 - | _ -> - let (_metonicCycle, _metonicYear, _moladDay, _moladHalakim, - tishri1After) = + | _ -> ( + let _metonicCycle, _metonicYear, _moladDay, _moladHalakim, tishri1After + = findStartOfYear (d.year + 1) in match d.month with - 7 -> tishri1After + d.day - 207 + | 7 -> tishri1After + d.day - 207 | 8 -> tishri1After + d.day - 178 | 9 -> tishri1After + d.day - 148 | 10 -> tishri1After + d.day - 119 | 11 -> tishri1After + d.day - 89 | 12 -> tishri1After + d.day - 60 | 13 -> tishri1After + d.day - 30 - | _ -> invalid_arg "sdn_of_hebrew" + | _ -> invalid_arg "sdn_of_hebrew") in - sdn + sdn_offset + sdn + sdn_hebrew_anno_mundi let findTishriMolad inputDay = let metonicCycle = (inputDay + 310) / 6940 in - let (moladDay, moladHalakim) = moladOfMetonicCycle metonicCycle in - let (moladDay, moladHalakim, metonicCycle) = + let moladDay, moladHalakim = moladOfMetonicCycle metonicCycle in + let moladDay, moladHalakim, metonicCycle = let rec loop moladDay moladHalakim metonicCycle = if moladDay < inputDay - 6940 + 310 then let metonicCycle = metonicCycle + 1 in let moladHalakim = moladHalakim + halakim_per_metonic_cycle in - let moladDay = moladDay + moladHalakim / halakim_per_day in + let moladDay = moladDay + (moladHalakim / halakim_per_day) in let moladHalakim = moladHalakim mod halakim_per_day in loop moladDay moladHalakim metonicCycle - else moladDay, moladHalakim, metonicCycle + else (moladDay, moladHalakim, metonicCycle) in loop moladDay moladHalakim metonicCycle in - let (metonicYear, moladDay, moladHalakim) = + let metonicYear, moladDay, moladHalakim = let rec loop metonicYear moladDay moladHalakim = if metonicYear < 18 then - if moladDay > inputDay - 74 then metonicYear, moladDay, moladHalakim + if moladDay > inputDay - 74 then (metonicYear, moladDay, moladHalakim) else let moladHalakim = - moladHalakim + - halakim_per_lunar_cycle * monthsPerYear.(metonicYear) + moladHalakim + + (halakim_per_lunar_cycle * monthsPerYear.(metonicYear)) in - let moladDay = moladDay + moladHalakim / halakim_per_day in + let moladDay = moladDay + (moladHalakim / halakim_per_day) in let moladHalakim = moladHalakim mod halakim_per_day in loop (metonicYear + 1) moladDay moladHalakim - else metonicYear, moladDay, moladHalakim + else (metonicYear, moladDay, moladHalakim) in loop 0 moladDay moladHalakim in - metonicCycle, metonicYear, moladDay, moladHalakim + (metonicCycle, metonicYear, moladDay, moladHalakim) let glop inputDay tishri1 tishri1After = let yearLength = tishri1After - tishri1 in let day = inputDay - tishri1 - 29 in if yearLength = 355 || yearLength = 385 then - if day <= 30 then 2, day else 3, day - 30 - else if day <= 29 then 2, day - else 3, day - 29 + if day <= 30 then (2, day) else (3, day - 30) + else if day <= 29 then (2, day) + else (3, day - 29) let hebrew_of_sdn sdn = - let inputDay = sdn - sdn_offset in - let (year, month, day) = - if inputDay <= 0 then 0, 0, 0 + let inputDay = sdn - sdn_hebrew_anno_mundi in + let year, month, day = + if inputDay <= 0 then (0, 0, 0) (* should raise invalid arg here instead *) else - let (metonicCycle, metonicYear, day, halakim) = - findTishriMolad inputDay - in + let metonicCycle, metonicYear, day, halakim = findTishriMolad inputDay in let init_day = day in let tishri1 = fTishri1 metonicYear day halakim in if inputDay >= tishri1 then - let year = metonicCycle * 19 + metonicYear + 1 in + let year = (metonicCycle * 19) + metonicYear + 1 in if inputDay < tishri1 + 59 then - if inputDay < tishri1 + 30 then year, 1, inputDay - tishri1 + 1 - else year, 2, inputDay - tishri1 - 29 + if inputDay < tishri1 + 30 then (year, 1, inputDay - tishri1 + 1) + else (year, 2, inputDay - tishri1 - 29) else let halakim = - halakim + halakim_per_lunar_cycle * monthsPerYear.(metonicYear) + halakim + (halakim_per_lunar_cycle * monthsPerYear.(metonicYear)) in - let day = day + halakim / halakim_per_day in + let day = day + (halakim / halakim_per_day) in let halakim = halakim mod halakim_per_day in - let tishri1After = - fTishri1 ((metonicYear + 1) mod 19) day halakim - in - let (month, day) = glop inputDay tishri1 tishri1After in - year, month, day + let tishri1After = fTishri1 ((metonicYear + 1) mod 19) day halakim in + let month, day = glop inputDay tishri1 tishri1After in + (year, month, day) else - let year = metonicCycle * 19 + metonicYear in + let year = (metonicCycle * 19) + metonicYear in if inputDay >= tishri1 - 177 then - let (month, day) = - if inputDay > tishri1 - 30 then 13, inputDay - tishri1 + 30 - else if inputDay > tishri1 - 60 then 12, inputDay - tishri1 + 60 - else if inputDay > tishri1 - 89 then 11, inputDay - tishri1 + 89 - else if inputDay > tishri1 - 119 then 10, inputDay - tishri1 + 119 - else if inputDay > tishri1 - 148 then 9, inputDay - tishri1 + 148 - else 8, inputDay - tishri1 + 178 + let month, day = + if inputDay > tishri1 - 30 then (13, inputDay - tishri1 + 30) + else if inputDay > tishri1 - 60 then (12, inputDay - tishri1 + 60) + else if inputDay > tishri1 - 89 then (11, inputDay - tishri1 + 89) + else if inputDay > tishri1 - 119 then (10, inputDay - tishri1 + 119) + else if inputDay > tishri1 - 148 then (9, inputDay - tishri1 + 148) + else (8, inputDay - tishri1 + 178) in - year, month, day + (year, month, day) else if monthsPerYear.((year - 1) mod 19) = 13 then let month = 7 in let day = inputDay - tishri1 + 207 in - if day > 0 then year, month, day + if day > 0 then (year, month, day) else let month = month - 1 in let day = day + 30 in - if day > 0 then year, month, day + if day > 0 then (year, month, day) else let month = month - 1 in let day = day + 30 in - if day > 0 then year, month, day + if day > 0 then (year, month, day) else let month = month - 1 in let day = day + 29 in - if day > 0 then year, month, day + if day > 0 then (year, month, day) else let tishri1After = tishri1 in - let (_metonicCycle, metonicYear, day, halakim) = + let _metonicCycle, metonicYear, day, halakim = findTishriMolad (init_day - 365) in let tishri1 = fTishri1 metonicYear day halakim in - let (month, day) = glop inputDay tishri1 tishri1After in - year, month, day + let month, day = glop inputDay tishri1 tishri1After in + (year, month, day) else let month = 6 in let day = inputDay - tishri1 + 207 in - if day > 0 then year, month, day + if day > 0 then (year, month, day) else let month = month - 1 in let day = day + 30 in - if day > 0 then year, month, day + if day > 0 then (year, month, day) else let month = month - 1 in let day = day + 29 in - if day > 0 then year, month, day + if day > 0 then (year, month, day) else let tishri1After = tishri1 in - let (_metonicCycle, metonicYear, day, halakim) = + let _metonicCycle, metonicYear, day, halakim = findTishriMolad (init_day - 365) in let tishri1 = fTishri1 metonicYear day halakim in - let (month, day) = glop inputDay tishri1 tishri1After in - year, month, day + let month, day = glop inputDay tishri1 tishri1After in + (year, month, day) in - {day = day; month = month; year = year; delta = 0} - -(* from and to gregorian *) - -let conv f f_max_month g g_max_month d = - let sdn = - if d.day = 0 then - if d.month = 0 then g {d with day = 1; month = 1} - else g {d with day = 1} - else g d - in - let sdn_max = - if d.day = 0 then - if d.month = 0 || d.month = g_max_month then - g {day = 1; month = 1; year = d.year + 1; delta = 0} - else - g - {day = 1; month = d.month + 1; year = d.year; - delta = 0} - else sdn + 1 - in - let d1 = f sdn in - let d2 = f (sdn_max + d.delta) in - if d1.day = 1 && d2.day = 1 then - if d1.month = 1 && d2.month = 1 then - if d1.year + 1 = d2.year then - {day = 0; month = 0; year = d1.year; delta = 0} - else {d1 with delta = sdn_max + d.delta - sdn - 1} - else if - d1.month + 1 = d2.month || - d1.month = f_max_month && d1.year + 1 = d2.year - then - {d1 with day = 0} - else {d1 with delta = sdn_max + d.delta - sdn - 1} - else {d1 with delta = sdn_max + d.delta - sdn - 1} - -let gregorian_of_julian = conv gregorian_of_sdn 12 sdn_of_julian 12 -let julian_of_gregorian = conv julian_of_sdn 12 sdn_of_gregorian 12 - -let gregorian_of_french = conv gregorian_of_sdn 12 sdn_of_french 13 -let french_of_gregorian = conv french_of_sdn 13 sdn_of_gregorian 12 - -let gregorian_of_hebrew = conv gregorian_of_sdn 12 sdn_of_hebrew 13 -let hebrew_of_gregorian = conv hebrew_of_sdn 13 sdn_of_gregorian 12 + { day; month; year; delta = 0; kind = Hebrew } (* Moon phases *) (* Borrowed from G.Satre of CNRS's program found at: @@ -447,9 +451,7 @@ let hebrew_of_gregorian = conv hebrew_of_sdn 13 sdn_of_gregorian 12 and transforming for interface sdn -> moon-day: but I did not understand everything and the code could perhaps be improved *) -type ('a, 'b) found = - Found of 'a - | NotYetFound of 'b +type ('a, 'b) found = Found of 'a | NotYetFound of 'b type moon_phase = NewMoon | FirstQuarter | FullMoon | LastQuarter let jjdate date_JJD = @@ -466,13 +468,11 @@ let jjdate date_JJD = let d = float (truncate (365.25 *. c)) in let e = float (truncate ((b -. d) /. 30.6001)) in let day = truncate (b -. d -. float (truncate (30.6001 *. e))) in - let month = - if e < 13.5 then truncate (e -. 1.0) else truncate (e -. 13.0) - in + let month = if e < 13.5 then truncate (e -. 1.0) else truncate (e -. 13.0) in let year = if month >= 3 then truncate (c -. 4716.0) else truncate (c -. 4715.0) in - day, month, year + (day, month, year) let is_leap_year year = if year mod 4 = 0 then @@ -490,34 +490,34 @@ let init_moon_age month day leap_year = let testmon i date first_moon_age_found date_JJD month_day moon_age = let d = float date.year /. 100.0 in - let tetus = 32.23 *. (d -. 18.30) *. (d -. 18.30) -. 15.0 in + let tetus = (32.23 *. (d -. 18.30) *. (d -. 18.30)) -. 15.0 in let tetuj = tetus /. 86400.0 in let date_JJD = date_JJD +. 0.0003472222 -. tetuj in - let (day, month, year) = jjdate date_JJD in + let day, month, year = jjdate date_JJD in let leap_year = is_leap_year year in let inside_month = month = date.month in - let (month_day, moon_age) = - if i = 0 && (date.month > month || month = 12 && date.month = 1) && - not first_moon_age_found - then - 1, init_moon_age month day leap_year - else month_day, moon_age + let month_day, moon_age = + if + i = 0 + && (date.month > month || (month = 12 && date.month = 1)) + && not first_moon_age_found + then (1, init_moon_age month day leap_year) + else (month_day, moon_age) in - inside_month, date_JJD, leap_year, month_day, moon_age + (inside_month, date_JJD, leap_year, month_day, moon_age) -let affmoph i date_JJD leap_year first_moon_age_found month_day moon_age - date = +let affmoph i date_JJD leap_year first_moon_age_found month_day moon_age date = let tabjm = [| 31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |] in - let (day, month, year) = jjdate date_JJD in + let day, month, year = jjdate date_JJD in let fracj = mod_float (date_JJD +. 0.5) 1.0 in let hh = fracj *. 24.0 in let hh = int_of_float (floor hh +. 0.1) in - let fracj = fracj -. float hh /. 24.0 in + let fracj = fracj -. (float hh /. 24.0) in let mm = fracj *. 1440.0 in let mm = int_of_float (floor mm +. 0.1) in let hh = if hh = 24 then - let jfin = tabjm.(month-1) in + let jfin = tabjm.(month - 1) in let _ = assert (leap_year = is_leap_year year) in let jfin = if month = 2 && leap_year then 29 else jfin in if day < jfin then 0 else hh @@ -530,15 +530,15 @@ let affmoph i date_JJD leap_year first_moon_age_found month_day moon_age else if month_day = date.day then let r = match i with - 0 -> Some (NewMoon, hh, mm), 1 - | 1 -> Some (FirstQuarter, hh, mm), moon_age - | 2 -> Some (FullMoon, hh, mm), moon_age - | _ -> Some (LastQuarter, hh, mm), moon_age + | 0 -> (Some (NewMoon, hh, mm), 1) + | 1 -> (Some (FirstQuarter, hh, mm), moon_age) + | 2 -> (Some (FullMoon, hh, mm), moon_age) + | _ -> (Some (LastQuarter, hh, mm), moon_age) in Found r else - let (moon_age, first_moon_age_found) = - if i = 0 then 2, true else moon_age + 1, first_moon_age_found + let moon_age, first_moon_age_found = + if i = 0 then (2, true) else (moon_age + 1, first_moon_age_found) in NotYetFound (first_moon_age_found, month_day + 1, moon_age) in @@ -547,16 +547,29 @@ let affmoph i date_JJD leap_year first_moon_age_found month_day moon_age let moon_phase_of_gregorian date = let pi314 = 3.141592653589793 in let tabm = - [| 0.041; 0.126; 0.203; 0.288; 0.370; 0.455; 0.537; 0.622; 0.707; 0.789; - 0.874; 0.956 |] + [| + 0.041; + 0.126; + 0.203; + 0.288; + 0.370; + 0.455; + 0.537; + 0.622; + 0.707; + 0.789; + 0.874; + 0.956; + |] in - let (year, date_month) = - if date.month = 1 then date.year - 1, 12 else date.year, date.month - 1 + let year, date_month = + if date.month = 1 then (date.year - 1, 12) else (date.year, date.month - 1) in - let year = float year +. tabm.(date_month-1) in + let year = float year +. tabm.(date_month - 1) in let ini_k = let k = (year -. 1900.0) *. 12.3685 in - let k = float (truncate k) -. 0.25 in if k < 0.0 then k -. 1. else k + let k = float (truncate k) -. 0.25 in + if k < 0.0 then k -. 1. else k in let rad = pi314 /. 180.0 in let rec loop ii prev_k leap_year first_moon_age_found month_day moon_age = @@ -569,7 +582,7 @@ let moon_phase_of_gregorian date = in let rec loop month_day moon_age = if month_day <= nbdays then - if month_day = date.day then None, moon_age + if month_day = date.day then (None, moon_age) else loop (month_day + 1) (moon_age + 1) else failwith "moon_phase" in @@ -580,51 +593,68 @@ let moon_phase_of_gregorian date = let t2 = t *. t in let t3 = t *. t2 in let j = - 2415020.75933 +. 29.5305888531 *. k +. 0.0001337 *. t2 -. - 0.000000150 *. t3 +. - 0.00033 *. sin (rad *. (166.56 +. 132.87 *. t -. 0.009 *. t2)) + 2415020.75933 +. (29.5305888531 *. k) +. (0.0001337 *. t2) + -. (0.000000150 *. t3) + +. (0.00033 *. sin (rad *. (166.56 +. (132.87 *. t) -. (0.009 *. t2)))) in let m = - rad *. - (359.2242 +. 29.10535608 *. k -. 0.0000333 *. t2 -. 0.00000347 *. t3) + rad + *. (359.2242 +. (29.10535608 *. k) -. (0.0000333 *. t2) + -. (0.00000347 *. t3)) in let m = mod_float m (2.0 *. pi314) in let mp = - rad *. - (306.0253 +. 385.81691806 *. k +. 0.0107306 *. t2 +. 0.00001236 *. t3) + rad + *. (306.0253 +. (385.81691806 *. k) +. (0.0107306 *. t2) + +. (0.00001236 *. t3)) in let mp = mod_float mp (2. *. pi314) in let f = - rad *. - (21.2964 +. 390.67050646 *. k -. 0.0016528 *. t2 -. 0.00000239 *. t3) + rad + *. (21.2964 +. (390.67050646 *. k) -. (0.0016528 *. t2) + -. (0.00000239 *. t3)) in let f = mod_float f (2. *. pi314) in let i = ii mod 4 in let date_JJD = if i = 0 || i = 2 then - j +. (0.1734 -. 0.000393 *. t) *. sin m +. - 0.0021 *. sin (2.0 *. m) -. 0.4068 *. sin mp +. - 0.0161 *. sin (2.0 *. mp) -. 0.0004 *. sin (3.0 *. mp) +. - 0.0104 *. sin (2.0 *. f) -. 0.0051 *. sin (m +. mp) -. - 0.0074 *. sin (m -. mp) +. 0.0004 *. sin (2.0 *. f +. m) -. - 0.0004 *. sin (2.0 *. f -. m) -. 0.0006 *. sin (2.0 *. f +. mp) +. - 0.001 *. sin (2.0 *. f -. mp) +. 0.0005 *. sin (m +. 2.0 *. mp) + j + +. ((0.1734 -. (0.000393 *. t)) *. sin m) + +. (0.0021 *. sin (2.0 *. m)) + -. (0.4068 *. sin mp) + +. (0.0161 *. sin (2.0 *. mp)) + -. (0.0004 *. sin (3.0 *. mp)) + +. (0.0104 *. sin (2.0 *. f)) + -. (0.0051 *. sin (m +. mp)) + -. (0.0074 *. sin (m -. mp)) + +. (0.0004 *. sin ((2.0 *. f) +. m)) + -. (0.0004 *. sin ((2.0 *. f) -. m)) + -. (0.0006 *. sin ((2.0 *. f) +. mp)) + +. (0.001 *. sin ((2.0 *. f) -. mp)) + +. (0.0005 *. sin (m +. (2.0 *. mp))) else let j = - j +. (0.1721 -. 0.0004 *. t) *. sin m +. - 0.0021 *. sin (2.0 *. m) -. 0.6280 *. sin mp +. - 0.0089 *. sin (2.0 *. mp) -. 0.0004 *. sin (3.0 *. mp) +. - 0.0079 *. sin (2.0 *. f) -. 0.0119 *. sin (m +. mp) -. - 0.0047 *. sin (m -. mp) +. 0.0003 *. sin (2.0 *. f +. m) -. - 0.0004 *. sin (2.0 *. f -. m) -. 0.0006 *. sin (2.0 *. f +. mp) +. - 0.0021 *. sin (2.0 *. f -. mp) +. - 0.0003 *. sin (m +. 2.0 *. mp) +. - 0.0004 *. sin (m -. 2.0 *. mp) -. 0.0003 *. sin (2.0 *. m +. mp) + j + +. ((0.1721 -. (0.0004 *. t)) *. sin m) + +. (0.0021 *. sin (2.0 *. m)) + -. (0.6280 *. sin mp) + +. (0.0089 *. sin (2.0 *. mp)) + -. (0.0004 *. sin (3.0 *. mp)) + +. (0.0079 *. sin (2.0 *. f)) + -. (0.0119 *. sin (m +. mp)) + -. (0.0047 *. sin (m -. mp)) + +. (0.0003 *. sin ((2.0 *. f) +. m)) + -. (0.0004 *. sin ((2.0 *. f) -. m)) + -. (0.0006 *. sin ((2.0 *. f) +. mp)) + +. (0.0021 *. sin ((2.0 *. f) -. mp)) + +. (0.0003 *. sin (m +. (2.0 *. mp))) + +. (0.0004 *. sin (m -. (2.0 *. mp))) + -. (0.0003 *. sin ((2.0 *. m) +. mp)) in - if i = 1 then j +. 0.0028 -. 0.0004 *. cos m +. 0.0003 *. cos mp - else j -. 0.0028 +. 0.0004 *. cos m -. 0.0003 *. cos mp + if i = 1 then j +. 0.0028 -. (0.0004 *. cos m) +. (0.0003 *. cos mp) + else j -. 0.0028 +. (0.0004 *. cos m) -. (0.0003 *. cos mp) in - let (inside_month, date_JJD, leap_year, month_day, moon_age) = + let inside_month, date_JJD, leap_year, month_day, moon_age = testmon i date first_moon_age_found date_JJD month_day moon_age in if inside_month then @@ -632,7 +662,7 @@ let moon_phase_of_gregorian date = affmoph i date_JJD leap_year first_moon_age_found month_day moon_age date with - NotYetFound (first_moon_age_found, month_day, moon_age) -> + | NotYetFound (first_moon_age_found, month_day, moon_age) -> loop (ii + 1) k leap_year first_moon_age_found month_day moon_age | Found x -> x else loop (ii + 1) k leap_year first_moon_age_found month_day moon_age @@ -643,3 +673,105 @@ let moon_phase_of_sdn jd = let date = gregorian_of_sdn jd in if date.year < -4000 || date.year > 2500 then failwith "moon_phase_of_sdn" else moon_phase_of_gregorian date + +let kind_to_string : type a. a kind -> string = + fun kind -> + match kind with + | Gregorian -> "Gregorian" + | Julian -> "Julian" + | French -> "French" + | Hebrew -> "Hebrew" + +let to_sdn : type a. a date -> sdn = + fun date -> + match date.kind with + | Gregorian -> sdn_of_gregorian date + | Julian -> sdn_of_julian date + | French -> sdn_of_french date + | Hebrew -> sdn_of_hebrew date + +let make : + type a. + a kind -> + day:int -> + month:int -> + year:int -> + delta:int -> + (a date, string) result = + fun kind ~day ~month ~year ~delta -> + let gregorian_nb_days_upper_bound = + [| 31; 29; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |] + in + let hebrew_nb_days_upper_bound = + (* last two are for Adar I and II; + Adar II should be 29, but we keep it simple and do not check for leap years *) + [| 30; 29; 30; 29; 30; 29; 30; 30; 30; 29; 30; 30; 30 |] + in + (* A year zero does not exist in the Anno Domini (AD) calendar year + system commonly used to number years in the Gregorian + and Julian calendar. *) + let check_greg = + year <> 0 && month <= 12 && day <= gregorian_nb_days_upper_bound.(month - 1) + in + let valid = + day > 0 && month > 0 + && + match kind with + | Gregorian -> check_greg + | Julian -> + (* Julian calendar was different before 45 BC *) + year < -45 || check_greg + | Hebrew -> month <= 13 && day <= hebrew_nb_days_upper_bound.(month - 1) + | French -> month <= 12 && day <= 30 + in + if valid then + let d = { day; month; year; delta; kind } in + if to_sdn d <= sdn_hebrew_anno_mundi then + Error + (Printf.sprintf + "Invalid value; this date is before the range of suported dates: \ + day=%d month=%d year=%d delta=%d kind=%s" + day month year delta (kind_to_string kind)) + else Ok d + else + Error + (Printf.sprintf "Invalid value: day=%d month=%d year=%d delta=%d kind=%s" + day month year delta (kind_to_string kind)) + +let of_sdn : type a. a kind -> sdn -> (a date, string) result = + fun kind sdn -> + if sdn <= sdn_hebrew_anno_mundi then + Error + (Printf.sprintf "SDN %d is before SDN %d (start of the world)!" sdn + sdn_hebrew_anno_mundi) + else + Ok + (match kind with + | Gregorian -> gregorian_of_sdn sdn + | Julian -> julian_of_sdn sdn + | French -> french_of_sdn sdn + | Hebrew -> hebrew_of_sdn sdn) + +let to_gregorian : type a. a date -> gregorian date = + fun date -> + match date.kind with + | Gregorian -> date + | Julian | French | Hebrew -> to_sdn date |> gregorian_of_sdn + +let to_julian : type a. a date -> julian date = + fun date -> + match date.kind with + | Julian -> date + | Gregorian | French | Hebrew -> to_sdn date |> julian_of_sdn + +let to_french : type a. a date -> french date = + fun date -> + match date.kind with + | French -> date + | Gregorian | Julian | Hebrew -> to_sdn date |> french_of_sdn + +let to_hebrew : type a. a date -> hebrew date = + fun date -> + match date.kind with + | Hebrew -> date + | Gregorian | Julian | French -> to_sdn date |> hebrew_of_sdn diff --git a/lib/calendars.mli b/lib/calendars.mli index 957a6cb..252c88c 100644 --- a/lib/calendars.mli +++ b/lib/calendars.mli @@ -1,22 +1,38 @@ -type d = { day : int ; month : int ; year : int ; delta : int } +type gregorian +type julian +type french +type hebrew -val gregorian_of_sdn : int -> d -val julian_of_sdn : int -> d -val french_of_sdn : int -> d -val hebrew_of_sdn : int -> d +type _ kind = + | Gregorian : gregorian kind + | Julian : julian kind + | French : french kind + | Hebrew : hebrew kind -val sdn_of_gregorian : d -> int -val sdn_of_julian : d -> int -val sdn_of_french : d -> int -val sdn_of_hebrew : d -> int - -val gregorian_of_julian : d -> d -val julian_of_gregorian : d -> d -val gregorian_of_french : d -> d -val french_of_gregorian : d -> d -val gregorian_of_hebrew : d -> d -val hebrew_of_gregorian : d -> d +type 'a date = private { + day : int; + month : int; + year : int; + delta : int; + kind : 'a kind; +} +type sdn = int type moon_phase = NewMoon | FirstQuarter | FullMoon | LastQuarter -val moon_phase_of_sdn : int -> (moon_phase * int * int) option * int +val make : + 'a kind -> + day:int -> + month:int -> + year:int -> + delta:sdn -> + ('a date, string) result + +val of_sdn : 'a kind -> sdn -> ('a date, string) result +val to_sdn : 'a date -> sdn +val to_gregorian : 'a date -> gregorian date +val to_julian : 'a date -> julian date +val to_french : 'a date -> french date +val to_hebrew : 'a date -> hebrew date +val moon_phase_of_sdn : sdn -> (moon_phase * int * int) option * int +val sdn_hebrew_anno_mundi : sdn diff --git a/lib/dune b/lib/dune index 027d65f..a3072a6 100644 --- a/lib/dune +++ b/lib/dune @@ -1,5 +1,4 @@ (library (name calendars) (public_name calendars) - (modules calendars) -) + (modules calendars)) diff --git a/test/dune b/test/dune index 8b65081..d84b48c 100644 --- a/test/dune +++ b/test/dune @@ -1,7 +1,4 @@ -(executable - (name test_julian) - (libraries ounit2 calendars) - (modules test_julian) -) - -(alias (name runtest) (action (run %{exe:test_julian.exe}) ) ) +(tests + (names test) + (libraries ounit2 calendars) + (modules test)) diff --git a/test/test.ml b/test/test.ml new file mode 100644 index 0000000..1014610 --- /dev/null +++ b/test/test.ml @@ -0,0 +1,87 @@ +(* Original test is from Scott E. Lee + * Copyright 1993-1995, Scott E. Lee, all rights reserved. + * Permission granted to use, copy, modify, distribute and sell so long as + * the above copyright and this permission statement are retained in all + * copies. THERE IS NO WARRANTY - USE AT YOUR OWN RISK. + * + * OCaml port is from Julien Sagot + * Copyright 2019, Julien Sagot + *) + +open OUnit +open Calendars + +(* gregorian and julian calendar differ by their leap year rules *) +let julian_feb_len year = + if (if year < 0 then year + 1 else year) mod 4 = 0 then 29 else 28 + +let gregorian_feb_len year = + let year = if year < 0 then year + 1 else year in + if year mod 4 = 0 && (year mod 100 <> 0 || year mod 400 = 0) then 29 else 28 + +let month_len = [| 31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |] + +let assert_equal_dmy = + assert_equal ~printer:(fun { day; month; year; _ } -> + Printf.sprintf "{ day:(%d) ; month:(%d) ; year:(%d) }" day month year) + +let assert_equal_sdn = assert_equal ~printer:string_of_int + +let kind_to_string : type a. a kind -> string = + fun kind -> + match kind with + | Gregorian -> "Gregorian" + | Julian -> "Julian" + | French -> "French" + | Hebrew -> "Hebrew" + +let test : type a. a kind -> (int -> a date) -> (int -> int) -> int -> test = + fun kind of_sdn feb_len sdn_offset -> + Printf.sprintf "%s <-> SDN" (kind_to_string kind) >:: fun _ -> + (* we start the loop on the first day of the Hebrew calendar + in the Julian calendar (day=7; month= 7; year=-3761); + but this does not correspond to the same SDN for Julian and Gregorian + this is why we have a +30 offset for Gregorian calendar *) + let buggy_hebrew_dates = ref 0 in + let sdn = ref sdn_offset in + let year_start = -3761 in + for year = year_start to 10000 do + (* year zero does not exists *) + if year <> 0 then + let month_start = if year = year_start then 10 else 1 in + for month = month_start to 12 do + let day_start = + if year = year_start && month = month_start then 7 else 1 + in + let stop = if month = 2 then feb_len year else month_len.(month - 1) in + for day = day_start to stop do + let d = Result.get_ok @@ make kind ~day ~month ~year ~delta:0 in + let sdn' = to_sdn d in + assert_equal_sdn !sdn sdn'; + assert_equal_dmy d (of_sdn sdn'); + assert_equal_sdn !sdn (to_gregorian d |> to_sdn); + assert_equal_sdn !sdn (to_julian d |> to_sdn); + assert_equal_sdn !sdn (to_french d |> to_sdn); + (* TODO some date/sdn conversion are buggy in Hebrew; + (never more than +/- 2 SDN) *) + if !sdn <> (to_hebrew d |> to_sdn) then incr buggy_hebrew_dates; + incr sdn + done + done + done; + Printf.eprintf "bad to_hebrew => to_sdn round trip: %d\n" !buggy_hebrew_dates + +let _ = + run_test_tt_main + ("test suite for Calendars" + >::: [ + (* It is probably irrelevant to test both Julian and Gregorian here... *) + test Julian + (fun sdn -> of_sdn Julian sdn |> Result.get_ok) + julian_feb_len + (sdn_hebrew_anno_mundi + 1); + test Gregorian + (fun sdn -> of_sdn Gregorian sdn |> Result.get_ok) + gregorian_feb_len + (sdn_hebrew_anno_mundi + 1 + 30); + ]) diff --git a/test/test_julian.ml b/test/test_julian.ml deleted file mode 100644 index 38ff3ea..0000000 --- a/test/test_julian.ml +++ /dev/null @@ -1,44 +0,0 @@ -(* Original test is from Scott E. Lee - * Copyright 1993-1995, Scott E. Lee, all rights reserved. - * Permission granted to use, copy, modify, distribute and sell so long as - * the above copyright and this permission statement are retained in all - * copies. THERE IS NO WARRANTY - USE AT YOUR OWN RISK. - * - * OCaml port is from Julien Sagot - * Copyright 2019, Julien Sagot - *) - -open OUnit -open Calendars - -let febLength year : int = - if (if year < 0 then year + 1 else year) mod 4 = 0 then 29 else 28 - -let monthLength : int array = [| 31 ; 28 ; 31 ; 30 ; 31 ; 30 ; 31 ; 31 ; 30 ; 31 ; 30 ; 31 |] - -let assert_equal_dmy = - assert_equal - ~printer:(fun { day ; month ; year ; _ } -> - Printf.sprintf "{ day:(%d) ; month:(%d) ; year:(%d) }" day month year ) - -let assert_equal_sdn = - assert_equal ~printer:string_of_int - -let _ = - run_test_tt_main begin - "Julian <-> SDN" >:: - fun _ -> - let sdn = ref 0 in - for year = -4713 to 10000 do - if year <> 0 then - for month = 1 to 12 do - for day = 1 to (if month = 2 then febLength (year) else Array.get monthLength @@ month - 1) do - let d = { day ; month ; year ; delta = 0 } in - let sdn' = sdn_of_julian d in - assert_equal_sdn !sdn sdn' ; - assert_equal_dmy d (julian_of_sdn sdn') ; - incr sdn - done - done - done - end