-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables,
- TypeSynonymInstances #-}
-
-module RMCA.GUI.Board where
-
-import Control.Concurrent.MVar
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,
+ ScopedTypeVariables, TypeSynonymInstances #-}
+
+module RMCA.GUI.Board ( GUICell (..)
+ , attachGameRules
+ , initGame
+ , initBoardRV
+ , rotateGUICell
+ , inertCell
+ , toGUICoords
+ , fromGUICoords
+ , validArea
+ , Player(..)
+ , actualTile
+ ) where
+
+import Control.Arrow
import Control.Monad
-import Control.Monad.IO.Class
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.Ratio
import Data.ReactiveValue
-import Debug.Trace
import Game.Board.BasicTurnGame
import Graphics.UI.Gtk hiding (Action)
-import Graphics.UI.Gtk.Board.BoardLink
-import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
+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.IOClockworks
import RMCA.Semantics
-data GUICell = GUICell { cellAction :: Action
- , repeatCount :: Int
- , asPh :: Bool
- } deriving(Show)
+newtype GUIBoard = GUIBoard (GameState 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
-newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
-
-type IOBoard = BIO.Board Int Tile (Player,GUICell)
-
-data Tile = Tile
-data Player = Player deriving(Show)
-
--- Takes a GUI coordinate and give the corresponding coordinate on the
--- internal board
-fromGUICoords :: (Int,Int) -> (Int,Int)
-fromGUICoords (x,y) = (x,(x `mod` 2 - y) `quot` 2)
-
--- Takes coordinates from the point of view of the internal board and
--- translates them to GUI board coordinates.
-toGUICoords :: (Int,Int) -> (Int,Int)
-toGUICoords (x,y) = (x,2*(-y) + x `mod` 2)
-
tileW :: Int
tileW = 40
tileH :: Int
-tileH = round (sqrt 3 * fromIntegral tileW / 3)
+tileH = round d
+ where d :: Double
+ d = sqrt 3 * fromIntegral tileW / 3
hexW :: Int
-hexW = round (4 * fromIntegral tileW / 3)
+hexW = round d
+ where d :: Double
+ d = 4 * fromIntegral tileW / 3
+{-
hexH :: Int
-hexH = round (sqrt 3 * fromIntegral hexW / 2)
-
-xMax, yMax :: Int
-(xMax,yMax) = BF.second (*2) $ neighbor N nec
-xMin, yMin :: Int
-(xMin,yMin) = BF.second (*2) swc
+hexH = round d
+ where d :: Double
+ d = sqrt 3 * fromIntegral hexW / 2
+-}
boardToTile :: [(Int,Int,Tile)]
-boardToTile = [(x,y,Tile) | (x,y) <- range ( (xMin-1,yMin)
- , (xMax+3,yMax+1))]
-
-defNa :: NoteAttr
-defNa = NoteAttr { naArt = NoAccent
- , naDur = 1 % 4
- , naOrn = noOrn
- }
-
-ctrlPieces :: [(Int,Int,Player,GUICell)]
-ctrlPieces = [(xMax+2,y,Player,GUICell { cellAction = action
- , repeatCount = 1
- , asPh = False
- })
- | let actions = [ Absorb, Stop defNa
- , ChDir False defNa N, ChDir True defNa N
- , Split defNa]
- -- /!\ It would be nice to find a general formula
- -- for placing the control pieces.
- , (y,action) <- zip [ yMin+4,yMin+8..] actions]
-
-ctrlCoords :: [(Int,Int)]
-ctrlCoords = map (\(x,y,_,_) -> (x,y)) ctrlPieces
-
-boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)]
-boardToPiece ph = (++ ctrlPieces) . map placePiece .
- filter (onBoard . fst) . assocs
- where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell)
- placePiece ((x,y),(a,n)) = let c = GUICell { cellAction = a
- , repeatCount = n
- , asPh = (x,y) `elem` phPosS
- }
- (x',y') = toGUICoords (x,y)
- in (x',y',Player,c)
- phPosS = map phPos ph
-
-validArea :: [(Int,Int)]
-validArea = filter (onBoard . fromGUICoords) $
- map (\(x,y,_,_) -> (x,y)) $ boardToPiece [] $ makeBoard []
+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
-na = NoteAttr {
- naArt = Accent13,
- naDur = 1 % 1,
- naOrn = Ornaments Nothing [] NoSlide
- }
-
inertCell :: GUICell
inertCell = GUICell { cellAction = Inert
, repeatCount = 1
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
+ canMoveTo _ _ _ fPos = fPos `elem` validArea || outGUIBoard fPos
- move guiBoard@(GUIBoard game) p iPos@(_,yi) fPos@(xf,yf)
+ move (GUIBoard game) _ iPos@(_,yi) fPos@(xf,yf)
| outGUIBoard iPos && outGUIBoard fPos = []
| outGUIBoard fPos = [ RemovePiece iPos
, AddPiece iPos Player nCell ]
}
| otherwise = inertCell
- applyChange (GUIBoard game) (AddPiece pos@(x,y) Player piece) =
+ applyChange (GUIBoard game) (AddPiece (x,y) Player piece) =
GUIBoard $ game { boardPieces' = bp' }
where bp' = (x,y,Player,piece):boardPieces' game
initGame :: IO (Game GUIBoard Int Tile Player GUICell)
initGame = do
pixbufs <- fileToPixbuf
- tilePixbuf <- pixbufNew ColorspaceRgb False 8 tileW tileH
- pixbufFill tilePixbuf 50 50 50 0
+ 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 _ = tilePixbuf
+ pixTile TileW = tilePixbufW
+ pixTile TileB = tilePixbufB
visualA = VisualGameAspects { tileF = pixTile
, pieceF = pixPiece
, bgColor = (1000,1000,1000)
-- 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)
+initBoardRV :: IOTick
+ -> BIO.Board Int Tile (Player,GUICell)
-> IO ( ReactiveFieldRead IO Board
, Array Pos (ReactiveFieldWrite IO GUICell)
- , ReactiveFieldReadWrite IO [PlayHead])
-initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard gArray) } = do
+ , ReactiveFieldWrite IO [PlayHead])
+initBoardRV tc board@BIO.Board { boardPieces = (GameBoard gArray) } = do
-- RV creation
phMVar <- newCBMVar []
- notBMVar <- mkClockRV 100
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)) .
+ map (first fromGUICoords .
+ second ((\(_,c) -> (cellAction c,repeatCount c)) .
fromJust)) $
filter (isJust . snd) boardArray
return board
notifierB :: IO () -> IO ()
- notifierB = reactiveValueOnCanRead notBMVar
+ notifierB = reactiveValueOnCanRead tc
getterP :: IO [PlayHead]
getterP = readCBMVar phMVar
setterP :: [PlayHead] -> IO ()
setterP lph = do
oph <- readCBMVar phMVar
- let phPosS = map phPos lph
- offPh :: PlayHead -> IO ()
+ let offPh :: PlayHead -> IO ()
offPh ph = do
let pos = toGUICoords $ phPos ph
piece <- boardGetPiece pos board
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,ph)
-
-clickHandling :: BIO.Board Int Tile (Player,GUICell) -> IO ()
-clickHandling board = do
- state <- newEmptyMVar
- boardOnPress board
- (\iPos -> liftIO $ do
- postGUIAsync $ void $ tryPutMVar state iPos
- return True
- )
- boardOnRelease board
- (\fPos -> liftIO $ do
- postGUIAsync $ do
- mp <- boardGetPiece fPos board
- mstate <- tryTakeMVar state
- when (fPos `elem` validArea && isJust mp &&
- maybe False (== fPos) mstate) $ do
- boardSetPiece fPos (BF.second rotateGUICell $
- fromJust mp) board
- return True
- )
-
- {-
- boardOnPress board
- (\i -> do
- mp <- boardGetPiece i board
- when (i `elem` validArea && isJust mp && fromJust mp == Inert) $
--}
+ | 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' >>=
- \f'' -> pixbufNewFromFile f'' >>=
- \p -> pixbufScaleSimple p hexW hexW InterpBilinear))
+ (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]])
sourcephile / git / tmp / julm / arpeggigon.git / blobdiff