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