アルゴリズムこうしん

Main.hs

{-# LANGUAGE RecursiveDo #-}

module Main where

import Control.Monad.Cont
import Control.Monad.State
import Data.IORef
import Data.List

data Action = Empty
            | Maenarae
            | Eraihito
            | Pekorinko
            | Kyorokyoro
            | Hiraoyogi
            | Kurihiroi
            | Shushu
            | Pyupyu
            | Owarikana
            | Owari
            deriving (Show, Eq, Ord, Enum)

say :: Action -> String
say Empty      = ""
say Maenarae   = "1歩進んで前習え"
say Eraihito   = "1歩進んで偉い人"
say Pekorinko  = "ひっくりかえってぺこりんこ"
say Kyorokyoro = "横に歩いてきょろきょろ"
say Hiraoyogi  = "ちょっとここらでひらおよぎ"
say Kurihiroi  = "ちょっとしゃがんで栗拾い"
say Shushu     = "空気入れますしゅうしゅう"
say Pyupyu     = "空気がはいってぴゅうぴゅう"
say Owarikana  = "そろそろ、終わりかな"
say Owari      = "おわり"

actions :: Int -> Int -> [Action]
actions n i = concat $ [ replicate i Empty
                       , [ Maenarae
                         , Eraihito
                         , Pekorinko
                         , Kyorokyoro
                         , Hiraoyogi
                         , Kurihiroi
                         , Shushu
                         , Pyupyu
                         ]
                       , replicate (n-i) Owarikana
                       , [Owari]
                       ]

type LastAction = Action -- 過去の自分の行動
type PrevAction = Action -- 前の人の行動
type NextAction = Action -- 後ろの人の行動

actor :: IORef LastAction -> ContT NextAction (StateT PrevAction IO) ()
actor actRef = do
  lastAct <- liftIO $ readIORef actRef    -- 自分が取った前の行動を取得
  prevAct <- lift get                     -- 前の人の行動を取得
  let myAct = case (lastAct, prevAct) of
        (Empty, Eraihito) -> Maenarae     -- 前の人が偉い人をしたら"前ならえ"
        (Empty, _       ) -> Empty        -- そうじゃなければ無言で進み続ける
        (Owarikana, _   ) -> Owarikana    -- "終わりかな"は一旦繰り返す
        _                 -> succ lastAct -- それ以外の場合は次の行動を取る
  lift $ put myAct                        -- 自分の行動を次の人に伝える

  ContT $ \k -> do
    nextAct <- k myAct                    -- 継続を使って後ろの人の行動を知る
    let myAct' = case (lastAct, nextAct) of
          (Owarikana, Owari) -> Owari     -- "終わりかな"の時は後ろの人が"おわり"なら自分も終わる
          _                  -> myAct     -- それ以外の場合は行動を変えない
    liftIO $ writeIORef actRef myAct'     -- 自分の状態を更新する
    pure myAct'                           -- 自分の行動を前の人に伝える

  pure ()

main :: IO ()
main = do
  -- actRef1 <- newIORef Empty
  -- actRef2 <- newIORef Empty
  -- fix $ \loop -> do
  --   (flip runStateT Eraihito) . (flip runContT (const $ pure Owari)) $ do
  --     actor actRef1 -- 一人目
  --     actor actRef2 -- 二人目
  --   actions <- mapM readIORef [actRef1, actRef2]
  --   putStrLn $ intercalate " / " $ map say actions
  --   if all (== Owari) actions
  --      then pure () -- 全員が"おわり"なら終了する
  --      else loop    -- そうでなければ繰り返す
  let n = 3
  actRefs <- sequence . replicate n $ newIORef Empty
  fix $ \loop -> do
    (flip runStateT Eraihito) .
      (flip runContT (const $ pure Owari)) .
        sequence $ map actor actRefs
    actions <- mapM readIORef actRefs
    putStrLn $ intercalate " / " $ map say actions
    if all (== Owari) actions
       then pure () -- 全員が"おわり"なら終了する
       else loop    -- そうでなければ繰り返す