there's something out there...

This commit is contained in:
nek0 2017-12-21 00:56:16 +01:00
parent c25c34c24b
commit a12707d740
6 changed files with 133 additions and 40 deletions

View file

@ -4,41 +4,31 @@ module InGame where
import Affection as A
import qualified SDL
import qualified Data.Map as M
import Data.Maybe (catMaybes, isJust, fromJust, isNothing)
import qualified Data.Set as S
import Data.Maybe (isNothing)
import Control.Monad (when, unless)
import Control.Monad.IO.Class (liftIO)
import System.Random (randomRIO)
import Linear
import NanoVG hiding (V2(..))
import Types
import Commons
import Menu
dVel :: Float
dVel = 100
dRot :: Float
dRot = 150
loadGame :: Affection UserData () -> Affection UserData ()
loadGame stateChange = do
liftIO $ logIO A.Debug "loading game"
ud <- getAffection
nhs <- newHaskelloids
kid <- partSubscribe (subKeyboard $ subsystems ud)
(\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeSpace -> do
liftIO $ logIO Debug "TODO: PEW!"
SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
liftIO $ logIO Debug "Reloading"
putAffection ud
{ stateUUIDs = UUIDClean [] []
}
loadGame stateChange
SDL.KeycodeEscape -> do
liftIO $ logIO Debug "Leave to Menu"
stateChange
_ -> return ()
)
kid <- partSubscribe (subKeyboard $ subsystems ud) (handleGameKeys stateChange)
putAffection ud
{ stateUUIDs = UUIDClean [] [kid]
, haskelloids = nhs
@ -47,9 +37,60 @@ loadGame stateChange = do
, sVel = V2 0 0
, sRot = 0
}
, shots = []
, state = InGame
, wonlost = Nothing
}
handleGameKeys :: Affection UserData () -> KeyboardMessage -> Affection UserData ()
handleGameKeys stateChange kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
liftIO $ logIO A.Debug "TODO: PEW!"
SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
ud <- getAffection
liftIO $ logIO A.Debug "Reloading"
putAffection ud
{ stateUUIDs = UUIDClean [] []
}
loadGame stateChange
SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Leave to Menu"
stateChange
SDL.KeycodeW -> accelShip dVel
SDL.KeycodeS -> accelShip (-dVel)
SDL.KeycodeA -> rotateShip dRot
SDL.KeycodeD -> rotateShip (-dRot)
_ -> return ()
accelShip :: Float -> Affection UserData ()
accelShip vel = do
ud <- getAffection
dt <- getDelta
let s = ship ud
nVel = sVel s + fmap (realToFrac dt *) ((V2 0 vel) `rotVec` sRot s)
putAffection ud
{ ship = s
{ sVel = nVel
}
}
rotateShip :: Float -> Affection UserData ()
rotateShip deg = do
ud <- getAffection
dt <- getDelta
putAffection ud
{ ship = (ship ud)
{ sRot = (sRot $ ship ud) - deg * realToFrac dt
}
}
rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
rotVec (V2 x y) deg = V2 nx ny
where
nx = x * (cos $ dtor deg) + y * (sin $ dtor deg)
ny = x * (sin $ dtor deg) - y * (cos $ dtor deg)
dtor = (pi / 180 *)
updateGame :: Double -> Affection UserData ()
updateGame sec = do
@ -59,6 +100,27 @@ updateGame sec = do
{ haskelloids = nhs
, ship = updateShip sec (ship ud)
}
ud2 <- getAffection
when
( ( any (checkCollision (ship ud2)) (haskelloids ud2)
|| any (checkFriendlyFire (ship ud2)) (shots ud2)
)
&& isNothing (wonlost ud2)
)
(putAffection ud2
{ wonlost = Just Lost
}
)
checkCollision :: Ship -> Haskelloid -> Bool
checkCollision s h =
distance (sPos s) (hPos h) < minDist
where
minDist = 20 + (50 / fromIntegral (hDiv h))
checkFriendlyFire :: Ship -> Pew -> Bool
checkFriendlyFire s p =
distance (sPos s) (pPos p) < 20
updateShip :: Double -> Ship -> Ship
updateShip ddt s@Ship{..} = s
@ -71,7 +133,32 @@ drawGame :: Affection UserData ()
drawGame = do
ud <- getAffection
mapM_ drawHaskelloid (haskelloids ud)
drawShip (ship ud)
case wonlost ud of
Just Lost -> liftIO $ do
let ctx = nano ud
save ctx
fontSize ctx 120
fontFace ctx "modulo"
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "YOU LOST!"
fillColor ctx (rgba 255 128 0 255)
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
Just Won -> liftIO $ do
let ctx = nano ud
save ctx
fontSize ctx 120
fontFace ctx "modulo"
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "YOU WON!"
fillColor ctx (rgba 255 128 0 255)
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit"
restore ctx
Nothing -> drawShip (ship ud)
drawShip :: Ship -> Affection UserData ()
drawShip Ship{..} = do

