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 newtype GUIBoard = GUIBoard (GameState Int Tile Player Action)
  16
  17 data Tile = Tile
  18 data Player = Player
  19
  20 tileW :: Int
  21 tileW = 35
  22
  23 tileH :: Int
  24 tileH = round (sqrt 3 * fromIntegral tileW / 3)
  25
  26 hexW :: Int
  27 hexW = round (4 * fromIntegral tileW / 3)
  28
  29 boardToTile :: [(Int,Int,Tile)]
  30 boardToTile = [(x,y,Tile) | (x,y) <- range ( (xMin-1,yMin)
  31                                            , (xMax+1,yMax+1))]
  32   where (xMax,yMax) = BF.second (*2) $ neighbor N nec
  33         (xMin,yMin) = BF.second (*2) swc
  34
  35 boardToPiece :: Board -> [(Int,Int,Player,Action)]
  36 boardToPiece = map placePiece . filter (onBoard . fst) . assocs
  37   where placePiece :: (Pos,Cell) -> (Int,Int,Player,Action)
  38         placePiece ((x,y),(a,_)) = let y' = 2*(-y) + x `mod` 2 in
  39                                      (x,y',Player,a)
  40
  41
  42 na = NoteAttr {
  43           naArt = Accent13,
  44           naDur = 1 % 1,
  45           naOrn = Ornaments Nothing [] NoSlide
  46       }
  47
  48 initGUIBoard :: GUIBoard
  49 initGUIBoard = GUIBoard $ GameState
  50   { curPlayer'   = Player
  51   , boardPos     = boardToTile
  52   , boardPieces' = boardToPiece $ makeBoard [((0,5), mkCell (ChDir True na NE))]
  53   }
  54 {-
  55 instance Show GUIBoard where
  56   show _ = "lol"
  57 -}
  58 instance PlayableGame GUIBoard Int Tile Player Action where
  59   curPlayer _               = Player
  60   allPos (GUIBoard game)    = boardPos game
  61   allPieces (GUIBoard game) = boardPieces' game
  62   moveEnabled _             = True
  63   canMove (GUIBoard game) _ (x,y)
  64     | Just (_,p) <- getPieceAt game (x,y)
  65     , Inert <- p = False
  66     | otherwise = True{-
  67   canMoveTo _ _ _ (x,y)
  68     | (x `mod` 2 == 0 && y `mod` 2 == 0) || (x `mod` 2 /= 0 && y `mod` 2 /= 0)
  69     = True
  70     | otherwise = False-}
  71   canMoveTo _ _ _ _ = True
  72
  73
  74   move (GUIBoard game) _ iPos@(_,yi) fPos@(xf,yf) = [MovePiece iPos fPos']
  75     where fPos'
  76             |    (xf `mod` 2 == 0 && yf `mod` 2 == 0)
  77               || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
  78             | otherwise = (xf,yf+signum' (yf-yi))
  79           signum' x
  80             | x == 0 = 1
  81             | otherwise = signum x
  82
  83
  84
  85   applyChange (GUIBoard game) (AddPiece pos@(x,y) _ piece) =
  86     GUIBoard $ game { boardPieces' = bp' }
  87     where bp' = (x,y,Player,piece):(
  88                 filter (\(x',y',_,_) -> (x',y') /= pos) $ boardPieces' game)
  89
  90   applyChange (GUIBoard game) (RemovePiece pos) =
  91     (\g -> applyChange g (AddPiece pos Player Inert)) $
  92     GUIBoard $ game { boardPieces' = bp' }
  93     where bp' = filter (\(x',y',_,_) -> pos /= (x',y')) $ boardPieces' game
  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       visual = VisualGameAspects { tileF = pixTile
 112                                  , pieceF = pixPiece
 113                                  , bgColor = (1000,1000,1000)
 114                                  , bg = Nothing
 115                                  }
 116
 117   return $ Game visual initGUIBoard
 118
 119 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 120 fileToPixbuf = sequence $
 121   map (\f -> uncurry (liftM2 (,))
 122              ( return f
 123              , pixbufNewFromFile f >>=
 124                \p -> pixbufScaleSimple p hexW hexW InterpBilinear )) $
 125   map ("img/" ++) $ ["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"