Nim Minimal Viable Snippet in Haskell

nim.hs

import Data.Maybe (isJust, isNothing, fromJust, fromMaybe)
import Data.List (find)
import Control.Applicative ((<|>))

--- Player ---

data Player = P1 | P2 deriving (Show, Eq)

next :: Player -> Player
next P1 = P2
next P2 = P1

--- Game ---

type Pile = Int
data Game = Game Pile Player deriving (Show)

winner :: Game -> Maybe Player
winner (Game 0 p) = Just $ next p
winner _          = Nothing

gameOver :: Game -> Bool
gameOver = isJust . winner

winnerIs :: Game -> Player -> Bool
g `winnerIs` p = winner g == Just p

--- Move ---

type Move    = Int
type Options = [Move] 

options :: Game -> Options
options (Game n _) = [1..min n 2]

move :: Game -> Move -> Game
move (Game n p) m = Game (n - m) (next p)

--- Strategy ---

type PureStrategy = Game -> Options ->    Move
type     Strategy = Game -> Options -> IO Move

(.:) :: (b -> c) -> (a -> a' -> b) -> a -> a' -> c
(.:) = (.) . (.)

taint :: PureStrategy -> Strategy
taint = (return .:)

takeMore :: PureStrategy
takeMore _ = maximum

takeLess :: PureStrategy
takeLess _ = minimum

type Tactics = Player -> Strategy

trivialTactics :: Tactics
trivialTactics P1 = taint takeMore
trivialTactics P2 = taint takeLess

--- Play ---

takeTurn :: Game -> Strategy -> IO Game
takeTurn g@(Game n p) s = do
	choice <- s g (options g)
	return $ move g choice

untilM :: Monad m => (a -> Bool) -> (a -> m a) -> a -> m a
untilM p f x = rec $ return x where
	rec mx = do
		x <- mx
		if p x then return x else rec $ f x

play :: Tactics -> Game -> IO Player
play t g = do
	let takeTurn' g@(Game _ p) = takeTurn g $ t p
	g' <- untilM gameOver takeTurn' g
	return $ fromJust $ winner g'

youPlay :: Player -> Tactics -> Game -> IO ()
youPlay p t g = do
	theWinner <- play t g
	putStrLn $ "  you " ++
		if p == theWinner then "win" else "lose"

--- Example Games ---

trivialPlay = play trivialTactics

g2  = Game  2 P1
g3  = Game  3 P1
g14 = Game 14 P1

-- try: trivialPlay g14

--- Human Player ---

-- See <http://stackoverflow.com/questions/10459988/how-do-i-catch-read-exceptions-in-haskell>.
maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of
	[(x, "")] -> Just x
	_         -> Nothing

consultHuman :: Strategy
consultHuman g os = do
	putStrLn $ "  in " ++ show g ++ " choose from " ++ show os
	line <- getLine
	choice <- case maybeRead line of
		Just choice -> return choice
		Nothing     -> do
			putStrLn $ "  no parse of " ++ show line
			consultHuman g os
	if choice `elem` os
		then return choice
		else do
			putStrLn $ "  " ++ show choice ++ " not in " ++ show os
			consultHuman g os

simpleTactics :: Tactics
simpleTactics P1 = consultHuman
simpleTactics P2 = taint takeMore

simplePlay = youPlay P1 simpleTactics

-- try: simplePlay g14

--- Look Ahead Player ---

findChoice :: (Game -> Bool) -> Game -> Maybe Move
findChoice p g = find (p . move g) $ options g

lookAhead :: Game -> Maybe Move
lookAhead g@(Game _ p) =
	findChoice (`winnerIs` p) g <|>
	findChoice (isNothing . lookAhead) g

lookAheadOrGiveUp :: PureStrategy
lookAheadOrGiveUp g os = last os `fromMaybe` lookAhead g

hardTactics :: Tactics
hardTactics P1 = consultHuman
hardTactics P2 = taint lookAheadOrGiveUp

hardPlay = youPlay P1 hardTactics

-- try: hardPlay g14