{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeSynonymInstances #-} module RMCA.GUI.Board ( GUICell (..) , attachGameRules , initGame , initBoardRV , rotateGUICell , inertCell , toGUICoords , fromGUICoords , validArea , Player(..) , actualTile ) where import Control.Monad import Data.Array import Data.Array.MArray import qualified Data.Bifunctor as BF import Data.Board.GameBoardIO import Data.CBMVar import Data.Maybe import Data.ReactiveValue import Game.Board.BasicTurnGame import Graphics.UI.Gtk hiding (Action) import Graphics.UI.Gtk.Board.BoardLink hiding (attachGameRules) import Graphics.UI.Gtk.Board.TiledBoard hiding ( Board , boardOnPieceDragDrop , boardOnPieceDragOver , boardOnPieceDragStart ) import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO import Paths_RMCA import RMCA.Global.Clock import RMCA.GUI.HelpersRewrite import RMCA.Semantics newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell } type IOBoard = BIO.Board Int Tile (Player,GUICell) -- There are two types of tiles that can be distinguished by setting -- two different colors for debugging purposes. A future release might -- want to remove that. data Tile = TileW | TileB rotateGUICell :: GUICell -> GUICell rotateGUICell g = g { cellAction = rotateAction $ cellAction g } where rotateAction (ChDir b na d) = ChDir b na (nextDir d) rotateAction x = x tileW :: Int tileW = 40 tileH :: Int tileH = round d where d :: Double d = sqrt 3 * fromIntegral tileW / 3 hexW :: Int hexW = round d where d :: Double d = 4 * fromIntegral tileW / 3 hexH :: Int hexH = round d where d :: Double d = sqrt 3 * fromIntegral hexW / 2 boardToTile :: [(Int,Int,Tile)] boardToTile = [(x,y,selTile) | (x,y) <- range ( (xMin-1,yMin) , (xMax+3,yMax+1)) , let selTile = if even x && even y || odd x && odd y then TileW else TileB ] outGUIBoard :: (Int,Int) -> Bool outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax inertCell :: GUICell inertCell = GUICell { cellAction = Inert , repeatCount = 1 , asPh = False } initGUIBoard :: GUIBoard initGUIBoard = GUIBoard GameState { curPlayer' = Player , boardPos = boardToTile , boardPieces' = boardToPiece [] $ makeBoard [] } instance PlayableGame GUIBoard Int Tile Player GUICell where curPlayer _ = Player allPos (GUIBoard game) = boardPos game allPieces (GUIBoard game) = boardPieces' game moveEnabled _ = True canMove (GUIBoard game) _ (x,y) | Just (_,p) <- getPieceAt game (x,y) , GUICell { cellAction = Inert } <- p = False | Nothing <- getPieceAt game (x,y) = False | otherwise = True canMoveTo _ _ _ fPos = fPos `elem` validArea || outGUIBoard fPos move (GUIBoard game) _ iPos@(_,yi) fPos@(xf,yf) | outGUIBoard iPos && outGUIBoard fPos = [] | outGUIBoard fPos = [ RemovePiece iPos , AddPiece iPos Player nCell ] | iPos `elem` ctrlCoords = [ RemovePiece fPos' , AddPiece fPos' Player (nCell { cellAction = ctrlAction }) ] | otherwise = [ MovePiece iPos fPos' , AddPiece iPos Player nCell ] where fPos' | (xf `mod` 2 == 0 && yf `mod` 2 == 0) || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf) | otherwise = (xf,yf+signum' (yf-yi)) signum' x | x == 0 = 1 | otherwise = signum x ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos nCell | Just (_,GUICell { asPh = ph, repeatCount = n }) <- getPieceAt game iPos = inertCell { repeatCount = n , asPh = ph } | otherwise = inertCell applyChange (GUIBoard game) (AddPiece (x,y) Player piece) = GUIBoard $ game { boardPieces' = bp' } where bp' = (x,y,Player,piece):boardPieces' game applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $ game { boardPieces' = bp' } where bp' = [p | p@(x',y',_,_) <- boardPieces' game , x /= x' || y /= y'] applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos) | Just (_,p) <- getPieceAt game iPos = applyChanges guiBoard [ RemovePiece iPos , RemovePiece fPos , AddPiece fPos Player p] | otherwise = guiBoard initGame :: IO (Game GUIBoard Int Tile Player GUICell) initGame = do pixbufs <- fileToPixbuf tilePixbufB <- pixbufNew ColorspaceRgb False 8 tileW tileH tilePixbufW <- pixbufNew ColorspaceRgb False 8 tileW tileH pixbufFill tilePixbufB 50 50 50 0 pixbufFill tilePixbufW 50 50 50 0 let pixPiece :: (Player,GUICell) -> Pixbuf pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs pixTile :: Tile -> Pixbuf pixTile TileW = tilePixbufW pixTile TileB = tilePixbufB visualA = VisualGameAspects { tileF = pixTile , pieceF = pixPiece , bgColor = (1000,1000,1000) , bg = Nothing } return $ Game visualA initGUIBoard -- Initializes a readable RV for the board and an readable-writable RV -- for the playheads. Also installs some handlers for pieces modification. initBoardRV :: BIO.Board Int Tile (Player,GUICell) -> IO ( ReactiveFieldRead IO Board , Array Pos (ReactiveFieldWrite IO GUICell) , ReactiveFieldWrite IO [PlayHead]) initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do -- RV creation phMVar <- newCBMVar [] notBMVar <- mkClockRV 50 let getterB :: IO Board getterB = do (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray let board = makeBoard $ map (BF.first fromGUICoords . BF.second ((\(_,c) -> (cellAction c,repeatCount c)) . fromJust)) $ filter (isJust . snd) boardArray return board notifierB :: IO () -> IO () notifierB = reactiveValueOnCanRead notBMVar getterP :: IO [PlayHead] getterP = readCBMVar phMVar setterP :: [PlayHead] -> IO () setterP lph = do oph <- readCBMVar phMVar let offPh :: PlayHead -> IO () offPh ph = do let pos = toGUICoords $ phPos ph piece <- boardGetPiece pos board when (isJust piece) $ do let (_,c) = fromJust piece boardSetPiece pos (Player, c { asPh = False }) board onPh :: PlayHead -> IO () onPh ph = do let pos = toGUICoords $ phPos ph piece <- boardGetPiece pos board when (isJust piece) $ do let (_,c) = fromJust piece boardSetPiece pos (Player, c { asPh = True }) board postGUIAsync $ mapM_ offPh oph postGUIAsync $ mapM_ onPh lph writeCBMVar phMVar lph notifierP :: IO () -> IO () notifierP = installCallbackCBMVar phMVar b = ReactiveFieldRead getterB notifierB ph = ReactiveFieldReadWrite setterP getterP notifierP setterW :: (Int,Int) -> GUICell -> IO () setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board arrW :: Array Pos (ReactiveFieldWrite IO GUICell) arrW = array (minimum validArea, maximum validArea) [(i, ReactiveFieldWrite (setterW i)) | i <- validArea :: [(Int,Int)]] return (b,arrW,writeOnly ph) fileToPixbuf :: IO [(FilePath,Pixbuf)] fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in uncurry (liftM2 (,)) ( return f' , getDataFileName f' >>= (pixbufNewFromFile >=> \p -> pixbufScaleSimple p hexW hexW InterpBilinear))) (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++ concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"] | d <- [N .. NW]]) actionToFile :: GUICell -> FilePath actionToFile GUICell { cellAction = a , asPh = ph } = case a of Inert -> "img/hexO" ++ (if ph then "n" else "ff") ++ ".png" Absorb -> "img/absorb.svg" Stop _ -> "img/stop.svg" ChDir True _ d -> "img/start" ++ show d ++ ".svg" ChDir False _ d -> "img/ric" ++ show d ++ ".svg" Split _ -> "img/split.svg"