Skip to content
Permalink
Browse files

Changed starting code to a better example

- Modified starting code to package bmp files in Assets
  • Loading branch information
Ashe committed Mar 3, 2018
1 parent 2d459d9 commit 380789362919b55b024141fbcda935796700bd9c
Showing with 98 additions and 12 deletions.
  1. BIN Assets/foo.bmp
  2. +2 −2 FirstGameHS.cabal
  3. +96 −10 src/Main.hs
BIN +8.77 MB (37000%) Assets/foo.bmp
Binary file not shown.
@@ -12,13 +12,13 @@ category: Game
build-type: Simple
cabal-version: >=1.10
extra-source-files: README.md
data-dir: Assets
data-files: *.bmp
data-files: Assets/*.bmp

executable FirstGameHS
hs-source-dirs: src
main-is: Main.hs
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, sdl2
, pretty-simple
other-modules: Paths_FirstGameHS
@@ -1,19 +1,84 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Main where

import Control.Monad
import Foreign.C.Types
import SDL.Vect
import SDL (($=))
import qualified SDL
import Data.List (foldl')
import SDL.Raw.Timer as SDL hiding (delay)
import Text.Pretty.Simple

import Paths_FirstGameHS(getDataFileName)

screenWidth, screenHeight :: CInt
(screenWidth, screenHeight) = (640, 480)

loadBMP :: FilePath -> IO SDL.Surface
loadBMP path = getDataFileName path >>= SDL.loadBMP
frameLimit :: Int
frameLimit = 60

-- This is our game world. It only consists of one lonely guy
-- who has a position and a velocity
data World
= Guy
{ position :: Point V2 CDouble
, velocity :: V2 CDouble
} deriving (Show, Eq)

-- Our initial world starts out with the guy roughly in the middle
initialGuy :: World
initialGuy =
Guy
{ position = P $ V2 (fromIntegral screenWidth / 2) (fromIntegral $ screenHeight - 100)
, velocity = V2 0 0
}

jumpVelocity :: V2 CDouble
jumpVelocity = V2 0 (-2)

walkingSpeed :: V2 CDouble
walkingSpeed = V2 1 0

gravity :: V2 CDouble
gravity = V2 0 0.7


-- These simplify matching on a specific key code
pattern KeyPressed a <- (SDL.KeyboardEvent (SDL.KeyboardEventData _ SDL.Pressed False (SDL.Keysym _ a _)))
pattern KeyReleased a <- (SDL.KeyboardEvent (SDL.KeyboardEventData _ SDL.Released _ (SDL.Keysym _ a _)))


-- This processed input and modifies velocities of things in our world accordingly
-- and then returns the new world
processInput :: World -> SDL.EventPayload -> World
processInput world@(Guy _ curVel) (KeyPressed SDL.KeycodeUp) =
world { velocity = curVel * V2 1 0 + jumpVelocity}
processInput world@(Guy _ curVel) (KeyPressed SDL.KeycodeLeft) =
world { velocity = negate walkingSpeed + curVel }
processInput world@(Guy _ curVel) (KeyPressed SDL.KeycodeRight) =
world { velocity = walkingSpeed + curVel }

processInput world@(Guy _ curVel) (KeyReleased SDL.KeycodeUp) =
world { velocity = curVel - jumpVelocity }
processInput world@(Guy _ curVel) (KeyReleased SDL.KeycodeLeft) =
world { velocity = curVel - negate walkingSpeed }
processInput world@(Guy _ curVel) (KeyReleased SDL.KeycodeRight) =
world { velocity = curVel - walkingSpeed }
processInput w _ = w


-- This function takes cares of applying things like our entities' velocities
-- to their positions, as well as
updateWorld :: CDouble -> World -> World
updateWorld delta (Guy (P pos) vel) =
let (V2 newPosX newPosY) = pos + (gravity + vel) * V2 delta delta
-- Ensure that we stay within bounds
fixedX = max 0 $ min newPosX (fromIntegral screenWidth - 50)
fixedY = max 0 $ min (fromIntegral screenHeight - 100) newPosY
in Guy (P $ V2 fixedX fixedY) vel


main :: IO ()
main = do
@@ -22,7 +87,7 @@ main = do
SDL.initialize [SDL.InitVideo]

-- Create a window with the correct screensize and make it appear
window <- SDL.createWindow "SDL Tutorial"
window <- SDL.createWindow "FirstGameHS"
SDL.defaultWindow { SDL.windowInitialSize = V2 screenWidth screenHeight }
SDL.showWindow window

@@ -39,25 +104,46 @@ main = do
SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound

-- Make a surface from file
xOutSurface <- getDataFileName "foo.bmp" >>= SDL.loadBMP
xOutSurface <- getDataFileName "Assets/foo.bmp" >>= SDL.loadBMP
texture <- SDL.createTextureFromSurface renderer xOutSurface

-- Free the surface as we have a texture now
SDL.freeSurface xOutSurface

let loop = do

let loop last world = do
events <- SDL.pollEvents

let quit = elem SDL.QuitEvent $ map SDL.eventPayload events
-- Need to calculate the time delta
now <- SDL.getPerformanceCounter
freq <- SDL.getPerformanceFrequency

let delta = (fromIntegral now - fromIntegral last) * 1000 / fromIntegral freq
payloads = map SDL.eventPayload events
quit = SDL.QuitEvent `elem` payloads

-- Update functions
let worldAfterInput = foldl' processInput world payloads
newWorld = updateWorld delta worldAfterInput

SDL.clear renderer
SDL.copy renderer texture Nothing (Just $ SDL.Rectangle (P $ V2 0 0) (V2 200 200))
SDL.present renderer

unless quit loop
-- Render functions
SDL.copy renderer texture Nothing Nothing
-- Draw our world(guy) as a white rectangle
let drawColor = SDL.rendererDrawColor renderer
drawColor $= V4 255 255 255 0
SDL.fillRect renderer . Just $ SDL.Rectangle (truncate <$> position newWorld) (V2 50 100)

-- My attempt at an FPS limit. I don't write games so it is possible this is incorrect
let frameDelay = 1000 / fromIntegral frameLimit
when (delta < frameDelay) $ SDL.delay (truncate $ frameDelay - delta)

loop
SDL.present renderer
unless quit $ loop now newWorld

now <- SDL.getPerformanceCounter
loop now initialGuy

SDL.destroyWindow window
SDL.quit

0 comments on commit 3807893

Please sign in to comment.
You can’t perform that action at this time.