src/RMCA/GUI/Board.hs

   1 {-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase,
   2              MultiParamTypeClasses, ScopedTypeVariables, TypeSynonymInstances
   3              #-}
   4
   5 module RMCA.GUI.Board ( GUICell (..)
   6                       , attachGameRules
   7                       , initGame
   8                       , initBoardRV
   9                       , rotateGUICell
  10                       , inertCell
  11                       , toGUICoords
  12                       , fromGUICoords
  13                       , validArea
  14                       , Player(..)
  15                       , actualTile
  16                       ) where
  17
  18 import           Control.Arrow
  19 import           Control.Monad
  20 import           Data.Array
  21 import           Data.Array.MArray
  22 import           Data.Board.GameBoardIO
  23 import           Data.CBMVar
  24 import           Data.Maybe
  25 import           Data.ReactiveValue
  26 import           Data.Word
  27 import           Game.Board.BasicTurnGame
  28 import           Graphics.UI.Gtk                  hiding (Action)
  29 import           Graphics.UI.Gtk.Board.BoardLink  hiding (attachGameRules)
  30 import           Graphics.UI.Gtk.Board.TiledBoard hiding
  31     ( Board
  32     , boardOnPieceDragDrop
  33     , boardOnPieceDragOver
  34     , boardOnPieceDragStart
  35     )
  36 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
  37 import           Paths_arpeggigon
  38 import           RMCA.GUI.HelpersRewrite
  39 import           RMCA.IOClockworks
  40 import           RMCA.Semantics
  41
  42 import           Debug.Trace
  43
  44 newtype GUIBoard = GUIBoard (GameState Int Tile Player GUICell)
  45
  46 -- There are two types of tiles that can be distinguished by setting
  47 -- two different colors for debugging purposes. A future release might
  48 -- want to remove that.
  49 data Tile = TileW | TileB
  50
  51
  52 rotateGUICell :: GUICell -> GUICell
  53 rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
  54   where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
  55         rotateAction x              = x
  56
  57 tileW :: Int
  58 tileW = 40
  59
  60 tileH :: Int
  61 tileH = round d
  62   where d :: Double
  63         d = sqrt 3 * fromIntegral tileW / 3
  64
  65 hexW :: Int
  66 hexW = round d
  67   where d :: Double
  68         d = 4 * fromIntegral tileW / 3
  69
  70 {-
  71 hexH :: Int
  72 hexH = round d
  73   where d :: Double
  74         d = sqrt 3 * fromIntegral hexW / 2
  75 -}
  76
  77 boardToTile :: [(Int,Int,Tile)]
  78 boardToTile = [(x,y,selTile) | (x,y) <- range ( (xMin-1,yMin)
  79                                               , (xMax+3,yMax+1))
  80                              , let selTile = if even x && even y
  81                                                 ||
  82                                                 odd x && odd y
  83                                              then TileW
  84                                              else TileB ]
  85
  86
  87
  88 outGUIBoard :: (Int,Int) -> Bool
  89 outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax
  90
  91 inertCell :: GUICell
  92 inertCell = GUICell { cellAction = Inert
  93                     , repeatCount = 1
  94                     , asPh = False
  95                     }
  96
  97 initGUIBoard :: GUIBoard
  98 initGUIBoard = GUIBoard GameState
  99   { curPlayer'   = Player
 100   , boardPos     = boardToTile
 101   , boardPieces' = boardToPiece [] $ makeBoard []
 102   }
 103
 104 instance PlayableGame GUIBoard Int Tile Player GUICell where
 105   curPlayer _               = Player
 106   allPos (GUIBoard game)    = boardPos game
 107   allPieces (GUIBoard game) = boardPieces' game
 108   moveEnabled _             = True
 109
 110   canMove (GUIBoard game) _ (x,y)
 111     | Just (_,p) <- getPieceAt game (x,y)
 112     , GUICell { cellAction = Inert } <- p = False
 113     | Nothing <- getPieceAt game (x,y) = False
 114     | otherwise = True
 115   canMoveTo _ _ _ fPos = fPos `elem` validArea || outGUIBoard fPos
 116
 117   move (GUIBoard game) _ iPos@(_,yi) fPos@(xf,yf)
 118     | outGUIBoard iPos && outGUIBoard fPos = []
 119     | outGUIBoard fPos = [ RemovePiece iPos
 120                          , AddPiece iPos Player nCell ]
 121     | iPos `elem` ctrlCoords = [ RemovePiece fPos'
 122                                , AddPiece fPos' Player
 123                                  (nCell { cellAction = ctrlAction }) ]
 124     | otherwise = [ MovePiece iPos fPos'
 125                   , AddPiece iPos Player nCell ]
 126     where fPos'
 127             |    (xf `mod` 2 == 0 && yf `mod` 2 == 0)
 128               || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
 129             | otherwise = (xf,yf+signum' (yf-yi))
 130           signum' x
 131             | x == 0 = 1
 132             | otherwise = signum x
 133           ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos
 134           nCell
 135             | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
 136                 getPieceAt game iPos = inertCell { repeatCount = n
 137                                                  , asPh = ph
 138                                                  }
 139             | otherwise = inertCell
 140
 141   applyChange (GUIBoard game) (AddPiece (x,y) Player piece) =
 142     GUIBoard $ game { boardPieces' = bp' }
 143     where bp' = (x,y,Player,piece):boardPieces' game
 144
 145   applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
 146     game { boardPieces' = bp' }
 147     where bp' = [p | p@(x',y',_,_) <- boardPieces' game
 148                    , x /= x' || y /= y']
 149
 150   applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
 151     | Just (_,p) <- getPieceAt game iPos
 152     = applyChanges guiBoard [ RemovePiece iPos
 153                             , RemovePiece fPos
 154                             , AddPiece fPos Player p
 155                             ]
 156     | otherwise = guiBoard
 157
 158 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
 159 initGame = do
 160   tilePixbufB <- pixbufNew ColorspaceRgb False 8 tileW tileH
 161   tilePixbufW <- pixbufNew ColorspaceRgb False 8 tileW tileH
 162   pixbufFill tilePixbufB 50 50 50 0
 163   pixbufFill tilePixbufW 50 50 50 0
 164   pixPiece <- pixbufForPiece
 165   let pixTile :: Tile -> Pixbuf
 166       pixTile TileW = tilePixbufW
 167       pixTile TileB = tilePixbufB
 168       visualA = VisualGameAspects { tileF = pixTile
 169                                   , pieceF = \(_,g) -> pixPiece g
 170                                   , bgColor = (1000,1000,1000)
 171                                   , bg = Nothing
 172                                   }
 173
 174   return $ Game visualA initGUIBoard
 175
 176 -- Initializes a readable RV for the board and an readable-writable RV
 177 -- for the playheads. Also installs some handlers for pieces modification.
 178 initBoardRV :: IOTick
 179             -> BIO.Board Int Tile (Player,GUICell)
 180             -> IO ( ReactiveFieldRead IO Board
 181                   , Array Pos (ReactiveFieldWrite IO GUICell)
 182                   , ReactiveFieldWrite IO [PlayHead])
 183 initBoardRV tc board@BIO.Board { boardPieces = (GameBoard gArray) } = do
 184   -- RV creation
 185   phMVar <- newCBMVar []
 186   let getterB :: IO Board
 187       getterB = do
 188         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
 189         let board = makeBoard $
 190               map (first fromGUICoords .
 191                    second ((\(_,c) -> (cellAction c,repeatCount c)) .
 192                               fromJust)) $
 193               filter (isJust . snd) boardArray
 194         return board
 195
 196       notifierB :: IO () -> IO ()
 197       notifierB = reactiveValueOnCanRead tc
 198
 199       getterP :: IO [PlayHead]
 200       getterP = readCBMVar phMVar
 201
 202       setterP :: [PlayHead] -> IO ()
 203       setterP lph = do
 204         oph <- readCBMVar phMVar
 205         unless (oph == lph) $ do
 206           let offPh :: PlayHead -> IO ()
 207               offPh ph = do
 208                 let pos = toGUICoords $ phPos ph
 209                 piece <- boardGetPiece pos board
 210                 when (isJust piece) $ do
 211                   let (_,c) = fromJust piece
 212                   boardSetPiece pos (Player, c { asPh = False }) board
 213               onPh :: PlayHead -> IO ()
 214               onPh ph =  do
 215                 let pos = toGUICoords $ phPos ph
 216                 piece <- boardGetPiece pos board
 217                 when (isJust piece) $ do
 218                   let (_,c) = fromJust piece
 219                   boardSetPiece pos (Player, c { asPh = True }) board
 220           postGUIAsync $ mapM_ offPh oph
 221           postGUIAsync $ mapM_ onPh lph
 222           writeCBMVar phMVar lph
 223
 224       notifierP :: IO () -> IO ()
 225       notifierP = installCallbackCBMVar phMVar
 226
 227       b = ReactiveFieldRead getterB notifierB
 228       ph = ReactiveFieldReadWrite setterP getterP notifierP
 229
 230       setterW :: (Int,Int) -> GUICell -> IO ()
 231       setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board
 232
 233       arrW :: Array Pos (ReactiveFieldWrite IO GUICell)
 234       arrW = array (minimum validArea, maximum validArea)
 235              [(i, ReactiveFieldWrite (setterW i))
 236              | i <- validArea :: [(Int,Int)]]
 237
 238   return (b,arrW,writeOnly ph)
 239
 240 -- If the repeatCount of some tile is superior to mrc,
 241 -- then this tile will be undistinguishable from any other tile with a
 242 -- repeat count superior to mrc.
 243 mrc :: (Num a) => a
 244 mrc = 6
 245
 246 pixbufForPiece :: IO (GUICell -> Pixbuf)
 247 pixbufForPiece = do
 248   let colorPlayHead _ r g b ma = if (r == 0 && g == 0 && b == 0)
 249                                  then (0, 0, 0, ma)
 250                                  else (0, g, 0, ma)
 251       colorRC 0  _ _ _ _ ma = (0, 0, 0, ma)
 252       colorRC rc _ r g b ma =
 253         if (r == 0 && g == 0 && b == 0)
 254         then (0, 0, 0, ma)
 255         else let (gradr, gradg, gradb)  = ( (maxBound - r) `quot` mrc
 256                                           , (g - minBound) `quot` mrc
 257                                           , (b - minBound) `quot` mrc
 258                                           )
 259              in ( r + gradr * (rc - 1)
 260                 , g - gradg * (rc - 1)
 261                 , b - gradb * (rc - 1)
 262                 , ma
 263                 )
 264   pixbufs <- mapM (\(a,rc) -> do df <- getDataFileName $ actionToFile a
 265                                  p <- do p' <- pixbufNewFromFile df
 266                                          pixbufScaleSimple p' hexW hexW InterpBilinear
 267                                  modifyPixbuf (colorRC rc) p
 268                                  p' <- pixbufCopy p
 269                                  modifyPixbuf colorPlayHead p'
 270                                  return ((a,rc), (p, p'))
 271                   ) [(a,r) | r <- [0..mrc], a <- actionList]
 272   let f GUICell { cellAction = a
 273                 , asPh = t
 274                 , repeatCount = r } =
 275         (if t then snd else fst) $ fromJust $
 276         lookup (anonymizeConstructor a, min (fromIntegral r) mrc) pixbufs
 277   return f
 278
 279 modifyPixbuf :: ((Int, Int) -> Word8 ->  Word8 -> Word8 -> Maybe Word8 ->
 280                 (Word8, Word8, Word8, Maybe Word8))
 281              -> Pixbuf -> IO ()
 282 modifyPixbuf f p = do
 283   pixs <- pixbufGetPixels p
 284   w <- pixbufGetWidth p
 285   h <- pixbufGetHeight p
 286   rs <- pixbufGetRowstride p
 287   chans <- pixbufGetNChannels p
 288   forM_ [(x,y) | x <- [0..w - 1], y <- [0..h - 1]] $ \(x,y) -> do
 289     let p = x * rs + y * chans
 290     red <- readArray pixs p
 291     green <- readArray pixs (p + 1)
 292     blue <- readArray pixs (p + 2)
 293     alpha <- if (chans == 4)
 294              then fmap Just $ readArray pixs (p + 3)
 295              else return Nothing
 296     let (nr, ng, nb, na) = f (x,y) red green blue alpha
 297     writeArray pixs p nr
 298     writeArray pixs (p + 1) ng
 299     writeArray pixs (p + 2) nb
 300     when (isJust na) $ writeArray pixs (p + 3) $ fromJust na
 301
 302
 303 actionToFile :: Action -> FilePath
 304 actionToFile = \case
 305                     Inert           -> "img/hexOff.png"
 306                     Absorb          -> "img/absorb.svg"
 307                     Stop _          -> "img/stop.svg"
 308                     ChDir True _ d  -> "img/start" ++ show d ++ ".svg"
 309                     ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
 310                     Split _         -> "img/split.svg"