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+3,yMax+1))]
  64
  65 defNa :: NoteAttr
  66 defNa = NoteAttr { naArt = NoAccent
  67                  , naDur = 1 % 4
  68                  , naOrn = noOrn
  69                  }
  70
  71 ctrlPieces :: [(Int,Int,Player,GUICell)]
  72 ctrlPieces = [(xMax+2,y,Player,GUICell { cellAction = action
  73                                        , repeatCount = 1
  74                                        , asPh = False
  75                                        })
  76              | let actions = [ Absorb, Stop defNa
  77                              , ChDir False defNa N, ChDir True defNa N
  78                              , Split defNa]
  79                      -- /!\ It would be nice to find a general formula
  80                      -- for placing the control pieces.
  81                      , (y,action) <- zip [ yMin+4,yMin+8..] actions]
  82
  83 ctrlCoord = map (\(x,y,_,_) -> (x,y)) ctrlPieces
  84
  85 boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)]
  86 boardToPiece ph = (++ ctrlPieces) . map placePiece .
  87                   filter (onBoard . fst) . assocs
  88   where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell)
  89         placePiece ((x,y),(a,n)) = let c = GUICell { cellAction = a
  90                                                    , repeatCount = n
  91                                                    , asPh = (x,y) `elem` phPosS
  92                                                    }
  93                                        (x',y') = toGUICoords (x,y)
  94                                    in (x',y',Player,c)
  95         phPosS = map phPos ph
  96
  97 validArea :: [(Int,Int)]
  98 validArea = filter (onBoard . fromGUICoords) $
  99             map (\(x,y,_,_) -> (x,y)) $ boardToPiece [] $ makeBoard []
 100
 101 na = NoteAttr {
 102           naArt = Accent13,
 103           naDur = 1 % 1,
 104           naOrn = Ornaments Nothing [] NoSlide
 105       }
 106
 107 initGUIBoard :: GUIBoard
 108 initGUIBoard = GUIBoard GameState
 109   { curPlayer'   = Player
 110   , boardPos     = boardToTile
 111   , boardPieces' = boardToPiece [] $
 112                    makeBoard [((0,0),  mkCell (ChDir True na NE)),
 113                               ((2,1),  mkCellRpt (ChDir False na NW) 3),
 114                               ((0,2),  mkCell (ChDir False na S))]
 115   }
 116
 117 instance PlayableGame GUIBoard Int Tile Player GUICell where
 118   curPlayer _               = Player
 119   allPos (GUIBoard game)    = boardPos game
 120   allPieces (GUIBoard game) = boardPieces' game
 121   moveEnabled _             = True
 122   canMove (GUIBoard game) _ (x,y)
 123     | Just (_,p) <- getPieceAt game (x,y)
 124     , GUICell { cellAction = Inert } <- p = False
 125     | Nothing <- getPieceAt game (x,y) = False
 126     | otherwise = True
 127   canMoveTo _ _ _ (x,y) = (x,y) `elem` validArea
 128
 129   move guiBoard@(GUIBoard game) p iPos@(_,yi) (xf,yf)
 130     | not (canMove guiBoard p iPos) = []
 131     | not (canMoveTo guiBoard p iPos fPos') = []
 132     | iPos `elem` ctrlCoord = [ RemovePiece fPos'
 133                               , AddPiece fPos' Player (nCell { cellAction = ctrlAction })
 134                               ]
 135     | otherwise = [ MovePiece iPos fPos'
 136                   , AddPiece iPos Player nCell]
 137     where fPos'
 138             |    (xf `mod` 2 == 0 && yf `mod` 2 == 0)
 139               || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
 140             | otherwise = (xf,yf)-- (xf,yf+signum' (yf-yi))
 141           signum' x
 142             | x == 0 = 1
 143             | otherwise = signum x
 144           ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos
 145           nCell
 146             | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
 147                 getPieceAt game iPos = inertCell { repeatCount = n
 148                                                  , asPh = ph
 149                                                  }
 150             | otherwise = inertCell
 151             where inertCell = GUICell { cellAction = Inert
 152                                       , repeatCount = 1
 153                                       , asPh = False}
 154
 155   applyChange (GUIBoard game) (AddPiece pos@(x,y) Player piece) =
 156     GUIBoard $ game { boardPieces' = bp' }
 157     where bp' = (x,y,Player,piece):boardPieces' game
 158
 159   applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
 160     game { boardPieces' = bp' }
 161     where bp' = [p | p@(x',y',_,_) <- boardPieces' game
 162                    , x /= x' || y /= y']
 163
 164   applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
 165     | Just (_,p) <- getPieceAt game iPos
 166     = applyChanges guiBoard [ RemovePiece iPos
 167                             , RemovePiece fPos
 168                             , AddPiece fPos Player p]
 169     | otherwise = guiBoard
 170
 171 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
 172 initGame = do
 173   pixbufs <- fileToPixbuf
 174   tilePixbuf <- pixbufNew ColorspaceRgb False 8 tileW tileH
 175   pixbufFill tilePixbuf 50 50 50 0
 176   let pixPiece :: (Player,GUICell) -> Pixbuf
 177       pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs
 178       pixTile :: Tile -> Pixbuf
 179       pixTile _ = tilePixbuf
 180       visualA = VisualGameAspects { tileF = pixTile
 181                                   , pieceF = pixPiece
 182                                   , bgColor = (1000,1000,1000)
 183                                   , bg = Nothing
 184                                   }
 185
 186   return $ Game visualA initGUIBoard
 187
 188 initBoardRV :: BIO.Board Int Tile (Player,GUICell)
 189             -> IO ( ReactiveFieldRead IO Board
 190                   , ReactiveFieldReadWrite IO [PlayHead])
 191 initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
 192   phMVar <- newCBMVar []
 193   oldphMVar <- newCBMVar []
 194   notBMVar <- mkClockRV 100
 195   let getterB :: IO Board
 196       getterB = do
 197         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs array
 198         let board = makeBoard $
 199               map (BF.first fromGUICoords .
 200                    BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
 201                               fromJust)) $
 202               filter (isJust . snd) boardArray
 203         return board
 204
 205       notifierB :: IO () -> IO ()
 206       notifierB = reactiveValueOnCanRead notBMVar
 207
 208       getterP :: IO [PlayHead]
 209       getterP = readCBMVar phMVar
 210
 211       setterP :: [PlayHead] -> IO ()
 212       setterP lph = do
 213         readCBMVar phMVar >>= writeCBMVar oldphMVar
 214         writeCBMVar phMVar lph
 215         oph <- readCBMVar oldphMVar
 216         let phPosS = map phPos lph
 217             offPh :: PlayHead -> IO ()
 218             offPh ph = do
 219               let pos = toGUICoords $ phPos ph
 220               piece <- boardGetPiece pos board
 221               when (isJust piece) $ do
 222                 let (_,c) = fromJust piece
 223                 boardSetPiece pos (Player, c { asPh = pos `elem` phPosS }) board
 224             onPh :: PlayHead -> IO ()
 225             onPh ph =  do
 226               let pos = toGUICoords $ phPos ph
 227               piece <- boardGetPiece pos board
 228               when (isJust piece) $ do
 229                 let (_,c) = fromJust piece
 230                 boardSetPiece pos (Player, c { asPh = True }) board
 231         mapM_ offPh oph
 232         mapM_ onPh lph
 233
 234       notifierP :: IO () -> IO ()
 235       notifierP = installCallbackCBMVar phMVar
 236
 237       b = ReactiveFieldRead getterB notifierB
 238       ph = ReactiveFieldReadWrite setterP getterP notifierP
 239   return (b,ph)
 240
 241 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 242 fileToPixbuf = mapM (\f -> let f' = "img/" ++ f in uncurry (liftM2 (,))
 243                       ( return f'
 244                       , pixbufNewFromFile f' >>=
 245                         \p -> pixbufScaleSimple p hexW hexW InterpBilinear ))
 246                (["hexOn.png","hexOff.png","stop.svg","split.svg"] ++
 247                 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
 248                        | d <- [N .. NW]])
 249
 250 actionToFile :: GUICell -> FilePath
 251 actionToFile GUICell { cellAction = a
 252                      , asPh = ph
 253                      } =
 254   case (a,ph) of
 255     (Inert,True) -> "img/hexOn.png"
 256     (Inert,False) -> "img/hexOff.png"
 257     (Absorb,_) -> "img/stop.svg"
 258     (Stop _,_) -> "img/stop.svg"
 259     (ChDir True _ d,_) -> "img/start" ++ show d ++ ".svg"
 260     (ChDir False _ d,_) -> "img/ric" ++ show d ++ ".svg"
 261     (Split _,_) -> "img/split.svg"