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     | iPos `elem` ctrlCoords = [ RemovePiece fPos'
 140                                , AddPiece fPos' Player
 141                                  (nCell { cellAction = ctrlAction }) ]
 142     | outGUIBoard fPos = [ RemovePiece iPos
 143                          , AddPiece iPos Player nCell ]
 144     | otherwise = [ MovePiece iPos fPos'
 145                   , AddPiece iPos Player nCell ]
 146     where fPos'
 147             |    (xf `mod` 2 == 0 && yf `mod` 2 == 0)
 148               || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
 149             | otherwise = (xf,yf+signum' (yf-yi))
 150           signum' x
 151             | x == 0 = 1
 152             | otherwise = signum x
 153           ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos
 154           nCell
 155             | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
 156                 getPieceAt game iPos = inertCell { repeatCount = n
 157                                                  , asPh = ph
 158                                                  }
 159             | otherwise = inertCell
 160             where inertCell = GUICell { cellAction = Inert
 161                                       , repeatCount = 1
 162                                       , asPh = False}
 163
 164   applyChange (GUIBoard game) (AddPiece pos@(x,y) Player piece) =
 165     GUIBoard $ game { boardPieces' = bp' }
 166     where bp' = (x,y,Player,piece):boardPieces' game
 167
 168   applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
 169     game { boardPieces' = bp' }
 170     where bp' = [p | p@(x',y',_,_) <- boardPieces' game
 171                    , x /= x' || y /= y']
 172
 173   applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
 174     | Just (_,p) <- getPieceAt game iPos
 175     = applyChanges guiBoard [ RemovePiece iPos
 176                             , RemovePiece fPos
 177                             , AddPiece fPos Player p]
 178     | otherwise = guiBoard
 179
 180 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
 181 initGame = do
 182   pixbufs <- fileToPixbuf
 183   tilePixbuf <- pixbufNew ColorspaceRgb False 8 tileW tileH
 184   pixbufFill tilePixbuf 50 50 50 0
 185   let pixPiece :: (Player,GUICell) -> Pixbuf
 186       pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs
 187       pixTile :: Tile -> Pixbuf
 188       pixTile _ = tilePixbuf
 189       visualA = VisualGameAspects { tileF = pixTile
 190                                   , pieceF = pixPiece
 191                                   , bgColor = (1000,1000,1000)
 192                                   , bg = Nothing
 193                                   }
 194
 195   return $ Game visualA initGUIBoard
 196
 197 -- Initializes a readable RV for the board and an readable-writable RV
 198 -- for the playheads. Also installs some handlers for pieces modification.
 199 initBoardRV :: BIO.Board Int Tile (Player,GUICell)
 200             -> IO ( ReactiveFieldRead IO Board
 201                   , ReactiveFieldReadWrite IO [PlayHead])
 202 initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
 203   -- RV creation
 204   phMVar <- newCBMVar []
 205   notBMVar <- mkClockRV 100
 206   let getterB :: IO Board
 207       getterB = do
 208         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs array
 209         let board = makeBoard $
 210               map (BF.first fromGUICoords .
 211                    BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
 212                               fromJust)) $
 213               filter (isJust . snd) boardArray
 214         return board
 215
 216       notifierB :: IO () -> IO ()
 217       notifierB = reactiveValueOnCanRead notBMVar
 218
 219       getterP :: IO [PlayHead]
 220       getterP = readCBMVar phMVar
 221
 222       setterP :: [PlayHead] -> IO ()
 223       setterP lph = do
 224         oph <- readCBMVar phMVar
 225         let phPosS = map phPos lph
 226             offPh :: PlayHead -> IO ()
 227             offPh ph = do
 228               let pos = toGUICoords $ phPos ph
 229               piece <- boardGetPiece pos board
 230               when (isJust piece) $ do
 231                 let (_,c) = fromJust piece
 232                 boardSetPiece pos (Player, c { asPh = False }) board
 233             onPh :: PlayHead -> IO ()
 234             onPh 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 = True }) board
 240         postGUIAsync $ mapM_ offPh oph
 241         postGUIAsync $ mapM_ onPh lph
 242         writeCBMVar phMVar lph
 243
 244       notifierP :: IO () -> IO ()
 245       notifierP = installCallbackCBMVar phMVar
 246
 247       b = ReactiveFieldRead getterB notifierB
 248       ph = ReactiveFieldReadWrite setterP getterP notifierP
 249   return (b,ph)
 250
 251 clickHandling :: BIO.Board Int Tile (Player,GUICell) -> IO ()
 252 clickHandling board = do
 253   state <- newEmptyMVar
 254   boardOnPress board
 255     (\iPos -> liftIO $ do
 256         postGUIAsync $ void $ tryPutMVar state iPos
 257         return True
 258     )
 259   boardOnRelease board
 260     (\fPos -> liftIO $ do
 261         postGUIAsync $ do
 262           mp <- boardGetPiece fPos board
 263           mstate <- tryTakeMVar state
 264           when (fPos `elem` validArea && isJust mp &&
 265                 maybe False (== fPos) mstate) $ do
 266             boardSetPiece fPos (BF.second rotateGUICell $
 267                                 fromJust mp) board
 268         return True
 269     )
 270
 271     {-
 272   boardOnPress board
 273     (\i -> do
 274         mp <- boardGetPiece i board
 275         when (i `elem` validArea && isJust mp && fromJust mp == Inert) $
 276 -}
 277
 278
 279 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 280 fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in
 281                         uncurry (liftM2 (,))
 282                         ( return f'
 283                         , getDataFileName f' >>=
 284                           \f'' -> pixbufNewFromFile f'' >>=
 285                           \p -> pixbufScaleSimple p hexW hexW InterpBilinear))
 286                (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
 287                 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
 288                        | d <- [N .. NW]])
 289
 290 actionToFile :: GUICell -> FilePath
 291 actionToFile GUICell { cellAction = a
 292                      , asPh = ph
 293                      } =
 294   case a of
 295     Inert           -> "img/hexO" ++ (if ph then "n" else "ff") ++ ".png"
 296     Absorb          -> "img/absorb.svg"
 297     Stop _          -> "img/stop.svg"
 298     ChDir True _ d  -> "img/start" ++ show d ++ ".svg"
 299     ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
 300     Split _         -> "img/split.svg"