-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables,
- TypeSynonymInstances #-}
-
-module RMCA.GUI.Board where
-
+{-# 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 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 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
-import Debug.Trace
-
-data GUICell = GUICell { cellAction :: Action
- , repeatCount :: Int
- , asPh :: Bool
- } deriving(Show)
+newtype GUIBoard = GUIBoard (GameState Int Tile Player GUICell)
-newtype GUIBoard = GUIBoard { toGS :: 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
-type IOBoard = BIO.Board Int Tile (Player,GUICell)
-
-data Tile = Tile
-data Player = Player deriving(Show)
rotateGUICell :: GUICell -> GUICell
rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
rotateAction x = x
--- 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
where d :: Double
d = 4 * fromIntegral tileW / 3
+{-
hexH :: Int
hexH = round d
where d :: Double
d = 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
+-}
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
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 game) _ iPos@(_,yi) fPos@(xf,yf)
| outGUIBoard iPos && outGUIBoard fPos = []
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)
, ReactiveFieldWrite IO [PlayHead])
-initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
+initBoardRV tc board@BIO.Board { boardPieces = (GameBoard gArray) } = do
-- RV creation
phMVar <- newCBMVar []
- notBMVar <- mkClockRV 10
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
sourcephile / git / tmp / julm / arpeggigon.git / blobdiff