View file

@ -68,6 +68,7 @@ load = do
, sImg = fromJust mshipImage
}
, haskelloids = []
, shots = []
, wonlost = Nothing
, state = Menu
, fade = FadeIn 1

View file

@ -12,6 +12,7 @@ import Linear as L
import NanoVG hiding (V2(..), V4(..))
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
-- internal imports
@ -29,8 +30,8 @@ main = do
, windowTitle = "Haskelloids"
, windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 0
, SDL.glColorPrecision = V4 0 8 8 8
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
-- , SDL.glColorPrecision = V4 0 8 8 8
}
}
, initScreenMode = SDL.Windowed
@ -54,6 +55,13 @@ pre = do
dw = floor $ (fromIntegral w - fromIntegral nw) / 2
GL.viewport $= (GL.Position dw 0, GL.Size nw h)
_ -> return ()
_ <- partSubscribe (subKeyboard subs) $ \kbdev ->
when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeF -> do
dt <- getDelta
liftIO $ logIO A.Debug $ "FPS: " ++ show (1/dt)
_ -> return ()
return ()
update :: Double -> Affection UserData ()
@ -70,9 +78,9 @@ handle e = do
draw :: Affection UserData ()
draw = do
ud <- getAffection
window <- drawWindow <$> get
pf <- liftIO $ SDL.getWindowPixelFormat window
liftIO $ logIO A.Debug $ "Window pixel format: " ++ show pf
liftIO $ beginFrame (nano ud) 800 600 (800/600)
-- window <- drawWindow <$> get
-- pf <- liftIO $ SDL.getWindowPixelFormat window
-- liftIO $ logIO A.Debug $ "Window pixel format: " ++ show pf
liftIO $ beginFrame (nano ud) 800 600 1
smDraw (state ud)
liftIO $ endFrame (nano ud)

View file

@ -80,7 +80,7 @@ drawMenu = do
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "HASKELLOIDS"
fillColor ctx (rgba 255 128 0 (alpha $ fade ud))
fillColor ctx (rgba 0 128 255 (alpha $ fade ud))
fontSize ctx 40
textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit"
restore ctx

View file

@ -3,17 +3,8 @@
module StateMachine where
import Affection
import qualified SDL
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Control.Monad (foldM, when)
import System.Random (randomRIO)
import Types
import Commons
import InGame
import Menu

View file

@ -13,7 +13,7 @@ import Control.Monad.IO.Class (liftIO)
data UserData = UserData
{ ship :: Ship
, haskelloids :: [Haskelloid]
-- , shots :: ParticleSystem
, shots :: [Pew]
-- , debris :: ParticleSystem
, wonlost :: Maybe WonLost
, pixelSize :: Int
@ -33,6 +33,12 @@ data Ship = Ship
, sImg :: Image
}
data Pew = Pew
{ pPos :: V2 Float
, pVel :: V2 Float
, pTTL :: Double
}
data Haskelloid = Haskelloid
{ hPos :: V2 Float
, hVel :: V2 Float
@ -44,7 +50,7 @@ data Haskelloid = Haskelloid
data State
= Menu
| HighScore
-- | HighScore
| InGame
data MenuFade