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           Debug.Trace
  16 import           Game.Board.BasicTurnGame
  17 import           Graphics.UI.Gtk                  hiding (Action)
  18 import           Graphics.UI.Gtk.Board.BoardLink
  19 import           Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
  20 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
  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 newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
  30
  31 data Tile = Tile
  32 data Player = Player deriving(Show)
  33
  34 -- Takes a GUI coordinate and give the corresponding coordinate on the
  35 -- internal board
  36 fromGUICoords :: (Int,Int) -> (Int,Int)
  37 fromGUICoords (x,y) = (x,(x `mod` 2 - y) `quot` 2)
  38
  39 -- Takes coordinates from the point of view of the internal board and
  40 -- translates them to GUI board coordinates.
  41 toGUICoords :: (Int,Int) -> (Int,Int)
  42 toGUICoords (x,y) = (x,2*(-y) + x `mod` 2)
  43
  44 tileW :: Int
  45 tileW = 40
  46
  47 tileH :: Int
  48 tileH = round (sqrt 3 * fromIntegral tileW / 3)
  49
  50 hexW :: Int
  51 hexW = round (4 * fromIntegral tileW / 3)
  52
  53 hexH :: Int
  54 hexH = round (sqrt 3 * fromIntegral hexW / 2)
  55
  56 xMax, yMax :: Int
  57 (xMax,yMax) = BF.second (*2) $ neighbor N nec
  58 xMin, yMin :: Int
  59 (xMin,yMin) = BF.second (*2) swc
  60
  61 boardToTile :: [(Int,Int,Tile)]
  62 boardToTile = [(x,y,Tile) | (x,y) <- range ( (xMin-1,yMin)
  63                                            , (xMax+1,yMax+1))]
  64
  65
  66
  67 boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)]
  68 boardToPiece ph = map placePiece . filter (onBoard . fst) . assocs
  69   where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell)
  70         placePiece ((x,y),(a,n)) = let y' = 2*(-y) + x `mod` 2
  71                                        c = GUICell { cellAction = a
  72                                                    , repeatCount = n
  73                                                    , asPh = (x,y) `elem` phPosS
  74                                                    }
  75                                    in (x,y',Player,c)
  76         phPosS = map phPos ph
  77
  78 validArea :: Board -> [(Int,Int)]
  79 validArea = map (\(x,y,_,_) -> (x,y)) . boardToPiece []
  80
  81 na = NoteAttr {
  82           naArt = Accent13,
  83           naDur = 1 % 1,
  84           naOrn = Ornaments Nothing [] NoSlide
  85       }
  86
  87 initGUIBoard :: GUIBoard
  88 initGUIBoard = GUIBoard GameState
  89   { curPlayer'   = Player
  90   , boardPos     = boardToTile
  91   , boardPieces' = boardToPiece [] $
  92                    makeBoard [((0,0),  mkCell (ChDir True na NE)),
  93                               ((2,1),  mkCellRpt (ChDir False na NW) 3),
  94                               ((0,2),  mkCell (ChDir False na S))]
  95   }
  96
  97 instance PlayableGame GUIBoard Int Tile Player GUICell where
  98   curPlayer _               = Player
  99   allPos (GUIBoard game)    = boardPos game
 100   allPieces (GUIBoard game) = boardPieces' game
 101   moveEnabled _             = True
 102   canMove (GUIBoard game) _ (x,y)
 103     | Just (_,p) <- getPieceAt game (x,y)
 104     , GUICell { cellAction = Inert } <- p = False
 105     | otherwise = True
 106   canMoveTo _ _ _ (x,y) = (x,y) `elem` validArea
 107     where validArea = map (\(x',y',_,_) -> (x',y')) $ boardToPiece [] $
 108                       makeBoard []
 109
 110   move (GUIBoard game) _ iPos@(_,yi) (xf,yf) = [ MovePiece iPos fPos'
 111                                                , AddPiece iPos Player nCell]
 112     where fPos'
 113             |    (xf `mod` 2 == 0 && yf `mod` 2 == 0)
 114               || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
 115             | otherwise = (xf,yf+signum' (yf-yi))
 116           signum' x
 117             | x == 0 = 1
 118             | otherwise = signum x
 119           nCell
 120             | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
 121                 getPieceAt game iPos = inertCell { repeatCount = n
 122                                                  , asPh = ph
 123                                                  }
 124             | otherwise = inertCell
 125             where inertCell = GUICell { cellAction = Inert
 126                                       , repeatCount = 1
 127                                       , asPh = False}
 128
 129   applyChange (GUIBoard game) (AddPiece pos@(x,y) Player piece) =
 130     GUIBoard $ game { boardPieces' = bp' }
 131     where bp' = (x,y,Player,piece):boardPieces' game
 132
 133   applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
 134     game { boardPieces' = bp' }
 135     where bp' = [p | p@(x',y',_,_) <- boardPieces' game
 136                    , x /= x' || y /= y']
 137
 138   applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
 139     | Just (_,p) <- getPieceAt game iPos
 140     = applyChanges guiBoard [ RemovePiece iPos
 141                             , RemovePiece fPos
 142                             , AddPiece fPos Player p]
 143     | otherwise = guiBoard
 144
 145 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
 146 initGame = do
 147   pixbufs <- fileToPixbuf
 148   tilePixbuf <- pixbufNew ColorspaceRgb False 8 tileW tileH
 149   pixbufFill tilePixbuf 50 50 50 0
 150   let pixPiece :: (Player,GUICell) -> Pixbuf
 151       pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs
 152       pixTile :: Tile -> Pixbuf
 153       pixTile _ = tilePixbuf
 154       visualA = VisualGameAspects { tileF = pixTile
 155                                   , pieceF = pixPiece
 156                                   , bgColor = (1000,1000,1000)
 157                                   , bg = Nothing
 158                                   }
 159
 160   return $ Game visualA initGUIBoard
 161
 162 initBoardRV :: BIO.Board Int Tile (Player,GUICell)
 163             -> IO ( ReactiveFieldRead IO Board
 164                   , ReactiveFieldReadWrite IO [PlayHead])
 165 initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
 166   phMVar <- newCBMVar []
 167   oldphMVar <- newCBMVar []
 168   notBMVar <- mkClockRV 100
 169   let getterB :: IO Board
 170       getterB = do
 171         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs array
 172         let board = makeBoard $
 173               map (BF.first fromGUICoords .
 174                    BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
 175                               fromJust)) $
 176               filter (isJust . snd) boardArray
 177         return board
 178
 179       notifierB :: IO () -> IO ()
 180       notifierB = reactiveValueOnCanRead notBMVar
 181
 182       getterP :: IO [PlayHead]
 183       getterP = readCBMVar phMVar
 184
 185       setterP :: [PlayHead] -> IO ()
 186       setterP lph = do
 187         let phPosS = map phPos lph
 188         readCBMVar phMVar >>= writeCBMVar oldphMVar
 189         oph <- readCBMVar oldphMVar
 190         writeCBMVar phMVar lph
 191         let offPh :: PlayHead -> IO ()
 192             offPh ph = do
 193               let pos = toGUICoords $ phPos ph
 194               piece <- boardGetPiece pos board
 195               when (isJust piece) $ do
 196                 let (_,c) = fromJust piece
 197                 boardSetPiece pos (Player, c { asPh = pos `elem` phPosS }) board
 198             onPh :: PlayHead -> IO ()
 199             onPh ph =  do
 200               let pos = toGUICoords $ phPos ph
 201               piece <- boardGetPiece pos board
 202               when (isJust piece) $ do
 203                 let (_,c) = fromJust piece
 204                 boardSetPiece pos (Player, c { asPh = True }) board
 205         mapM_ offPh oph
 206         print oph
 207         mapM_ onPh lph
 208         print lph
 209
 210       notifierP :: IO () -> IO ()
 211       notifierP = installCallbackCBMVar phMVar
 212
 213       b = ReactiveFieldRead getterB notifierB
 214       ph = ReactiveFieldReadWrite setterP getterP notifierP
 215   return (b,ph)
 216
 217 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 218 fileToPixbuf = mapM (\f -> let f' = "img/" ++ f in uncurry (liftM2 (,))
 219                       ( return f'
 220                       , pixbufNewFromFile f' >>=
 221                         \p -> pixbufScaleSimple p hexW hexW InterpBilinear ))
 222                (["hexOn.png","hexOff.png","stop.svg","split.svg"] ++
 223                 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
 224                        | d <- [N .. NW]])
 225
 226 actionToFile :: GUICell -> FilePath
 227 actionToFile GUICell { cellAction = a
 228                      , asPh = ph
 229                      } =
 230   case (a,ph) of
 231     (Inert,True) -> "img/hexOn.png"
 232     (Inert,False) -> "img/hexOff.png"
 233     (Absorb,_) -> "img/stop.svg"
 234     (Stop _,_) -> "img/stop.svg"
 235     (ChDir True _ d,_) -> "img/start" ++ show d ++ ".svg"
 236     (ChDir False _ d,_) -> "img/ric" ++ show d ++ ".svg"
 237     (Split _,_) -> "img/split.svg"