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