src/RMCA/GUI/Board.hs

   1 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables,
   2              TypeSynonymInstances #-}
   3
   4 module RMCA.GUI.Board where
   5
   6 import           Control.Monad
   7 import           Data.Array
   8 import           Data.Array.MArray
   9 import qualified Data.Bifunctor                   as BF
  10 import           Data.Board.GameBoardIO
  11 import           Data.CBMVar
  12 import           Data.Maybe
  13 import           Data.Ratio
  14 import           Data.ReactiveValue
  15 import           Game.Board.BasicTurnGame
  16 import           Graphics.UI.Gtk                  hiding (Action)
  17 import           Graphics.UI.Gtk.Board.BoardLink
  18 import           Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
  19 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
  20 import           Paths_RMCA
  21 import           RMCA.Global.Clock
  22 import           RMCA.Semantics
  23
  24 import           Debug.Trace
  25
  26 data GUICell = GUICell { cellAction  :: Action
  27                        , repeatCount :: Int
  28                        , asPh        :: Bool
  29                        } deriving(Show)
  30
  31 newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
  32
  33 type IOBoard = BIO.Board Int Tile (Player,GUICell)
  34
  35 data Tile = Tile
  36 data Player = Player deriving(Show)
  37
  38 rotateGUICell :: GUICell -> GUICell
  39 rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
  40   where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
  41         rotateAction x = x
  42
  43 -- Takes a GUI coordinate and give the corresponding coordinate on the
  44 -- internal board
  45 fromGUICoords :: (Int,Int) -> (Int,Int)
  46 fromGUICoords (x,y) = (x,(x `mod` 2 - y) `quot` 2)
  47
  48 -- Takes coordinates from the point of view of the internal board and
  49 -- translates them to GUI board coordinates.
  50 toGUICoords :: (Int,Int) -> (Int,Int)
  51 toGUICoords (x,y) = (x,2*(-y) + x `mod` 2)
  52
  53 tileW :: Int
  54 tileW = 40
  55
  56 tileH :: Int
  57 tileH = round d
  58   where d :: Double
  59         d = sqrt 3 * fromIntegral tileW / 3
  60
  61 hexW :: Int
  62 hexW = round d
  63   where d :: Double
  64         d = 4 * fromIntegral tileW / 3
  65
  66 hexH :: Int
  67 hexH = round d
  68   where d :: Double
  69         d = sqrt 3 * fromIntegral hexW / 2
  70
  71 xMax, yMax :: Int
  72 (xMax,yMax) = BF.second (*2) $ neighbor N nec
  73 xMin, yMin :: Int
  74 (xMin,yMin) = BF.second (*2) swc
  75
  76 boardToTile :: [(Int,Int,Tile)]
  77 boardToTile = [(x,y,Tile) | (x,y) <- range ( (xMin-1,yMin)
  78                                            , (xMax+3,yMax+1))]
  79
  80 defNa :: NoteAttr
  81 defNa = NoteAttr { naArt = NoAccent
  82                  , naDur = 1 % 4
  83                  , naOrn = noOrn
  84                  }
  85
  86 ctrlPieces :: [(Int,Int,Player,GUICell)]
  87 ctrlPieces = [(xMax+2,y,Player,GUICell { cellAction = action
  88                                        , repeatCount = 1
  89                                        , asPh = False
  90                                        })
  91              | let actions = [ Absorb, Stop defNa
  92                              , ChDir False defNa N, ChDir True defNa N
  93                              , Split defNa]
  94                      -- /!\ It would be nice to find a general formula
  95                      -- for placing the control pieces.
  96                      , (y,action) <- zip [ yMin+4,yMin+8..] actions]
  97
  98 ctrlCoords :: [(Int,Int)]
  99 ctrlCoords = map (\(x,y,_,_) -> (x,y)) ctrlPieces
 100
 101 boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)]
 102 boardToPiece ph = (++ ctrlPieces) . map placePiece .
 103                   filter (onBoard . fst) . assocs
 104   where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell)
 105         placePiece ((x,y),(a,n)) = let c = GUICell { cellAction = a
 106                                                    , repeatCount = n
 107                                                    , asPh = (x,y) `elem` phPosS
 108                                                    }
 109                                        (x',y') = toGUICoords (x,y)
 110                                    in (x',y',Player,c)
 111         phPosS = map phPos ph
 112
 113 validArea :: [(Int,Int)]
 114 validArea = filter (onBoard . fromGUICoords) $
 115             map (\(x,y,_,_) -> (x,y)) $ boardToPiece [] $ makeBoard []
 116
 117 outGUIBoard :: (Int,Int) -> Bool
 118 outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax
 119
 120 inertCell :: GUICell
 121 inertCell = GUICell { cellAction = Inert
 122                     , repeatCount = 1
 123                     , asPh = False
 124                     }
 125
 126 initGUIBoard :: GUIBoard
 127 initGUIBoard = GUIBoard GameState
 128   { curPlayer'   = Player
 129   , boardPos     = boardToTile
 130   , boardPieces' = boardToPiece [] $ makeBoard []
 131   }
 132
 133 instance PlayableGame GUIBoard Int Tile Player GUICell where
 134   curPlayer _               = Player
 135   allPos (GUIBoard game)    = boardPos game
 136   allPieces (GUIBoard game) = boardPieces' game
 137   moveEnabled _             = True
 138   canMove (GUIBoard game) _ (x,y)
 139     | Just (_,p) <- getPieceAt game (x,y)
 140     , GUICell { cellAction = Inert } <- p = False
 141     | Nothing <- getPieceAt game (x,y) = False
 142     | otherwise = True
 143   canMoveTo _ _ _ fPos = fPos `elem` validArea
 144                          || outGUIBoard fPos
 145
 146   move (GUIBoard game) _ iPos@(_,yi) fPos@(xf,yf)
 147     | outGUIBoard iPos && outGUIBoard fPos = []
 148     | outGUIBoard fPos = [ RemovePiece iPos
 149                          , AddPiece iPos Player nCell ]
 150     | iPos `elem` ctrlCoords = [ RemovePiece fPos'
 151                                , AddPiece fPos' Player
 152                                  (nCell { cellAction = ctrlAction }) ]
 153     | otherwise = [ MovePiece iPos fPos'
 154                   , AddPiece iPos Player nCell ]
 155     where fPos'
 156             |    (xf `mod` 2 == 0 && yf `mod` 2 == 0)
 157               || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
 158             | otherwise = (xf,yf+signum' (yf-yi))
 159           signum' x
 160             | x == 0 = 1
 161             | otherwise = signum x
 162           ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos
 163           nCell
 164             | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
 165                 getPieceAt game iPos = inertCell { repeatCount = n
 166                                                  , asPh = ph
 167                                                  }
 168             | otherwise = inertCell
 169
 170   applyChange (GUIBoard game) (AddPiece (x,y) Player piece) =
 171     GUIBoard $ game { boardPieces' = bp' }
 172     where bp' = (x,y,Player,piece):boardPieces' game
 173
 174   applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
 175     game { boardPieces' = bp' }
 176     where bp' = [p | p@(x',y',_,_) <- boardPieces' game
 177                    , x /= x' || y /= y']
 178
 179   applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
 180     | Just (_,p) <- getPieceAt game iPos
 181     = applyChanges guiBoard [ RemovePiece iPos
 182                             , RemovePiece fPos
 183                             , AddPiece fPos Player p]
 184     | otherwise = guiBoard
 185
 186 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
 187 initGame = do
 188   pixbufs <- fileToPixbuf
 189   tilePixbuf <- pixbufNew ColorspaceRgb False 8 tileW tileH
 190   pixbufFill tilePixbuf 50 50 50 0
 191   let pixPiece :: (Player,GUICell) -> Pixbuf
 192       pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs
 193       pixTile :: Tile -> Pixbuf
 194       pixTile _ = tilePixbuf
 195       visualA = VisualGameAspects { tileF = pixTile
 196                                   , pieceF = pixPiece
 197                                   , bgColor = (1000,1000,1000)
 198                                   , bg = Nothing
 199                                   }
 200
 201   return $ Game visualA initGUIBoard
 202
 203 -- Initializes a readable RV for the board and an readable-writable RV
 204 -- for the playheads. Also installs some handlers for pieces modification.
 205 initBoardRV :: BIO.Board Int Tile (Player,GUICell)
 206             -> IO ( ReactiveFieldRead IO Board
 207                   , Array Pos (ReactiveFieldWrite IO GUICell)
 208                   , ReactiveFieldWrite IO [PlayHead])
 209 initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
 210   -- RV creation
 211   phMVar <- newCBMVar []
 212   notBMVar <- mkClockRV 10
 213   let getterB :: IO Board
 214       getterB = do
 215         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
 216         let board = makeBoard $
 217               map (BF.first fromGUICoords .
 218                    BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
 219                               fromJust)) $
 220               filter (isJust . snd) boardArray
 221         return board
 222
 223       notifierB :: IO () -> IO ()
 224       notifierB = reactiveValueOnCanRead notBMVar
 225
 226       getterP :: IO [PlayHead]
 227       getterP = readCBMVar phMVar
 228
 229       setterP :: [PlayHead] -> IO ()
 230       setterP lph = do
 231         oph <- readCBMVar phMVar
 232         let offPh :: PlayHead -> IO ()
 233             offPh ph = do
 234               let pos = toGUICoords $ phPos ph
 235               piece <- boardGetPiece pos board
 236               when (isJust piece) $ do
 237                 let (_,c) = fromJust piece
 238                 boardSetPiece pos (Player, c { asPh = False }) board
 239             onPh :: PlayHead -> IO ()
 240             onPh ph =  do
 241               let pos = toGUICoords $ phPos ph
 242               piece <- boardGetPiece pos board
 243               when (isJust piece) $ do
 244                 let (_,c) = fromJust piece
 245                 boardSetPiece pos (Player, c { asPh = True }) board
 246         postGUIAsync $ mapM_ offPh oph
 247         postGUIAsync $ mapM_ onPh lph
 248         writeCBMVar phMVar lph
 249
 250       notifierP :: IO () -> IO ()
 251       notifierP = installCallbackCBMVar phMVar
 252
 253       b = ReactiveFieldRead getterB notifierB
 254       ph = ReactiveFieldReadWrite setterP getterP notifierP
 255
 256       setterW :: (Int,Int) -> GUICell -> IO ()
 257       setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board
 258
 259
 260       arrW :: Array Pos (ReactiveFieldWrite IO GUICell)
 261       arrW = array (minimum validArea, maximum validArea)
 262              [(i, ReactiveFieldWrite (setterW i))
 263              | i <- validArea :: [(Int,Int)]]
 264
 265   return (b,arrW,writeOnly ph)
 266
 267 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 268 fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in
 269                         uncurry (liftM2 (,))
 270                         ( return f'
 271                         , getDataFileName f' >>=
 272                           (pixbufNewFromFile >=>
 273                            \p -> pixbufScaleSimple p hexW hexW InterpBilinear)))
 274                (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
 275                 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
 276                        | d <- [N .. NW]])
 277
 278 actionToFile :: GUICell -> FilePath
 279 actionToFile GUICell { cellAction = a
 280                      , asPh = ph
 281                      } =
 282   case a of
 283     Inert           -> "img/hexO" ++ (if ph then "n" else "ff") ++ ".png"
 284     Absorb          -> "img/absorb.svg"
 285     Stop _          -> "img/stop.svg"
 286     ChDir True _ d  -> "img/start" ++ show d ++ ".svg"
 287     ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
 288     Split _         -> "img/split.svg"