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