diff --git a/Data/Time/Calendar/Hebrew.hs b/Data/Time/Calendar/Hebrew.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Calendar/Hebrew.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +--------------------------------------------------------- +-- +-- Module : Data.Time.Calendar.Hebrew +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Conversion to and from Hebrew dates. +-- +--------------------------------------------------------- +module Data.Time.Calendar.Hebrew + ( HebrewDate (..) + , Month (..) + , fromHebrew + , toHebrew + -- * Testing + , testSuite + ) where + +import Control.Applicative ((<$>)) +import Control.Arrow +import Data.Time.Calendar (Day (..), fromGregorian) +import Data.Time.Calendar.WeekDate (toWeekDate) + +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck (testProperty) +import Test.HUnit hiding (Test) +import Test.QuickCheck + +import Data.Object +import Data.ByteString.Class + +------ data definitions +data Month = Tishrei | Cheshvan | Kislev | Tevet | Shevat + | Adar | Adar1 | Adar2 + | Nissan | Iyar | Sivan | Tammuz | Av | Elul + deriving (Eq, Ord, Show, Enum, Read) +data YearType = Chaser | Ksidran | Shlema + deriving (Eq, Ord, Show, Enum) +data YearLeap = Leap | NonLeap + deriving (Eq, Ord, Show, Enum) + +------ newtypes +newtype Chalakim = Chalakim Integer + deriving (Eq, Ord, Show, Enum, Num, Real, Integral) +type TotalChalakim = Chalakim + +newtype Shaot = Shaot Integer + deriving (Eq, Ord, Show, Enum, Num, Real, Integral) + +newtype Days = Days Integer + deriving (Eq, Ord, Show, Enum, Num, Real, Integral) +type Weekday = Days +type Julian = Days +type TotalDays = Days +type Date = Days + +newtype Weeks = Weeks Integer + deriving (Eq, Ord, Show, Enum, Num, Real, Integral) + +newtype Months = Months Integer + deriving (Eq, Ord, Show, Enum, Num, Real, Integral) + +newtype Years = Years Integer + deriving (Eq, Ord, Show, Enum, Num, Real, Integral) + +------ simple conversions +daysFromWeeks :: Weeks -> Days +daysFromWeeks (Weeks w) = Days (w * 7) + +weeksFromDays :: Days -> (Weeks, Days) +weeksFromDays (Days d) = (Weeks *** Days) (d `divMod` 7) + +shaotFromDays :: Days -> Shaot +shaotFromDays (Days d) = Shaot (d * 24) + +daysFromShaot :: Shaot -> (Days, Shaot) +daysFromShaot (Shaot s) = (Days *** Shaot) (s `divMod` 24) + +chalakimFromShaot :: Shaot -> Chalakim +chalakimFromShaot (Shaot s) = Chalakim (s * 1080) + +shaotFromChalakim :: Chalakim -> (Shaot, Chalakim) +shaotFromChalakim (Chalakim c) = (Shaot *** Chalakim) (c `divMod` 1080) + +chalakimFromMonths :: Months -> Chalakim +chalakimFromMonths (Months m) = Chalakim m * lunarMonth + +------ constants +lunarMonth :: TotalChalakim +lunarMonth = joinChalakim 0 29 12 793 + +------ building functions +splitChalakim :: TotalChalakim -> (Weeks, Weekday, Shaot, Chalakim) +splitChalakim tc = + let (s', c) = shaotFromChalakim tc + (d', s) = daysFromShaot s' + (w, d) = weeksFromDays d' + in (w, d, s, c) + +case_splitChalakim :: Assertion +case_splitChalakim = do + splitChalakim 1080 @=? (0, 0, 1, 0) + splitChalakim (15 * 24 * 1080) @=? (2, 1, 0, 0) + +joinChalakim :: Weeks -> Days -> Shaot -> Chalakim -> TotalChalakim +joinChalakim w d s c = + chalakimFromShaot (shaotFromDays (daysFromWeeks w + d) + s) + c + +prop_joinSplitChalakim :: TotalChalakim -> Bool +prop_joinSplitChalakim tc = tc == uncurry4 joinChalakim (splitChalakim tc) + where + uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e + uncurry4 f (a, b, c, d) = f a b c d + +------ year dependent constants +isLeapYear :: Years -> YearLeap +isLeapYear y = + let res = + case y `mod` 19 of + 3 -> Leap + 6 -> Leap + 8 -> Leap + 11 -> Leap + 14 -> Leap + 17 -> Leap + 0 -> Leap -- 19 + _ -> NonLeap + in res + +extraMonthCount :: Years -> Months +extraMonthCount i = + case i of + 0 -> 0 + 1 -> 0 + 2 -> 0 + 3 -> 1 + 4 -> 1 + 5 -> 1 + 6 -> 2 + 7 -> 2 + 8 -> 3 + 9 -> 3 + 10 -> 3 + 11 -> 4 + 12 -> 4 + 13 -> 4 + 14 -> 5 + 15 -> 5 + 16 -> 5 + 17 -> 6 + 18 -> 6 + _ -> error $ "extraMonthCount: " ++ show i + +monthsTilTishrei :: Years -> Months +monthsTilTishrei (Years i) = Months $ (235 * i - 234) `div` 19 + +monthsTilTishreiLong :: Years -> Months +monthsTilTishreiLong (Years y') = + let (machzorim, y) = (y' - 1) `divMod` 19 + base = Months $ (y' - 1) * 12 + machzorim * 7 + extra = extraMonthCount $ Years y + in base + extra + +case_monthsTilTishrei :: Assertion +case_monthsTilTishrei = do + 0 @=? monthsTilTishrei 1 + 12 @=? monthsTilTishrei 2 + 24 @=? monthsTilTishrei 3 + 37 @=? monthsTilTishrei 4 + 235 @=? monthsTilTishrei 20 + +prop_monthsTilTishrei :: Years -> Bool +prop_monthsTilTishrei y = monthsTilTishrei y == monthsTilTishreiLong y + +firstTishrei :: TotalChalakim +firstTishrei = joinChalakim 0 1 5 204 + +moladTishrei :: Years -> TotalChalakim +moladTishrei y = chalakimFromMonths (monthsTilTishrei y) + firstTishrei + +case_moladTishrei :: Assertion +case_moladTishrei = do + let testMolad w x y z = do + let (_, d, s, c) = splitChalakim $ moladTishrei w + in (w, d, s, c) @?= (w, x, y, z) + testMolad 5764 5 10 491 + testMolad 1 1 5 204 + testMolad 2 5 14 0 + testMolad 3 2 22 876 + testMolad 4 1 20 385 + testMolad 5 6 5 181 + testMolad 6 3 13 1057 + testMolad 7 2 11 566 + testMolad 8 6 20 362 + testMolad 9 5 17 951 + testMolad 10 3 2 747 + testMolad 11 0 11 543 + testMolad 18 0 15 414 + testMolad 19 5 0 210 + testMolad 20 3 21 799 + +monthLength :: YearLeap -> YearType -> Month -> Days +monthLength _ _ Tishrei = 30 +monthLength _ _ Tevet = 29 +monthLength _ _ Shevat = 30 +monthLength _ _ Nissan = 30 +monthLength _ _ Iyar = 29 +monthLength _ _ Sivan = 30 +monthLength _ _ Tammuz = 29 +monthLength _ _ Av = 30 +monthLength _ _ Elul = 29 +monthLength Leap _ Adar = 0 +monthLength Leap _ Adar1 = 30 +monthLength Leap _ Adar2 = 29 +monthLength NonLeap _ Adar = 29 +monthLength NonLeap _ Adar1 = 0 +monthLength NonLeap _ Adar2 = 0 +monthLength _ Shlema Cheshvan = 30 +monthLength _ _ Cheshvan = 29 +monthLength _ Chaser Kislev = 29 +monthLength _ _ Kislev = 30 + +------ conversion functions +julianFromDate :: YearLeap -> YearType -> Month -> Date -> Julian +julianFromDate yl yt m d = + let ml = monthLength yl yt + months = case m of + Tishrei -> [] + _ -> enumFromTo Tishrei (pred m) + in d + sum (map ml months) + +dateFromJulian :: YearLeap -> YearType -> Julian -> (Month, Date) +dateFromJulian yl yt j' = + let ml = monthLength yl yt + helper :: Month -> Julian -> (Month, Date) + helper m j + | ml m >= j = (m, j) + | m == Elul = + error $ "Invalid dateFromJulain args: " ++ show (yl, yt, j', j) + | otherwise = helper (succ m) (j - ml m) + in helper Tishrei j' + +prop_dateToFromJulian :: YearLeap -> YearType -> Julian -> Bool +prop_dateToFromJulian yl yt j = + j == uncurry (julianFromDate yl yt) (dateFromJulian yl yt j) + +------ determining year stuff +roshHashana :: Years -> TotalDays +roshHashana y = daysFromWeeks w + d + dechiyot + where + (w, d, s, c) = splitChalakim $ moladTishrei y + dechiyot + | s > 18 || s == 18 && c > 0 = + case d of + 0 -> 1 + 1 -> 1 + 2 -> 2 -- otherwise it would be Wednesday + 3 -> 1 + 4 -> 2 -- otherwise it would be Friday + 5 -> 1 + 6 -> 2 -- otherwise it would be Sunday + _ -> error $ "roshHashana: d ==" ++ show d + | d `elem` [0, 3, 5] = 1 -- ADU rosh + | d == 2 && + isLeapYear y == NonLeap && + (s > 9 || + s == 9 && c > 204) = 2 + | isLeapYear (y - 1) == Leap && + d == 1 && + (s > 15 || + s == 15 && c > 589) = 2 + | otherwise = 0 + +case_firstRoshHashana :: Assertion +case_firstRoshHashana = roshHashana 1 @?= 1 + +dayOfWeek :: TotalDays -> Weekday +dayOfWeek t = + let (_, w) = weeksFromDays t + in w + +prop_validRoshHashanaDay :: Years -> Bool +prop_validRoshHashanaDay = (`elem` [1, 2, 4, 6]) . dayOfWeek . roshHashana + +yearLength :: Years -> TotalDays +yearLength y = roshHashana (y + 1) - roshHashana y + +prop_yearLength :: Years -> Bool +prop_yearLength y = + let l = yearLength y + in l `elem` [353, 354, 355, 383, 384, 385] + +julianFromDays :: TotalDays -> (Years, Julian) +julianFromDays td = uncurry helper $ approx td where + helper :: Years -> TotalDays -> (Years, Julian) + helper y d -- FIXME do not use yearLength here... + | yearLength y < d = helper (y + 1) (d - yearLength y) + | otherwise = (y, fromIntegral d) + approx :: TotalDays -> (Years, TotalDays) + approx (Days td') = + let minYears = Years $ td' `div` 366 + Days rh = roshHashana minYears + rem' = Days $ td' - rh + 1 + in (minYears, rem') + +prop_roshHashana_julianFromDays :: Years -> Bool +prop_roshHashana_julianFromDays y = (y, 1) == julianFromDays (roshHashana y) + +yearDef :: TotalDays -> TotalDays -> (YearLeap, YearType) +yearDef a b = case b - a of + 353 -> (NonLeap, Chaser) + 354 -> (NonLeap, Ksidran) + 355 -> (NonLeap, Shlema) + 383 -> (Leap, Chaser) + 384 -> (Leap, Ksidran) + 385 -> (Leap, Shlema) + x -> error $ "Invalid year length: " ++ show x + +------ convert dates +data HebrewDate = HebrewDate + { year :: Int + , month :: Month + , date :: Int + } + deriving Eq +instance Show HebrewDate where + show (HebrewDate y m d) = show d ++ " " ++ show m ++ ", " ++ show y + +epochOffset :: Integral i => i +epochOffset = 2052004 + +fromHebrew :: HebrewDate -> Day +fromHebrew h = + let Days td = totalDaysFromHebrew h + in ModifiedJulianDay $ td - epochOffset + +toHebrew :: Day -> HebrewDate +toHebrew d' = + let jd = toModifiedJulianDay d' + epochOffset + td = fromIntegral jd + (y, j) = julianFromDays td + (yl, yt) = yearDef (roshHashana y) (roshHashana $ y + 1) + (m, d) = dateFromJulian yl yt j + in HebrewDate (fromIntegral y) m (fromIntegral d) + +totalDaysFromHebrew :: HebrewDate -> TotalDays +totalDaysFromHebrew (HebrewDate y m d) = + let rh = roshHashana $ Years $ fromIntegral y + rh2 = roshHashana $ Years $ fromIntegral $ y + 1 + (yl, yt) = yearDef rh rh2 + ml = monthLength yl yt + ds = fromIntegral $ sum $ map ml [Tishrei ..m] + in rh + ds + fromIntegral d - fromIntegral (ml m) - 1 + +prop_fromToHebrew :: Integer -> Bool +prop_fromToHebrew d' = + let d = ModifiedJulianDay d' + in d == fromHebrew (toHebrew d) + +prop_sameWeekday :: HebrewDate -> Bool +prop_sameWeekday h = + let td = totalDaysFromHebrew h + wd1 = dayOfWeek td + d = fromHebrew h + (_, _, wd2) = toWeekDate d + wd2' = fromIntegral wd2 `mod` 7 + in wd1 == wd2' + +case_integralSpotCheck :: Assertion +case_integralSpotCheck = do + (toModifiedJulianDay $ fromGregorian 2009 9 26) @=? + (toModifiedJulianDay $ fromHebrew $ HebrewDate 5770 Tishrei 8) + dayOfWeek (roshHashana 5770) @?= 6 + roshHashana 5770 @=? totalDaysFromHebrew (HebrewDate 5770 Tishrei 1) + dayOfWeek (totalDaysFromHebrew $ HebrewDate 5770 Tishrei 3) @?= 1 + +case_spotChecks :: Assertion +case_spotChecks = do + fromGregorian 1984 9 27 @=? fromHebrew (HebrewDate 5745 Tishrei 1) + fromGregorian 1985 1 12 @=? fromHebrew (HebrewDate 5745 Tevet 19) + fromGregorian 1986 9 8 @=? fromHebrew (HebrewDate 5746 Elul 4) + +------ testing +testSuite :: Test +testSuite = testGroup "Data.Time.Calendar.Hebrew" + [ testProperty "join and split chalakim" prop_joinSplitChalakim + , testProperty "to/from julian date" prop_dateToFromJulian + , testCase "first rosh hashana is day 1" case_firstRoshHashana + , testProperty "rosh hashana/julianFromDays" prop_roshHashana_julianFromDays + , testProperty "to/from hebrew" prop_fromToHebrew + , testCase "splitChalakim " case_splitChalakim + , testCase "molad tishrei" case_moladTishrei + , testProperty "months til tishrei" prop_monthsTilTishrei + , testProperty "valid year length" prop_yearLength + , testCase "months til tishrei case" case_monthsTilTishrei + , testProperty "rosh hashana valid weekday" prop_validRoshHashanaDay + , testProperty "greg/hebrew same weekday" prop_sameWeekday + , testCase "integral date spot check" case_integralSpotCheck + , testCase "individual date spot checks" case_spotChecks + ] + +instance Arbitrary Chalakim where + coarbitrary = undefined + arbitrary = fromIntegral <$> (arbitrary :: Gen Int) + +instance Arbitrary Days where + coarbitrary = undefined + arbitrary = fromIntegral . (+ 1) . (`mod` 353) + <$> (arbitrary :: Gen Int) + +instance Arbitrary Years where + coarbitrary = undefined + arbitrary = fromIntegral . (+ 1) . (`mod` 6000) + <$> (arbitrary :: Gen Int) + +enumAll :: Enum e => [e] +enumAll = enumFrom $ toEnum 1 + +instance Arbitrary YearLeap where + coarbitrary = undefined + arbitrary = elements enumAll + +instance Arbitrary YearType where + coarbitrary = undefined + arbitrary = elements enumAll + +instance Arbitrary HebrewDate where + coarbitrary = undefined + arbitrary = do + m <- elements [Tishrei, Cheshvan, Kislev, Tevet, Shevat, + Nissan, Iyar, Sivan, Tammuz, Av, Elul] + y <- (+ 1) . (`mod` 6000) <$> arbitrary + day <- (+ 1) . (`mod` 29) <$> arbitrary + return $! HebrewDate y m day + +----- Data.Object instances +instance ToScalar Month where + toScalar = toScalar . show +instance ToObject Month where + toObject = toObject . toScalar +readM :: (Read r, Monad m) => String -> m r +readM s = case reads s of + ((x, _):_) -> return x + _ -> fail $ "Unable to read: " ++ s +instance FromScalar Month where + fromScalar bs = + case readM $ fromLazyByteString bs of + Just x -> return x + Nothing -> fail $ "Invalid hebrew month: " ++ fromLazyByteString bs +instance FromObject Month where + fromObject o = fromObject o >>= fromScalar diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2008, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,11 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' }) + +> runTests' :: a -> b -> c -> d -> IO () +> runTests' _ _ _ _ = system "runhaskell Test.hs" >> return () diff --git a/hebrew-time.cabal b/hebrew-time.cabal new file mode 100644 --- /dev/null +++ b/hebrew-time.cabal @@ -0,0 +1,26 @@ +name: hebrew-time +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: Hebrew dates and prayer times. +description: Conversion to and from Hebrew dates. +category: Data +stability: unstable +cabal-version: >= 1.2 +build-type: Simple +homepage: http://github.com/snoyberg/hebrew-time/tree/master + +library + build-depends: base >= 4 && < 5, + time >= 1.1.3, + test-framework, + test-framework-quickcheck, + test-framework-hunit, + HUnit, + QuickCheck >= 1 && < 2, + bytestring-class, + data-object >= 0.0.2 + exposed-modules: Data.Time.Calendar.Hebrew + ghc-options: -Wall