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