Data.Time.Calendar の Day型と返還可能な和暦の型、Warekiを定義しました。
Wareki は Ord インスタンスを実装してありますので、そのまま比較、ソートできます。
import Data.Time.Calendar (Day(..), fromGregorian, toGregorian, fromGregorianValid) import Data.List (find) import Control.Applicative ((<$>),(<*>)) import Test.HUnit data GName = Meiji | Taisho | Showa | Heisei deriving (Eq,Ord,Show) data Gengo = Gengo{start, end :: Day, name :: GName} deriving Show data Wareki = Wareki{gengo :: GName, year:: Integer, month, day :: Int } deriving (Eq,Show) instance Ord Wareki where compare (Wareki g1 y1 m1 d1) (Wareki g2 y2 m2 d2) = compare ((gnameToInteger g1)*40000 + y1 * 400 + (fromIntegral m1) * 31 + (fromIntegral d1)) ((gnameToInteger g2)*40000 + y2 * 400 + (fromIntegral m2) * 31 + (fromIntegral d2)) where gnameToInteger :: GName -> Integer gnameToInteger Meiji = 0 gnameToInteger Taisho = 1 gnameToInteger Showa = 2 gnameToInteger Heisei = 3 gengoList :: [Gengo] gengoList = [ makeGengo Meiji 1868 10 23 1912 7 29, makeGengo Taisho 1912 7 30 1926 12 24, makeGengo Showa 1926 12 25 1989 1 7, makeGengo Heisei 1989 1 8 2100 12 31 ] where makeGengo :: GName -> Integer -> Int -> Int -> Integer -> Int -> Int -> Gengo makeGengo gName sy sm sd ey em ed = Gengo{ start = fromGregorian sy sm sd, end = fromGregorian ey em ed, name = gName } -- 西暦から和暦への変換 fromDayToWareki :: Day -> Maybe Wareki fromDayToWareki day = case (gName, startYear) of (Just gengoName, Just gStartYear) -> Just Wareki{gengo = gengoName, year = gYear - gStartYear + 1, month = gMonth, day = gDay} (_ , _ ) -> Nothing where g :: Maybe Gengo g = find (\x->(day >= start x) && (day <= end x)) gengoList gName :: Maybe GName gName = name <$> g startYear :: Maybe Integer startYear = getYear <$> toGregorian <$> start <$> g (gYear,gMonth,gDay) = toGregorian day warekiTest = "Wareki" ~: test [ fromDayToWareki (fromGregorian 1912 7 29) ~?= Just (Wareki Meiji 45 7 29), fromDayToWareki (fromGregorian 1912 7 30) ~?= Just (Wareki Taisho 1 7 30), fromDayToWareki (fromGregorian 1926 12 24) ~?= Just (Wareki Taisho 15 12 24), fromDayToWareki (fromGregorian 1926 12 25) ~?= Just (Wareki Showa 1 12 25), (fromDayToWareki (fromGregorian 1926 12 24) >>= fromWarekiToDay) ~?= Just (fromGregorian 1926 12 24)] {- > runTestTT warekiTest Cases: 5  Tried: 0  Errors: 0  Failures: 0 Cases: 5  Tried: 1  Errors: 0  Failures: 0 Cases: 5  Tried: 2  Errors: 0  Failures: 0 Cases: 5  Tried: 3  Errors: 0  Failures: 0 Cases: 5  Tried: 4  Errors: 0  Failures: 0 Cases: 5  Tried: 5  Errors: 0  Failures: 0 Counts {cases = 5, tried = 5, errors = 0, failures = 0} -} getYear :: (Integer, Int, Int) -> Integer getYear (y,_,_) = y -- 和暦から西暦への変換 fromWarekiToDay :: Wareki -> Maybe Day fromWarekiToDay (Wareki wName wYear wMonth wDay) = case startYear of Just stYear -> case fromGregorianValid (stYear + wYear - 1) wMonth wDay of Nothing -> Nothing Just newDay -> case (\e -> newDay <= e) <$> endDay of Just valid -> if valid then Just newDay else Nothing Nothing -> Nothing Nothing -> Nothing where g :: Maybe Gengo g = warekiToGengo (Wareki wName wYear wMonth wDay) startYear :: Maybe Integer startYear = getYear <$> toGregorian <$> start <$> g endDay :: Maybe Day endDay = end <$> g warekiToGengo :: Wareki -> Maybe Gengo warekiToGengo w = wgetGengo' w gengoList where wgetGengo' :: Wareki -> [Gengo] -> Maybe Gengo wgetGengo' _ [] = Nothing wgetGengo' wareki (x:xs) = if gengo wareki == name x then Just x else wgetGengo' wareki xs toDayTest = "toDay" ~: test [ fromWarekiToDay (Wareki Meiji 45 7 29) ~?= Just (fromGregorian 1912 7 29), fromWarekiToDay (Wareki Taisho 1 7 30) ~?= Just (fromGregorian 1912 7 30), fromWarekiToDay (Wareki Taisho 15 12 24) ~?= Just (fromGregorian 1926 12 24), fromWarekiToDay (Wareki Showa 1 12 25) ~?= Just (fromGregorian 1926 12 25), -- 大正16年は存在しない。 fromWarekiToDay (Wareki Taisho 16 12 24) ~?= Nothing , -- 大正15年12月25日は昭和なので存在しない。 fromWarekiToDay (Wareki Taisho 15 12 25) ~?= Nothing , -- 年号の範囲内の異常な値は存在しない。 fromWarekiToDay (Wareki Taisho 1 13 25) ~?= Nothing, -- 2012/12/24 修正 fromWarekiToDay (Wareki Taisho 1 13 33) ~?= Nothing, -- 2012/12/24 修正 (fromWarekiToDay (Wareki Meiji 45 7 29) >>= fromDayToWareki) ~?= Just (Wareki Meiji 45 7 29) ] {- > runTestTT toDayTest Cases: 9 Tried: 0 Errors: 0 Failures: 0 Cases: 9 Tried: 1 Errors: 0 Failures: 0 Cases: 9 Tried: 2 Errors: 0 Failures: 0 Cases: 9 Tried: 3 Errors: 0 Failures: 0 Cases: 9 Tried: 4 Errors: 0 Failures: 0 Cases: 9 Tried: 5 Errors: 0 Failures: 0 Cases: 9 Tried: 6 Errors: 0 Failures: 0 Cases: 9 Tried: 7 Errors: 0 Failures: 0 Cases: 9 Tried: 8 Errors: 0 Failures: 0 Cases: 9 Tried: 9 Errors: 0 Failures: 0 Counts {cases = 9, tried = 9, errors = 0, failures = 0} -}
参考
- Haskell の代数的データ型を比較、特定の基準でソート – compare, sortBy
- 2012/12/24 fromGregorianに異常な値が設定されても丸めてしまうため、年号の範囲内であれば異常な値の月日でも丸めてDay型のデータを作っていました。fromGregorianValid を使い異常な値のときは Nothing を返すように変更しました。
- 20130513 もうちょっと綺麗に
import Data.Time.Calendar (Day(..), fromGregorian, toGregorian, fromGregorianValid) import Data.List (find) import Control.Applicative import Test.HUnit data GName = Meiji | Taisho | Showa | Heisei deriving (Eq,Ord,Enum,Show) data Gengo = Gengo{ gname :: GName, gstart, gend :: Day } deriving Show data Wareki = Wareki{gengo :: GName, gyear:: Integer, gmonth, gday :: Int } deriving (Eq,Show) instance Ord Wareki where compare w1 w2 = compare (fromWarekiToDay w1) (fromWarekiToDay w2) gengoList :: [Gengo] gengoList = [ Gengo Meiji (fromGregorian 1868 10 23) (fromGregorian 1912 7 29), Gengo Taisho (fromGregorian 1912 7 30) (fromGregorian 1926 12 24), Gengo Showa (fromGregorian 1926 12 25) (fromGregorian 1989 1 7), Gengo Heisei (fromGregorian 1989 1 8) (fromGregorian 2100 12 31) ] -- 西暦から和暦への変換 fromDayToWareki :: Day -> Maybe Wareki fromDayToWareki day = case (gName, startYear) of (Just gengoName, Just gStartYear) -> Just (Wareki gengoName (adYear - gStartYear + 1) adMonth adDay) (_ , _ ) -> Nothing where g :: Maybe Gengo g = find (\(Gengo _ st ed)->(st <= day) && (day <= ed)) gengoList gName :: Maybe GName gName = gname <$> g startYear :: Maybe Integer startYear = getYear <$> toGregorian <$> gstart <$> g (adYear,adMonth,adDay) = toGregorian day getYear :: (Integer, Int, Int) -> Integer getYear (y,_,_) = y -- 和暦から西暦への変換 fromWarekiToDay :: Wareki -> Maybe Day fromWarekiToDay (Wareki wName wYear wMonth wDay) = case startYear of Just stYear -> let newDay = fromGregorianValid (stYear + wYear - 1) wMonth wDay in case (<=) <$> newDay <*> endDay of Just valid -> if valid then newDay else Nothing Nothing -> Nothing Nothing -> Nothing where g :: Maybe Gengo g = find (\(Gengo gn _ _) -> gn == wName) gengoList startYear :: Maybe Integer startYear = getYear <$> toGregorian <$> gstart <$> g endDay :: Maybe Day endDay = gend <$> g {- warekiTest = "Wareki" ~: test [ fromDayToWareki (fromGregorian 1912 7 29) ~?= Just (Wareki Meiji 45 7 29), fromDayToWareki (fromGregorian 1912 7 30) ~?= Just (Wareki Taisho 1 7 30), fromDayToWareki (fromGregorian 1926 12 24) ~?= Just (Wareki Taisho 15 12 24), fromDayToWareki (fromGregorian 1926 12 25) ~?= Just (Wareki Showa 1 12 25), (fromDayToWareki (fromGregorian 1926 12 24) >>= fromWarekiToDay) ~?= Just (fromGregorian 1926 12 24), ((Wareki Showa 1 12 25) == (Wareki Showa 1 12 25)) ~?= True, ((Wareki Heisei 1 1 10) > (Wareki Showa 56 12 25)) ~?= True ] toDayTest = "toDay" ~: test [ fromWarekiToDay (Wareki Meiji 45 7 29) ~?= Just (fromGregorian 1912 7 29), fromWarekiToDay (Wareki Taisho 1 7 30) ~?= Just (fromGregorian 1912 7 30), fromWarekiToDay (Wareki Taisho 15 12 24) ~?= Just (fromGregorian 1926 12 24), fromWarekiToDay (Wareki Showa 1 12 25) ~?= Just (fromGregorian 1926 12 25), -- 大正16年は存在しない。 fromWarekiToDay (Wareki Taisho 16 12 24) ~?= Nothing , -- 大正15年12月25日は昭和なので存在しない。 fromWarekiToDay (Wareki Taisho 15 12 25) ~?= Nothing , -- 年号の範囲内の異常な値は存在しない。 fromWarekiToDay (Wareki Taisho 1 13 25) ~?= Nothing, fromWarekiToDay (Wareki Taisho 1 13 33) ~?= Nothing, (fromWarekiToDay (Wareki Meiji 45 7 29) >>= fromDayToWareki) ~?= Just (Wareki Meiji 45 7 29) ] doTest = do runTestTT warekiTest runTestTT toDayTest -}
