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.Arrow
  18 import           Control.Monad
  19 import           Data.Array
  20 import           Data.Array.MArray
  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_arpeggigon
  36 import           RMCA.GUI.HelpersRewrite
  37 import           RMCA.IOClockworks
  38 import           RMCA.Semantics
  39
  40 newtype GUIBoard = GUIBoard (GameState Int Tile Player GUICell)
  41
  42 -- There are two types of tiles that can be distinguished by setting
  43 -- two different colors for debugging purposes. A future release might
  44 -- want to remove that.
  45 data Tile = TileW | TileB
  46
  47
  48 rotateGUICell :: GUICell -> GUICell
  49 rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
  50   where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
  51         rotateAction x = x
  52
  53 tileW :: Int
  54 tileW = 40
  55
  56 tileH :: Int
  57 tileH = round d
  58   where d :: Double
  59         d = sqrt 3 * fromIntegral tileW / 3
  60
  61 hexW :: Int
  62 hexW = round d
  63   where d :: Double
  64         d = 4 * fromIntegral tileW / 3
  65
  66 {-
  67 hexH :: Int
  68 hexH = round d
  69   where d :: Double
  70         d = sqrt 3 * fromIntegral hexW / 2
  71 -}
  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 :: IOTick
 176             -> BIO.Board Int Tile (Player,GUICell)
 177             -> IO ( ReactiveFieldRead IO Board
 178                   , Array Pos (ReactiveFieldWrite IO GUICell)
 179                   , ReactiveFieldWrite IO [PlayHead])
 180 initBoardRV tc board@BIO.Board { boardPieces = (GameBoard gArray) } = do
 181   -- RV creation
 182   phMVar <- newCBMVar []
 183   let getterB :: IO Board
 184       getterB = do
 185         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
 186         let board = makeBoard $
 187               map (first fromGUICoords .
 188                    second ((\(_,c) -> (cellAction c,repeatCount c)) .
 189                               fromJust)) $
 190               filter (isJust . snd) boardArray
 191         return board
 192
 193       notifierB :: IO () -> IO ()
 194       notifierB = reactiveValueOnCanRead tc
 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       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"