]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/Board.hs
Add a warning about Jack in the README.
[tmp/julm/arpeggigon.git] / src / RMCA / GUI / Board.hs
1 {-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase,
2 MultiParamTypeClasses, ScopedTypeVariables, TypeSynonymInstances
3 #-}
4
5 module RMCA.GUI.Board ( GUICell (..)
6 , attachGameRules
7 , initGame
8 , initBoardRV
9 , rotateGUICell
10 , inertCell
11 , toGUICoords
12 , fromGUICoords
13 , validArea
14 , Player(..)
15 , actualTile
16 ) where
17
18 import Control.Arrow
19 import Control.Monad
20 import Data.Array
21 import Data.Array.MArray
22 import Data.Board.GameBoardIO
23 import Data.CBMVar
24 import Data.Maybe
25 import Data.ReactiveValue
26 import Data.Word
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
31 ( Board
32 , boardOnPieceDragDrop
33 , boardOnPieceDragOver
34 , boardOnPieceDragStart
35 )
36 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
37 import Paths_arpeggigon
38 import RMCA.GUI.HelpersRewrite
39 import RMCA.IOClockworks
40 import RMCA.Semantics
41
42 import Debug.Trace
43
44 newtype GUIBoard = GUIBoard (GameState Int Tile Player GUICell)
45
46 -- There are two types of tiles that can be distinguished by setting
47 -- two different colors for debugging purposes. A future release might
48 -- want to remove that.
49 data Tile = TileW | TileB
50
51
52 rotateGUICell :: GUICell -> GUICell
53 rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
54 where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
55 rotateAction x = x
56
57 tileW :: Int
58 tileW = 40
59
60 tileH :: Int
61 tileH = round d
62 where d :: Double
63 d = sqrt 3 * fromIntegral tileW / 3
64
65 hexW :: Int
66 hexW = round d
67 where d :: Double
68 d = 4 * fromIntegral tileW / 3
69
70 {-
71 hexH :: Int
72 hexH = round d
73 where d :: Double
74 d = sqrt 3 * fromIntegral hexW / 2
75 -}
76
77 boardToTile :: [(Int,Int,Tile)]
78 boardToTile = [(x,y,selTile) | (x,y) <- range ( (xMin-1,yMin)
79 , (xMax+3,yMax+1))
80 , let selTile = if even x && even y
81 ||
82 odd x && odd y
83 then TileW
84 else TileB ]
85
86
87
88 outGUIBoard :: (Int,Int) -> Bool
89 outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax
90
91 inertCell :: GUICell
92 inertCell = GUICell { cellAction = Inert
93 , repeatCount = 1
94 , asPh = False
95 }
96
97 initGUIBoard :: GUIBoard
98 initGUIBoard = GUIBoard GameState
99 { curPlayer' = Player
100 , boardPos = boardToTile
101 , boardPieces' = boardToPiece [] $ makeBoard []
102 }
103
104 instance PlayableGame GUIBoard Int Tile Player GUICell where
105 curPlayer _ = Player
106 allPos (GUIBoard game) = boardPos game
107 allPieces (GUIBoard game) = boardPieces' game
108 moveEnabled _ = True
109
110 canMove (GUIBoard game) _ (x,y)
111 | Just (_,p) <- getPieceAt game (x,y)
112 , GUICell { cellAction = Inert } <- p = False
113 | Nothing <- getPieceAt game (x,y) = False
114 | otherwise = True
115 canMoveTo _ _ _ fPos = fPos `elem` validArea || outGUIBoard fPos
116
117 move (GUIBoard game) _ iPos@(_,yi) fPos@(xf,yf)
118 | outGUIBoard iPos && outGUIBoard fPos = []
119 | outGUIBoard fPos = [ RemovePiece iPos
120 , AddPiece iPos Player nCell ]
121 | iPos `elem` ctrlCoords = [ RemovePiece fPos'
122 , AddPiece fPos' Player
123 (nCell { cellAction = ctrlAction }) ]
124 | otherwise = [ MovePiece iPos fPos'
125 , AddPiece iPos Player nCell ]
126 where fPos'
127 | (xf `mod` 2 == 0 && yf `mod` 2 == 0)
128 || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
129 | otherwise = (xf,yf+signum' (yf-yi))
130 signum' x
131 | x == 0 = 1
132 | otherwise = signum x
133 ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos
134 nCell
135 | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
136 getPieceAt game iPos = inertCell { repeatCount = n
137 , asPh = ph
138 }
139 | otherwise = inertCell
140
141 applyChange (GUIBoard game) (AddPiece (x,y) Player piece) =
142 GUIBoard $ game { boardPieces' = bp' }
143 where bp' = (x,y,Player,piece):boardPieces' game
144
145 applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
146 game { boardPieces' = bp' }
147 where bp' = [p | p@(x',y',_,_) <- boardPieces' game
148 , x /= x' || y /= y']
149
150 applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
151 | Just (_,p) <- getPieceAt game iPos
152 = applyChanges guiBoard [ RemovePiece iPos
153 , RemovePiece fPos
154 , AddPiece fPos Player p
155 ]
156 | otherwise = guiBoard
157
158 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
159 initGame = do
160 --pixbufs <- fileToPixbuf
161 tilePixbufB <- pixbufNew ColorspaceRgb False 8 tileW tileH
162 tilePixbufW <- pixbufNew ColorspaceRgb False 8 tileW tileH
163 pixbufFill tilePixbufB 50 50 50 0
164 pixbufFill tilePixbufW 50 50 50 0
165 pixPiece <- pixbufForPiece
166 let pixTile :: Tile -> Pixbuf
167 pixTile TileW = tilePixbufW
168 pixTile TileB = tilePixbufB
169 visualA = VisualGameAspects { tileF = pixTile
170 , pieceF = \(_,g) -> pixPiece g
171 , bgColor = (1000,1000,1000)
172 , bg = Nothing
173 }
174
175 return $ Game visualA initGUIBoard
176
177 -- Initializes a readable RV for the board and an readable-writable RV
178 -- for the playheads. Also installs some handlers for pieces modification.
179 initBoardRV :: IOTick
180 -> BIO.Board Int Tile (Player,GUICell)
181 -> IO ( ReactiveFieldRead IO Board
182 , Array Pos (ReactiveFieldWrite IO GUICell)
183 , ReactiveFieldWrite IO [PlayHead])
184 initBoardRV tc board@BIO.Board { boardPieces = (GameBoard gArray) } = do
185 -- RV creation
186 phMVar <- newCBMVar []
187 let getterB :: IO Board
188 getterB = do
189 (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
190 let board = makeBoard $
191 map (first fromGUICoords .
192 second ((\(_,c) -> (cellAction c,repeatCount c)) .
193 fromJust)) $
194 filter (isJust . snd) boardArray
195 return board
196
197 notifierB :: IO () -> IO ()
198 notifierB = reactiveValueOnCanRead tc
199
200 getterP :: IO [PlayHead]
201 getterP = readCBMVar phMVar
202
203 setterP :: [PlayHead] -> IO ()
204 setterP lph = do
205 oph <- readCBMVar phMVar
206 unless (oph == lph) $ do
207 let offPh :: PlayHead -> IO ()
208 offPh ph = do
209 let pos = toGUICoords $ phPos ph
210 piece <- boardGetPiece pos board
211 when (isJust piece) $ do
212 let (_,c) = fromJust piece
213 boardSetPiece pos (Player, c { asPh = False }) board
214 onPh :: PlayHead -> IO ()
215 onPh ph = do
216 let pos = toGUICoords $ phPos ph
217 piece <- boardGetPiece pos board
218 when (isJust piece) $ do
219 let (_,c) = fromJust piece
220 boardSetPiece pos (Player, c { asPh = True }) board
221 postGUIAsync $ mapM_ offPh oph
222 postGUIAsync $ mapM_ onPh lph
223 writeCBMVar phMVar lph
224
225 notifierP :: IO () -> IO ()
226 notifierP = installCallbackCBMVar phMVar
227
228 b = ReactiveFieldRead getterB notifierB
229 ph = ReactiveFieldReadWrite setterP getterP notifierP
230
231 setterW :: (Int,Int) -> GUICell -> IO ()
232 setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board
233
234 arrW :: Array Pos (ReactiveFieldWrite IO GUICell)
235 arrW = array (minimum validArea, maximum validArea)
236 [(i, ReactiveFieldWrite (setterW i))
237 | i <- validArea :: [(Int,Int)]]
238
239 return (b,arrW,writeOnly ph)
240 {-
241 fileToPixbuf :: IO [(FilePath,Pixbuf)]
242 fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in
243 uncurry (liftM2 (,))
244 ( return f'
245 , getDataFileName f' >>=
246 (pixbufNewFromFile >=>
247 \p -> pixbufScaleSimple p hexW hexW InterpBilinear)))
248 (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
249 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
250 | d <- [N .. NW]])
251 -}
252
253 -- If the repeatCount of some tile is superior to mrc,
254 -- then this tile will be undistinguishable from any other tile with a
255 -- repeat count superior to mrc.
256 mrc :: (Num a) => a
257 mrc = 6
258
259 pixbufForPiece :: IO (GUICell -> Pixbuf)
260 pixbufForPiece = do
261 let colorPlayHead _ r g b ma = if (r == 0 && g == 0 && b == 0)
262 then (0, 0, 0, ma)
263 else (0, g, 0, ma)
264 colorRC 0 _ _ _ _ ma = (0, 0, 0, ma)
265 colorRC rc _ r g b ma =
266 if (r == 0 && g == 0 && b == 0)
267 then (0, 0, 0, ma)
268 else let (gradr, gradg, gradb) = ( (maxBound - r) `quot` mrc
269 , (g - minBound) `quot` mrc
270 , (b - minBound) `quot` mrc
271 )
272 in ( r + gradr * (rc - 1)
273 , g - gradg * (rc - 1)
274 , b - gradb * (rc - 1)
275 , ma
276 )
277 pixbufs <- mapM (\(a,rc) -> do df <- getDataFileName $ actionToFile a
278 p <- do p' <- pixbufNewFromFile df
279 pixbufScaleSimple p' hexW hexW InterpBilinear
280 modifyPixbuf (colorRC rc) p
281 p' <- pixbufCopy p
282 modifyPixbuf colorPlayHead p'
283 return ((a,rc), (p, p'))
284 ) [(a,r) | r <- [0..mrc], a <- actionList]
285 let f GUICell { cellAction = a
286 , asPh = t
287 , repeatCount = r } =
288 (if t then snd else fst) $ fromJust $
289 lookup (anonymizeConstructor a, min (fromIntegral r) mrc) pixbufs
290 return f
291
292 modifyPixbuf :: ((Int, Int) -> Word8 -> Word8 -> Word8 -> Maybe Word8 ->
293 (Word8, Word8, Word8, Maybe Word8))
294 -> Pixbuf -> IO ()
295 modifyPixbuf f p = do
296 pixs <- pixbufGetPixels p
297 w <- pixbufGetWidth p
298 h <- pixbufGetHeight p
299 rs <- pixbufGetRowstride p
300 chans <- pixbufGetNChannels p
301 forM_ [(x,y) | x <- [0..w - 1], y <- [0..h - 1]] $ \(x,y) -> do
302 let p = x * rs + y * chans
303 red <- readArray pixs p
304 green <- readArray pixs (p + 1)
305 blue <- readArray pixs (p + 2)
306 alpha <- if (chans == 4)
307 then fmap Just $ readArray pixs (p + 3)
308 else return Nothing
309 let (nr, ng, nb, na) = f (x,y) red green blue alpha
310 writeArray pixs p nr
311 writeArray pixs (p + 1) ng
312 writeArray pixs (p + 2) nb
313 when (isJust na) $ writeArray pixs (p + 3) $ fromJust na
314
315
316 actionToFile :: Action -> FilePath
317 actionToFile = \case
318 Inert -> "img/hexOff.png"
319 Absorb -> "img/absorb.svg"
320 Stop _ -> "img/stop.svg"
321 ChDir True _ d -> "img/start" ++ show d ++ ".svg"
322 ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
323 Split _ -> "img/split.svg"