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+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   notBMVar <- mkClockRV 100
 198   let getterB :: IO Board
 199       getterB = do
 200         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs array
 201         let board = makeBoard $
 202               map (BF.first fromGUICoords .
 203                    BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
 204                               fromJust)) $
 205               filter (isJust . snd) boardArray
 206         return board
 207
 208       notifierB :: IO () -> IO ()
 209       notifierB = reactiveValueOnCanRead notBMVar
 210
 211       getterP :: IO [PlayHead]
 212       getterP = readCBMVar phMVar
 213
 214       setterP :: [PlayHead] -> IO ()
 215       setterP lph = do
 216         oph <- readCBMVar phMVar
 217         let phPosS = map phPos lph
 218             offPh :: PlayHead -> IO ()
 219             offPh ph = do
 220               let pos = toGUICoords $ phPos ph
 221               piece <- boardGetPiece pos board
 222               when (isJust piece) $ do
 223                 let (_,c) = fromJust piece
 224                 boardSetPiece pos (Player, c { asPh = False }) board
 225             onPh :: PlayHead -> IO ()
 226             onPh ph =  do
 227               let pos = toGUICoords $ phPos ph
 228               piece <- boardGetPiece pos board
 229               when (isJust piece) $ do
 230                 let (_,c) = fromJust piece
 231                 boardSetPiece pos (Player, c { asPh = True }) board
 232         postGUIAsync $ mapM_ offPh oph
 233         postGUIAsync $ mapM_ onPh lph
 234         writeCBMVar phMVar lph
 235
 236       notifierP :: IO () -> IO ()
 237       notifierP = installCallbackCBMVar phMVar
 238
 239       b = ReactiveFieldRead getterB notifierB
 240       ph = ReactiveFieldReadWrite setterP getterP notifierP
 241   return (b,ph)
 242
 243 clickHandling :: BIO.Board Int Tile (Player,GUICell) -> IO ()
 244 clickHandling board = do
 245   state <- newEmptyMVar
 246   boardOnPress board
 247     (\iPos -> liftIO $ do
 248         postGUIAsync $ void $ tryPutMVar state iPos
 249         return True
 250     )
 251   boardOnRelease board
 252     (\fPos -> liftIO $ do
 253         postGUIAsync $ do
 254           mp <- boardGetPiece fPos board
 255           mstate <- tryTakeMVar state
 256           when (fPos `elem` validArea && isJust mp &&
 257                 maybe False (== fPos) mstate) $ do
 258             boardSetPiece fPos (BF.second rotateGUICell $
 259                                 fromJust mp) board
 260         return True
 261     )
 262
 263     {-
 264   boardOnPress board
 265     (\i -> do
 266         mp <- boardGetPiece i board
 267         when (i `elem` validArea && isJust mp && fromJust mp == Inert) $
 268 -}
 269
 270
 271 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 272 fileToPixbuf = mapM (\f -> let f' = "img/" ++ f in uncurry (liftM2 (,))
 273                       ( return f'
 274                       , pixbufNewFromFile f' >>=
 275                         \p -> pixbufScaleSimple p hexW hexW InterpBilinear ))
 276                (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
 277                 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
 278                        | d <- [N .. NW]])
 279
 280 actionToFile :: GUICell -> FilePath
 281 actionToFile GUICell { cellAction = a
 282                      , asPh = ph
 283                      } =
 284   case (a,ph) of
 285     (Inert,True) -> "img/hexOn.png"
 286     (Inert,False) -> "img/hexOff.png"
 287     (Absorb,_) -> "img/absorb.svg"
 288     (Stop _,_) -> "img/stop.svg"
 289     (ChDir True _ d,_) -> "img/start" ++ show d ++ ".svg"
 290     (ChDir False _ d,_) -> "img/ric" ++ show d ++ ".svg"
 291     (Split _,_) -> "img/split.svg"