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 rotateGUICell :: GUICell -> GUICell
  52 rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
  53   where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
  54         rotateAction (Split na ds)  = Split na (turnQueue ds 1)
  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         -- print board
 195         return board
 196
 197       notifierB :: IO () -> IO ()
 198       notifierB = reactiveValueOnCanRead tc
 199
 200       getterP :: IO [PlayHead]
 201       getterP = readCBMVar phMVar
 202
 203       setterP :: [PlayHead] -> IO ()
 204       setterP lph = do
 205         oph <- readCBMVar phMVar
 206         unless (oph == lph) $ do
 207           let offPh :: PlayHead -> IO ()
 208               offPh ph = do
 209                 let pos = toGUICoords $ phPos ph
 210                 piece <- boardGetPiece pos board
 211                 when (isJust piece) $ do
 212                   let (_,c) = fromJust piece
 213                   boardSetPiece pos (Player, c { asPh = False }) board
 214               onPh :: PlayHead -> IO ()
 215               onPh ph =  do
 216                 let pos = toGUICoords $ phPos ph
 217                 piece <- boardGetPiece pos board
 218                 when (isJust piece) $ do
 219                   let (_,c) = fromJust piece
 220                   boardSetPiece pos (Player, c { asPh = True }) board
 221           postGUIAsync $ mapM_ offPh oph
 222           postGUIAsync $ mapM_ onPh lph
 223           writeCBMVar phMVar lph
 224
 225       notifierP :: IO () -> IO ()
 226       notifierP = installCallbackCBMVar phMVar
 227
 228       b = ReactiveFieldRead getterB notifierB
 229       ph = ReactiveFieldReadWrite setterP getterP notifierP
 230
 231       setterW :: (Int,Int) -> GUICell -> IO ()
 232       setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board
 233
 234       arrW :: Array Pos (ReactiveFieldWrite IO GUICell)
 235       arrW = array (minimum validArea, maximum validArea)
 236              [(i, ReactiveFieldWrite (setterW i))
 237              | i <- validArea :: [(Int,Int)]]
 238
 239   return (b,arrW,writeOnly ph)
 240
 241 -- If the repeatCount of some tile is superior to mrc,
 242 -- then this tile will be undistinguishable from any other tile with a
 243 -- repeat count superior to mrc.
 244 mrc :: (Num a) => a
 245 mrc = 6
 246
 247 pixbufForPiece :: IO (GUICell -> Pixbuf)
 248 pixbufForPiece = do
 249   let colorPlayHead _ r g b ma = if (r == 0 && g == 0 && b == 0)
 250                                  then (0, 0, 0, ma)
 251                                  else (0, g, 0, ma)
 252       colorRC 0  _ _ _ _ ma = (0, 0, 0, ma)
 253       colorRC rc _ r g b ma =
 254         if (r == 0 && g == 0 && b == 0)
 255         then (0, 0, 0, ma)
 256         else let (gradr, gradg, gradb)  = ( (maxBound - r) `quot` mrc
 257                                           , (g - minBound) `quot` mrc
 258                                           , (b - minBound) `quot` mrc
 259                                           )
 260              in ( r + gradr * (rc - 1)
 261                 , g - gradg * (rc - 1)
 262                 , b - gradb * (rc - 1)
 263                 , ma
 264                 )
 265   pixbufs <- mapM (\(a,rc) -> do df <- getDataFileName $ actionToFile a
 266                                  p <- do p' <- pixbufNewFromFile df
 267                                          pixbufScaleSimple p' hexW hexW InterpBilinear
 268                                  modifyPixbuf (colorRC rc) p
 269                                  p' <- pixbufCopy p
 270                                  modifyPixbuf colorPlayHead p'
 271                                  return ((a,rc), (p, p'))
 272                   ) [(a,r) | r <- [0..mrc], a <- actionList]
 273   let f GUICell { cellAction = a
 274                 , asPh = t
 275                 , repeatCount = r } =
 276         (if t then snd else fst) $ fromJust $
 277         lookup (anonymizeConstructor a, min (fromIntegral r) mrc) pixbufs
 278   return f
 279
 280 modifyPixbuf :: ((Int, Int) -> Word8 ->  Word8 -> Word8 -> Maybe Word8 ->
 281                 (Word8, Word8, Word8, Maybe Word8))
 282              -> Pixbuf -> IO ()
 283 modifyPixbuf f p = do
 284   pixs <- pixbufGetPixels p
 285   w <- pixbufGetWidth p
 286   h <- pixbufGetHeight p
 287   rs <- pixbufGetRowstride p
 288   chans <- pixbufGetNChannels p
 289   forM_ [(x,y) | x <- [0..w - 1], y <- [0..h - 1]] $ \(x,y) -> do
 290     let p = x * rs + y * chans
 291     red <- readArray pixs p
 292     green <- readArray pixs (p + 1)
 293     blue <- readArray pixs (p + 2)
 294     alpha <- if (chans == 4)
 295              then fmap Just $ readArray pixs (p + 3)
 296              else return Nothing
 297     let (nr, ng, nb, na) = f (x,y) red green blue alpha
 298     writeArray pixs p nr
 299     writeArray pixs (p + 1) ng
 300     writeArray pixs (p + 2) nb
 301     when (isJust na) $ writeArray pixs (p + 3) $ fromJust na
 302
 303
 304 actionToFile :: Action -> FilePath
 305 actionToFile = \case
 306                     Inert           -> "img/hexOff.png"
 307                     Absorb          -> "img/absorb.svg"
 308                     Stop _          -> "img/stop.svg"
 309                     ChDir True _ d  -> "img/start" ++ show d ++ ".svg"
 310                     ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
 311                     Split _ _       -> "img/split.svg"