Tic Tac Toe

tictactoe.hs

{-# LANGUAGE RankNTypes #-}
import Data.Foldable (foldl')
import Data.Monoid (Any)

import Data.Vector (Vector, (!))
import qualified Data.Vector as V

import Control.Lens hiding ((:<))
import Control.Lens.Internal.Context (runPretext)
import Control.Comonad.Cofree

import qualified Data.IntMap as M

-- Types
type Grid = Vector (Maybe Player)

data Player = X | O deriving (Read, Show, Ord, Eq)
data Game = Turn Player Grid | Won Player Grid | Drawn Grid
          deriving (Read, Show, Ord, Eq)

-- Lensy accessors
winner :: Fold Game Player
winner f (Won p b) = flip Won b <$> f p
winner _ s         = pure s

winning :: Fold Game Grid
winning f (Won p b) = Won p <$> f b
winning _ s         = pure s

drawing :: Fold Game Grid
drawing f (Drawn b) = Drawn <$> f b
drawing _ s         = pure s

incomplete :: Fold Game (Player, Grid)
incomplete f (Turn p b) = uncurry Turn <$> f (p, b)
incomplete _ s          = pure s

-- Utility
size :: Foldable f => Cofree f a -> Integer
size = go 0
  where
    go s (_ :< xs) = foldl' go (s + 1) xs

{-# INLINE shoots #-}
shoots :: Traversable g => Traversal' (Cofree g a) a
shoots f = go
  where
    go xss@(x :< xs) | null xs   = pure xss
                     | otherwise = (:<) <$> f x <*> traverse go xs

{-# INLINE leaves #-}
leaves :: Traversable g => Traversal' (Cofree g a) a
leaves f = go
  where
    go (x :< xs) | null xs   = (:< xs) <$> f x
                 | otherwise = (x :<) <$> traverse go xs

-- not actually named 'eats'
{-# INLINE telescoped_ #-}
telescoped_ :: Functor f => [(Cofree g a -> f (Cofree g a)) -> g (Cofree g a) -> f (g (Cofree g a))] -> (Cofree g a -> f (Cofree g a)) -> Cofree g a -> f (Cofree g a)
telescoped_ = foldr (\l r -> _unwrap . l . r) id

having :: Getting Any s a -> Prism' s s
having = filtered . has

-- Let's play...
new :: Game
new = Turn X . V.replicate 9 $ Nothing

moves :: Game -> M.IntMap Game
moves (Won _ _)  = M.empty
moves (Drawn _) = M.empty
moves (Turn p b) = M.fromList $ map (fmap check) boards
  where
    boards = addMove <$> holesOf (itraversed <. having _Nothing) b
      where
        addMove pt = runPretext pt . Indexed $ \i _ -> (i, Just p)

    check board | won board   = Won p board
                | drawn board = Drawn board
                | otherwise   = Turn (other p) board

    won board = any (all (== Just p)) $ map (map (board !)) lanes
    lanes = [ [0,1,2], [3,4,5], [6,7,8], [2,4,6]
            , [0,3,6], [1,4,7], [2,5,8], [0,4,8] ]

    drawn = V.all (/= Nothing)

    other X = O
    other O = X

tree :: Cofree M.IntMap Game
tree = coiter moves new

$ ghci coiter.hs
GHCi, version 8.0.1: http://www.haskell.org/ghc/  :? for help
[1 of 1] Compiling Main             ( coiter.hs, interpreted )
Ok, modules loaded: Main.
*Main> size tree -- evaluate the whole thing, somewhat slow since it's interpreted
549946
*Main> lengthOf leaves tree -- count the number of completed games of tic-tac-toe
255168
*Main> lengthOf (leaves . winning) tree -- count the number of games where one side wins
209088
*Main> lengthOf (leaves . drawing) tree -- count the number of draws
46080
*Main> lengthOf (leaves . winner . filtered (== X)) tree -- numer of games X wins
131184
*Main> tree ^? telescoped [] -- Examine the game board when no moves have been made
Just (Turn X [Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing])
*Main> tree ^? telescoped [ix 2] -- one move
Just (Turn O [Nothing,Nothing,Just X,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing])
*Main> tree ^? telescoped [ix 2, ix 4] -- two moves
Just (Turn X [Nothing,Nothing,Just X,Nothing,Just O,Nothing,Nothing,Nothing,Nothing])
*Main> tree ^? telescoped [ix 2, ix 4, ix 4] -- Can't move in the same place twice..
Nothing
*Main> lengthOf (telescoped_ [ix 4] . leaves . winner . filtered (== X)) tree -- how many games does X win when the first move is in the center?
15648
*Main> lengthOf (telescoped_ [ix 4, ix 1] . leaves . winner . filtered (== O)) tree -- how many does O win when the first move is in the center?
612