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   --pixbufs <- fileToPixbuf
 161   tilePixbufB <- pixbufNew ColorspaceRgb False 8 tileW tileH
 162   tilePixbufW <- pixbufNew ColorspaceRgb False 8 tileW tileH
 163   pixbufFill tilePixbufB 50 50 50 0
 164   pixbufFill tilePixbufW 50 50 50 0
 165   pixPiece <- pixbufForPiece
 166   let pixTile :: Tile -> Pixbuf
 167       pixTile TileW = tilePixbufW
 168       pixTile TileB = tilePixbufB
 169       visualA = VisualGameAspects { tileF = pixTile
 170                                   , pieceF = \(_,g) -> pixPiece g
 171                                   , bgColor = (1000,1000,1000)
 172                                   , bg = Nothing
 173                                   }
 174
 175   return $ Game visualA initGUIBoard
 176
 177 -- Initializes a readable RV for the board and an readable-writable RV
 178 -- for the playheads. Also installs some handlers for pieces modification.
 179 initBoardRV :: IOTick
 180             -> BIO.Board Int Tile (Player,GUICell)
 181             -> IO ( ReactiveFieldRead IO Board
 182                   , Array Pos (ReactiveFieldWrite IO GUICell)
 183                   , ReactiveFieldWrite IO [PlayHead])
 184 initBoardRV tc board@BIO.Board { boardPieces = (GameBoard gArray) } = do
 185   -- RV creation
 186   phMVar <- newCBMVar []
 187   let getterB :: IO Board
 188       getterB = do
 189         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
 190         let board = makeBoard $
 191               map (first fromGUICoords .
 192                    second ((\(_,c) -> (cellAction c,repeatCount c)) .
 193                               fromJust)) $
 194               filter (isJust . snd) boardArray
 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 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 242 fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in
 243                         uncurry (liftM2 (,))
 244                         ( return f'
 245                         , getDataFileName f' >>=
 246                           (pixbufNewFromFile >=>
 247                            \p -> pixbufScaleSimple p hexW hexW InterpBilinear)))
 248                (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
 249                 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
 250                        | d <- [N .. NW]])
 251 -}
 252
 253 -- If the repeatCount of some tile is superior to mrc,
 254 -- then this tile will be undistinguishable from any other tile with a
 255 -- repeat count superior to mrc.
 256 mrc :: (Num a) => a
 257 mrc = 6
 258
 259 pixbufForPiece :: IO (GUICell -> Pixbuf)
 260 pixbufForPiece = do
 261   let colorPlayHead _ r g b ma = if (r == 0 && g == 0 && b == 0)
 262                                  then (0, 0, 0, ma)
 263                                  else (0, g, 0, ma)
 264       colorRC 0  _ _ _ _ ma = (0, 0, 0, ma)
 265       colorRC rc _ r g b ma =
 266         if (r == 0 && g == 0 && b == 0)
 267         then (0, 0, 0, ma)
 268         else let (gradr, gradg, gradb)  = ( (maxBound - r) `quot` mrc
 269                                           , (g - minBound) `quot` mrc
 270                                           , (b - minBound) `quot` mrc
 271                                           )
 272              in ( r + gradr * (rc - 1)
 273                 , g - gradg * (rc - 1)
 274                 , b - gradb * (rc - 1)
 275                 , ma
 276                 )
 277   pixbufs <- mapM (\(a,rc) -> do df <- getDataFileName $ actionToFile a
 278                                  p <- do p' <- pixbufNewFromFile df
 279                                          pixbufScaleSimple p' hexW hexW InterpBilinear
 280                                  modifyPixbuf (colorRC rc) p
 281                                  p' <- pixbufCopy p
 282                                  modifyPixbuf colorPlayHead p'
 283                                  return ((a,rc), (p, p'))
 284                   ) [(a,r) | r <- [0..mrc], a <- actionList]
 285   let f GUICell { cellAction = a
 286                 , asPh = t
 287                 , repeatCount = r } =
 288         (if t then snd else fst) $ fromJust $
 289         lookup (anonymizeConstructor a, min (fromIntegral r) mrc) pixbufs
 290   return f
 291
 292 modifyPixbuf :: ((Int, Int) -> Word8 ->  Word8 -> Word8 -> Maybe Word8 ->
 293                 (Word8, Word8, Word8, Maybe Word8))
 294              -> Pixbuf -> IO ()
 295 modifyPixbuf f p = do
 296   pixs <- pixbufGetPixels p
 297   w <- pixbufGetWidth p
 298   h <- pixbufGetHeight p
 299   rs <- pixbufGetRowstride p
 300   chans <- pixbufGetNChannels p
 301   forM_ [(x,y) | x <- [0..w - 1], y <- [0..h - 1]] $ \(x,y) -> do
 302     let p = x * rs + y * chans
 303     red <- readArray pixs p
 304     green <- readArray pixs (p + 1)
 305     blue <- readArray pixs (p + 2)
 306     alpha <- if (chans == 4)
 307             then fmap Just $ readArray pixs (p + 3)
 308             else return Nothing
 309     let (nr, ng, nb, na) = f (x,y) red green blue alpha
 310     writeArray pixs p nr
 311     writeArray pixs (p + 1) ng
 312     writeArray pixs (p + 2) nb
 313     when (isJust na) $ writeArray pixs (p + 3) $ fromJust na
 314
 315
 316 actionToFile :: Action -> FilePath
 317 actionToFile = \case
 318                     Inert           -> "img/hexOff.png"
 319                     Absorb          -> "img/absorb.svg"
 320                     Stop _          -> "img/stop.svg"
 321                     ChDir True _ d  -> "img/start" ++ show d ++ ".svg"
 322                     ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
 323                     Split _         -> "img/split.svg"