module Data.Time.Calendar.OrdinalDate where
import Data.Time.Calendar.Days
import Data.Time.Calendar.Private
toOrdinalDate :: Day -> (Integer, Int)
toOrdinalDate (ModifiedJulianDay mjd) = (year, yd)
where
a = mjd + 678575
quadcent = div a 146097
b = mod a 146097
cent = min (div b 36524) 3
c = b - (cent * 36524)
quad = div c 1461
d = mod c 1461
y = min (div d 365) 3
yd = fromInteger (d - (y * 365) + 1)
year = quadcent * 400 + cent * 100 + quad * 4 + y + 1
fromOrdinalDate :: Integer -> Int -> Day
fromOrdinalDate year day = ModifiedJulianDay mjd
where
y = year - 1
mjd =
(fromIntegral
(clip
1
(if isLeapYear year
then 366
else 365)
day)) +
(365 * y) +
(div y 4) -
(div y 100) +
(div y 400) -
678576
fromOrdinalDateValid :: Integer -> Int -> Maybe Day
fromOrdinalDateValid year day = do
day' <-
clipValid
1
(if isLeapYear year
then 366
else 365)
day
let
y = year - 1
mjd = (fromIntegral day') + (365 * y) + (div y 4) - (div y 100) + (div y 400) - 678576
return (ModifiedJulianDay mjd)
showOrdinalDate :: Day -> String
showOrdinalDate date = (show4 y) ++ "-" ++ (show3 d)
where
(y, d) = toOrdinalDate date
isLeapYear :: Integer -> Bool
isLeapYear year = (mod year 4 == 0) && ((mod year 400 == 0) || not (mod year 100 == 0))
mondayStartWeek :: Day -> (Int, Int)
mondayStartWeek date = (fromInteger ((div d 7) - (div k 7)), fromInteger (mod d 7) + 1)
where
yd = snd (toOrdinalDate date)
d = (toModifiedJulianDay date) + 2
k = d - (toInteger yd)
sundayStartWeek :: Day -> (Int, Int)
sundayStartWeek date = (fromInteger ((div d 7) - (div k 7)), fromInteger (mod d 7))
where
yd = snd (toOrdinalDate date)
d = (toModifiedJulianDay date) + 3
k = d - (toInteger yd)
fromMondayStartWeek ::
Integer
-> Int
-> Int
-> Day
fromMondayStartWeek year w d = let
firstDay = fromOrdinalDate year 1
zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7
zbWeek = w - 1
zbDay = d - 1
zbYearDay = zbFirstMonday + 7 * toInteger zbWeek + toInteger zbDay
in addDays zbYearDay firstDay
fromMondayStartWeekValid ::
Integer
-> Int
-> Int
-> Maybe Day
fromMondayStartWeekValid year w d = do
d' <- clipValid 1 7 d
let
firstDay = fromOrdinalDate year 1
zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7
zbWeek = w - 1
zbDay = d' - 1
zbYearDay = zbFirstMonday + 7 * toInteger zbWeek + toInteger zbDay
zbYearDay' <-
clipValid
0
(if isLeapYear year
then 365
else 364)
zbYearDay
return $ addDays zbYearDay' firstDay
fromSundayStartWeek ::
Integer
-> Int
-> Int
-> Day
fromSundayStartWeek year w d = let
firstDay = fromOrdinalDate year 1
zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7
zbWeek = w - 1
zbDay = d
zbYearDay = zbFirstSunday + 7 * toInteger zbWeek + toInteger zbDay
in addDays zbYearDay firstDay
fromSundayStartWeekValid ::
Integer
-> Int
-> Int
-> Maybe Day
fromSundayStartWeekValid year w d = do
d' <- clipValid 0 6 d
let
firstDay = fromOrdinalDate year 1
zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7
zbWeek = w - 1
zbDay = d'
zbYearDay = zbFirstSunday + 7 * toInteger zbWeek + toInteger zbDay
zbYearDay' <-
clipValid
0
(if isLeapYear year
then 365
else 364)
zbYearDay
return $ addDays zbYearDay' firstDay