path: root/src/Game/Map.hs

{-# OPTIONS_GHC -Wno-orphans #-}

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

import Control.Applicative ((<|>))
import Control.Monad
import Data.Maybe (fromMaybe)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Game.Entities.Types (Dir (..))
import qualified Game.Utils as U
import SDL (($=))
import qualified SDL
import Text.JSON
import Text.JSON.Types

frameDelay :: Int
frameDelay = 6

deadlyTileId :: Int
deadlyTileId = 29

data Tileset = Tileset
  { cols :: Int,
    width :: Int,
    height :: Int,
    firstGid :: Int,
    tilecount :: Int,
    tiles :: Vector Tile
  }
  deriving (Show)

data Layer
  = TileLayer
      {name :: String, tiles :: Vector Int}
  | ObjectLayer
      {name :: String, objects :: Vector 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,
    tilesets :: Vector Tileset,
    layers :: Vector Layer
  }
  deriving (Show)

newtype Frame = Frame Int deriving (Show)

data Tile = Tile
  {id :: Int, animation :: Vector Frame}
  deriving (Show)

instance JSON a => JSON (Vector a) where
  showJSON = undefined
  readJSON obj = fmap Vector.fromList (readJSON obj)

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 Frame where
  showJSON = undefined
  readJSON (JSObject obj) = do
    Frame <$> valFromObj "tileid" obj
  readJSON _ = mzero

instance JSON Tile where
  showJSON = undefined
  readJSON (JSObject obj) = do
    Tile
      <$> valFromObj "id" obj
      <*> valFromObj "animation" obj
  readJSON _ = mzero

instance JSON Tileset where
  showJSON = undefined
  readJSON (JSObject obj) = do
    Tileset
      <$> valFromObj "columns" obj
      <*> valFromObj "tilewidth" obj
      <*> valFromObj "tileheight" obj
      <*> valFromObj "firstgid" obj
      <*> valFromObj "tilecount" obj
      <*> (valFromObj "tiles" obj <|> pure Vector.empty)
  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 Vector.empty
  pure $ case Vector.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,
    tilesets :: Vector Tileset,
    tileLayers :: Vector (Vector Int),
    blocked :: Vector Int,
    objects :: Vector Object
  }
  deriving (Show)

data Viewport = Viewport Int Int Int Int

data MapState = MapState
  { delay :: Int,
    step :: Int
  }

data Map = Map MapData SDL.Texture MapState

-- | 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 = Vector.mapMaybe (filterTileLayer (\l -> l.name /= "Blocked")) s.layers
          blockedLayers = Vector.mapMaybe (filterTileLayer (\l -> l.name == "Blocked")) s.layers
      blockedLayer <- Vector.headM blockedLayers
      pure $
        Map
          MapData
            { width = s.width,
              height = s.height,
              tilesets = s.tilesets,
              tileLayers = tileLayers,
              blocked = blockedLayer,
              objects = join $ Vector.mapMaybe filterObjectLayer s.layers
            }
          tex
          (MapState 0 0)
    Error e -> error e
  where
    filterTileLayer :: (Layer -> Bool) -> Layer -> Maybe (Vector Int)
    filterTileLayer f l = case l of
      TileLayer _ tiles -> if f l then Just tiles else Nothing
      _ -> Nothing
    filterObjectLayer :: Layer -> Maybe (Vector 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 _ tilesets _ blocked _) _ _) x y =
  blocked Vector.! ((x `div` ts.width) + (y `div` ts.height) * mapWidth) >= ts.firstGid
  where
    ts = Vector.head tilesets

-- | Check for collision detection vs deadly tiles in "Blocked" TileLayer.
-- x and y in pixels.
isBlockedDeadly :: Map -> Int -> Int -> Bool
isBlockedDeadly (Map (MapData mapWidth _ tilesets _ blocked _) _ _) x y =
  blocked Vector.! ((x `div` ts.width) + (y `div` ts.height) * mapWidth) == deadlyTileId + ts.firstGid
  where
    ts = Vector.head tilesets

-- | Return the objects in a map.
objects :: Map -> [Object]
objects (Map md _ _) = Vector.toList md.objects

isPlayer :: Object -> Bool
isPlayer (PlayerEntity _ _) = True
isPlayer _ = False

-- | Return the number of batteries in a map.
totalBatteries :: Map -> Int
totalBatteries (Map md _ _) = Vector.length $ Vector.filter isBattery (md.objects)
  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
    tileset = Vector.head mapData.tilesets
    mapWidth = mapData.width * tileset.width
    mapHeight = mapData.height * 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 (MapState _ step)) (Viewport vx vy vw vh) = do
  Vector.mapM_
    ( \layer ->
        Vector.mapM_
          ( \(x, y) ->
              -- clipping because we draw one extra row/col because the scroll
              when (x >= 0 && y >= 0 && x < mapData.width && y < mapData.height) $
                renderTile x y (layer Vector.! (x + (y * mapData.width)))
          )
          index
    )
    mapData.tileLayers
  where
    tileset = Vector.head mapData.tilesets
    tileWidth = tileset.width
    tileHeight = tileset.height

    -- origin x, y in tiles
    ox = vx `div` tileWidth - 1
    oy = vy `div` tileHeight - 1

    -- viewport size in tiles
    drawWidth = 1 + vw `div` tileWidth
    drawHeight = 1 + vh `div` tileHeight

    -- we draw one extra row/col
    index = Vector.fromList [(x, y) | x <- [ox .. ox + drawWidth], y <- [oy .. oy + drawHeight]]

    -- XXX: performance of this?
    findTileset :: Int -> Maybe Tileset
    findTileset tile = Vector.find (\t -> t.firstGid + t.tilecount > tile && t.firstGid <= tile) mapData.tilesets

    findTile :: Tileset -> Int -> Int
    findTile ts tile = case Vector.find (\t -> t.id == tile - ts.firstGid) ts.tiles of
      Nothing -> tile - ts.firstGid
      Just (Tile _ frames) -> fmap (\(Frame i) -> i) frames Vector.! (step `mod` Vector.length frames)

    renderTile :: Int -> Int -> Int -> IO ()
    renderTile x y tile =
      case findTileset tile of
        Nothing -> pure ()
        Just ts -> do
          let tsTile = findTile ts tile
              tx = tsTile `rem` ts.cols
              ty = tsTile `div` ts.cols
              src = U.rect (tx * ts.width) (ty * ts.height) ts.width ts.height
              dst = U.rect (x * tileWidth) (y * tileHeight) ts.width ts.height
          SDL.copy renderer tex (Just src) (Just dst)

-- | Update the state of the map.
update :: Map -> Map
update (Map mapData texture state)
  | state.delay < frameDelay = Map mapData texture state {delay = state.delay + 1}
  | otherwise = Map mapData texture state {delay = 0, step = state.step + 1}