aboutsummaryrefslogtreecommitdiff
path: root/src/Game.hs
blob: 0d5ae451a671b7fb1bc276a71bddeece756e505f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
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