Initial import

1 files changed, 143 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