src/RMCA/GUI/Board.hs

   1 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables,
   2              TypeSynonymInstances #-}
   3
   4 module RMCA.GUI.Board where
   5
   6 import           Control.Concurrent.MVar
   7 import           Control.Monad
   8 import           Control.Monad.IO.Class
   9 import           Data.Array
  10 import           Data.Array.MArray
  11 import qualified Data.Bifunctor                   as BF
  12 import           Data.Board.GameBoardIO
  13 import           Data.CBMVar
  14 import           Data.Maybe
  15 import           Data.Ratio
  16 import           Data.ReactiveValue
  17 import           Debug.Trace
  18 import           Game.Board.BasicTurnGame
  19 import           Graphics.UI.Gtk                  hiding (Action)
  20 import           Graphics.UI.Gtk.Board.BoardLink
  21 import           Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
  22 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
  23 import           Paths_RMCA
  24 import           RMCA.Global.Clock
  25 import           RMCA.Semantics
  26
  27 data GUICell = GUICell { cellAction  :: Action
  28                        , repeatCount :: Int
  29                        , asPh        :: Bool
  30                        } deriving(Show)
  31
  32 rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
  33   where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
  34         rotateAction x = x
  35
  36 newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
  37
  38 type IOBoard = BIO.Board Int Tile (Player,GUICell)
  39
  40 data Tile = Tile
  41 data Player = Player deriving(Show)
  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 (sqrt 3 * fromIntegral tileW / 3)
  58
  59 hexW :: Int
  60 hexW = round (4 * fromIntegral tileW / 3)
  61
  62 hexH :: Int
  63 hexH = round (sqrt 3 * fromIntegral hexW / 2)
  64
  65 xMax, yMax :: Int
  66 (xMax,yMax) = BF.second (*2) $ neighbor N nec
  67 xMin, yMin :: Int
  68 (xMin,yMin) = BF.second (*2) swc
  69
  70 boardToTile :: [(Int,Int,Tile)]
  71 boardToTile = [(x,y,Tile) | (x,y) <- range ( (xMin-1,yMin)
  72                                            , (xMax+3,yMax+1))]
  73
  74 defNa :: NoteAttr
  75 defNa = NoteAttr { naArt = NoAccent
  76                  , naDur = 1 % 4
  77                  , naOrn = noOrn
  78                  }
  79
  80 ctrlPieces :: [(Int,Int,Player,GUICell)]
  81 ctrlPieces = [(xMax+2,y,Player,GUICell { cellAction = action
  82                                        , repeatCount = 1
  83                                        , asPh = False
  84                                        })
  85              | let actions = [ Absorb, Stop defNa
  86                              , ChDir False defNa N, ChDir True defNa N
  87                              , Split defNa]
  88                      -- /!\ It would be nice to find a general formula
  89                      -- for placing the control pieces.
  90                      , (y,action) <- zip [ yMin+4,yMin+8..] actions]
  91
  92 ctrlCoords :: [(Int,Int)]
  93 ctrlCoords = map (\(x,y,_,_) -> (x,y)) ctrlPieces
  94
  95 boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)]
  96 boardToPiece ph = (++ ctrlPieces) . map placePiece .
  97                   filter (onBoard . fst) . assocs
  98   where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell)
  99         placePiece ((x,y),(a,n)) = let c = GUICell { cellAction = a
 100                                                    , repeatCount = n
 101                                                    , asPh = (x,y) `elem` phPosS
 102                                                    }
 103                                        (x',y') = toGUICoords (x,y)
 104                                    in (x',y',Player,c)
 105         phPosS = map phPos ph
 106
 107 validArea :: [(Int,Int)]
 108 validArea = filter (onBoard . fromGUICoords) $
 109             map (\(x,y,_,_) -> (x,y)) $ boardToPiece [] $ makeBoard []
 110
 111 outGUIBoard :: (Int,Int) -> Bool
 112 outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax
 113
 114 na = NoteAttr {
 115           naArt = Accent13,
 116           naDur = 1 % 1,
 117           naOrn = Ornaments Nothing [] NoSlide
 118       }
 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@(GUIBoard game) p 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 pos@(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                   , ReactiveFieldReadWrite IO [PlayHead])
 209 initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard gArray) } = do
 210   -- RV creation
 211   phMVar <- newCBMVar []
 212   notBMVar <- mkClockRV 100
 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 phPosS = map phPos lph
 233             offPh :: PlayHead -> IO ()
 234             offPh ph = do
 235               let pos = toGUICoords $ phPos ph
 236               piece <- boardGetPiece pos board
 237               when (isJust piece) $ do
 238                 let (_,c) = fromJust piece
 239                 boardSetPiece pos (Player, c { asPh = False }) board
 240             onPh :: PlayHead -> IO ()
 241             onPh ph =  do
 242               let pos = toGUICoords $ phPos ph
 243               piece <- boardGetPiece pos board
 244               when (isJust piece) $ do
 245                 let (_,c) = fromJust piece
 246                 boardSetPiece pos (Player, c { asPh = True }) board
 247         postGUIAsync $ mapM_ offPh oph
 248         postGUIAsync $ mapM_ onPh lph
 249         writeCBMVar phMVar lph
 250
 251       notifierP :: IO () -> IO ()
 252       notifierP = installCallbackCBMVar phMVar
 253
 254       b = ReactiveFieldRead getterB notifierB
 255       ph = ReactiveFieldReadWrite setterP getterP notifierP
 256
 257       setterW :: (Int,Int) -> GUICell -> IO ()
 258       setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board
 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,ph)
 266
 267 clickHandling :: BIO.Board Int Tile (Player,GUICell) -> IO ()
 268 clickHandling board = do
 269   state <- newEmptyMVar
 270   boardOnPress board
 271     (\iPos -> liftIO $ do
 272         postGUIAsync $ void $ tryPutMVar state iPos
 273         return True
 274     )
 275   boardOnRelease board
 276     (\fPos -> liftIO $ do
 277         postGUIAsync $ do
 278           mp <- boardGetPiece fPos board
 279           mstate <- tryTakeMVar state
 280           when (fPos `elem` validArea && isJust mp &&
 281                 maybe False (== fPos) mstate) $ do
 282             boardSetPiece fPos (BF.second rotateGUICell $
 283                                 fromJust mp) board
 284         return True
 285     )
 286
 287     {-
 288   boardOnPress board
 289     (\i -> do
 290         mp <- boardGetPiece i board
 291         when (i `elem` validArea && isJust mp && fromJust mp == Inert) $
 292 -}
 293
 294
 295 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 296 fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in
 297                         uncurry (liftM2 (,))
 298                         ( return f'
 299                         , getDataFileName f' >>=
 300                           \f'' -> pixbufNewFromFile f'' >>=
 301                           \p -> pixbufScaleSimple p hexW hexW InterpBilinear))
 302                (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
 303                 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
 304                        | d <- [N .. NW]])
 305
 306 actionToFile :: GUICell -> FilePath
 307 actionToFile GUICell { cellAction = a
 308                      , asPh = ph
 309                      } =
 310   case a of
 311     Inert           -> "img/hexO" ++ (if ph then "n" else "ff") ++ ".png"
 312     Absorb          -> "img/absorb.svg"
 313     Stop _          -> "img/stop.svg"
 314     ChDir True _ d  -> "img/start" ++ show d ++ ".svg"
 315     ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
 316     Split _         -> "img/split.svg"