Initial import

6 files changed, 541 insertions, 0 deletions

diff --git a/src/Game.hs b/src/Game.hs
new file mode 100644
index 0000000..0d5ae45
--- /dev/null
+++ b/src/Game.hs
@@ -0,0 +1,143 @@
+module Game (main) where
+
+import Control.Monad.Reader
+import Data.IORef
+import Data.Maybe (fromMaybe)
+import Data.Text (pack)
+import Foreign.C.Types (CInt)
+import qualified Game.Controller as C
+import qualified Game.Entities as E
+import qualified Game.Map as M
+import qualified Game.Sprites as S
+import Game.Utils (isPressed)
+import SDL (($=), ($~))
+import qualified SDL
+import qualified SDL.Image
+import SDL.Vect (V2 (..))
+
+name :: String
+name = "Haskell gamedev [Space Platformer]"
+
+gameWidth, gameHeight :: CInt
+(gameWidth, gameHeight) = (320, 180)
+
+gameScale :: CInt
+gameScale = 3
+
+windowWidth, windowHeight :: CInt
+(windowWidth, windowHeight) = (gameWidth * gameScale, gameHeight * gameScale)
+
+version :: String
+version = "0.1.0"
+
+data Env = Env
+  { _window :: SDL.Window,
+    _renderer :: SDL.Renderer,
+    _canvas :: SDL.Texture,
+    _fullscreen :: IORef Bool,
+    _renderRect :: IORef (SDL.Rectangle CInt),
+    _controls :: IORef C.Controls,
+    _map :: M.Map,
+    _sprites :: S.SpriteSheet,
+    _entities :: IORef [E.Entity]
+  }
+
+defaultRenderRect :: SDL.Rectangle CInt
+defaultRenderRect = SDL.Rectangle (SDL.P $ V2 0 0) (V2 windowWidth windowHeight)
+
+main :: IO ()
+main = do
+  SDL.initialize [SDL.InitVideo]
+  window <-
+    SDL.createWindow
+      (pack $ name ++ " " ++ version)
+      SDL.defaultWindow {SDL.windowInitialSize = SDL.V2 windowWidth windowHeight}
+  renderer <-
+    SDL.createRenderer
+      window
+      (-1)
+      SDL.RendererConfig
+        { SDL.rendererType = SDL.AcceleratedVSyncRenderer,
+          SDL.rendererTargetTexture = True
+        }
+  SDL.HintRenderScaleQuality $= SDL.ScaleNearest
+  canvas <- SDL.createTexture renderer SDL.RGBA8888 SDL.TextureAccessTarget (V2 gameWidth gameHeight)
+  fullscreen <- newIORef False
+  renderRect <- newIORef defaultRenderRect
+  tsTexture <- SDL.Image.loadTexture renderer "data/tiles.png"
+  ssTexture <- SDL.Image.loadTexture renderer "data/sprites.png"
+  controls <- newIORef C.init
+  map' <- M.load "data/map.json" tsTexture
+  sprites <- S.load "data/sprites.json" ssTexture
+  entities <- newIORef ([] :: [E.Entity])
+  player <- E.mkPlayer sprites 32 104 controls (M.isBlocked map')
+  entities $~ (player :)
+  runReaderT gameLoop (Env window renderer canvas fullscreen renderRect controls map' sprites entities)
+  SDL.destroyWindow window
+  SDL.quit
+
+toggleFullscreen :: ReaderT Env IO ()
+toggleFullscreen = do
+  env <- ask
+  let fullscreen = _fullscreen env
+      renderRect = _renderRect env
+      renderer = _renderer env
+      window = _window env
+  fullscreen $~ not
+  fs <- SDL.get fullscreen
+  let mode = if fs then SDL.FullscreenDesktop else SDL.Windowed
+   in SDL.setWindowMode window mode
+
+  vp <- if fs then SDL.get $ SDL.rendererViewport renderer else pure Nothing
+  let newRenderRect = case vp of
+        Nothing -> defaultRenderRect
+        Just (SDL.Rectangle _ (V2 w h)) ->
+          SDL.Rectangle (SDL.P $ V2 rx ry) (V2 rw rh)
+          where
+            scale = min (w `div` gameWidth) (h `div` gameHeight)
+            rx = (w - (gameWidth * scale)) `div` 2
+            ry = (h - (gameHeight * scale)) `div` 2
+            rw = gameWidth * scale
+            rh = gameHeight * scale
+   in renderRect $= newRenderRect
+
+gameLoop :: ReaderT Env IO ()
+gameLoop = do
+  env <- ask
+  let renderer = _renderer env
+      canvas = _canvas env
+      renderRect = _renderRect env
+      controls = _controls env
+      map' = _map env
+      entities = _entities env
+
+  events <- map SDL.eventPayload <$> SDL.pollEvents
+
+  -- F11 for fullscreen / windowed
+  when (fromMaybe False $ isPressed SDL.KeycodeF11 events) toggleFullscreen
+
+  -- ESC or close the window to quit
+  let quit = fromMaybe False (isPressed SDL.KeycodeEscape events) || SDL.QuitEvent `elem` events
+  unless quit $ do
+    -- update controls
+    controls $~ C.update events
+
+    SDL.rendererRenderTarget renderer $= Just canvas
+    SDL.clear renderer
+
+    -- update entities filtering out the ones that have been destroyed
+    updated <- liftIO $ fmap (filter (not . E.eDestroy)) (traverse (\e -> E.eUpdate e e) =<< readIORef entities)
+    entities $= updated
+
+    -- render map and entities
+    void $ liftIO $ do
+      M.render renderer map'
+      traverse (E.render renderer) updated
+
+    SDL.rendererRenderTarget renderer $= Nothing
+    rect <- SDL.get renderRect
+    SDL.copy renderer canvas Nothing (Just rect)
+
+    SDL.present renderer
+
+    gameLoop
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