Skip to content
Browse files

Converts to and from Hebrew dates

  • Loading branch information...
1 parent a889c52 commit 0737ced1b656cdfe615d45cad4ccf83248dc1fc1 @snoyberg committed
Showing with 506 additions and 0 deletions.
  1. +2 −0 .gitignore
  2. +435 −0 Data/Time/Calendar/Hebrew.hs
  3. +25 −0 LICENSE
  4. +1 −0 README
  5. +11 −0 Setup.lhs
  6. +8 −0 Test.hs
  7. +24 −0 hebrew-time.cabal
View
2 .gitignore
@@ -0,0 +1,2 @@
+dist
+*.swp
View
435 Data/Time/Calendar/Hebrew.hs
@@ -0,0 +1,435 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+---------------------------------------------------------
+--
+-- Module : Data.Time.Calendar.Hebrew
+-- Copyright : Michael Snoyman
+-- License : BSD3
+--
+-- Maintainer : Michael Snoyman <michael@snoyman.com>
+-- 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
+
+------ data definitions
+data Month = Tishrei | Cheshvan | Kislev | Tevet | Shevat
+ | Adar | Adar1 | Adar2
+ | Nissan | Iyar | Sivan | Tammuz | Av | Elul
+ deriving (Eq, Ord, Show, Enum)
+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, Show)
+
+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
View
25 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.
View
1 README
@@ -0,0 +1 @@
+Hebrew dates and prayer times.
View
11 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 ()
View
8 Test.hs
@@ -0,0 +1,8 @@
+import Test.Framework (defaultMain)
+
+import qualified Data.Time.Calendar.Hebrew
+
+main :: IO ()
+main = defaultMain
+ [ Data.Time.Calendar.Hebrew.testSuite
+ ]
View
24 hebrew-time.cabal
@@ -0,0 +1,24 @@
+name: hebrew-time
+version: 0.0.0
+license: BSD3
+license-file: LICENSE
+author: Michael Snoyman <michael@snoyman.com>
+maintainer: Michael Snoyman <michael@snoyman.com>
+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.*
+ exposed-modules: Data.Time.Calendar.Hebrew
+ ghc-options: -Wall

0 comments on commit 0737ced

Please sign in to comment.
Something went wrong with that request. Please try again.