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