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