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 newtype GUIBoard = GUIBoard (GameState 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 {-
  69 hexH :: Int
  70 hexH = round d
  71   where d :: Double
  72         d = sqrt 3 * fromIntegral hexW / 2
  73 -}
  74
  75 boardToTile :: [(Int,Int,Tile)]
  76 boardToTile = [(x,y,selTile) | (x,y) <- range ( (xMin-1,yMin)
  77                                               , (xMax+3,yMax+1))
  78                              , let selTile = if even x && even y
  79                                                 ||
  80                                                 odd x && odd y
  81                                              then TileW
  82                                              else TileB ]
  83
  84
  85
  86 outGUIBoard :: (Int,Int) -> Bool
  87 outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax
  88
  89 inertCell :: GUICell
  90 inertCell = GUICell { cellAction = Inert
  91                     , repeatCount = 1
  92                     , asPh = False
  93                     }
  94
  95 initGUIBoard :: GUIBoard
  96 initGUIBoard = GUIBoard GameState
  97   { curPlayer'   = Player
  98   , boardPos     = boardToTile
  99   , boardPieces' = boardToPiece [] $ makeBoard []
 100   }
 101
 102 instance PlayableGame GUIBoard Int Tile Player GUICell where
 103   curPlayer _               = Player
 104   allPos (GUIBoard game)    = boardPos game
 105   allPieces (GUIBoard game) = boardPieces' game
 106   moveEnabled _             = True
 107
 108   canMove (GUIBoard game) _ (x,y)
 109     | Just (_,p) <- getPieceAt game (x,y)
 110     , GUICell { cellAction = Inert } <- p = False
 111     | Nothing <- getPieceAt game (x,y) = False
 112     | otherwise = True
 113   canMoveTo _ _ _ fPos = fPos `elem` validArea || outGUIBoard fPos
 114
 115   move (GUIBoard game) _ iPos@(_,yi) fPos@(xf,yf)
 116     | outGUIBoard iPos && outGUIBoard fPos = []
 117     | outGUIBoard fPos = [ RemovePiece iPos
 118                          , AddPiece iPos Player nCell ]
 119     | iPos `elem` ctrlCoords = [ RemovePiece fPos'
 120                                , AddPiece fPos' Player
 121                                  (nCell { cellAction = ctrlAction }) ]
 122     | otherwise = [ MovePiece iPos fPos'
 123                   , AddPiece iPos Player nCell ]
 124     where fPos'
 125             |    (xf `mod` 2 == 0 && yf `mod` 2 == 0)
 126               || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
 127             | otherwise = (xf,yf+signum' (yf-yi))
 128           signum' x
 129             | x == 0 = 1
 130             | otherwise = signum x
 131           ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos
 132           nCell
 133             | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
 134                 getPieceAt game iPos = inertCell { repeatCount = n
 135                                                  , asPh = ph
 136                                                  }
 137             | otherwise = inertCell
 138
 139   applyChange (GUIBoard game) (AddPiece (x,y) Player piece) =
 140     GUIBoard $ game { boardPieces' = bp' }
 141     where bp' = (x,y,Player,piece):boardPieces' game
 142
 143   applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
 144     game { boardPieces' = bp' }
 145     where bp' = [p | p@(x',y',_,_) <- boardPieces' game
 146                    , x /= x' || y /= y']
 147
 148   applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
 149     | Just (_,p) <- getPieceAt game iPos
 150     = applyChanges guiBoard [ RemovePiece iPos
 151                             , RemovePiece fPos
 152                             , AddPiece fPos Player p]
 153     | otherwise = guiBoard
 154
 155 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
 156 initGame = do
 157   --pixbufs <- fileToPixbuf
 158   tilePixbufB <- pixbufNew ColorspaceRgb False 8 tileW tileH
 159   tilePixbufW <- pixbufNew ColorspaceRgb False 8 tileW tileH
 160   pixbufFill tilePixbufB 50 50 50 0
 161   pixbufFill tilePixbufW 50 50 50 0
 162   pixPiece <- pixbufForPiece
 163   let pixTile :: Tile -> Pixbuf
 164       pixTile TileW = tilePixbufW
 165       pixTile TileB = tilePixbufB
 166       visualA = VisualGameAspects { tileF = pixTile
 167                                   , pieceF = pixPiece
 168                                   , bgColor = (1000,1000,1000)
 169                                   , bg = Nothing
 170                                   }
 171
 172   return $ Game visualA initGUIBoard
 173
 174 -- Initializes a readable RV for the board and an readable-writable RV
 175 -- for the playheads. Also installs some handlers for pieces modification.
 176 initBoardRV :: IOTick
 177             -> BIO.Board Int Tile (Player,GUICell)
 178             -> IO ( ReactiveFieldRead IO Board
 179                   , Array Pos (ReactiveFieldWrite IO GUICell)
 180                   , ReactiveFieldWrite IO [PlayHead])
 181 initBoardRV tc board@BIO.Board { boardPieces = (GameBoard gArray) } = do
 182   -- RV creation
 183   phMVar <- newCBMVar []
 184   let getterB :: IO Board
 185       getterB = do
 186         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
 187         let board = makeBoard $
 188               map (first fromGUICoords .
 189                    second ((\(_,c) -> (cellAction c,repeatCount c)) .
 190                               fromJust)) $
 191               filter (isJust . snd) boardArray
 192         return board
 193
 194       notifierB :: IO () -> IO ()
 195       notifierB = reactiveValueOnCanRead tc
 196
 197       getterP :: IO [PlayHead]
 198       getterP = readCBMVar phMVar
 199
 200       setterP :: [PlayHead] -> IO ()
 201       setterP lph = do
 202         oph <- readCBMVar phMVar
 203         let offPh :: PlayHead -> IO ()
 204             offPh ph = do
 205               let pos = toGUICoords $ phPos ph
 206               piece <- boardGetPiece pos board
 207               when (isJust piece) $ do
 208                 let (_,c) = fromJust piece
 209                 boardSetPiece pos (Player, c { asPh = False }) board
 210             onPh :: PlayHead -> IO ()
 211             onPh ph =  do
 212               let pos = toGUICoords $ phPos ph
 213               piece <- boardGetPiece pos board
 214               when (isJust piece) $ do
 215                 let (_,c) = fromJust piece
 216                 boardSetPiece pos (Player, c { asPh = True }) board
 217         postGUIAsync $ mapM_ offPh oph
 218         postGUIAsync $ mapM_ onPh lph
 219         writeCBMVar phMVar lph
 220
 221       notifierP :: IO () -> IO ()
 222       notifierP = installCallbackCBMVar phMVar
 223
 224       b = ReactiveFieldRead getterB notifierB
 225       ph = ReactiveFieldReadWrite setterP getterP notifierP
 226
 227       setterW :: (Int,Int) -> GUICell -> IO ()
 228       setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board
 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 pixbufForPiece :: IO ((Player, GUICell) -> Pixbuf)
 249 pixbufForPiece = do
 250   let changeColor _ r g b ma = if (r == 0 && g == 0 && b == 0)
 251                                then (r, g, b, ma)
 252                                else (0, g, 0, ma)
 253   pixbufs <- mapM (\a -> do df <- getDataFileName $ actionToFile a
 254                             p <- do p' <- pixbufNewFromFile df
 255                                     pixbufScaleSimple p' hexW hexW InterpBilinear
 256                             p' <- pixbufCopy p
 257                             modifyPixbuf changeColor p'
 258                             return (a, (p, p'))
 259                  ) actionList
 260   let f (_, GUICell { cellAction = a
 261                     , asPh = t }) = (if t then snd else fst) $ fromJust $
 262                                     lookup (anonymizeConstructor a) pixbufs
 263   return f
 264
 265 modifyPixbuf :: ((Int, Int) -> Word8 ->  Word8 -> Word8 -> Maybe Word8 ->
 266                 (Word8, Word8, Word8, Maybe Word8))
 267              -> Pixbuf -> IO ()
 268 modifyPixbuf f p = do
 269   pixs <- pixbufGetPixels p
 270   w <- pixbufGetWidth p
 271   h <- pixbufGetHeight p
 272   rs <- pixbufGetRowstride p
 273   chans <- pixbufGetNChannels p
 274   forM_ [(x,y) | x <- [0..w - 1], y <- [0..h - 1]] $ \(x,y) -> do
 275     let p = x * rs + y * chans
 276     red <- readArray pixs p
 277     green <- readArray pixs (p + 1)
 278     blue <- readArray pixs (p + 2)
 279     alpha <- if (chans == 4)
 280             then fmap Just $ readArray pixs (p + 3)
 281             else return Nothing
 282     let (nr, ng, nb, na) = f (x,y) red green blue alpha
 283     writeArray pixs p nr
 284     writeArray pixs (p + 1) ng
 285     writeArray pixs (p + 2) nb
 286     when (isJust na) $ writeArray pixs (p + 3) $ fromJust na
 287
 288
 289 actionToFile :: Action -> FilePath
 290 actionToFile = \case
 291                     Inert           -> "img/hexOff.png"
 292                     Absorb          -> "img/absorb.svg"
 293                     Stop _          -> "img/stop.svg"
 294                     ChDir True _ d  -> "img/start" ++ show d ++ ".svg"
 295                     ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
 296                     Split _         -> "img/split.svg"