path: root/src/Game/Map.hs

module Game.Map
  ( Map (..),
    Object (..),
    objects,
    totalBatteries,
    loadMapList,
    load,
    render,
    isBlocked,
    isPlayer,
    Viewport (..),
    viewport,
  )
where

import Control.Applicative ((<|>))
import Control.Monad
import Data.List (find)
import Data.Maybe (fromMaybe, mapMaybe)
import Game.Entities.Types (Dir (..))
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)

data PropertyValue = PropertyValueBool Bool | PropertyValueInt Int | PropertyValueString String

data Property = Property String PropertyValue

-- | The object types in the map.
data Object
  = PlayerEntity Int Int
  | BatteryEntity Int Int
  | SlimeEntity Int Int Dir
  | RobotEntity Int Int Dir
  | ShooterEntity Int Int Dir
  | RunnerEntity Int Int Dir
  | TrackerEntity Int Int Dir
  deriving (Show, Eq, Ord)

data JsonMapData = JsonMapData
  { width :: Int,
    height :: Int,
    tileset :: Tileset,
    layers :: [Layer]
  }
  deriving (Show)

instance JSON Property where
  showJSON = undefined
  readJSON (JSObject obj) = do
    Property
      <$> valFromObj "name" obj
      <*> case get_field obj "type" of
        Just "bool" -> PropertyValueBool <$> valFromObj "value" obj
        Just "int" -> PropertyValueInt <$> valFromObj "value" obj
        Just "string" -> PropertyValueString <$> valFromObj "value" obj
        _ -> Error "unsupported property value type"
  readJSON _ = mzero

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

-- Gets the "flip" custom property; if present and set, the entity will face left.
-- Only takes into account the first "flip" property found.
getPropertyDir :: JSObject JSValue -> Result Dir
getPropertyDir obj = do
  props <- valFromObj "properties" obj <|> pure []
  pure $ case find flipProp props of
    Just _ -> DirLeft
    Nothing -> DirRight
  where
    flipProp :: Property -> Bool
    flipProp (Property "flip" (PropertyValueBool True)) = True
    flipProp _ = False

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 <*> getPropertyDir obj
      Just "Robot" ->
        RobotEntity <$> valFromObj "x" obj <*> valFromObj "y" obj <*> getPropertyDir obj
      Just "Shooter" ->
        ShooterEntity <$> valFromObj "x" obj <*> valFromObj "y" obj <*> getPropertyDir obj
      Just "Runner" ->
        RunnerEntity <$> valFromObj "x" obj <*> valFromObj "y" obj <*> getPropertyDir obj
      Just "Tracker" ->
        TrackerEntity <$> valFromObj "x" obj <*> valFromObj "y" obj <*> getPropertyDir 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 list of maps from JSON file.
loadMapList :: String -> IO [String]
loadMapList filename = do
  d <- readFile filename
  case decode d :: Result [String] of
    Ok s -> pure s
    Error e -> error e

-- | 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)