src/RMCA/GUI/Board.hs

   1 {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,
   2              ScopedTypeVariables, TypeSynonymInstances #-}
   3
   4 module RMCA.GUI.Board ( GUICell (..)
   5                       , attachGameRules
   6                       , initGame
   7                       , initBoardRV
   8                       , rotateGUICell
   9                       , inertCell
  10                       , toGUICoords
  11                       , fromGUICoords
  12                       , validArea
  13                       , Player(..)
  14                       , actualTile
  15                       ) where
  16
  17 import           Control.Monad
  18 import           Data.Array
  19 import           Data.Array.MArray
  20 import qualified Data.Bifunctor                   as BF
  21 import           Data.Board.GameBoardIO
  22 import           Data.CBMVar
  23 import           Data.Maybe
  24 import           Data.ReactiveValue
  25 import           Game.Board.BasicTurnGame
  26 import           Graphics.UI.Gtk                  hiding (Action)
  27 import           Graphics.UI.Gtk.Board.BoardLink  hiding (attachGameRules)
  28 import           Graphics.UI.Gtk.Board.TiledBoard hiding
  29     ( Board
  30     , boardOnPieceDragDrop
  31     , boardOnPieceDragOver
  32     , boardOnPieceDragStart
  33     )
  34 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
  35 import           Paths_RMCA
  36 import           RMCA.Global.Clock
  37 import           RMCA.GUI.HelpersRewrite
  38 import           RMCA.Semantics
  39
  40 newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
  41
  42 type IOBoard = BIO.Board Int Tile (Player,GUICell)
  43
  44 -- There are two types of tiles that can be distinguished by setting
  45 -- two different colors for debugging purposes. A future release might
  46 -- want to remove that.
  47 data Tile = TileW | TileB
  48
  49
  50 rotateGUICell :: GUICell -> GUICell
  51 rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
  52   where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
  53         rotateAction x = x
  54
  55 tileW :: Int
  56 tileW = 40
  57
  58 tileH :: Int
  59 tileH = round d
  60   where d :: Double
  61         d = sqrt 3 * fromIntegral tileW / 3
  62
  63 hexW :: Int
  64 hexW = round d
  65   where d :: Double
  66         d = 4 * fromIntegral tileW / 3
  67
  68 hexH :: Int
  69 hexH = round d
  70   where d :: Double
  71         d = sqrt 3 * fromIntegral hexW / 2
  72
  73 boardToTile :: [(Int,Int,Tile)]
  74 boardToTile = [(x,y,selTile) | (x,y) <- range ( (xMin-1,yMin)
  75                                               , (xMax+3,yMax+1))
  76                              , let selTile = if even x && even y
  77                                                 ||
  78                                                 odd x && odd y
  79                                              then TileW
  80                                              else TileB ]
  81
  82
  83
  84 outGUIBoard :: (Int,Int) -> Bool
  85 outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax
  86
  87 inertCell :: GUICell
  88 inertCell = GUICell { cellAction = Inert
  89                     , repeatCount = 1
  90                     , asPh = False
  91                     }
  92
  93 initGUIBoard :: GUIBoard
  94 initGUIBoard = GUIBoard GameState
  95   { curPlayer'   = Player
  96   , boardPos     = boardToTile
  97   , boardPieces' = boardToPiece [] $ makeBoard []
  98   }
  99
 100 instance PlayableGame GUIBoard Int Tile Player GUICell where
 101   curPlayer _               = Player
 102   allPos (GUIBoard game)    = boardPos game
 103   allPieces (GUIBoard game) = boardPieces' game
 104   moveEnabled _             = True
 105
 106   canMove (GUIBoard game) _ (x,y)
 107     | Just (_,p) <- getPieceAt game (x,y)
 108     , GUICell { cellAction = Inert } <- p = False
 109     | Nothing <- getPieceAt game (x,y) = False
 110     | otherwise = True
 111   canMoveTo _ _ _ fPos = fPos `elem` validArea || outGUIBoard fPos
 112
 113   move (GUIBoard game) _ iPos@(_,yi) fPos@(xf,yf)
 114     | outGUIBoard iPos && outGUIBoard fPos = []
 115     | outGUIBoard fPos = [ RemovePiece iPos
 116                          , AddPiece iPos Player nCell ]
 117     | iPos `elem` ctrlCoords = [ RemovePiece fPos'
 118                                , AddPiece fPos' Player
 119                                  (nCell { cellAction = ctrlAction }) ]
 120     | otherwise = [ MovePiece iPos fPos'
 121                   , AddPiece iPos Player nCell ]
 122     where fPos'
 123             |    (xf `mod` 2 == 0 && yf `mod` 2 == 0)
 124               || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
 125             | otherwise = (xf,yf+signum' (yf-yi))
 126           signum' x
 127             | x == 0 = 1
 128             | otherwise = signum x
 129           ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos
 130           nCell
 131             | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
 132                 getPieceAt game iPos = inertCell { repeatCount = n
 133                                                  , asPh = ph
 134                                                  }
 135             | otherwise = inertCell
 136
 137   applyChange (GUIBoard game) (AddPiece (x,y) Player piece) =
 138     GUIBoard $ game { boardPieces' = bp' }
 139     where bp' = (x,y,Player,piece):boardPieces' game
 140
 141   applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
 142     game { boardPieces' = bp' }
 143     where bp' = [p | p@(x',y',_,_) <- boardPieces' game
 144                    , x /= x' || y /= y']
 145
 146   applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
 147     | Just (_,p) <- getPieceAt game iPos
 148     = applyChanges guiBoard [ RemovePiece iPos
 149                             , RemovePiece fPos
 150                             , AddPiece fPos Player p]
 151     | otherwise = guiBoard
 152
 153 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
 154 initGame = do
 155   pixbufs <- fileToPixbuf
 156   tilePixbufB <- pixbufNew ColorspaceRgb False 8 tileW tileH
 157   tilePixbufW <- pixbufNew ColorspaceRgb False 8 tileW tileH
 158   pixbufFill tilePixbufB 50 50 50 0
 159   pixbufFill tilePixbufW 50 50 50 0
 160   let pixPiece :: (Player,GUICell) -> Pixbuf
 161       pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs
 162       pixTile :: Tile -> Pixbuf
 163       pixTile TileW = tilePixbufW
 164       pixTile TileB = tilePixbufB
 165       visualA = VisualGameAspects { tileF = pixTile
 166                                   , pieceF = pixPiece
 167                                   , bgColor = (1000,1000,1000)
 168                                   , bg = Nothing
 169                                   }
 170
 171   return $ Game visualA initGUIBoard
 172
 173 -- Initializes a readable RV for the board and an readable-writable RV
 174 -- for the playheads. Also installs some handlers for pieces modification.
 175 initBoardRV :: BIO.Board Int Tile (Player,GUICell)
 176             -> IO ( ReactiveFieldRead IO Board
 177                   , Array Pos (ReactiveFieldWrite IO GUICell)
 178                   , ReactiveFieldWrite IO [PlayHead])
 179 initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
 180   -- RV creation
 181   phMVar <- newCBMVar []
 182   notBMVar <- mkClockRV 50
 183   let getterB :: IO Board
 184       getterB = do
 185         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
 186         let board = makeBoard $
 187               map (BF.first fromGUICoords .
 188                    BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
 189                               fromJust)) $
 190               filter (isJust . snd) boardArray
 191         return board
 192
 193       notifierB :: IO () -> IO ()
 194       notifierB = reactiveValueOnCanRead notBMVar
 195
 196       getterP :: IO [PlayHead]
 197       getterP = readCBMVar phMVar
 198
 199       setterP :: [PlayHead] -> IO ()
 200       setterP lph = do
 201         oph <- readCBMVar phMVar
 202         let offPh :: PlayHead -> IO ()
 203             offPh ph = do
 204               let pos = toGUICoords $ phPos ph
 205               piece <- boardGetPiece pos board
 206               when (isJust piece) $ do
 207                 let (_,c) = fromJust piece
 208                 boardSetPiece pos (Player, c { asPh = False }) board
 209             onPh :: PlayHead -> IO ()
 210             onPh ph =  do
 211               let pos = toGUICoords $ phPos ph
 212               piece <- boardGetPiece pos board
 213               when (isJust piece) $ do
 214                 let (_,c) = fromJust piece
 215                 boardSetPiece pos (Player, c { asPh = True }) board
 216         postGUIAsync $ mapM_ offPh oph
 217         postGUIAsync $ mapM_ onPh lph
 218         writeCBMVar phMVar lph
 219
 220       notifierP :: IO () -> IO ()
 221       notifierP = installCallbackCBMVar phMVar
 222
 223       b = ReactiveFieldRead getterB notifierB
 224       ph = ReactiveFieldReadWrite setterP getterP notifierP
 225
 226       setterW :: (Int,Int) -> GUICell -> IO ()
 227       setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board
 228
 229
 230       arrW :: Array Pos (ReactiveFieldWrite IO GUICell)
 231       arrW = array (minimum validArea, maximum validArea)
 232              [(i, ReactiveFieldWrite (setterW i))
 233              | i <- validArea :: [(Int,Int)]]
 234
 235   return (b,arrW,writeOnly ph)
 236
 237 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 238 fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in
 239                         uncurry (liftM2 (,))
 240                         ( return f'
 241                         , getDataFileName f' >>=
 242                           (pixbufNewFromFile >=>
 243                            \p -> pixbufScaleSimple p hexW hexW InterpBilinear)))
 244                (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
 245                 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
 246                        | d <- [N .. NW]])
 247
 248 actionToFile :: GUICell -> FilePath
 249 actionToFile GUICell { cellAction = a
 250                      , asPh = ph
 251                      } =
 252   case a of
 253     Inert           -> "img/hexO" ++ (if ph then "n" else "ff") ++ ".png"
 254     Absorb          -> "img/absorb.svg"
 255     Stop _          -> "img/stop.svg"
 256     ChDir True _ d  -> "img/start" ++ show d ++ ".svg"
 257     ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
 258     Split _         -> "img/split.svg"