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