1------------------------------------------------------------------------------ 2-- -- 3-- Matreshka Project -- 4-- -- 5-- Localization, Internationalization, Globalization for Ada -- 6-- -- 7-- Runtime Library Component -- 8-- -- 9------------------------------------------------------------------------------ 10-- -- 11-- Copyright © 2011-2013, Vadim Godunko <vgodunko@gmail.com> -- 12-- All rights reserved. -- 13-- -- 14-- Redistribution and use in source and binary forms, with or without -- 15-- modification, are permitted provided that the following conditions -- 16-- are met: -- 17-- -- 18-- * Redistributions of source code must retain the above copyright -- 19-- notice, this list of conditions and the following disclaimer. -- 20-- -- 21-- * Redistributions in binary form must reproduce the above copyright -- 22-- notice, this list of conditions and the following disclaimer in the -- 23-- documentation and/or other materials provided with the distribution. -- 24-- -- 25-- * Neither the name of the Vadim Godunko, IE nor the names of its -- 26-- contributors may be used to endorse or promote products derived from -- 27-- this software without specific prior written permission. -- 28-- -- 29-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -- 30-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -- 31-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -- 32-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -- 33-- HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- 34-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -- 35-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- 36-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- 37-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- 38-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- 39-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- 40-- -- 41------------------------------------------------------------------------------ 42-- $Revision: 3662 $ $Date: 2013-01-20 22:31:23 +0400 (Sun, 20 Jan 2013) $ 43------------------------------------------------------------------------------ 44 45package body Matreshka.Internals.Calendars.Gregorian is 46 47 use type Julian_Day_Number; 48 49 -- Gregorian_Epoch : constant := 1_721_426; 50 51 Min_Year : constant := -10_000; 52 Julian_Epoch : constant := 1_931_305; 53 -- days from Min_Year to zero julian day 54 55 Days_In_4_Years : constant := 365 * 4 + 1; 56 Days_In_400_Years : constant := ((365 * 4 + 1) * 25 - 1) * 4 + 1; 57 58 procedure Split 59 (Julian_Day : Julian_Day_Number; 60 Shifted_Year : out Julian_Day_Number; 61 Day_In_Year : out Julian_Day_Number); 62 63 --------- 64 -- Day -- 65 --------- 66 67 function Day (Julian_Day : Julian_Day_Number) return Day_Number is 68 Days : Julian_Day_Number; 69 Years : Julian_Day_Number; 70 Shifted_Month : Julian_Day_Number; 71 72 begin 73 Split (Julian_Day, Shifted_Year => Years, Day_In_Year => Days); 74 Shifted_Month := (5 * Days + 2) / 153; 75 76 return Day_Number (Days - (153 * Shifted_Month + 2) / 5 + 1); 77 end Day; 78 79 ----------------- 80 -- Day_Of_Week -- 81 ----------------- 82 83 function Day_Of_Week 84 (Julian_Day : Julian_Day_Number) return Day_Of_Week_Number is 85 begin 86 return Day_Of_Week_Number ((Julian_Day mod 7) + 1); 87 end Day_Of_Week; 88 89 ----------------- 90 -- Day_Of_Year -- 91 ----------------- 92 93 function Day_Of_Year 94 (Julian_Day : Julian_Day_Number) return Day_Of_Year_Number 95 is 96 Days : Julian_Day_Number; 97 Years : Julian_Day_Number; 98 99 begin 100 Split (Julian_Day, Shifted_Year => Years, Day_In_Year => Days); 101 102 return Day_Of_Year_Number (Days + 1); 103 end Day_Of_Year; 104 105 ------------------- 106 -- Days_In_Month -- 107 ------------------- 108 109 function Days_In_Month (Date : Julian_Day_Number) return Day_Number is 110 begin 111 return Days_In_Month (Year (Date), Month (Date)); 112 end Days_In_Month; 113 114 ------------------- 115 -- Days_In_Month -- 116 ------------------- 117 118 function Days_In_Month 119 (Year : Year_Number; Month : Year_Number) return Day_Number 120 is 121 -- Length of months has some kind of regularity and circularity: 122 -- 123 -- 12 31 7 31 124 -- 1 31 8 31 125 -- 2 28/29 9 30 126 -- 3 31 10 31 127 -- 4 30 11 30 128 -- 5 31 129 -- 6 30 130 -- 131 -- To make December be first month the reminder of 12 of Month is 132 -- computed. Reminder of 7 is used to compute number of month in cycle. 133 -- Now, base number of days can be computed as: 134 -- 135 -- Base := 30 + Month_In_Cycle mod 2 136 -- 137 -- Later, correction is computed: 138 -- 139 -- +1, then month_in_cycle = 0, so, for July and December. 140 -- -1, then Month = 2 and Is_Leap_Year (Year), so for February of leap 141 -- year 142 -- -2, then Month = 2 and not Is_Leap_Year (Year), so for February of 143 -- non leap year. 144 -- 0, otherwise 145 146 Month_In_Cycle : constant Integer := (Month mod 12) mod 7; 147 Base : Integer := 30 + (Month_In_Cycle mod 2); 148 149 begin 150 if Month_In_Cycle = 0 then 151 Base := Base + 1; 152 153 elsif Month = 2 then 154 Base := Base - 1; 155 156 if not Is_Leap_Year (Year) then 157 Base := Base - 1; 158 end if; 159 end if; 160 161 return Base; 162 end Days_In_Month; 163 164 ------------------ 165 -- Days_In_Year -- 166 ------------------ 167 168 function Days_In_Year 169 (Date : Julian_Day_Number) return Day_Of_Year_Number is 170 begin 171 return Days_In_Year (Year (Date)); 172 end Days_In_Year; 173 174 ------------------ 175 -- Days_In_Year -- 176 ------------------ 177 178 function Days_In_Year (Year : Year_Number) return Day_Of_Year_Number is 179 begin 180 if Is_Leap_Year (Year) then 181 return 366; 182 183 else 184 return 365; 185 end if; 186 end Days_In_Year; 187 188 ------------------ 189 -- Is_Leap_Year -- 190 ------------------ 191 192 function Is_Leap_Year (Date : Julian_Day_Number) return Boolean is 193 begin 194 return Is_Leap_Year (Year (Date)); 195 end Is_Leap_Year; 196 197 ------------------ 198 -- Is_Leap_Year -- 199 ------------------ 200 201 function Is_Leap_Year (Year : Year_Number) return Boolean is 202 begin 203 return Year mod 4 = 0 and (Year mod 100 /= 0 or Year mod 400 = 0); 204 end Is_Leap_Year; 205 206 ---------------- 207 -- Julian_Day -- 208 ---------------- 209 210 function Julian_Day 211 (Year : Year_Number; 212 Month : Month_Number; 213 Day : Day_Number) return Julian_Day_Number 214 is 215 Shifted_Year : constant Julian_Day_Number 216 := Julian_Day_Number (Year - Min_Year) - Boolean'Pos (Month <= 2); 217 Shifted_Month : constant Julian_Day_Number 218 := Julian_Day_Number (Month - 3) mod 12; 219 220 begin 221 return 222 Julian_Day_Number (Day - 1) 223 + (153 * Shifted_Month + 2) / 5 -- first day of year for month 224 + 365 * Shifted_Year 225 + Shifted_Year / 4 -- number of leap years 226 - Shifted_Year / 100 -- excluding 100 227 + Shifted_Year / 400 -- includeing 400 228 - Julian_Epoch; -- days from Min_Year to zero julian day 229 end Julian_Day; 230 231 ----------- 232 -- Month -- 233 ----------- 234 235 function Month (Julian_Day : Julian_Day_Number) return Month_Number is 236 Days : Julian_Day_Number; 237 Years : Julian_Day_Number; 238 Shifted_Month : Julian_Day_Number; 239 240 begin 241 Split (Julian_Day, Shifted_Year => Years, Day_In_Year => Days); 242 Shifted_Month := (5 * Days + 2) / 153; 243 244 return Month_Number (((Shifted_Month + 2) mod 12) + 1); 245 end Month; 246 247 ----------- 248 -- Split -- 249 ----------- 250 251 procedure Split 252 (Date : Julian_Day_Number; 253 Year : out Year_Number; 254 Month : out Month_Number; 255 Day : out Day_Number) 256 is 257 Days : Julian_Day_Number; 258 Years : Julian_Day_Number; 259 Shifted_Month : Julian_Day_Number; 260 261 begin 262 Split (Date, Shifted_Year => Years, Day_In_Year => Days); 263 Shifted_Month := (5 * Days + 2) / 153; 264 265 Year := Year_Number (Years + Boolean'Pos (Days > 305) + Min_Year); 266 Month := Month_Number (((Shifted_Month + 2) mod 12) + 1); 267 Day := Day_Number (Days - (153 * Shifted_Month + 2) / 5 + 1); 268 end Split; 269 270 ----------- 271 -- Split -- 272 ----------- 273 274 procedure Split 275 (Julian_Day : Julian_Day_Number; 276 Shifted_Year : out Julian_Day_Number; 277 Day_In_Year : out Julian_Day_Number) 278 is 279 Days : Julian_Day_Number := Julian_Day + Julian_Epoch; 280 Years : Julian_Day_Number; 281 Centuries : constant Julian_Day_Number 282 := (4 * Days + 3) / Days_In_400_Years; 283 284 begin 285 Days := Days - Centuries * Days_In_400_Years / 4; 286 Years := (Days * 4 + 3) / Days_In_4_Years; 287 Day_In_Year := Days - Years * Days_In_4_Years / 4; 288 Shifted_Year := 100 * Centuries + Years; 289 end Split; 290 291 ---------- 292 -- Year -- 293 ---------- 294 295 function Year (Julian_Day : Julian_Day_Number) return Year_Number is 296 Days : Julian_Day_Number; 297 Years : Julian_Day_Number; 298 299 begin 300 Split (Julian_Day, Shifted_Year => Years, Day_In_Year => Days); 301 302 return Year_Number (Years + Boolean'Pos (Days > 305) + Min_Year); 303 end Year; 304 305end Matreshka.Internals.Calendars.Gregorian; 306