tictactoe.hs

--Authored by Grant Slatton on 2013 October 10
--All code is released to the public domain under the terms of [http://unlicense.org/]

import Data.List
import Control.Monad
import Data.Maybe
import Data.Function

magicSquare = [8,1,6,3,5,7,4,9,2]

type Game = ([Int], [Int], [Int], Int)
blankGame = ([1..9], [], [], 1)::Game
aboutToWin = move (move (move (move blankGame 8) 3) 1) 5

move :: Game -> Int -> Game
move g@(free, p1, p2, turn) x
    | not $ elem x free = g
    | turn == 1 = (delete x free, x:p1, p2, -turn)
    | otherwise = (delete x free, p1, x:p2, -turn)
    where

powerSet :: [a] -> [[a]]
powerSet = (filterM (const [True, False]))

powerSet3 :: [a] -> [[a]]
powerSet3 xs = filter (\x -> 3 == length x) $ powerSet xs

winner :: Game -> Maybe Int
winner (free, p1, p2, _)
    | elem 15 $ map sum $ powerSet3 p1 = Just 1
    | elem 15 $ map sum $ powerSet3 p2 = Just (-1)
    | null free = Just 0
    | otherwise = Nothing

negamax :: Game -> (Int, Int)
negamax g@(free, p1, p2, turn)
    | not $ isNothing $ win = (turn * (fromJust win), 0)
    | otherwise = maximumBy (compare `on` fst) $ zip (map (negate . fst . negamax) children) free
    where
        win = winner g
        children = map (move g) free
        scores = map negamax children

main = do
        play blankGame
        putStrLn "Game Over"

play :: Game -> IO ()
play g@(_, _, _, 1) = do
                            xy <- getLine
                            let x = xy !! 0
                            let y = xy !! 2
                            let nextState = move g $ magicSquare !! ((read [x]::Int)*3+(read [y]::Int))
                            if isNothing $ winner nextState
                            then play nextState
                            else return ()

play gs@(_, _, _, (-1)) = do
                                putStrLn ((show (div index 3)) ++ " " ++ (show (mod index 3)))
                                if isNothing $ winner nextState
                                then play nextState
                                else return ()
                                where
                                    nextMove = snd $ negamax gs
                                    index = fromJust $ elemIndex nextMove magicSquare
                                    nextState = move gs nextMove