From 2103dc0dcf42fd2489d5f9e4fec46146f7cc9db5 Mon Sep 17 00:00:00 2001
From: "Juan J. Martinez" <jjm@usebox.net>
Date: Sat, 4 Feb 2023 21:20:12 +0000
Subject: Initial import

---
 src/Game/Controller.hs |  32 ++++++++++++
 src/Game/Entities.hs   | 139 +++++++++++++++++++++++++++++++++++++++++++++++++
 src/Game/Map.hs        | 120 ++++++++++++++++++++++++++++++++++++++++++
 src/Game/Sprites.hs    |  88 +++++++++++++++++++++++++++++++
 src/Game/Utils.hs      |  19 +++++++
 5 files changed, 398 insertions(+)
 create mode 100644 src/Game/Controller.hs
 create mode 100644 src/Game/Entities.hs
 create mode 100644 src/Game/Map.hs
 create mode 100644 src/Game/Sprites.hs
 create mode 100644 src/Game/Utils.hs

(limited to 'src/Game')

diff --git a/src/Game/Controller.hs b/src/Game/Controller.hs
new file mode 100644
index 0000000..3ec7e4c
--- /dev/null
+++ b/src/Game/Controller.hs
@@ -0,0 +1,32 @@
+module Game.Controller (Controls (..), init, update) where
+
+import Data.Maybe (fromMaybe)
+import Game.Utils (isPressed)
+import qualified SDL
+import Prelude hiding (init)
+
+data Controls = Controls
+  { cUp :: Bool,
+    cDown :: Bool,
+    cLeft :: Bool,
+    cRight :: Bool,
+    cA :: Bool,
+    cB :: Bool,
+    cMenu :: Bool
+  }
+  deriving (Show)
+
+init :: Controls
+init = Controls False False False False False False False
+
+update :: [SDL.EventPayload] -> Controls -> Controls
+update events controls =
+  controls
+    { cUp = fromMaybe (cUp controls) $ isPressed SDL.KeycodeUp events,
+      cDown = fromMaybe (cDown controls) $ isPressed SDL.KeycodeDown events,
+      cLeft = fromMaybe (cLeft controls) $ isPressed SDL.KeycodeLeft events,
+      cRight = fromMaybe (cRight controls) $ isPressed SDL.KeycodeRight events,
+      cA = fromMaybe (cA controls) $ isPressed SDL.KeycodeZ events,
+      cB = fromMaybe (cB controls) $ isPressed SDL.KeycodeX events,
+      cMenu = fromMaybe (cMenu controls) $ isPressed SDL.KeycodeReturn events
+    }
diff --git a/src/Game/Entities.hs b/src/Game/Entities.hs
new file mode 100644
index 0000000..0d37632
--- /dev/null
+++ b/src/Game/Entities.hs
@@ -0,0 +1,139 @@
+module Game.Entities (Entity (..), toSpriteSet, mkPlayer, render) where
+
+import Data.IORef
+import qualified Game.Controller as C
+import qualified Game.Sprites as S
+import qualified SDL
+
+data Dir = DirRight | DirLeft deriving (Eq)
+
+data Type = TypePlayer -- \| TypeEnemy | TypeItem
+
+toSpriteSet :: Dir -> Int
+toSpriteSet DirRight = 0
+toSpriteSet DirLeft = 1
+
+frameDelay :: Int
+frameDelay = 6
+
+jumpFrame :: Int
+jumpFrame = 3
+
+gravityOff :: Int
+gravityOff = -1
+
+gravityUp :: Int
+gravityUp = 0
+
+gravityDown :: Int
+gravityDown = 16
+
+gravityTable :: [Int]
+gravityTable = [0, 6, 4, 4, 2, 2, 2, 2, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3]
+
+data Entity = Entity
+  { eType :: Type,
+    eX :: Int,
+    eY :: Int,
+    eDelay :: Int,
+    eFrame :: Int,
+    eFrameLimit :: Int,
+    eGravity :: Int,
+    eDir :: Dir,
+    eSprite :: S.Sprite,
+    eUpdate :: Entity -> IO Entity,
+    eBlocked :: Int -> Int -> Bool,
+    eDestroy :: Bool
+  }
+
+mkPlayer :: S.SpriteSheet -> Int -> Int -> IORef C.Controls -> (Int -> Int -> Bool) -> IO Entity
+mkPlayer sprites x y controls isBlocked = do
+  s <- S.get sprites "player"
+  pure $ Entity TypePlayer x y 0 0 3 gravityOff DirRight s (updatePlayer controls) isBlocked False
+
+updateFrame :: Bool -> Entity -> Entity
+updateFrame updated e
+  | isGravityOn = e
+  | delay > 0 = e {eDelay = delay - 1}
+  | frame < eFrameLimit e = e {eDelay = frameDelay, eFrame = if updated then frame + 1 else 0}
+  | otherwise = e {eDelay = frameDelay, eFrame = 0}
+  where
+    isGravityOn = eGravity e > gravityOff
+    frame = eFrame e
+    delay = eDelay e
+
+updateHorizontal :: Bool -> Bool -> Entity -> Entity
+updateHorizontal left right e
+  -- prevent pressing both directions (keyboard)
+  | left && right = e
+  -- change direction first
+  | left && eDir e /= DirLeft = e {eDir = DirLeft, eDelay = 0}
+  | right && eDir e /= DirRight = e {eDir = DirRight, eDelay = 0}
+  | left && isGoingDown = if isBlocked (x - 1) (y + 23) then e else e {eX = x - 1}
+  | left && not isGoingDown = if isBlocked (x - 1) (y + 23) && isBlocked (x - 1) (y + 17) then e else e {eX = x - 1}
+  | right && isGoingDown = if isBlocked (x + 17) (y + 23) then e else e {eX = x + 1}
+  | right && not isGoingDown = if isBlocked (x + 17) (y + 23) && isBlocked (x + 17) (y + 17) then e else e {eX = x + 1}
+  | otherwise = e
+  where
+    x = eX e
+    y = eY e
+    isBlocked = eBlocked e
+    gravity = eGravity e
+    isGoingDown = gravity == gravityOff || gravity >= gravityDown
+
+updateVertical :: Bool -> Entity -> Entity
+updateVertical jump e
+  | jump && gravity == gravityOff = e {eGravity = gravityUp, eFrame = jumpFrame}
+  | otherwise = e
+  where
+    gravity = eGravity e
+
+applyGravity :: Int -> Entity -> Entity
+applyGravity v e
+  | v == 0 = e
+  -- hit the floor
+  | isGoingDown
+      && (isBlocked (x + 2) (y + 24) || isBlocked (x + 12) (y + 24))
+      && not (isBlocked (x + 2) (y + 23))
+      && not (isBlocked (x + 12) (y + 23)) =
+      e {eGravity = gravityOff, eDelay = 0, eFrame = 0}
+  | otherwise = applyGravity (v - 1) e {eY = y + change}
+  where
+    gravity = eGravity e
+    isGoingDown = gravity >= gravityDown
+    change = if isGoingDown then 1 else -1
+    x = eX e
+    y = eY e
+    isBlocked = eBlocked e
+
+updateGravity :: Entity -> Entity
+updateGravity e
+  | current > gravityOff = applyGravity (gravityTable !! current) e {eGravity = new}
+  | not (isBlocked (x + 2) (y + 24) || isBlocked (x + 12) (y + 24)) = e {eGravity = gravityDown, eFrame = jumpFrame}
+  | otherwise = e
+  where
+    current = eGravity e
+    new = if current > gravityOff && current < length gravityTable - 1 then current + 1 else current
+    x = eX e
+    y = eY e
+    isBlocked = eBlocked e
+
+updatePlayer :: IORef C.Controls -> Entity -> IO Entity
+updatePlayer controls e = do
+  ctl <- readIORef controls
+  pure $
+    updateGravity $
+      updateVertical (C.cA ctl) $
+        updateHorizontal (C.cLeft ctl) (C.cRight ctl) $
+          -- left or right, but not both (keyboard)
+          updateFrame ((C.cLeft ctl || C.cRight ctl) && (C.cLeft ctl /= C.cRight ctl)) e
+
+render :: SDL.Renderer -> Entity -> IO ()
+render renderer ent =
+  S.render renderer sp x y set frame
+  where
+    sp = eSprite ent
+    x = eX ent
+    y = eY ent
+    set = toSpriteSet $ eDir ent
+    frame = eFrame ent
diff --git a/src/Game/Map.hs b/src/Game/Map.hs
new file mode 100644
index 0000000..7866f97
--- /dev/null
+++ b/src/Game/Map.hs
@@ -0,0 +1,120 @@
+module Game.Map
+  ( Map,
+    load,
+    render,
+    isBlocked,
+  )
+where
+
+import Control.Monad
+import qualified Game.Utils as U
+import qualified SDL
+import Text.JSON
+import Text.JSON.Types
+
+data Tileset = Tileset
+  { tsCols :: Int,
+    tsWidth :: Int,
+    tsHeight :: Int,
+    tsFirstGid :: Int
+  }
+  deriving (Show)
+
+data TileLayer = TileLayer
+  { tlName :: String,
+    tlTiles :: [Int]
+  }
+  deriving (Show)
+
+data MapData = MapData
+  { mWidth :: Int,
+    mHeight :: Int,
+    mTileset :: Tileset,
+    mLayers :: [TileLayer]
+  }
+  deriving (Show)
+
+data Map = Map MapData SDL.Texture
+
+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 TileLayer where
+  showJSON = undefined
+  readJSON (JSObject obj) =
+    case get_field obj "type" of
+      Just "tilelayer" ->
+        TileLayer
+          <$> valFromObj "name" obj
+          <*> valFromObj "data" obj
+      _ -> Error "unsupported layer type"
+  readJSON _ = mzero
+
+instance JSON MapData where
+  showJSON = undefined
+  readJSON (JSObject obj) =
+    MapData
+      <$> valFromObj "width" obj
+      <*> valFromObj "height" obj
+      <*> valFromObj "tilesets" obj
+      <*> valFromObj "layers" obj
+  readJSON _ = mzero
+
+-- | Loads a map from a JSON file.
+load :: String -> SDL.Texture -> IO Map
+load filename tex = do
+  d <- readFile filename
+  case decode d :: Result MapData of
+    Ok s -> pure $ Map s tex
+    Error e -> error e
+
+-- | Check for collision detection vs "Blocked" TileLayer that MUST be last layer.
+--   x and y in pixels.
+isBlocked :: Map -> Int -> Int -> Bool
+isBlocked (Map (MapData width _ ts layers) _) x y =
+  tiles !! ((x `div` tw) + (y `div` th) * width) >= firstgid
+  where
+    tiles = tlTiles (last layers)
+    tw = tsWidth ts
+    th = tsHeight ts
+    firstgid = tsFirstGid ts
+
+-- | Renders a map.
+render :: SDL.Renderer -> Map -> IO ()
+render renderer (Map mapData tex) = do
+  mapM_
+    ( \layer ->
+        mapM_
+          ( \(x, y) ->
+              renderTile x y $ tlTiles layer !! (x + (y * mWidth mapData))
+          )
+          index
+    )
+    (init $ mLayers mapData)
+  where
+    mw = mWidth mapData
+    mh = mHeight mapData
+    index = [(x, y) | x <- [0 .. mw - 1], y <- [0 .. mh - 1]]
+
+    ts = mTileset mapData
+    firstgid = tsFirstGid ts
+    cols = tsCols ts
+    tileWidth = tsWidth ts
+    tileHeight = tsHeight ts
+
+    renderTile :: Int -> Int -> Int -> IO ()
+    renderTile x y tile
+      | tile < firstgid = pure ()
+      | otherwise = do
+          let tx = (tile - firstgid) `rem` cols
+              ty = (tile - firstgid) `div` cols
+              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)
diff --git a/src/Game/Sprites.hs b/src/Game/Sprites.hs
new file mode 100644
index 0000000..de949b5
--- /dev/null
+++ b/src/Game/Sprites.hs
@@ -0,0 +1,88 @@
+module Game.Sprites
+  ( SpriteSheet,
+    Sprite,
+    load,
+    get,
+    render,
+  )
+where
+
+import Control.Monad
+import Data.List (find)
+import Foreign.C.Types (CInt)
+import qualified Game.Utils as U
+import qualified SDL
+import SDL.Vect (V2 (..))
+import Text.JSON
+
+-- | Sprite sheet contains description of the different sprites.
+--
+-- Load a sprite sheet from JSON with `load`.
+-- Use `get` to get a specific sprite.
+data SpriteSheet = SpriteSheet Sprites SDL.Texture
+
+-- | A sprite description that can be rendered.
+--
+-- Can be rendered with `render`.
+data Sprite = Sprite [[SDL.Rectangle CInt]] SDL.Texture
+
+newtype SpriteData = SpriteData [[SDL.Rectangle CInt]] deriving (Show)
+
+newtype Sprites = Sprites [(String, SpriteData)] deriving (Show)
+
+data Frame = Frame Int Int Int Int deriving (Show)
+
+setsToRects :: [Frame] -> [Int] -> [SDL.Rectangle CInt]
+setsToRects frames =
+  map
+    ( \s -> do
+        case frames !! s of
+          Frame x y w h -> U.rect x y w h
+    )
+
+instance JSON Frame where
+  showJSON = undefined
+  readJSON (JSObject obj) = do
+    Frame
+      <$> valFromObj "x" obj
+      <*> valFromObj "y" obj
+      <*> valFromObj "width" obj
+      <*> valFromObj "height" obj
+  readJSON _ = mzero
+
+instance JSON SpriteData where
+  showJSON = undefined
+  readJSON (JSObject obj) = do
+    frames <- valFromObj "frames" obj
+    sets <- valFromObj "sets" obj
+    Ok $ SpriteData $ map (setsToRects frames) sets
+  readJSON _ = mzero
+
+instance JSON Sprites where
+  showJSON = undefined
+  readJSON obj =
+    Sprites
+      <$> decJSDict "sprites" obj
+
+-- | Loads a spritesheet described on a JSON file.
+load :: String -> SDL.Texture -> IO SpriteSheet
+load filename tex = do
+  d <- readFile filename
+  case decode d :: Result Sprites of
+    Ok s -> pure $ SpriteSheet s tex
+    Error e -> error e
+
+-- | Gets a named sprite from the spritesheet.
+get :: SpriteSheet -> String -> IO Sprite
+get (SpriteSheet (Sprites sprites) tex) sid =
+  case fmap snd (find (\(name, _) -> name == sid) sprites) of
+    Nothing -> error $ "sprite '" ++ sid ++ "' not found"
+    Just (SpriteData frames) -> pure $ Sprite frames tex
+
+-- | Renders a sprite on position (x, y) selecting a set and a frame within that set.
+render :: SDL.Renderer -> Sprite -> Int -> Int -> Int -> Int -> IO ()
+render renderer (Sprite frames tex) x y set frame = do
+  let src = (frames !! set) !! frame
+      dst = case src of
+        SDL.Rectangle _ (V2 w h) -> U.rect x y (fromIntegral w) (fromIntegral h)
+  SDL.copy renderer tex (Just src) (Just dst)
diff --git a/src/Game/Utils.hs b/src/Game/Utils.hs
new file mode 100644
index 0000000..acfab6f
--- /dev/null
+++ b/src/Game/Utils.hs
@@ -0,0 +1,19 @@
+module Game.Utils (rect, isPressed) where
+
+import Foreign.C.Types (CInt)
+import qualified SDL
+import SDL.Vect (V2 (..))
+
+rect :: Int -> Int -> Int -> Int -> SDL.Rectangle CInt
+rect x y w h = SDL.Rectangle (SDL.P $ V2 (fromIntegral x) (fromIntegral y)) (V2 (fromIntegral w) (fromIntegral h))
+
+isPressed :: SDL.Keycode -> [SDL.EventPayload] -> Maybe Bool
+isPressed code events
+  -- TODO: gamepad support
+  | any (isEventKey SDL.Pressed code) events = Just True
+  | any (isEventKey SDL.Released code) events = Just False
+  | otherwise = Nothing
+  where
+    isEventKey :: SDL.InputMotion -> SDL.Keycode -> SDL.EventPayload -> Bool
+    isEventKey expected keycode (SDL.KeyboardEvent (SDL.KeyboardEventData _ motion False ksym)) = expected == motion && SDL.keysymKeycode ksym == keycode
+    isEventKey _ _ _ = False
-- 
cgit v1.2.3