右記ブログの変更版 http://d.hatena.ne.jp/morning_reading/20110415/p1

nimmt.hs

module Nimmt where

import Control.Applicative ((<$>))
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class (liftIO)
import Control.Monad (when)

cls :: IO ()
cls = putStr "\ESC[2J"

type Pos = (Int, Int)
type Board = [Int]

goto :: Pos -> IO ()
goto (x, y) = putStr $ "\ESC[" ++ show y ++ ";" ++ show x ++ "H"

-- 1: *****
-- 2: ****
-- ...
-- のように現在の駒の数を表示
showboard :: Board -> IO ()
showboard b = goto (1,1) >> mapM_ showLine (zip [1..] b)
  where
    showLine (id,num) = putStrLn $ show id ++ ": " ++ replicate num '*'

-- 1 <= n <= limit の範囲の自然数を端末から受け取る
checkLimit :: Int -> Int -> Maybe Int
checkLimit limit n
  | 1 <= n && n <= limit = Just n
  | otherwise = Nothing

getNat :: Int -> MaybeT IO Int
getNat limit = liftIO readLn >>= MaybeT . return . checkLimit limit

nextboard :: Board -> Int -> Int -> Board
nextboard b s n = let (xs, (y:ys)) = splitAt s b in xs ++ [y-n] ++ ys

nextgen :: Board -> IO Board
nextgen b = do
  r <- runMaybeT $ nextgenM b
  case r of
    Nothing -> nextgen b
    Just r' -> return r'

nextgenM :: Board -> MaybeT IO Board
nextgenM b = do
  liftIO $ putStr "Enter slot number: "
  s <- getNat $ length b
  liftIO $ putStr "Enter take number: "
  x <- getNat $ b !! (s-1)
  return $ nextboard b (s-1) x

nimmt :: Board -> IO ()
nimmt b = do
  cls
  showboard b
  b <- nextgen b
  when (any (/=0) b) (nimmt b)

run_nimmt :: IO ()
run_nimmt = nimmt [5,4,3,2,1]

nimmt2.hs

module Nimmt(nimmt) where

import Control.Monad (when)
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class (liftIO)
import Control.Applicative ((<$>))

type Input = (Int, Int)
type Board = [Int]

-- entry point
nimmt = run [5, 4, 3, 2, 1]

run :: Board -> IO ()
run b = do
  drawBoard b
  b' <- update b <$> getUserInput b
  when (isGamePlaying b') $ run b'

------------------------------------------------------------
-- IO actions
drawBoard :: Board -> IO ()
drawBoard b = cls >> resetCursor >> mapM_ drawLine (zip [1..] b)
  where
    cls = putStr "\ESC[2J"
    resetCursor = putStr "\ESC[1;1H"
    drawLine (id, n) = putStrLn $ show id ++ ": " ++ replicate n '*'

getUserInput :: Board -> IO Input
getUserInput b = do
  inp <- runMaybeT $ getUserInput' b
  case inp of
    Nothing -> putStrLn "invalid user input. try again" >> getUserInput b
    Just inp' -> return inp'

getUserInput' :: Board -> MaybeT IO Input
getUserInput' b = do
  liftIO $ putStr "enter slot number: "
  s <- getNat $ length b
  liftIO $ putStr "enter take number: "
  t <- getNat $ b !! (s-1)
  return (s, t)

getNat :: Int -> MaybeT IO Int
getNat limit = liftIO readLn >>= MaybeT . return . checkLimit limit

checkLimit :: Int -> Int -> Maybe Int
checkLimit limit n
  | 1 <= n && n <= limit = Just n
  | otherwise = Nothing

------------------------------------------------------------
-- functions
isGamePlaying :: Board -> Bool
isGamePlaying b = any (/=0) b

update :: Board -> Input -> Board
update b (id, n) = let (xs, (y:ys)) = splitAt (id-1) b in xs ++ [y-n] ++ ys