module Game.Map ( Map (..), Object (..), objects, totalBatteries, load, render, isBlocked, isPlayer, Viewport (..), viewport, ) where import Control.Monad import Data.Maybe (fromMaybe, mapMaybe) import qualified Game.Utils as U import SDL (($=)) import qualified SDL import Text.JSON import Text.JSON.Types data Tileset = Tileset { cols :: Int, width :: Int, height :: Int, firstGid :: Int } deriving (Show) data Layer = TileLayer {name :: String, tiles :: [Int]} | ObjectLayer {name :: String, objects :: [Object]} deriving (Show) -- | The object types in the map. data Object = PlayerEntity Int Int | BatteryEntity Int Int | SlimeEntity Int Int | RobotEntity Int Int deriving (Show, Eq, Ord) data JsonMapData = JsonMapData { width :: Int, height :: Int, tileset :: Tileset, layers :: [Layer] } deriving (Show) instance JSON Tileset where showJSON = undefined readJSON (JSArray [JSObject obj]) = do Tileset <$> valFromObj "columns" obj <*> valFromObj "tilewidth" obj <*> valFromObj "tileheight" obj <*> valFromObj "firstgid" obj readJSON _ = mzero instance JSON Layer where showJSON = undefined readJSON (JSObject obj) = case get_field obj "type" of Just "tilelayer" -> TileLayer <$> valFromObj "name" obj <*> valFromObj "data" obj Just "objectgroup" -> ObjectLayer <$> valFromObj "name" obj <*> valFromObj "objects" obj _ -> Error "unsupported layer type" readJSON _ = mzero instance JSON Object where showJSON = undefined readJSON (JSObject obj) = case get_field obj "name" of Just "Player" -> PlayerEntity <$> valFromObj "x" obj <*> valFromObj "y" obj Just "Battery" -> BatteryEntity <$> valFromObj "x" obj <*> valFromObj "y" obj Just "Slime" -> SlimeEntity <$> valFromObj "x" obj <*> valFromObj "y" obj Just "Robot" -> RobotEntity <$> valFromObj "x" obj <*> valFromObj "y" obj Just (JSString (JSONString s)) -> Error $ "unsupported entity " ++ show s e -> Error $ "unsupported entity in " ++ show e readJSON _ = mzero instance JSON JsonMapData where showJSON = undefined readJSON (JSObject obj) = JsonMapData <$> valFromObj "width" obj <*> valFromObj "height" obj <*> valFromObj "tilesets" obj <*> valFromObj "layers" obj readJSON _ = mzero data MapData = MapData { width :: Int, height :: Int, tileset :: Tileset, tileLayers :: [[Int]], blocked :: [Int], objects :: [Object] } deriving (Show) data Viewport = Viewport Int Int Int Int data Map = Map MapData SDL.Texture -- | Loads a map from a JSON file. load :: String -> SDL.Texture -> IO Map load filename tex = do d <- readFile filename case decode d :: Result JsonMapData of Ok s -> do let tileLayers = mapMaybe (filterTileLayer (\l -> l.name /= "Blocked")) s.layers blockedLayers = mapMaybe (filterTileLayer (\l -> l.name == "Blocked")) s.layers blockedLayer <- case blockedLayers of [l] -> pure l xs -> error $ "A single \"Blocked\" layer expected, " ++ show (length xs) ++ " found" pure $ Map MapData { width = s.width, height = s.height, tileset = s.tileset, tileLayers = tileLayers, blocked = blockedLayer, objects = concat $ mapMaybe filterObjectLayer s.layers } tex Error e -> error e where filterTileLayer :: (Layer -> Bool) -> Layer -> Maybe [Int] filterTileLayer f l = case l of TileLayer _ tiles -> if f l then Just tiles else Nothing _ -> Nothing filterObjectLayer :: Layer -> Maybe [Object] filterObjectLayer l = case l of ObjectLayer _ objs -> Just objs _ -> Nothing -- | Check for collision detection vs "Blocked" TileLayer. -- x and y in pixels. isBlocked :: Map -> Int -> Int -> Bool isBlocked (Map (MapData mapWidth _ ts _ blocked _) _) x y = blocked !! ((x `div` ts.width) + (y `div` ts.height) * mapWidth) >= ts.firstGid -- | Return the objects in a map. objects :: Map -> [Object] objects (Map md _) = md.objects isPlayer :: Object -> Bool isPlayer (PlayerEntity _ _) = True isPlayer _ = False -- | Return the number of batteries in a map. totalBatteries :: Map -> Int totalBatteries m = length $ filter isBattery (objects m) where isBattery :: Object -> Bool isBattery (BatteryEntity _ _) = True isBattery _ = False -- | Set the SDL viewport based on the map and the provided viewport coordinates. -- It returns the viewport to be used by render. -- Optionally an offset can be provided. viewport :: SDL.Renderer -> Map -> Int -> Int -> Int -> Int -> Maybe (Int, Int) -> IO Viewport viewport renderer (Map mapData _) vx vy vw vh offs = do SDL.rendererViewport renderer $= Just mapRect pure $ Viewport newx newy vw vh where mapWidth = mapData.width * mapData.tileset.width mapHeight = mapData.height * mapData.tileset.height halfViewportWidth = vw `div` 2 halfViewportHeight = vh `div` 2 -- the coords are the center focus fx = max (vx - halfViewportWidth) 0 fy = max (vy - halfViewportHeight) 0 newx = min (if fx + halfViewportWidth > mapWidth then mapWidth - vw else fx) (mapWidth - vw) newy = min (if fy + halfViewportHeight > mapHeight then mapHeight - vh else fy) (mapHeight - vh) (offsx, offsy) = fromMaybe (0, 0) offs mapRect = U.rect (offsx - newx) (offsy - newy) (newx + vw) (newy + vh) -- | Render a map. -- Requires a Viewport from viewport. render :: SDL.Renderer -> Map -> Viewport -> IO () render renderer (Map mapData tex) (Viewport vx vy vw vh) = do mapM_ ( \layer -> mapM_ ( \(x, y) -> -- clipping because we draw one extra row/col because the scroll when (x < mapData.width && y < mapData.height) $ renderTile x y (layer !! (x + (y * mapData.width))) ) index ) mapData.tileLayers where tileWidth = mapData.tileset.width tileHeight = mapData.tileset.height -- origin x, y in tiles ox = vx `div` tileWidth oy = vy `div` tileHeight -- viewport size in tiles drawWidth = vw `div` tileWidth drawHeight = vh `div` tileHeight -- we draw one extra row/col index = [(x, y) | x <- [ox .. ox + drawWidth], y <- [oy .. oy + drawHeight]] columns = mapData.tileset.cols firstgid = mapData.tileset.firstGid renderTile :: Int -> Int -> Int -> IO () renderTile x y tile | tile < firstgid = pure () | otherwise = do let tx = (tile - firstgid) `rem` columns ty = (tile - firstgid) `div` columns src = U.rect (tx * tileWidth) (ty * tileHeight) tileWidth tileHeight dst = U.rect (x * tileWidth) (y * tileHeight) tileWidth tileHeight SDL.copy renderer tex (Just src) (Just dst)