I posted an early implementation of this before and it was pretty popular, so I got around to implementing some AI and stuff! Hope it's not considered too spammy to post about this again.
import Data.List import Data.Maybe import Text.Read import System.Random data State = X | O | Blank deriving (Eq, Read) type Board = [[State]] type MoveSource = Board -> IO (Int, Int) instance Show State where show X = "X" show O = "O" show Blank = " " showBoard :: Board -> String showBoard board = let printedRows = map (\row -> (show $ row !! 0) ++ "|" ++ (show $ row !! 1) ++ "|" ++ (show $ row !! 2)) board in (intercalate "\n-----\n" printedRows) ++ "\n" board = [[Blank, Blank, Blank], [Blank, Blank, Blank], [Blank, Blank, Blank]] main = do (winner, finalState) <- playGame humanMove (aiMove O) board X putStrLn "\nGame over!" putStr $ showBoard finalState if winner /= Blank then putStrLn $ "\nWinner:" ++ show winner else putStrLn "Draw." humanMove :: MoveSource humanMove board = do putStr $ showBoard board putStr "Enter row/col (1-3):" line <- getLine let rowMaybe = readMaybe (line !! 0 :"") :: Maybe Int colMaybe = readMaybe (line !! 1 :"") :: Maybe Int if rowMaybe == Nothing || colMaybe == Nothing then do putStrLn "Bad input. Try again." humanMove board else do let row = (fromJust rowMaybe) - 1 col = (fromJust colMaybe) - 1 if (row < 0) || (row > 2) || (col < 0) || (col > 2) then do putStrLn "Bad coords. Try again." humanMove board else do if not $ checkState board Blank (row, col) then do putStrLn $ (show (row, col)) ++ "is taken:" putStr (showBoard board) putStrLn "Spot taken. Try again." humanMove board else pure (row, col) aiMove :: State -> MoveSource aiMove symbol board = let instaWin = canWin board symbol instaLose = canWin board (if symbol == O then X else O) options = openSpaces board in case instaWin of Just instaWin -> pure instaWin Nothing -> case instaLose of Just instaLose -> pure instaLose Nothing -> do i <- randomRIO (0, length options) pure $ options !! i playGame :: MoveSource -> MoveSource -> Board -> State -> IO (State, Board) playGame xMoveSource oMoveSource board currentTurn = do move <- if currentTurn == X then xMoveSource board else oMoveSource board let nextTurn = if currentTurn == X then O else X newBoard = makeMove move currentTurn board if gameOver newBoard /= Nothing then pure $ (fromJust $ gameOver newBoard, newBoard) else playGame xMoveSource oMoveSource newBoard nextTurn makeMove :: (Int, Int) -> State -> Board -> Board makeMove (row, col) state board = let oldrow = board !! row newrow = editList oldrow col state in editList board row newrow gameOver :: Board -> Maybe State gameOver board = let xWon = any id $ fmap (checkPattern board X) waysToWin oWon = any id $ fmap (checkPattern board O) waysToWin draw = all id $ fmap (\row -> all id $ fmap (/= Blank) row) board in if xWon then Just X else if oWon then Just O else if draw then Just Blank else Nothing -- a generic helper to update a list item in-place editList :: [a] -> Int -> a -> [a] editList list i new = (take i list) ++ new : (drop (i+1) list) -- checks whether each of a list of positions is in a given state checkPattern :: Board -> State -> [(Int, Int)] -> Bool checkPattern board state pattern = all id $ fmap (checkState board state) pattern checkState :: Board -> State -> (Int, Int) -> Bool checkState board state coord = let row = board !! (fst coord) slot = row !! (snd coord) in slot == state waysToWin = [ [(0,0), (0,1), (0,2)], [(1,0), (1,1), (1,2)], [(2,0), (2,1), (2,2)], [(0,0), (1,0), (2,0)], [(0,1), (1,1), (2,1)], [(0,2), (1,2), (2,2)], [(0,0), (1,1), (2,2)], [(0,2), (1,1), (2,0)]] allSpaces = [(row, col) | row <- [0..2], col <- [0..2]] openSpaces board = filter (checkState board Blank) allSpaces wouldWin :: Board -> State -> (Int, Int) -> Bool wouldWin board state move = let hypotheticalBoard = makeMove move state board result = gameOver hypotheticalBoard in result == Just state canWin :: Board -> State -> Maybe (Int, Int) canWin board state = let outcomes = (\move -> (move, wouldWin board state move)) <$> (openSpaces board) winningMoves = filter snd outcomes in if not $ null winningMoves then Just $ fst (winningMoves !! 0) else Nothing
To be honest, it took me about an hour to get the
canWin stuff implemented properly. My initial approach involved not having
wouldWin as a separate function, and I got thrown off for a while by needing to recall which move led to the winning state found. As you can see, I ended up using the lambda in
let outcomes to pack it into a tuple (not really a solution I'm fond of). In fact the unreadability of my early attempts to solve that problem were what led me to think of putting out
wouldWin. I also remembered that
<$> exists as an infix synonym for
fmap. I like it more.
I don't think I'll be putting more work into this project unless someone has refactor suggestions, but I feel like I've gained a real increase in ability from it.
I do regret the decision to use
row, col instead of
x, y. Not sure what possessed me to do that. But w/e.
On another note, I feel like this has decreased my appreciation for the value of automatic currying. There were still some places where I ended up having to use lambdas anyway, and evenin the cases I eliminated them it didn't seem like as much as improvement as I expected. Like in the
filter snd outcomes case. I used to have
filter (\(move, result) -> result) outcomes, but at the same time, I feel like the old way was clearer. IDK.