第13回Ruby勉強会＠関西の演習課題をHaskellで解いてみました

問題はこちらです。今回の課題はオブジェクト変数、クラス変数の使い分けがポイントです。Haskellでこういう状態を覚えておくようなプログラムは書きにくいです。悩んだ末、結局IORefを使ってしまいました。うーむ。

module Main (main) where

import Data.Char (toUpper, isUpper)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import Data.List (intersperse, isPrefixOf)
import System.IO (hFlush, stdout)
import System.Random (randomRIO)

join :: [a] -> [[a]] -> [a]
join = (concat .) . intersperse

type TalkS = String -> IO (Maybe String)

newGrannyFactory :: IO (String -> Bool -> IO (String, TalkS))
newGrannyFactory = return . newGranny =<< newIORef []

newGranny :: IORef [String] -> String -> Bool -> IO (String, TalkS)
newGranny nameHistory name hearingAid = do
  gr <- greeting
  modifyIORef nameHistory (\ a -> name : a) 
  byeCount <- newIORef 0
  return $ (gr, talkWithGranny byeCount hearingAid)
  where
    greeting = do
      names <- readIORef nameHistory
      let names' = map (++ " san") names
      if (null names')
        then return "Konnitiha."
        else if (length names' < 4)
               then return $ join " to " names' ++ " ga hanashiteita ko dane."
               else return $ head names' ++ " tachi ga hanashiteita ko dane."

talkWithGranny :: IORef Int -> Bool -> TalkS
talkWithGranny byeCount hearingAid msg
  | hearingAid     && isByeWithHearingAid    = return Nothing
  | not hearingAid && isByeWithoutHearingAid = do
      count <- readIORef byeCount
      case count of
        2 -> return Nothing
        _ -> modifyIORef byeCount (+ 1) >> replayLoud
  | isLoud    = writeIORef byeCount 0 >> replayYear
  | otherwise = writeIORef byeCount 0 >> replayLoud
  where
    isByeWithHearingAid    = "BYE" `isPrefixOf` map toUpper msg
    isByeWithoutHearingAid = "BYE" == msg

    isLoud = (not $ null msg) && (all isUpper msg)

    replayYear = do
      n  <- randomRIO (0, 20)
      return $ Just $ "Iya-, " ++ (show $ 1930 + n) ++ "nen irai naine-!!"

    replayLoud = do
      return $ Just $ "Ha?! motto ookina koe de hanashiteokure, bouya!!"

main :: IO ()
main = do
  newGranny <- newGrannyFactory
  newGranny "Tome"   True  >>= (\ (gr, tk) -> putStrLn gr >> loop tk)
  newGranny "Ume"    False >>= (\ (gr, tk) -> putStrLn gr >> loop tk)
  newGranny "Kathy"  False >>= (\ (gr, tk) -> putStrLn gr >> loop tk)
  newGranny "Sakura" False >>= (\ (gr, tk) -> putStrLn gr >> loop tk)
  newGranny "Kiku"   False >>= (\ (gr, tk) -> putStrLn gr >> loop tk)
  where
    loop talkWithGranny = do
      repley <- talkWithGranny =<< getMessage
      case repley of
        Just msg -> putStrLn msg >> loop talkWithGranny
        Nothing  -> return ()
 
    getMessage = putStr "> " >> hFlush stdout >> getLine

実行例:

$ ./granny.exe
Konnitiha.
> aaa
Ha?! motto ookina koe de hanashiteokure, bouya!!
> AAA
Iya-, 1950nen irai naine-!!
> bye!!
Tome san ga hanashiteita ko dane.
> BYE
Ha?! motto ookina koe de hanashiteokure, bouya!!
> BYE
Ha?! motto ookina koe de hanashiteokure, bouya!!
> BYE
Ume san to Tome san ga hanashiteita ko dane.
> BYE
Ha?! motto ookina koe de hanashiteokure, bouya!!
> BYE
Ha?! motto ookina koe de hanashiteokure, bouya!!
> BYE
Kathy san to Ume san to Tome san ga hanashiteita ko dane.
> BYE
Ha?! motto ookina koe de hanashiteokure, bouya!!
> BYE
Ha?! motto ookina koe de hanashiteokure, bouya!!
> BYE
Sakura san tachi ga hanashiteita ko dane.
> BYE
Ha?! motto ookina koe de hanashiteokure, bouya!!
> BYE
Ha?! motto ookina koe de hanashiteokure, bouya!!
> BYE