]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/Board.hs
Solved memory leak issue when Jack is connected. There still is a leak when Jack...
[tmp/julm/arpeggigon.git] / src / RMCA / GUI / Board.hs
1 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables,
2 TypeSynonymInstances #-}
3
4 module RMCA.GUI.Board where
5
6 import Control.Monad
7 import Data.Array
8 import Data.Array.MArray
9 import qualified Data.Bifunctor as BF
10 import Data.Board.GameBoardIO
11 import Data.CBMVar
12 import Data.Maybe
13 import Data.Ratio
14 import Data.ReactiveValue
15 import Game.Board.BasicTurnGame
16 import Graphics.UI.Gtk hiding (Action)
17 import Graphics.UI.Gtk.Board.BoardLink
18 import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
19 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
20 import Paths_RMCA
21 import RMCA.Global.Clock
22 import RMCA.Semantics
23
24 import Debug.Trace
25
26 data GUICell = GUICell { cellAction :: Action
27 , repeatCount :: Int
28 , asPh :: Bool
29 } deriving(Show)
30
31 newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
32
33 type IOBoard = BIO.Board Int Tile (Player,GUICell)
34
35 data Tile = Tile
36 data Player = Player deriving(Show)
37
38 rotateGUICell :: GUICell -> GUICell
39 rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
40 where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
41 rotateAction x = x
42
43 -- Takes a GUI coordinate and give the corresponding coordinate on the
44 -- internal board
45 fromGUICoords :: (Int,Int) -> (Int,Int)
46 fromGUICoords (x,y) = (x,(x `mod` 2 - y) `quot` 2)
47
48 -- Takes coordinates from the point of view of the internal board and
49 -- translates them to GUI board coordinates.
50 toGUICoords :: (Int,Int) -> (Int,Int)
51 toGUICoords (x,y) = (x,2*(-y) + x `mod` 2)
52
53 tileW :: Int
54 tileW = 40
55
56 tileH :: Int
57 tileH = round d
58 where d :: Double
59 d = sqrt 3 * fromIntegral tileW / 3
60
61 hexW :: Int
62 hexW = round d
63 where d :: Double
64 d = 4 * fromIntegral tileW / 3
65
66 hexH :: Int
67 hexH = round d
68 where d :: Double
69 d = sqrt 3 * fromIntegral hexW / 2
70
71 xMax, yMax :: Int
72 (xMax,yMax) = BF.second (*2) $ neighbor N nec
73 xMin, yMin :: Int
74 (xMin,yMin) = BF.second (*2) swc
75
76 boardToTile :: [(Int,Int,Tile)]
77 boardToTile = [(x,y,Tile) | (x,y) <- range ( (xMin-1,yMin)
78 , (xMax+3,yMax+1))]
79
80 defNa :: NoteAttr
81 defNa = NoteAttr { naArt = NoAccent
82 , naDur = 1 % 4
83 , naOrn = noOrn
84 }
85
86 ctrlPieces :: [(Int,Int,Player,GUICell)]
87 ctrlPieces = [(xMax+2,y,Player,GUICell { cellAction = action
88 , repeatCount = 1
89 , asPh = False
90 })
91 | let actions = [ Absorb, Stop defNa
92 , ChDir False defNa N, ChDir True defNa N
93 , Split defNa]
94 -- /!\ It would be nice to find a general formula
95 -- for placing the control pieces.
96 , (y,action) <- zip [ yMin+4,yMin+8..] actions]
97
98 ctrlCoords :: [(Int,Int)]
99 ctrlCoords = map (\(x,y,_,_) -> (x,y)) ctrlPieces
100
101 boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)]
102 boardToPiece ph = (++ ctrlPieces) . map placePiece .
103 filter (onBoard . fst) . assocs
104 where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell)
105 placePiece ((x,y),(a,n)) = let c = GUICell { cellAction = a
106 , repeatCount = n
107 , asPh = (x,y) `elem` phPosS
108 }
109 (x',y') = toGUICoords (x,y)
110 in (x',y',Player,c)
111 phPosS = map phPos ph
112
113 validArea :: [(Int,Int)]
114 validArea = filter (onBoard . fromGUICoords) $
115 map (\(x,y,_,_) -> (x,y)) $ boardToPiece [] $ makeBoard []
116
117 outGUIBoard :: (Int,Int) -> Bool
118 outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax
119
120 inertCell :: GUICell
121 inertCell = GUICell { cellAction = Inert
122 , repeatCount = 1
123 , asPh = False
124 }
125
126 initGUIBoard :: GUIBoard
127 initGUIBoard = GUIBoard GameState
128 { curPlayer' = Player
129 , boardPos = boardToTile
130 , boardPieces' = boardToPiece [] $ makeBoard []
131 }
132
133 instance PlayableGame GUIBoard Int Tile Player GUICell where
134 curPlayer _ = Player
135 allPos (GUIBoard game) = boardPos game
136 allPieces (GUIBoard game) = boardPieces' game
137 moveEnabled _ = True
138 canMove (GUIBoard game) _ (x,y)
139 | Just (_,p) <- getPieceAt game (x,y)
140 , GUICell { cellAction = Inert } <- p = False
141 | Nothing <- getPieceAt game (x,y) = False
142 | otherwise = True
143 canMoveTo _ _ _ fPos = fPos `elem` validArea
144 || outGUIBoard fPos
145
146 move (GUIBoard game) _ iPos@(_,yi) fPos@(xf,yf)
147 | outGUIBoard iPos && outGUIBoard fPos = []
148 | outGUIBoard fPos = [ RemovePiece iPos
149 , AddPiece iPos Player nCell ]
150 | iPos `elem` ctrlCoords = [ RemovePiece fPos'
151 , AddPiece fPos' Player
152 (nCell { cellAction = ctrlAction }) ]
153 | otherwise = [ MovePiece iPos fPos'
154 , AddPiece iPos Player nCell ]
155 where fPos'
156 | (xf `mod` 2 == 0 && yf `mod` 2 == 0)
157 || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
158 | otherwise = (xf,yf+signum' (yf-yi))
159 signum' x
160 | x == 0 = 1
161 | otherwise = signum x
162 ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos
163 nCell
164 | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
165 getPieceAt game iPos = inertCell { repeatCount = n
166 , asPh = ph
167 }
168 | otherwise = inertCell
169
170 applyChange (GUIBoard game) (AddPiece (x,y) Player piece) =
171 GUIBoard $ game { boardPieces' = bp' }
172 where bp' = (x,y,Player,piece):boardPieces' game
173
174 applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
175 game { boardPieces' = bp' }
176 where bp' = [p | p@(x',y',_,_) <- boardPieces' game
177 , x /= x' || y /= y']
178
179 applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
180 | Just (_,p) <- getPieceAt game iPos
181 = applyChanges guiBoard [ RemovePiece iPos
182 , RemovePiece fPos
183 , AddPiece fPos Player p]
184 | otherwise = guiBoard
185
186 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
187 initGame = do
188 pixbufs <- fileToPixbuf
189 tilePixbuf <- pixbufNew ColorspaceRgb False 8 tileW tileH
190 pixbufFill tilePixbuf 50 50 50 0
191 let pixPiece :: (Player,GUICell) -> Pixbuf
192 pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs
193 pixTile :: Tile -> Pixbuf
194 pixTile _ = tilePixbuf
195 visualA = VisualGameAspects { tileF = pixTile
196 , pieceF = pixPiece
197 , bgColor = (1000,1000,1000)
198 , bg = Nothing
199 }
200
201 return $ Game visualA initGUIBoard
202
203 -- Initializes a readable RV for the board and an readable-writable RV
204 -- for the playheads. Also installs some handlers for pieces modification.
205 initBoardRV :: BIO.Board Int Tile (Player,GUICell)
206 -> IO ( ReactiveFieldRead IO Board
207 , Array Pos (ReactiveFieldWrite IO GUICell)
208 , ReactiveFieldWrite IO [PlayHead])
209 initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
210 -- RV creation
211 phMVar <- newCBMVar []
212 notBMVar <- mkClockRV 10
213 let getterB :: IO Board
214 getterB = do
215 (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
216 let board = makeBoard $
217 map (BF.first fromGUICoords .
218 BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
219 fromJust)) $
220 filter (isJust . snd) boardArray
221 return board
222
223 notifierB :: IO () -> IO ()
224 notifierB = reactiveValueOnCanRead notBMVar
225
226 getterP :: IO [PlayHead]
227 getterP = readCBMVar phMVar
228
229 setterP :: [PlayHead] -> IO ()
230 setterP lph = do
231 oph <- readCBMVar phMVar
232 let offPh :: PlayHead -> IO ()
233 offPh ph = do
234 let pos = toGUICoords $ phPos ph
235 piece <- boardGetPiece pos board
236 when (isJust piece) $ do
237 let (_,c) = fromJust piece
238 boardSetPiece pos (Player, c { asPh = False }) board
239 onPh :: PlayHead -> IO ()
240 onPh ph = do
241 let pos = toGUICoords $ phPos ph
242 piece <- boardGetPiece pos board
243 when (isJust piece) $ do
244 let (_,c) = fromJust piece
245 boardSetPiece pos (Player, c { asPh = True }) board
246 postGUIAsync $ mapM_ offPh oph
247 postGUIAsync $ mapM_ onPh lph
248 writeCBMVar phMVar lph
249
250 notifierP :: IO () -> IO ()
251 notifierP = installCallbackCBMVar phMVar
252
253 b = ReactiveFieldRead getterB notifierB
254 ph = ReactiveFieldReadWrite setterP getterP notifierP
255
256 setterW :: (Int,Int) -> GUICell -> IO ()
257 setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board
258
259
260 arrW :: Array Pos (ReactiveFieldWrite IO GUICell)
261 arrW = array (minimum validArea, maximum validArea)
262 [(i, ReactiveFieldWrite (setterW i))
263 | i <- validArea :: [(Int,Int)]]
264
265 return (b,arrW,writeOnly ph)
266
267 fileToPixbuf :: IO [(FilePath,Pixbuf)]
268 fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in
269 uncurry (liftM2 (,))
270 ( return f'
271 , getDataFileName f' >>=
272 (pixbufNewFromFile >=>
273 \p -> pixbufScaleSimple p hexW hexW InterpBilinear)))
274 (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
275 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
276 | d <- [N .. NW]])
277
278 actionToFile :: GUICell -> FilePath
279 actionToFile GUICell { cellAction = a
280 , asPh = ph
281 } =
282 case a of
283 Inert -> "img/hexO" ++ (if ph then "n" else "ff") ++ ".png"
284 Absorb -> "img/absorb.svg"
285 Stop _ -> "img/stop.svg"
286 ChDir True _ d -> "img/start" ++ show d ++ ".svg"
287 ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
288 Split _ -> "img/split.svg"