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