module Game.Grid where
import Control.Applicative
import Control.Arrow
import Data.List.Split
import Data.Map (Map, fromList)
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text as T
import Debug.Trace
import Game.Disc
import Game.Util
import Graphics.Blank
type Cord = (Int, Int)
type Board = Map Cord Disc
data Direction = NW | N | NE | E | SE | S | SW | W
deriving (Show, Eq, Enum)
grid w h = do
let sz = min w h
let sqSize = sz / 9
clearRect (0,0,w,h)
beginPath()
save()
translate (w / 2, h / 2)
lineWidth 3
beginPath()
strokeStyle "black"
sequence_ $ computeSquare (sz/2, sz/2) sqSize <$> gridCord 8
fillStyle "green"
fill()
stroke()
restore()
gridCord n = (,) <$> [0..n1] <*> [0..n1]
computeSquare (x0, y0) sz (x, y) = sqr (x0 + x*sz, y0 + y * sz, sz)
sqr (x, y, s) = rect (x, y, s, s)
pointToSq :: (Double, Double) -> Double -> Double -> Maybe Cord
pointToSq (x,y) w h = validate $
do x' <- Just $ round $ ((x w / 2) / sz) * 10
y' <- Just $ round $ ((y h / 2) / sz) * 10
return (x', y')
where sz = min w h
validate :: Maybe Cord -> Maybe Cord
validate c@(Just (x , y)) = if (x > maxX || x < minX) || (y > maxY || y < minY)
then Nothing else c
validate Nothing = Nothing
adjacent :: Cord -> [Cord]
adjacent (x, y) = Prelude.filter (\(a,b) -> a >= minX && a <= maxX
&& b >= minY && b <= maxY && (a,b) /= (x,y))
$ (,) <$> [ x1..x+1 ] <*> [ y1..y+1 ]
direction :: Cord -> Cord -> Direction
direction (nc_x, nc_y) (oc_x, oc_y)
| (nc_x > oc_x) && (nc_y > oc_y) = NW
| (nc_x == oc_x) && (nc_y > oc_y) = N
| (nc_x < oc_x) && (nc_y > oc_y) = NE
| (nc_x < oc_x) && (nc_y == oc_y) = E
| (nc_x < oc_x) && (nc_y < oc_y) = SE
| (nc_x == oc_x) && (nc_y < oc_y) = S
| (nc_x > oc_x) && (nc_y < oc_y) = SW
| (nc_x > oc_x) && (nc_y == oc_y) = W
move :: Direction -> Cord -> Maybe Cord
move N (x,y) = validate $ return (x, y1)
move NE (x,y) = validate $ return (x+1,y1)
move E (x,y) = validate $ return (x+1,y)
move SE (x,y) = validate $ return (x+1,y+1)
move S (x,y) = validate $ return (x,y+1)
move SW (x,y) = validate $ return (x1,y+1)
move W (x,y) = validate $ return (x1,y)
move NW (x,y) = validate $ return (x1,y1)
isValidMove :: Cord -> Map Cord Disc -> Disc -> Bool
isValidMove pos board turn = isEmptySquare pos board
&& areAdjacentSquareOpposite pos board turn
&& sandwiches pos board turn
isEmptySquare :: Cord -> Map Cord Disc -> Bool
isEmptySquare pos board = isNothing $ Map.lookup pos board
areAdjacentSquareOpposite :: Cord -> Map Cord Disc -> Disc -> Bool
areAdjacentSquareOpposite pos board turn = not . null
$ adjacentOppositeSquares pos board turn
adjacentOppositeSquares :: Cord -> Map Cord Disc -> Disc -> [Maybe Disc]
adjacentOppositeSquares pos board turn =
filter (== (Just $ swap turn))
$ flip Map.lookup board <$> adjacent pos
sandwiches :: Cord -> Map Cord Disc -> Disc -> Bool
sandwiches pos board turn = not . null $ filter isJust
$ allFirstSameDiscs pos board turn
allFirstSameDiscs pos board turn = sds <$> vps
where
l d = move d pos
ps = zip allDirections (l <$> allDirections)
vps = filter (\(a, Just b) -> isJust (Map.lookup b board)
&& (Map.lookup b board /= Just turn))
$ filter (isJust . snd)
$ second validate <$> ps
sds (d, Just p) = getFirstSameDisc p d board turn
getFirstSameDisc :: Cord -> Direction -> Map Cord Disc -> Disc -> Maybe (Cord, Disc)
getFirstSameDisc pos dir board turn = collapse $ head z
where
l = line pos dir
md = (flip Map.lookup board =<<) <$> l
z = dropWhile (\(a,b) -> (b == (Just $ swap turn)))
$ safeTail
$ zip l md
updateBoard :: Cord -> Disc -> Board -> Board
updateBoard pos turn board = Map.union (fromList nv) board
where
z :: [(Direction, Maybe (Cord, Disc))]
z = zip allDirections $ allFirstSameDiscs pos board turn
bs = sequence $ concat $ between pos <$> z
nv = case bs of
Just l -> zip l $ repeat turn
Nothing -> []
between :: Cord -> (Direction, Maybe (Cord, Disc)) -> [Maybe Cord]
between _ (_, Nothing) = []
between pos1 (_, Just (pos2, disc)) =
takeWhile (/= Just pos2) $ line pos1 $ direction pos1 pos2
line :: Cord -> Direction -> [Maybe Cord]
line pos d = l
where
l = Just pos : scanl (\c _ -> c >>= move d)
(Just pos >>= move d) l
allDirections :: [Direction]
allDirections = (toEnum <$> [0..7::Int])::[Direction]
allValidMoves :: Board -> Disc -> [Cord]
allValidMoves board turn = filter iv cs
where
cs = emptyCords board
iv c = isValidMove c board turn
emptyCords :: Board -> [Cord]
emptyCords board = Set.toList $ Set.difference bs es
where
bs = Set.fromList ((,) <$> [minX..maxX] <*> [minY..maxY])
es = Set.fromList (fst <$> Map.toList board)