From a12707d7400aa479c9a9317eb9c7e1ac339a7454 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 21 Dec 2017 00:56:16 +0100 Subject: [PATCH] there's something out there... --- src/InGame.hs | 131 ++++++++++++++++++++++++++++++++++++-------- src/Init.hs | 1 + src/Main.hs | 20 +++++-- src/Menu.hs | 2 +- src/StateMachine.hs | 9 --- src/Types.hs | 10 +++- 6 files changed, 133 insertions(+), 40 deletions(-) diff --git a/src/InGame.hs b/src/InGame.hs index e5c7a44..1815bd9 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -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 diff --git a/src/Init.hs b/src/Init.hs index be9b08b..d377e12 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -68,6 +68,7 @@ load = do , sImg = fromJust mshipImage } , haskelloids = [] + , shots = [] , wonlost = Nothing , state = Menu , fade = FadeIn 1 diff --git a/src/Main.hs b/src/Main.hs index e90de68..41560e6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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) diff --git a/src/Menu.hs b/src/Menu.hs index fa12dcb..bffa789 100644 --- a/src/Menu.hs +++ b/src/Menu.hs @@ -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 diff --git a/src/StateMachine.hs b/src/StateMachine.hs index ad5dffd..3e784e7 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs index 017e6d5..4f424bf 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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