Hatena::ブログ(Diary)

sirocco の書いてもすぐに忘れるメモ

2012-04-02

Haskellによる西暦(Day)<=>和暦変換、和暦の比較

| 07:16 |

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 &#160;Tried: 0 &#160;Errors: 0 &#160;Failures: 0
Cases: 5 &#160;Tried: 1 &#160;Errors: 0 &#160;Failures: 0
Cases: 5 &#160;Tried: 2 &#160;Errors: 0 &#160;Failures: 0
Cases: 5 &#160;Tried: 3 &#160;Errors: 0 &#160;Failures: 0
Cases: 5 &#160;Tried: 4 &#160;Errors: 0 &#160;Failures: 0
Cases: 5 &#160;Tried: 5 &#160;Errors: 0 &#160;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}
-}

参考

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
-}

はてなユーザーのみコメントできます。はてなへログインもしくは新規登録をおこなってください。

リンク元