module Game.TicTacToe3D.TicTacToe3D (
Team,
Issue,
Board,
Game (..),
done,
newGame,
playGame
) where
import Control.Monad
import Data.Functor
import Data.Monoid
import Data.Maybe
import Data.List
import Data.Foldable as F
import Data.Tuple.Homogenous
import Game.TicTacToe3D.Vector3 as V
collapse :: [a] -> [(a, a)]
collapse ns = take (halfLen ns) (collapse' ns)
where halfLen ms = length ms `quot` 2
collapse' ms = zip ms (reverse ms)
directions :: Int -> [([Int], [Int])]
directions i = collapse $ allDirections
where allDirections = replicateM i [1, 0, 1]
directions3 :: [Tuple2 I3]
directions3 = f <$> directions 3 where
f t = g <$> Tuple2 t where
g [x, y, z] = (x, y, z)
explode :: I3 -> [Tuple2 [I3]]
explode c = (walk c <$>) <$> directions3 where
walk h i = let j = add h i in j : walk j i where
add (h, i, j) (k, l, m) = (h + k, i + l, j + m)
withinC :: Int -> Int -> I3 -> Bool
withinC min max c =
F.all f $ Tuple3 c where
f n = min <= n && n < max
explode' :: Int -> I3 -> [[I3]]
explode' len crd = catMaybes $ do
Tuple2 (fs, bs) <- explode crd
let line = crd : pick fs ++ pick bs where
pick = takeWhile $ withinC 0 len
return $ if length line == len then Just line else Nothing
type Team = Bool
type Issue = Maybe Team
type Board = (Int, V3 Issue)
foldI :: [Issue] -> Issue
foldI [] = Nothing
foldI (x:xs) = F.foldr add x xs
where add m n = if m == n then m else Nothing
firstJust :: (Foldable f) => f (Maybe a) -> Maybe a
firstJust ms = join $ F.find isJust ms
check :: Board -> I3 -> Maybe ([I3], Team)
check (i, v) c = firstJust $ do
l <- explode' i c
let j = foldI $ (v V.!) <$> l
return $ (,) l <$> j
type Result = Maybe (Either [I3] Board)
play :: Board -> Team -> I3 -> Result
play (l, v) t c
| v V.! c /= Nothing = Nothing
| otherwise =
let new = (l, v V.// (c, Just t))
in Just $ case check new c of
Just (cs, _) -> Left cs
Nothing -> Right new
initBoard :: Int -> (I3 -> Issue) -> Board
initBoard i f = (,) i $ V.init i f
data Game = Game Board Team | Done Team [I3]
newGame :: Game
newGame = Game newBoard True where
newBoard = (initBoard 3 $ const Nothing)
done :: Game -> Bool
done (Done _ _) = True
done _ = False
playGame :: Int -> Game -> Game
playGame _ g @ (Done _ _) = g
playGame c g @ (Game b t) =
case play b t (i3 c) of
Just (Left cs) -> Done t cs
Just (Right b') -> Game b' (not t)
Nothing -> g