tictactoe.hs

import qualified Data.Set as S
import qualified Data.List as L
import qualified Data.Map as M

type Move = Int
type Moves = S.Set Move

chunk :: [a] -> Int ->[[a]]
chunk [] n = []
chunk l n = [(take n l)] ++ (chunk (drop n l) n)

winningMoves :: Int -> [Moves]
winningMoves x = 
  let horizontal = chunk (take (x * x) [1..]) x
      vertical   = L.transpose horizontal
      fwdDiagonal = take x ([1,(x+2)..])
      revDiagonal = take x ([x,(x+x-1)..])
  in map S.fromList (horizontal ++ vertical ++ [fwdDiagonal , revDiagonal])

isWinningCombination :: Moves -> Bool
isWinningCombination moves = any (flip S.isSubsetOf moves) (winningMoves 3)

data Symbol = X | O | Space deriving (Eq)

instance Show Symbol where
  show X = "X"
  show O = "O"
  show Space = " "

data Player = Player {name :: String,
                      symbol :: Symbol,
                      moves :: Moves} deriving (Show,Eq)
data Players = Players {currPlayer :: Player,
                        nextPlayer :: Player} deriving (Show,Eq)
data Game = InPlay Players | Won Player | Drawn deriving (Eq)

numberOfMoves = length . moves
sumAll = foldl (+) 0

insertMove :: Player -> Move -> Player
insertMove (Player name symbol moves) move = Player name symbol (S.insert move moves)

mapMoves :: Player -> M.Map Int Symbol
mapMoves (Player name symbol moves) = M.fromSet (\x -> symbol) moves

totalMoves :: Players -> Int
totalMoves (Players cp np) = sumAll $ map numberOfMoves [cp,np]

makeMove :: Game -> Move -> Game
makeMove (Won winner) _ = Won winner
makeMove Drawn _ = Drawn
makeMove (InPlay players) move 
  | isWinningCombination (moves activePlayer) = Won activePlayer
  | (totalMoves players) == 8 = Drawn
  | otherwise = InPlay (Players (nextPlayer players) activePlayer)
  where activePlayer = insertMove (currPlayer players) move

createMap (Players c n) = foldl M.union M.empty $ map mapMoves [c,n]
findWithDefault m d k = M.findWithDefault d k m

instance Show Game where
  show Drawn = "Game Drawn"
  show (Won winner) = "Winner: " ++ (name winner)
  show (InPlay players) = 
    let lookup = findWithDefault (createMap players) Space
        board  = map lookup [1..9]
    in unlines $ map unwords $ (flip chunk 3) $ map show board

getPlayer :: (String, Symbol) -> IO Player
getPlayer (person,symbol) = do
  putStrLn ("Enter name for " ++ person ++ ": ")
  name <- getLine
  return $ Player name symbol (S.fromList [])

displayCurrentTurn :: Game -> IO ()
displayCurrentTurn (InPlay players)= do
  print (currPlayer players)

setupGame :: IO Game
setupGame = do
  playerList <- mapM getPlayer [("Player 1",X), ("Player 2",O)]
  let players = Players (head playerList) (last playerList)
  return $ InPlay players

playGame :: Game -> IO ()
playGame (Won winner) = do
  print winner
  return ()
playGame game = do
  displayCurrentTurn game
  print game
  putStrLn "Enter move"
  choice <- getLine
  let move = read choice :: Int
  playGame $ makeMove game move

main = do
  game <- setupGame
  return $ playGame game