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 ctrlCoords :: [(Int,Int)]
  90 ctrlCoords = map (\(x,y,_,_) -> (x,y)) ctrlPieces
  91
  92 boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)]
  93 boardToPiece ph = (++ ctrlPieces) . map placePiece .
  94                   filter (onBoard . fst) . assocs
  95   where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell)
  96         placePiece ((x,y),(a,n)) = let c = GUICell { cellAction = a
  97                                                    , repeatCount = n
  98                                                    , asPh = (x,y) `elem` phPosS
  99                                                    }
 100                                        (x',y') = toGUICoords (x,y)
 101                                    in (x',y',Player,c)
 102         phPosS = map phPos ph
 103
 104 validArea :: [(Int,Int)]
 105 validArea = filter (onBoard . fromGUICoords) $
 106             map (\(x,y,_,_) -> (x,y)) $ boardToPiece [] $ makeBoard []
 107
 108 outGUIBoard :: (Int,Int) -> Bool
 109 outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax
 110
 111 na = NoteAttr {
 112           naArt = Accent13,
 113           naDur = 1 % 1,
 114           naOrn = Ornaments Nothing [] NoSlide
 115       }
 116
 117 initGUIBoard :: GUIBoard
 118 initGUIBoard = GUIBoard GameState
 119   { curPlayer'   = Player
 120   , boardPos     = boardToTile
 121   , boardPieces' = boardToPiece [] $ makeBoard []
 122   }
 123
 124 instance PlayableGame GUIBoard Int Tile Player GUICell where
 125   curPlayer _               = Player
 126   allPos (GUIBoard game)    = boardPos game
 127   allPieces (GUIBoard game) = boardPieces' game
 128   moveEnabled _             = True
 129   canMove (GUIBoard game) _ (x,y)
 130     | Just (_,p) <- getPieceAt game (x,y)
 131     , GUICell { cellAction = Inert } <- p = False
 132     | Nothing <- getPieceAt game (x,y) = False
 133     | otherwise = True
 134   canMoveTo _ _ _ fPos = fPos `elem` validArea
 135                          || outGUIBoard fPos
 136
 137   move guiBoard@(GUIBoard game) p iPos@(_,yi) fPos@(xf,yf)
 138     | iPos `elem` ctrlCoords = [ RemovePiece fPos'
 139                                , AddPiece fPos' Player
 140                                  (nCell { cellAction = ctrlAction }) ]
 141     | outGUIBoard fPos = [ RemovePiece iPos
 142                          , AddPiece iPos Player nCell ]
 143     | otherwise = [ MovePiece iPos fPos'
 144                   , AddPiece iPos Player nCell ]
 145     where fPos'
 146             |    (xf `mod` 2 == 0 && yf `mod` 2 == 0)
 147               || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
 148             | otherwise = (xf,yf+signum' (yf-yi))
 149           signum' x
 150             | x == 0 = 1
 151             | otherwise = signum x
 152           ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos
 153           nCell
 154             | Just (_,GUICell { asPh = ph, repeatCount = n }) <-
 155                 getPieceAt game iPos = inertCell { repeatCount = n
 156                                                  , asPh = ph
 157                                                  }
 158             | otherwise = inertCell
 159             where inertCell = GUICell { cellAction = Inert
 160                                       , repeatCount = 1
 161                                       , asPh = False}
 162
 163   applyChange (GUIBoard game) (AddPiece pos@(x,y) Player piece) =
 164     GUIBoard $ game { boardPieces' = bp' }
 165     where bp' = (x,y,Player,piece):boardPieces' game
 166
 167   applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
 168     game { boardPieces' = bp' }
 169     where bp' = [p | p@(x',y',_,_) <- boardPieces' game
 170                    , x /= x' || y /= y']
 171
 172   applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
 173     | Just (_,p) <- getPieceAt game iPos
 174     = applyChanges guiBoard [ RemovePiece iPos
 175                             , RemovePiece fPos
 176                             , AddPiece fPos Player p]
 177     | otherwise = guiBoard
 178
 179 initGame :: IO (Game GUIBoard Int Tile Player GUICell)
 180 initGame = do
 181   pixbufs <- fileToPixbuf
 182   tilePixbuf <- pixbufNew ColorspaceRgb False 8 tileW tileH
 183   pixbufFill tilePixbuf 50 50 50 0
 184   let pixPiece :: (Player,GUICell) -> Pixbuf
 185       pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs
 186       pixTile :: Tile -> Pixbuf
 187       pixTile _ = tilePixbuf
 188       visualA = VisualGameAspects { tileF = pixTile
 189                                   , pieceF = pixPiece
 190                                   , bgColor = (1000,1000,1000)
 191                                   , bg = Nothing
 192                                   }
 193
 194   return $ Game visualA initGUIBoard
 195
 196 -- Initializes a readable RV for the board and an readable-writable RV
 197 -- for the playheads. Also installs some handlers for pieces modification.
 198 initBoardRV :: BIO.Board Int Tile (Player,GUICell)
 199             -> IO ( ReactiveFieldRead IO Board
 200                   , ReactiveFieldReadWrite IO [PlayHead])
 201 initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
 202   -- RV creation
 203   phMVar <- newCBMVar []
 204   notBMVar <- mkClockRV 100
 205   let getterB :: IO Board
 206       getterB = do
 207         (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs array
 208         let board = makeBoard $
 209               map (BF.first fromGUICoords .
 210                    BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
 211                               fromJust)) $
 212               filter (isJust . snd) boardArray
 213         return board
 214
 215       notifierB :: IO () -> IO ()
 216       notifierB = reactiveValueOnCanRead notBMVar
 217
 218       getterP :: IO [PlayHead]
 219       getterP = readCBMVar phMVar
 220
 221       setterP :: [PlayHead] -> IO ()
 222       setterP lph = do
 223         oph <- readCBMVar phMVar
 224         let phPosS = map phPos lph
 225             offPh :: PlayHead -> IO ()
 226             offPh 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 = False }) board
 232             onPh :: PlayHead -> IO ()
 233             onPh ph =  do
 234               let pos = toGUICoords $ phPos ph
 235               piece <- boardGetPiece pos board
 236               when (isJust piece) $ do
 237                 let (_,c) = fromJust piece
 238                 boardSetPiece pos (Player, c { asPh = True }) board
 239         postGUIAsync $ mapM_ offPh oph
 240         postGUIAsync $ mapM_ onPh lph
 241         writeCBMVar phMVar lph
 242
 243       notifierP :: IO () -> IO ()
 244       notifierP = installCallbackCBMVar phMVar
 245
 246       b = ReactiveFieldRead getterB notifierB
 247       ph = ReactiveFieldReadWrite setterP getterP notifierP
 248   return (b,ph)
 249
 250 clickHandling :: BIO.Board Int Tile (Player,GUICell) -> IO ()
 251 clickHandling board = do
 252   state <- newEmptyMVar
 253   boardOnPress board
 254     (\iPos -> liftIO $ do
 255         postGUIAsync $ void $ tryPutMVar state iPos
 256         return True
 257     )
 258   boardOnRelease board
 259     (\fPos -> liftIO $ do
 260         postGUIAsync $ do
 261           mp <- boardGetPiece fPos board
 262           mstate <- tryTakeMVar state
 263           when (fPos `elem` validArea && isJust mp &&
 264                 maybe False (== fPos) mstate) $ do
 265             boardSetPiece fPos (BF.second rotateGUICell $
 266                                 fromJust mp) board
 267         return True
 268     )
 269
 270     {-
 271   boardOnPress board
 272     (\i -> do
 273         mp <- boardGetPiece i board
 274         when (i `elem` validArea && isJust mp && fromJust mp == Inert) $
 275 -}
 276
 277
 278 fileToPixbuf :: IO [(FilePath,Pixbuf)]
 279 fileToPixbuf = mapM (\f -> let f' = "img/" ++ f in uncurry (liftM2 (,))
 280                       ( return f'
 281                       , pixbufNewFromFile f' >>=
 282                         \p -> pixbufScaleSimple p hexW hexW InterpBilinear ))
 283                (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++
 284                 concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
 285                        | d <- [N .. NW]])
 286
 287 actionToFile :: GUICell -> FilePath
 288 actionToFile GUICell { cellAction = a
 289                      , asPh = ph
 290                      } =
 291   case (a,ph) of
 292     (Inert,True) -> "img/hexOn.png"
 293     (Inert,False) -> "img/hexOff.png"
 294     (Absorb,_) -> "img/absorb.svg"
 295     (Stop _,_) -> "img/stop.svg"
 296     (ChDir True _ d,_) -> "img/start" ++ show d ++ ".svg"
 297     (ChDir False _ d,_) -> "img/ric" ++ show d ++ ".svg"
 298     (Split _,_) -> "img/split.svg"