|
| 1 | +(***************************************************************************) |
| 2 | +(* Copyright (C) 2000-2013 LexiFi SAS. All rights reserved. *) |
| 3 | +(* *) |
| 4 | +(* This program is free software: you can redistribute it and/or modify *) |
| 5 | +(* it under the terms of the GNU General Public License as published *) |
| 6 | +(* by the Free Software Foundation, either version 3 of the License, *) |
| 7 | +(* or (at your option) any later version. *) |
| 8 | +(* *) |
| 9 | +(* This program is distributed in the hope that it will be useful, *) |
| 10 | +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) |
| 11 | +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) |
| 12 | +(* GNU General Public License for more details. *) |
| 13 | +(* *) |
| 14 | +(* You should have received a copy of the GNU General Public License *) |
| 15 | +(* along with this program. If not, see <http://www.gnu.org/licenses/>. *) |
| 16 | +(***************************************************************************) |
| 17 | + |
| 18 | +type date = int |
| 19 | + |
| 20 | +type gregorian = { |
| 21 | + year : int; |
| 22 | + month : int; |
| 23 | + day : int; |
| 24 | + hour : int; |
| 25 | + minute : int |
| 26 | + } |
| 27 | + |
| 28 | +let hours_in_day = 24 |
| 29 | +let minutes_in_day = hours_in_day * 60 |
| 30 | +let fminutes_in_day = float minutes_in_day |
| 31 | +let minutes_to_noon = (hours_in_day / 2) * 60 |
| 32 | + |
| 33 | +(* |
| 34 | + Communications of the ACM by Henry F. Fliegel and Thomas C. Van Flandern, |
| 35 | + ``A Machine Algorithm for Processing Calendar Dates'', |
| 36 | + CACM, volume 11, number 10, October 1968, p. 657 |
| 37 | +*) |
| 38 | +let date_of_gregorian {year = y; month = m; day = d; hour = hr; minute = mn} = |
| 39 | + ( |
| 40 | + (match m with |
| 41 | + | 1 | 2 -> |
| 42 | + ( 1461 * ( y + 4800 - 1 ) ) / 4 + |
| 43 | + ( 367 * ( m + 10 ) ) / 12 - |
| 44 | + ( 3 * ( ( y + 4900 - 1 ) / 100 ) ) / 4 |
| 45 | + | _ -> |
| 46 | + ( 1461 * ( y + 4800 ) ) / 4 + |
| 47 | + ( 367 * ( m - 2 ) ) / 12 - |
| 48 | + ( 3 * ( ( y + 4900 ) / 100 ) ) / 4) |
| 49 | + + d - 32075 - 2444238) * minutes_in_day |
| 50 | + + hr * 60 + mn |
| 51 | + |
| 52 | +let gregorian_of_date minutes_since_epoch = |
| 53 | + let jul = minutes_since_epoch / minutes_in_day in |
| 54 | + let l = jul + 68569 + 2444238 in |
| 55 | + let n = ( 4 * l ) / 146097 in |
| 56 | + let l = l - ( 146097 * n + 3 ) / 4 in |
| 57 | + let i = ( 4000 * ( l + 1 ) ) / 1461001 in |
| 58 | + let l = l - ( 1461 * i ) / 4 + 31 in |
| 59 | + let j = ( 80 * l ) / 2447 in |
| 60 | + let d = l - ( 2447 * j ) / 80 in |
| 61 | + let l = j / 11 in |
| 62 | + let m = j + 2 - ( 12 * l ) in |
| 63 | + let y = 100 * ( n - 49 ) + i + l in |
| 64 | + let daytime = minutes_since_epoch mod minutes_in_day in |
| 65 | + if daytime = minutes_to_noon |
| 66 | + then {year = y; month = m; day = d; hour = 12; minute = 0} |
| 67 | + else {year = y; month = m; day = d; hour = daytime / 60; minute = daytime mod 60} |
| 68 | + |
| 69 | +let check_date ~year ~month ~day = |
| 70 | + 1 <= day && |
| 71 | + 1 <= month && month <= 12 && |
| 72 | + 1980 <= year && year <= 2299 && |
| 73 | + begin |
| 74 | + day <= 28 || |
| 75 | + match month with |
| 76 | + | 2 -> day = 29 && year mod 4 = 0 && (year = 2000 || (year mod 100 <> 0)) |
| 77 | + (* we don't check y mod 400 because 2000 is ok and we don't support |
| 78 | + neither 1600 nor 2400. *) |
| 79 | + | 4 | 6 | 9 | 11 -> day <= 30 |
| 80 | + | _ -> day <= 31 |
| 81 | + end |
| 82 | + |
| 83 | +let of_string s : date = |
| 84 | + let sub ofs len = |
| 85 | + let rec sub acc ofs len = |
| 86 | + if len = 0 |
| 87 | + then acc |
| 88 | + else sub (acc * 10 + int_of_char(String.unsafe_get s ofs) - 48) (ofs + 1) (len - 1) |
| 89 | + in |
| 90 | + sub (int_of_char(String.unsafe_get s ofs) - 48) (ofs + 1) (len - 1) |
| 91 | + in |
| 92 | + if String.length s < 10 then invalid_arg "date_of_string"; |
| 93 | + let year = sub 0 4 in |
| 94 | + let month = sub 5 2 in |
| 95 | + let day = sub 8 2 in |
| 96 | + (* minimal coherence check of the date, just what is needed more than what the lexer is doing *) |
| 97 | + if check_date ~year ~month ~day then |
| 98 | + if String.length s < 16 |
| 99 | + then date_of_gregorian{year; month; day; hour=12; minute=0} |
| 100 | + else date_of_gregorian{year; month; day; hour=sub 11 2; minute=sub 14 2} |
| 101 | + else invalid_arg "date_of_string" |
| 102 | + |
| 103 | +let days_between t1 t2 = |
| 104 | + float (t1 - t2) /. fminutes_in_day |
| 105 | + |
| 106 | +let act_365 t1 t2 = (days_between t1 t2) /. 365. |
| 107 | + |
| 108 | +let leap y = (y mod 4 = 0) && ((y mod 100 <> 0) || (y mod 400 = 0)) |
| 109 | +let end_of_month year month = |
| 110 | + match month with |
| 111 | + | 2 when leap year -> 29 |
| 112 | + | 2 -> 28 |
| 113 | + | 4 | 6 | 9 | 11 -> 30 |
| 114 | + | _ -> 31 |
| 115 | +let add_months date nbmonths = |
| 116 | + let {year = y; month = m; day = d; hour = _; minute = _;} as date = gregorian_of_date date in |
| 117 | + let m = m + nbmonths in |
| 118 | + let y, m = y + (m-1) / 12, ((m-1) mod 12) + 1 in |
| 119 | + let y, m = if m <= 0 then y - 1, m + 12 else y, m in |
| 120 | + date_of_gregorian {date with year = y; month = m; day = min d (end_of_month y m)} |
| 121 | +let add_years date nbyears = add_months date (nbyears * 12) |
| 122 | + |
| 123 | +let max_date = of_string "2299-12-31T23:59:59" |
| 124 | +let min_date = of_string "1980-01-01T12:00:00" |
0 commit comments