RMCA/GUI/Board.hs

   1 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables,
   2              TypeSynonymInstances #-}
   3
   4 module RMCA.GUI.Board where
   5
   6 import           Control.Concurrent.MVar
   7 import           Control.Monad
   8 import           Control.Monad.IO.Class
   9 import           Data.Array
  10 import           Data.Array.MArray
  11 import qualified Data.Bifunctor                   as BF
  12 import           Data.Board.GameBoardIO
  13 import           Data.CBMVar
  14 import           Data.Maybe
  15 import           Data.Ratio
  16 import           Data.ReactiveValue
  17 import           Debug.Trace
  18 import           Game.Board.BasicTurnGame
  19 import           Graphics.UI.Gtk                  hiding (Action)
  20 import           Graphics.UI.Gtk.Board.BoardLink
  21 import           Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
  22 import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
  23 import           RMCA.Global.Clock
  24 import           RMCA.Semantics
  25
  26 data GUICell = GUICell { cellAction  :: Action
  27                        , repeatCount :: Int
  28                        , asPh        :: Bool
  29                        } deriving(Show)
  30
  31 rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
  32   where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
  33         rotateAction x = x
  34
  35 newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
  36
  37 data Tile = Tile
  38 data Player = Player deriving(Show)
  39
  40 -- Takes a GUI coordinate and give the corresponding coordinate on the
  41 -- internal board
  42 fromGUICoords :: (Int,Int) -> (Int,Int)
  43 fromGUICoords (x,y) = (x,(x `mod` 2 - y) `quot` 2)
  44
  45 -- Takes coordinates from the point of view of the internal board and
  46 -- translates them to GUI board coordinates.
  47 toGUICoords :: (Int,Int) -> (Int,Int)
  48 toGUICoords (x,y) = (x,2*(-y) + x `mod` 2)
  49
  50 tileW :: Int
  51 tileW = 40
  52
  53 tileH :: Int
  54 tileH = round (sqrt 3 * fromIntegral tileW / 3)
  55
  56 hexW :: Int
  57 hexW = round (4 * fromIntegral tileW / 3)
  58
  59 hexH :: Int
  60 hexH = round (sqrt 3 * fromIntegral hexW / 2)
  61
  62 xMax, yMax :: Int
  63 (xMax,yMax) = BF.second (*2) $ neighbor N nec
  64 xMin, yMin :: Int
  65 (xMin,yMin) = BF.second (*2) swc
  66
  67 boardToTile :: [(Int,Int,Tile)]
  68 boardToTile = [(x,y,Tile) | (x,y) <- range ( (xMin-1,yMin)
  69                                            , (xMax+3,yMax+1))]
  70
  71 defNa :: NoteAttr
  72 defNa = NoteAttr { naArt = NoAccent
  73                  , naDur = 1 % 4
  74                  , naOrn = noOrn
  75                  }
  76
  77 ctrlPieces :: [(Int,Int,Player,GUICell)]
  78 ctrlPieces = [(xMax+2,y,Player,GUICell { cellAction = action
  79                                        , repeatCount = 1
  80                                        , asPh = False
  81                                        })
  82              | let actions = [ Absorb, Stop defNa
  83                              , ChDir False defNa N, ChDir True defNa N
  84                              , Split defNa]
  85                      -- /!\ It would be nice to find a general formula
  86                      -- for placing the control pieces.
  87                      , (y,action) <- zip [ yMin+4,yMin+8..] actions]
  88
  89 ctrlCoord = map (\(x,y,_,_) -> (x,y)) ctrlPieces
  90
  91 boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)]
  92 boardToPiece ph = (++ ctrlPieces) . map placePiece .
  93                   filter (onBoard . fst) . assocs
  94   where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell)
  95         placePiece ((x,y),(a,n)) = let c = GUICell { cellAction = a
  96                                                    , repeatCount = n
  97                                                    , asPh = (x,y) `elem` phPosS
  98                                                    }
  99                                        (x',y') = toGUICoords (x,y)
 100                                    in (x',y',Player,c)
 101         phPosS = map phPos ph
 102
 103 validArea :: [(Int,Int)]
 104 validArea = filter (onBoard . fromGUICoords) $
 105             map (\(x,y,_,_) -> (x,y)) $ boardToPiece [] $ makeBoard []
 106
 107 na = NoteAttr {
 108           naArt = Accent13,
 109           naDur = 1 % 1,
 110           naOrn = Ornaments Nothing [] NoSlide
 111       }
 112
 113 initGUIBoard :: GUIBoard
 114 initGUIBoard = GUIBoard GameState
 115   { curPlayer'   = Player
 116   , boardPos     = boardToTile
 117   , boardPieces' = boardToPiece [] $ makeBoard []
 118   }
 119
 120 instance PlayableGame GUIBoard Int Tile Player GUICell where
 121   curPlayer _               = Player
 122   allPos (GUIBoard game)    = boardPos game
 123   allPieces (GUIBoard game) = boardPieces' game
 124   moveEnabled _             = True
 125   canMove (GUIBoard game) _ (x,y)
 126     | Just (_,p) <- getPieceAt game (x,y)
 127     , GUICell { cellAction = Inert } <- p = False
 128     | Nothing <- getPieceAt game (x,y) = False
 129     | otherwise = True
 130   canMoveTo _ _ _ (x,y) = (x,y) `elem` validArea
 131
 132   move guiBoard@(GUIBoard game) p iPos@(_,yi) (xf,yf)
 133     | iPos `elem` ctrlCoord = [ RemovePiece fPos'
 134                               , AddPiece fPos' Player (nCell { cellAction = ctrlAction })
 135                               ]
 136     | otherwise = [ MovePiece iPos fPos'
 137                   , AddPiece iPos Player nCell]
 138     where fPos'
 139             |    (xf `mod` 2 == 0 && yf `mod` 2 == 0)
 140               || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
 141             | otherwise = (xf,yf)-- (xf,yf+signum' (yf-yi))
 142           signum' x
 143             | x == 0 = 1
 144             | otherwise = signum x
 145           ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos
 146           nCell
 147             | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
 148                 getPieceAt game iPos = inertCell { repeatCount = n
 149                                                  , asPh = ph
 150                                                  }
 151             | otherwise = inertCell
 152             where inertCell = GUICell { cellAction = Inert
 153                                       , repeatCount = 1
 154                                       , asPh = False}
 155
 156   applyChange (GUIBoard game) (AddPiece pos@(x,y) Player piece) =
 157     GUIBoard $ game { boardPieces' = bp' }
 158     where bp' = (x,y,Player,piece):boardPieces' game
 159
 160   applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
 161     game { boardPieces' = bp' }
 162     where bp' = [p | p@(x',y',_,_) <- boardPieces' game
 163                    , x /= x' || y /= y']
 164
 165   applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
 166     | Just (_,p) <- getPieceAt game iPos
 167     = applyChanges guiBoard [ RemovePiece iPos
 168                             , RemovePiece fPos
 169                             , AddPiece fPos Player p]
 170     | otherwise = guiBoard
 171
 172 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
 173 initGame = do
 174   pixbufs <- fileToPixbuf
 175   tilePixbuf <- pixbufNew ColorspaceRgb False 8 tileW tileH
 176   pixbufFill tilePixbuf 50 50 50 0
 177   let pixPiece :: (Player,GUICell) -> Pixbuf
 178       pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs
 179       pixTile :: Tile -> Pixbuf
 180       pixTile _ = tilePixbuf
 181       visualA = VisualGameAspects { tileF = pixTile
 182                                   , pieceF = pixPiece
 183                                   , bgColor = (1000,1000,1000)
 184                                   , bg = Nothing
 185                                   }
 186
 187   return $ Game visualA initGUIBoard
 188
 189 -- Initializes a readable RV for the board and an readable-writable RV
 190 -- for the playheads. Also installs some handlers for pieces modification.
 191 initBoardRV :: BIO.Board Int Tile (Player,GUICell)
 192             -> IO ( ReactiveFieldRead IO Board
 193                   , ReactiveFieldReadWrite IO [PlayHead])
 194 initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
 195   -- RV creation
 196   phMVar <- newCBMVar []
 197   oldphMVar <- newCBMVar []
 198   notBMVar <- mkClockRV 100
 199   let getterB :: IO Board
 200       getterB = do
 201         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs array
 202         let board = makeBoard $
 203               map (BF.first fromGUICoords .
 204                    BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
 205                               fromJust)) $
 206               filter (isJust . snd) boardArray
 207         return board
 208
 209       notifierB :: IO () -> IO ()
 210       notifierB = reactiveValueOnCanRead notBMVar
 211
 212       getterP :: IO [PlayHead]
 213       getterP = readCBMVar phMVar
 214
 215       setterP :: [PlayHead] -> IO ()
 216       setterP lph = do
 217         readCBMVar phMVar >>= writeCBMVar oldphMVar
 218         writeCBMVar phMVar lph
 219         oph <- readCBMVar oldphMVar
 220         let phPosS = map phPos lph
 221             offPh :: PlayHead -> IO ()
 222             offPh ph = do
 223               let pos = toGUICoords $ phPos ph
 224               piece <- boardGetPiece pos board
 225               when (isJust piece) $ do
 226                 let (_,c) = fromJust piece
 227                 boardSetPiece pos (Player, c { asPh = pos `elem` phPosS }) board
 228             onPh :: PlayHead -> IO ()
 229             onPh ph =  do
 230               let pos = toGUICoords $ phPos ph
 231               piece <- boardGetPiece pos board
 232               when (isJust piece) $ do
 233                 let (_,c) = fromJust piece
 234                 boardSetPiece pos (Player, c { asPh = True }) board
 235         mapM_ offPh oph
 236         mapM_ onPh lph
 237
 238       notifierP :: IO () -> IO ()
 239       notifierP = installCallbackCBMVar phMVar
 240
 241       b = ReactiveFieldRead getterB notifierB
 242       ph = ReactiveFieldReadWrite setterP getterP notifierP
 243   return (b,ph)
 244
 245 clickHandling :: BIO.Board Int Tile (Player,GUICell) -> IO ()
 246 clickHandling board = do
 247   state <- newEmptyMVar
 248   boardOnPress board
 249     (\iPos -> liftIO $ do
 250         tryPutMVar state iPos
 251         return True
 252     )
 253   boardOnRelease board
 254     (\fPos -> liftIO $ do
 255         mp <- boardGetPiece fPos board
 256         mstate <- tryTakeMVar state
 257         when (fPos `elem` validArea && isJust mp &&
 258               maybe False (== fPos) mstate) $ do
 259           boardSetPiece fPos (BF.second rotateGUICell $
 260                               fromJust mp) board
 261         return True
 262     )
 263
 264     {-
 265   boardOnPress board
 266     (\i -> do
 267         mp <- boardGetPiece i board
 268         when (i `elem` validArea && isJust mp && fromJust mp == Inert) $
 269 -}
 270
 271
 272 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 273 fileToPixbuf = mapM (\f -> let f' = "img/" ++ f in uncurry (liftM2 (,))
 274                       ( return f'
 275                       , pixbufNewFromFile f' >>=
 276                         \p -> pixbufScaleSimple p hexW hexW InterpBilinear ))
 277                (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
 278                 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
 279                        | d <- [N .. NW]])
 280
 281 actionToFile :: GUICell -> FilePath
 282 actionToFile GUICell { cellAction = a
 283                      , asPh = ph
 284                      } =
 285   case (a,ph) of
 286     (Inert,True) -> "img/hexOn.png"
 287     (Inert,False) -> "img/hexOff.png"
 288     (Absorb,_) -> "img/absorb.svg"
 289     (Stop _,_) -> "img/stop.svg"
 290     (ChDir True _ d,_) -> "img/start" ++ show d ++ ".svg"
 291     (ChDir False _ d,_) -> "img/ric" ++ show d ++ ".svg"
 292     (Split _,_) -> "img/split.svg"