Created
June 9, 2016 23:50
-
-
Save chowells79/dbc7c6df2af8f1e00aa6a037c1cfc3d8 to your computer and use it in GitHub Desktop.
Tic Tac Toe
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
Author
chowells79
commented
Jun 10, 2016
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment