DouKaku?

module Main　where

import Char
import Control.Monad
import Control.Monad.State
import Data.Array.IArray
import Data.List
import Data.Maybe
import Data.Function
import System.Random

type Summary = Array Int Int
type Board = Array Int Int
type Idx = Int
type Token = Int
tkX = 1 :: Token
tkO = 2 :: Token

doIf :: Bool -> (a -> a) -> a -> a
doIf True f a = f a
doIf False _ a = a

mapArray array f idxs = array // ([(x, f (array ! x)) | x <- idxs])

idxSumIdx = [[0, 3, 6], [1, 3], 
　　　　[2, 3, 7], [0, 4], [1, 4, 6, 7], 
　　　　[2, 4], [0, 5, 7], [1, 5], [2, 5, 6]] 

idxToSumIdx idx = idxSumIdx!!idx

type TTT = ((Summary, Summary), Board, Int, Token)

turn :: TTT -> Idx -> TTT
turn (sum@(xSummary, oSummary), board, i, tk) idx
    | tk == tkX = ((sumMe', sumOpp), board', i + 1, tkO)
    | otherwise = ((sumOpp, sumMe'), board', i + 1, tkX)
    where
        sumMe' = mapArray sumMe (+ 1) (idxToSumIdx idx)
        (sumMe, sumOpp) = doIf (tk == tkO) (swap) sum
        board' = board // [(idx, tk)]
        swap (a, b) = (b, a)
        
won :: TTT -> Maybe Token
won ((xSummary, oSummary), _, _, _)
    | elem 3 (elems xSummary) = Just tkX
    | elem 3 (elems oSummary) = Just tkO
    | otherwise = Nothing

availableMoves :: TTT -> [Idx]
availableMoves (_, board, _, _) = map (fst) $ filter ((==0).snd) $ assocs board

lineScore :: (Summary, Summary) -> Int -> Int
lineScore (sumSelf, sumEn) iLine = check (sumSelf!iLine) (sumEn!iLine)
    where
        check 2 0 = 10000 -- can win in 1 attempts (2 self & no enemy)
        check 0 2 = 1000 -- can lose in 1 attempts (2 enemy & no self)
        check 0 1 = 100 -- can lose in 2 attempts (1 enemy & no self)
        check 1 0 = 10 -- can win in 2 attempts (1 self & no enemy)
        check 0 0 = 1 -- can win in 3 attempts (empty)
        check _ _ = 0 -- can't win nor lose (!0 enemy & !0 self)

scoreCell :: (Summary, Summary) -> Idx -> Int
scoreCell summaries idx = sum $ map (lineScore summaries) $ idxToSumIdx idx

type Player = TTT -> IO TTT

smartPlayer :: Player
smartPlayer ttt@(sum, _, _, tk) = return $ turn ttt bestMove
    where
        bestMove = snd $ maximumBy (compare `on` fst) $ zip (map (scoreCell sum) avm) avm
        avm = availableMoves ttt

randomPlayer :: Player
randomPlayer ttt = do
        idx <- bestMove
        return $ turn ttt idx
    where
        bestMove = randomChoice $ availableMoves ttt
        randomChoice xs = do
            idx <- getStdRandom $ randomR (0, (length xs) - 1)
            return $ xs!!idx

type STTT = StateT TTT IO ()

playTurn :: Player -> STTT
playTurn p = do
    ttt@(_, _, _, tk) <- get
    ttt' <- liftIO (p ttt)
    put ttt'
    liftIO (evaluate ttt')
    where
        evaluate :: TTT -> IO ()
        evaluate ttt''
            | isJust $ won ttt'' = fail (show $ fromJust $ won ttt'')
            | otherwise = return ()

play :: [Player] -> IO Int
play players =  do
    catch doGame catcher 
    where
        initialTTT     = ((initialSummary, initialSummary), initialBoard, 0, tkX)
        initialSummary = listArray (0, 7) $ repeat 0
        initialBoard   = listArray (0, 8) $ repeat 0

        
        doGame = do
            evalStateT (mapM playTurn players) initialTTT
            return 0

        catcher :: IOError -> IO Int
        catcher e
            | e == (userError "1") = return 1
            | e == (userError "2") = return 2
            | otherwise = return 0

main = do
    putStrLn "[draw, 1st win, 2nd win]"
    tries <- replicateM 10000 (play players)
    print $ elems $ foldl (\rg idx -> mapArray rg (+1) [idx]) rgSum tries
    where
        rgSum :: Array Int Int
        rgSum = listArray (0, 2) $ repeat 0
--        players = take 9 $ cycle [smartPlayer, smartPlayer]
        players = take 9 $ cycle [randomPlayer, smartPlayer]
--        players = take 9 $ cycle [smartPlayer, randomPlayer]
--        players = take 9 $ cycle [randomPlayer, randomPlayer]