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