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   | 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