]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/GUI/Board.hs
Playheads all correct.
[tmp/julm/arpeggigon.git] / 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 Debug.Trace
16 import Game.Board.BasicTurnGame
17 import Graphics.UI.Gtk hiding (Action)
18 import Graphics.UI.Gtk.Board.BoardLink
19 import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
20 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
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 newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
30
31 data Tile = Tile
32 data Player = Player deriving(Show)
33
34 -- Takes a GUI coordinate and give the corresponding coordinate on the
35 -- internal board
36 fromGUICoords :: (Int,Int) -> (Int,Int)
37 fromGUICoords (x,y) = (x,(x `mod` 2 - y) `quot` 2)
38
39 -- Takes coordinates from the point of view of the internal board and
40 -- translates them to GUI board coordinates.
41 toGUICoords :: (Int,Int) -> (Int,Int)
42 toGUICoords (x,y) = (x,2*(-y) + x `mod` 2)
43
44 tileW :: Int
45 tileW = 40
46
47 tileH :: Int
48 tileH = round (sqrt 3 * fromIntegral tileW / 3)
49
50 hexW :: Int
51 hexW = round (4 * fromIntegral tileW / 3)
52
53 hexH :: Int
54 hexH = round (sqrt 3 * fromIntegral hexW / 2)
55
56 xMax, yMax :: Int
57 (xMax,yMax) = BF.second (*2) $ neighbor N nec
58 xMin, yMin :: Int
59 (xMin,yMin) = BF.second (*2) swc
60
61 boardToTile :: [(Int,Int,Tile)]
62 boardToTile = [(x,y,Tile) | (x,y) <- range ( (xMin-1,yMin)
63 , (xMax+1,yMax+1))]
64
65
66
67 boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)]
68 boardToPiece ph = map placePiece . filter (onBoard . fst) . assocs
69 where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell)
70 placePiece ((x,y),(a,n)) = let y' = 2*(-y) + x `mod` 2
71 c = GUICell { cellAction = a
72 , repeatCount = n
73 , asPh = (x,y) `elem` phPosS
74 }
75 in (x,y',Player,c)
76 phPosS = map phPos ph
77
78 validArea :: Board -> [(Int,Int)]
79 validArea = map (\(x,y,_,_) -> (x,y)) . boardToPiece []
80
81 na = NoteAttr {
82 naArt = Accent13,
83 naDur = 1 % 1,
84 naOrn = Ornaments Nothing [] NoSlide
85 }
86
87 initGUIBoard :: GUIBoard
88 initGUIBoard = GUIBoard GameState
89 { curPlayer' = Player
90 , boardPos = boardToTile
91 , boardPieces' = boardToPiece [] $
92 makeBoard [((0,0), mkCell (ChDir True na NE)),
93 ((2,1), mkCellRpt (ChDir False na NW) 3),
94 ((0,2), mkCell (ChDir False na S))]
95 }
96
97 instance PlayableGame GUIBoard Int Tile Player GUICell where
98 curPlayer _ = Player
99 allPos (GUIBoard game) = boardPos game
100 allPieces (GUIBoard game) = boardPieces' game
101 moveEnabled _ = True
102 canMove (GUIBoard game) _ (x,y)
103 | Just (_,p) <- getPieceAt game (x,y)
104 , GUICell { cellAction = Inert } <- p = False
105 | otherwise = True
106 canMoveTo _ _ _ (x,y) = (x,y) `elem` validArea
107 where validArea = map (\(x',y',_,_) -> (x',y')) $ boardToPiece [] $
108 makeBoard []
109
110 move (GUIBoard game) _ iPos@(_,yi) (xf,yf) = [ MovePiece iPos fPos'
111 , AddPiece iPos Player nCell]
112 where fPos'
113 | (xf `mod` 2 == 0 && yf `mod` 2 == 0)
114 || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
115 | otherwise = (xf,yf+signum' (yf-yi))
116 signum' x
117 | x == 0 = 1
118 | otherwise = signum x
119 nCell
120 | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
121 getPieceAt game iPos = inertCell { repeatCount = n
122 , asPh = ph
123 }
124 | otherwise = inertCell
125 where inertCell = GUICell { cellAction = Inert
126 , repeatCount = 1
127 , asPh = False}
128
129 applyChange (GUIBoard game) (AddPiece pos@(x,y) Player piece) =
130 GUIBoard $ game { boardPieces' = bp' }
131 where bp' = (x,y,Player,piece):boardPieces' game
132
133 applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
134 game { boardPieces' = bp' }
135 where bp' = [p | p@(x',y',_,_) <- boardPieces' game
136 , x /= x' || y /= y']
137
138 applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
139 | Just (_,p) <- getPieceAt game iPos
140 = applyChanges guiBoard [ RemovePiece iPos
141 , RemovePiece fPos
142 , AddPiece fPos Player p]
143 | otherwise = guiBoard
144
145 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
146 initGame = do
147 pixbufs <- fileToPixbuf
148 tilePixbuf <- pixbufNew ColorspaceRgb False 8 tileW tileH
149 pixbufFill tilePixbuf 50 50 50 0
150 let pixPiece :: (Player,GUICell) -> Pixbuf
151 pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs
152 pixTile :: Tile -> Pixbuf
153 pixTile _ = tilePixbuf
154 visualA = VisualGameAspects { tileF = pixTile
155 , pieceF = pixPiece
156 , bgColor = (1000,1000,1000)
157 , bg = Nothing
158 }
159
160 return $ Game visualA initGUIBoard
161
162 initBoardRV :: BIO.Board Int Tile (Player,GUICell)
163 -> IO ( ReactiveFieldRead IO Board
164 , ReactiveFieldReadWrite IO [PlayHead])
165 initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
166 phMVar <- newCBMVar []
167 oldphMVar <- newCBMVar []
168 notBMVar <- mkClockRV 100
169 let getterB :: IO Board
170 getterB = do
171 (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs array
172 let board = makeBoard $
173 map (BF.first fromGUICoords .
174 BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
175 fromJust)) $
176 filter (isJust . snd) boardArray
177 return board
178
179 notifierB :: IO () -> IO ()
180 notifierB = reactiveValueOnCanRead notBMVar
181
182 getterP :: IO [PlayHead]
183 getterP = readCBMVar phMVar
184
185 setterP :: [PlayHead] -> IO ()
186 setterP lph = do
187 let phPosS = map phPos lph
188 readCBMVar phMVar >>= writeCBMVar oldphMVar
189 oph <- readCBMVar oldphMVar
190 writeCBMVar phMVar lph
191 let offPh :: PlayHead -> IO ()
192 offPh ph = do
193 let pos = toGUICoords $ phPos ph
194 piece <- boardGetPiece pos board
195 when (isJust piece) $ do
196 let (_,c) = fromJust piece
197 boardSetPiece pos (Player, c { asPh = pos `elem` phPosS }) board
198 onPh :: PlayHead -> IO ()
199 onPh ph = do
200 let pos = toGUICoords $ phPos ph
201 piece <- boardGetPiece pos board
202 when (isJust piece) $ do
203 let (_,c) = fromJust piece
204 boardSetPiece pos (Player, c { asPh = True }) board
205 mapM_ offPh oph
206 print oph
207 mapM_ onPh lph
208 print lph
209
210 notifierP :: IO () -> IO ()
211 notifierP = installCallbackCBMVar phMVar
212
213 b = ReactiveFieldRead getterB notifierB
214 ph = ReactiveFieldReadWrite setterP getterP notifierP
215 return (b,ph)
216
217 fileToPixbuf :: IO [(FilePath,Pixbuf)]
218 fileToPixbuf = mapM (\f -> let f' = "img/" ++ f in uncurry (liftM2 (,))
219 ( return f'
220 , pixbufNewFromFile f' >>=
221 \p -> pixbufScaleSimple p hexW hexW InterpBilinear ))
222 (["hexOn.png","hexOff.png","stop.svg","split.svg"] ++
223 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
224 | d <- [N .. NW]])
225
226 actionToFile :: GUICell -> FilePath
227 actionToFile GUICell { cellAction = a
228 , asPh = ph
229 } =
230 case (a,ph) of
231 (Inert,True) -> "img/hexOn.png"
232 (Inert,False) -> "img/hexOff.png"
233 (Absorb,_) -> "img/stop.svg"
234 (Stop _,_) -> "img/stop.svg"
235 (ChDir True _ d,_) -> "img/start" ++ show d ++ ".svg"
236 (ChDir False _ d,_) -> "img/ric" ++ show d ++ ".svg"
237 (Split _,_) -> "img/split.svg"