]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/HelpersRewrite.hs
Edit change log.
[tmp/julm/arpeggigon.git] / src / RMCA / GUI / HelpersRewrite.hs
1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
2
3 -- This module contains function that allow the particular geometry of
4 -- the board to not cause too much problems.
5 --
6 -- They are stolen from the gtk-helpers library.
7
8 module RMCA.GUI.HelpersRewrite where
9
10 import Control.Arrow
11 import Control.Monad
12 import Control.Monad.IO.Class
13 import Data.Array
14 import Data.IORef
15 import Data.Maybe
16 import Data.Ratio
17 import Game.Board.BasicTurnGame
18 import Graphics.UI.Gtk hiding (Action)
19 import Graphics.UI.Gtk.Board.BoardLink hiding (attachGameRules)
20 import Graphics.UI.Gtk.Board.TiledBoard hiding
21 ( Board
22 , boardOnPieceDragDrop
23 , boardOnPieceDragOver
24 , boardOnPieceDragStart
25 )
26 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
27 import RMCA.Semantics
28
29 data GUICell = GUICell { cellAction :: Action
30 , repeatCount :: Int
31 , asPh :: Bool
32 } deriving(Show,Eq)
33
34 data Player = Player deriving(Show)
35
36 -- Takes a GUI coordinate and give the corresponding coordinate on the
37 -- internal board
38 fromGUICoords :: (Int,Int) -> (Int,Int)
39 fromGUICoords (x,y) = (x,(x `mod` 2 - y) `quot` 2)
40
41 -- Takes coordinates from the point of view of the internal board and
42 -- translates them to GUI board coordinates.
43 toGUICoords :: (Int,Int) -> (Int,Int)
44 toGUICoords (x,y) = (x,2*(-y) + x `mod` 2)
45
46 defNa :: NoteAttr
47 defNa = NoteAttr { naArt = NoAccent
48 , naDur = 1 % 4
49 , naOrn = noOrn
50 }
51
52 xMax, yMax :: Int
53 (xMax,yMax) = second (*2) $ neighbor N nec
54 xMin, yMin :: Int
55 (xMin,yMin) = second (*2) swc
56
57 ctrlPieces :: [(Int,Int,Player,GUICell)]
58 ctrlPieces = [(xMax+2,y,Player,GUICell { cellAction = action
59 , repeatCount = 1
60 , asPh = False
61 })
62 | let actions = [ Absorb, Stop defNa
63 , ChDir False defNa N, ChDir True defNa N
64 , Split defNa]
65 -- /!\ It would be nice to find a general formula
66 -- for placing the control pieces.
67 , (y,action) <- zip [ yMin+4,yMin+8..] actions]
68
69 ctrlCoords :: [(Int,Int)]
70 ctrlCoords = map (\(x,y,_,_) -> (x,y)) ctrlPieces
71
72 boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)]
73 boardToPiece ph = (++ ctrlPieces) . map placePiece .
74 filter (onBoard . fst) . assocs
75 where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell)
76 placePiece ((x,y),(a,n)) = let c = GUICell { cellAction = a
77 , repeatCount = n
78 , asPh = (x,y) `elem` phPosS
79 }
80 (x',y') = toGUICoords (x,y)
81 in (x',y',Player,c)
82 phPosS = map phPos ph
83
84 validArea :: [(Int,Int)]
85 validArea = filter (onBoard . fromGUICoords) $
86 map (\(x,y,_,_) -> (x,y)) $ boardToPiece [] $ makeBoard []
87
88 -- Because of the geometry of the board, a tile might be covered by a
89 -- piece without actually carrying any. This function retrieves the
90 -- index of the tile carrying the piece that covers the tile.
91 actualTile :: (Int,Int) -> (Int,Int)
92 actualTile p@(x,y)
93 | y <= yMin || p `elem` piecesCoords = p
94 | otherwise = (x,y-1)
95 where piecesCoords = validArea ++ ctrlCoords
96
97 boardOnPieceDragStart :: BIO.Board Int tile piece
98 -> ((Int, Int) -> IO Bool) -> IO()
99 boardOnPieceDragStart board f = boardOnPress board $ \ix -> do
100 (x,y) <- eventCoordinates
101 returning False $ liftIO $ do
102 drag <- readIORef (dragEnabled board)
103 when drag $ do
104 canDragThis <- f ix
105 let from = if canDragThis
106 then Just $ actualTile ix
107 else Nothing
108 orig = if canDragThis
109 then Just (relativePos board (actualTile ix) (round x, round y))
110 else Nothing
111 writeIORef (draggingFrom board) from
112 writeIORef (draggingMouseOrig board) orig
113 boardInvalidate board
114
115 boardOnPieceDragOver :: Ix index =>
116 BIO.Board index tile piece
117 -> ((index, index) -> (index, index) -> IO Bool) -> IO()
118 boardOnPieceDragOver board f = boardOnMotion board $ \ix -> do
119 (x,y) <- eventCoordinates
120 returning False $ liftIO $ do
121 drag <- readIORef (dragEnabled board)
122 origM <- readIORef (draggingFrom board)
123 when (drag && isJust origM) $ do
124 canDropHere <- f (fromJust origM) ix
125 let newDest = if canDropHere then Just ix else Nothing
126 writeIORef (draggingTo board) newDest
127 writeIORef (draggingMousePos board) (Just (round x, round y))
128 boardInvalidate board
129
130 boardOnPieceDragDrop :: Ix index =>
131 BIO.Board index tile piece
132 -> ((index, index) -> (index, index) -> IO ()) -> IO()
133 boardOnPieceDragDrop board f = void $ do
134 widgetAddEvents (boardDrawingArea board) [ButtonPressMask, ButtonReleaseMask]
135 boardDrawingArea board `on` buttonReleaseEvent $ returning False $ liftIO $ do
136 drag <- readIORef (dragEnabled board)
137 origM <- readIORef (draggingFrom board)
138 destM <- readIORef (draggingTo board)
139 let notSame = origM /= destM
140 when (drag && isJust origM) $ do
141
142 -- No longer dragging
143 writeIORef (draggingFrom board) Nothing
144 writeIORef (draggingTo board) Nothing
145 writeIORef (draggingMouseOrig board) Nothing
146 writeIORef (draggingMousePos board) Nothing
147
148 -- When possible, call the handler
149 when (isJust destM && notSame) $ f (fromJust origM) (fromJust destM)
150
151 -- In any case, the board must be repainted
152 boardInvalidate board
153
154 -- This is a function shamelessy stolen and rewritten from gtk-helpers
155 -- to allow for hexagonal boards.
156 attachGameRules :: (PlayableGame a Int tile player piece) =>
157 Game a Int tile player piece
158 -> IO (BIO.Board Int tile (player, piece))
159 attachGameRules game = do
160 board <- boardNew (allPos $ gameS game) (tileF $ visual game)
161 (pieceF $ visual game)
162
163 let (r,g,b) = bgColor (visual game)
164 (r', g', b') = (fromIntegral r, fromIntegral g, fromIntegral b)
165 mapM_ (\s -> widgetModifyBg board s (Color r' g' b'))
166 [StateNormal, StateActive, StatePrelight, StateSelected]
167 when (isJust (bg $ visual game)) $
168 boardSetBackground board (bg $ visual game)
169
170 vgRef <- newIORef game
171
172 -- Set the initial board state
173 mapM_ (\(x,y) -> boardSetPiece x y board)
174 [((x,y),(pl,pc)) | (x,y,pl,pc) <- allPieces (gameS game)]
175
176 board `boardOnPieceDragStart` \pos' -> do
177 let pos = actualTile pos'
178 visualGame <- readIORef vgRef
179 let game' = gameS visualGame
180 return (moveEnabled game' && canMove game' (curPlayer game') pos)
181
182 board `boardOnPieceDragOver` \posF' posT' -> do
183 let posF = actualTile posF'
184 posT = actualTile posT'
185 visualGame <- readIORef vgRef
186 let game' = gameS visualGame
187 return (moveEnabled game' && canMoveTo game' (curPlayer game') posF posT)
188
189 board `boardOnPieceDragDrop` \posF' posT' -> do
190 let posF = actualTile posF'
191 posT = actualTile posT'
192 visualGame <- readIORef vgRef
193 let game' = gameS visualGame
194 moves = move game' (curPlayer game') posF posT
195 game'' = foldl applyChange game' moves
196 writeIORef vgRef (visualGame { gameS = game'' })
197 forM_ moves (applyBoardChange board)
198
199 when (moveEnabled (gameS game)) $ boardEnableDrag board
200
201 return board