]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/Board.hs
Add basic note duration selection (doesn't look like it's actually doing something…).
[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)
28
29 rotateGUICell :: GUICell -> GUICell
30 rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
31 where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
32 rotateAction x = x
33
34 newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
35
36 type IOBoard = BIO.Board Int Tile (Player,GUICell)
37
38 data Tile = Tile
39 data Player = Player deriving(Show)
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 , ReactiveFieldReadWrite IO [PlayHead])
207 initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
208 -- RV creation
209 phMVar <- newCBMVar []
210 notBMVar <- mkClockRV 100
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 arrW :: Array Pos (ReactiveFieldWrite IO GUICell)
258 arrW = array (minimum validArea, maximum validArea)
259 [(i, ReactiveFieldWrite (setterW i))
260 | i <- validArea :: [(Int,Int)]]
261
262 return (b,arrW,ph)
263
264 {-
265 boardOnPress board
266 (\i -> do
267 mp <- boardGetPiece i board
268 when (i `elem` validArea && isJust mp && fromJust mp == Inert) $
269 -}
270
271
272 fileToPixbuf :: IO [(FilePath,Pixbuf)]
273 fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in
274 uncurry (liftM2 (,))
275 ( return f'
276 , getDataFileName f' >>=
277 (pixbufNewFromFile >=>
278 \p -> pixbufScaleSimple p hexW hexW InterpBilinear)))
279 (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
280 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
281 | d <- [N .. NW]])
282
283 actionToFile :: GUICell -> FilePath
284 actionToFile GUICell { cellAction = a
285 , asPh = ph
286 } =
287 case a of
288 Inert -> "img/hexO" ++ (if ph then "n" else "ff") ++ ".png"
289 Absorb -> "img/absorb.svg"
290 Stop _ -> "img/stop.svg"
291 ChDir True _ d -> "img/start" ++ show d ++ ".svg"
292 ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
293 Split _ -> "img/split.svg"