RMCA/GUI/Board.hs

   1 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
   2
   3 module RMCA.GUI.Board where
   4
   5 import           Control.Monad
   6 import           Data.Array
   7 import qualified Data.Bifunctor                  as BF
   8 import           Data.Maybe
   9 import           Data.Ratio
  10 import           Game.Board.BasicTurnGame
  11 import           Graphics.UI.Gtk                 hiding (Action)
  12 import           Graphics.UI.Gtk.Board.BoardLink
  13 import           RMCA.Semantics
  14
  15 import           Debug.Trace
  16
  17 newtype GUIBoard = GUIBoard { toGS :: (GameState Int Tile Player Action) }
  18
  19 data Tile = Tile
  20 data Player = Player deriving(Show)
  21
  22 tileW :: Int
  23 tileW = 40
  24
  25 tileH :: Int
  26 tileH = round (sqrt 3 * fromIntegral tileW / 3)
  27
  28 hexW :: Int
  29 hexW = round (4 * fromIntegral tileW / 3)
  30
  31 hexH :: Int
  32 hexH = round (sqrt 3 * fromIntegral hexW / 2)
  33
  34 xMax, yMax :: Int
  35 (xMax,yMax) = BF.second (*2) $ neighbor N nec
  36 xMin, yMin :: Int
  37 (xMin,yMin) = BF.second (*2) swc
  38
  39 boardToTile :: [(Int,Int,Tile)]
  40 boardToTile = [(x,y,Tile) | (x,y) <- range ( (xMin-1,yMin)
  41                                            , (xMax+1,yMax+1))]
  42
  43 boardToPiece :: Board -> [(Int,Int,Player,Action)]
  44 boardToPiece = map placePiece . filter (onBoard . fst) . assocs
  45   where placePiece :: (Pos,Cell) -> (Int,Int,Player,Action)
  46         placePiece ((x,y),(a,_)) = let y' = 2*(-y) + x `mod` 2 in
  47                                      (x,y',Player,a)
  48
  49 na = NoteAttr {
  50           naArt = Accent13,
  51           naDur = 1 % 1,
  52           naOrn = Ornaments Nothing [] NoSlide
  53       }
  54
  55 initGUIBoard :: GUIBoard
  56 initGUIBoard = GUIBoard $ GameState
  57   { curPlayer'   = Player
  58   , boardPos     = boardToTile
  59   , boardPieces' = boardToPiece $ makeBoard [((0,5), mkCell (ChDir True na NE))]
  60   }
  61
  62
  63 instance PlayableGame GUIBoard Int Tile Player Action where
  64   curPlayer _               = Player
  65   allPos (GUIBoard game)    = boardPos game
  66   allPieces (GUIBoard game) = boardPieces' game
  67   moveEnabled _             = True
  68   canMove (GUIBoard game) _ (x,y)
  69     | Just (_,p) <- getPieceAt game (x,y)
  70     , Inert <- p = False
  71     | otherwise = True
  72   canMoveTo _ _ _ (x,y) = (x,y) `elem` validArea
  73     where validArea = map (\(x',y',_,_) -> (x',y')) $ boardToPiece $ makeBoard []
  74
  75   move _ _ iPos@(_,yi) (xf,yf) = [ MovePiece iPos fPos'
  76                                  , AddPiece iPos Player Inert]
  77     where fPos'
  78             |    (xf `mod` 2 == 0 && yf `mod` 2 == 0)
  79               || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
  80             | otherwise = (xf,yf+signum' (yf-yi))
  81           signum' x
  82             | x == 0 = 1
  83             | otherwise = signum x
  84
  85
  86   applyChange (GUIBoard game) (AddPiece pos@(x,y) Player piece) =
  87     GUIBoard $ game { boardPieces' = bp' }
  88     where bp' = (x,y,Player,piece):(boardPieces' game)
  89
  90   applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
  91     game { boardPieces' = bp' }
  92     where bp' = [p | p@(x',y',_,_) <- boardPieces' game
  93                    , (x /= x' || y /= y')]
  94
  95   applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
  96     | Just (_,p) <- getPieceAt game iPos
  97     = applyChanges guiBoard [ RemovePiece iPos
  98                             , RemovePiece fPos
  99                             , AddPiece fPos Player p]
 100     | otherwise = guiBoard
 101
 102 initGame :: IO (Game GUIBoard Int Tile Player Action)
 103 initGame = do
 104   pixbufs <- fileToPixbuf
 105   tilePixbuf <- pixbufNew ColorspaceRgb False 8 tileW tileH
 106   pixbufFill tilePixbuf 50 50 50 0
 107   let pixPiece :: (Player,Action) -> Pixbuf
 108       pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs
 109       pixTile :: Tile -> Pixbuf
 110       pixTile _ = tilePixbuf
 111       visualA = VisualGameAspects { tileF = pixTile
 112                                   , pieceF = pixPiece
 113                                   , bgColor = (1000,1000,1000)
 114                                   , bg = Nothing
 115                                   }
 116
 117   return $ Game visualA initGUIBoard
 118
 119 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 120 fileToPixbuf = sequence $
 121   map (\f -> let f' = "img/" ++ f in uncurry (liftM2 (,))
 122              ( return f'
 123              , pixbufNewFromFile f' >>=
 124                \p -> pixbufScaleSimple p hexW hexW InterpBilinear )) $
 125   ["hexOn.png","stop.svg","split.svg"] ++
 126   concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
 127          | d <- [N .. NW]]
 128
 129 actionToFile :: Action -> FilePath
 130 actionToFile a = case a of
 131   Inert -> "img/hexOn.png"
 132   Absorb -> "img/stop.svg"
 133   Stop _ -> "img/stop.svg"
 134   ChDir True _ d -> "img/start" ++ show d ++ ".svg"
 135   ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
 136   Split _ -> "img/split.svg"