1 {-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase,
2 MultiParamTypeClasses, ScopedTypeVariables, TypeSynonymInstances
5 module RMCA.GUI.Board ( GUICell (..)
21 import Data.Array.MArray
22 import Data.Board.GameBoardIO
25 import Data.ReactiveValue
27 import Game.Board.BasicTurnGame
28 import Graphics.UI.Gtk hiding (Action)
29 import Graphics.UI.Gtk.Board.BoardLink hiding (attachGameRules)
30 import Graphics.UI.Gtk.Board.TiledBoard hiding
32 , boardOnPieceDragDrop
33 , boardOnPieceDragOver
34 , boardOnPieceDragStart
36 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
37 import Paths_arpeggigon
38 import RMCA.GUI.HelpersRewrite
39 import RMCA.IOClockworks
42 newtype GUIBoard = GUIBoard (GameState Int Tile Player GUICell)
44 -- There are two types of tiles that can be distinguished by setting
45 -- two different colors for debugging purposes. A future release might
46 -- want to remove that.
47 data Tile = TileW | TileB
50 rotateGUICell :: GUICell -> GUICell
51 rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
52 where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
61 d = sqrt 3 * fromIntegral tileW / 3
66 d = 4 * fromIntegral tileW / 3
72 d = sqrt 3 * fromIntegral hexW / 2
75 boardToTile :: [(Int,Int,Tile)]
76 boardToTile = [(x,y,selTile) | (x,y) <- range ( (xMin-1,yMin)
78 , let selTile = if even x && even y
86 outGUIBoard :: (Int,Int) -> Bool
87 outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax
90 inertCell = GUICell { cellAction = Inert
95 initGUIBoard :: GUIBoard
96 initGUIBoard = GUIBoard GameState
98 , boardPos = boardToTile
99 , boardPieces' = boardToPiece [] $ makeBoard []
102 instance PlayableGame GUIBoard Int Tile Player GUICell where
104 allPos (GUIBoard game) = boardPos game
105 allPieces (GUIBoard game) = boardPieces' game
108 canMove (GUIBoard game) _ (x,y)
109 | Just (_,p) <- getPieceAt game (x,y)
110 , GUICell { cellAction = Inert } <- p = False
111 | Nothing <- getPieceAt game (x,y) = False
113 canMoveTo _ _ _ fPos = fPos `elem` validArea || outGUIBoard fPos
115 move (GUIBoard game) _ iPos@(_,yi) fPos@(xf,yf)
116 | outGUIBoard iPos && outGUIBoard fPos = []
117 | outGUIBoard fPos = [ RemovePiece iPos
118 , AddPiece iPos Player nCell ]
119 | iPos `elem` ctrlCoords = [ RemovePiece fPos'
120 , AddPiece fPos' Player
121 (nCell { cellAction = ctrlAction }) ]
122 | otherwise = [ MovePiece iPos fPos'
123 , AddPiece iPos Player nCell ]
125 | (xf `mod` 2 == 0 && yf `mod` 2 == 0)
126 || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
127 | otherwise = (xf,yf+signum' (yf-yi))
130 | otherwise = signum x
131 ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos
133 | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
134 getPieceAt game iPos = inertCell { repeatCount = n
137 | otherwise = inertCell
139 applyChange (GUIBoard game) (AddPiece (x,y) Player piece) =
140 GUIBoard $ game { boardPieces' = bp' }
141 where bp' = (x,y,Player,piece):boardPieces' game
143 applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
144 game { boardPieces' = bp' }
145 where bp' = [p | p@(x',y',_,_) <- boardPieces' game
146 , x /= x' || y /= y']
148 applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
149 | Just (_,p) <- getPieceAt game iPos
150 = applyChanges guiBoard [ RemovePiece iPos
152 , AddPiece fPos Player p]
153 | otherwise = guiBoard
155 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
157 --pixbufs <- fileToPixbuf
158 tilePixbufB <- pixbufNew ColorspaceRgb False 8 tileW tileH
159 tilePixbufW <- pixbufNew ColorspaceRgb False 8 tileW tileH
160 pixbufFill tilePixbufB 50 50 50 0
161 pixbufFill tilePixbufW 50 50 50 0
162 pixPiece <- pixbufForPiece
163 let pixTile :: Tile -> Pixbuf
164 pixTile TileW = tilePixbufW
165 pixTile TileB = tilePixbufB
166 visualA = VisualGameAspects { tileF = pixTile
168 , bgColor = (1000,1000,1000)
172 return $ Game visualA initGUIBoard
174 -- Initializes a readable RV for the board and an readable-writable RV
175 -- for the playheads. Also installs some handlers for pieces modification.
176 initBoardRV :: IOTick
177 -> BIO.Board Int Tile (Player,GUICell)
178 -> IO ( ReactiveFieldRead IO Board
179 , Array Pos (ReactiveFieldWrite IO GUICell)
180 , ReactiveFieldWrite IO [PlayHead])
181 initBoardRV tc board@BIO.Board { boardPieces = (GameBoard gArray) } = do
183 phMVar <- newCBMVar []
184 let getterB :: IO Board
186 (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
187 let board = makeBoard $
188 map (first fromGUICoords .
189 second ((\(_,c) -> (cellAction c,repeatCount c)) .
191 filter (isJust . snd) boardArray
194 notifierB :: IO () -> IO ()
195 notifierB = reactiveValueOnCanRead tc
197 getterP :: IO [PlayHead]
198 getterP = readCBMVar phMVar
200 setterP :: [PlayHead] -> IO ()
202 oph <- readCBMVar phMVar
203 let offPh :: PlayHead -> IO ()
205 let pos = toGUICoords $ phPos ph
206 piece <- boardGetPiece pos board
207 when (isJust piece) $ do
208 let (_,c) = fromJust piece
209 boardSetPiece pos (Player, c { asPh = False }) board
210 onPh :: PlayHead -> IO ()
212 let pos = toGUICoords $ phPos ph
213 piece <- boardGetPiece pos board
214 when (isJust piece) $ do
215 let (_,c) = fromJust piece
216 boardSetPiece pos (Player, c { asPh = True }) board
217 postGUIAsync $ mapM_ offPh oph
218 postGUIAsync $ mapM_ onPh lph
219 writeCBMVar phMVar lph
221 notifierP :: IO () -> IO ()
222 notifierP = installCallbackCBMVar phMVar
224 b = ReactiveFieldRead getterB notifierB
225 ph = ReactiveFieldReadWrite setterP getterP notifierP
227 setterW :: (Int,Int) -> GUICell -> IO ()
228 setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board
230 arrW :: Array Pos (ReactiveFieldWrite IO GUICell)
231 arrW = array (minimum validArea, maximum validArea)
232 [(i, ReactiveFieldWrite (setterW i))
233 | i <- validArea :: [(Int,Int)]]
235 return (b,arrW,writeOnly ph)
237 fileToPixbuf :: IO [(FilePath,Pixbuf)]
238 fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in
241 , getDataFileName f' >>=
242 (pixbufNewFromFile >=>
243 \p -> pixbufScaleSimple p hexW hexW InterpBilinear)))
244 (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
245 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
248 pixbufForPiece :: IO ((Player, GUICell) -> Pixbuf)
250 let changeColor _ r g b ma = if (r == 0 && g == 0 && b == 0)
253 pixbufs <- mapM (\a -> do df <- getDataFileName $ actionToFile a
254 p <- do p' <- pixbufNewFromFile df
255 pixbufScaleSimple p' hexW hexW InterpBilinear
257 modifyPixbuf changeColor p'
260 let f (_, GUICell { cellAction = a
261 , asPh = t }) = (if t then snd else fst) $ fromJust $
262 lookup (anonymizeConstructor a) pixbufs
265 modifyPixbuf :: ((Int, Int) -> Word8 -> Word8 -> Word8 -> Maybe Word8 ->
266 (Word8, Word8, Word8, Maybe Word8))
268 modifyPixbuf f p = do
269 pixs <- pixbufGetPixels p
270 w <- pixbufGetWidth p
271 h <- pixbufGetHeight p
272 rs <- pixbufGetRowstride p
273 chans <- pixbufGetNChannels p
274 forM_ [(x,y) | x <- [0..w - 1], y <- [0..h - 1]] $ \(x,y) -> do
275 let p = x * rs + y * chans
276 red <- readArray pixs p
277 green <- readArray pixs (p + 1)
278 blue <- readArray pixs (p + 2)
279 alpha <- if (chans == 4)
280 then fmap Just $ readArray pixs (p + 3)
282 let (nr, ng, nb, na) = f (x,y) red green blue alpha
284 writeArray pixs (p + 1) ng
285 writeArray pixs (p + 2) nb
286 when (isJust na) $ writeArray pixs (p + 3) $ fromJust na
289 actionToFile :: Action -> FilePath
291 Inert -> "img/hexOff.png"
292 Absorb -> "img/absorb.svg"
293 Stop _ -> "img/stop.svg"
294 ChDir True _ d -> "img/start" ++ show d ++ ".svg"
295 ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
296 Split _ -> "img/split.svg"