there's something out there...

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

src/Init.hs

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

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)

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

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
 

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