playable!

src/InGame.hs

@@ -5,30 +5,40 @@ import Affection as A
 import qualified SDL
 
 import qualified Data.Set as S
-import Data.Maybe (isNothing)
+import Data.Maybe (isNothing, catMaybes)
 
 import Control.Monad (when, unless)
 import Control.Monad.IO.Class (liftIO)
 
+import System.Random (randomRIO)
+
 import Linear
 
 import NanoVG hiding (V2(..))
 
+import Foreign.C.Types (CFloat(..))
+
 import Types
 import Commons
 
 dVel :: Float
 dVel = 100
 
+pewVel :: Float
+pewVel = 200
+
+pewTTL :: Double
+pewTTL = 10
+
 dRot :: Float
 dRot = 150
 
-loadGame :: Affection UserData () -> Affection UserData ()
-loadGame stateChange = do
+loadGame :: Affection UserData () -> Affection UserData () -> Affection UserData ()
+loadGame stateChange clean = do
   liftIO $ logIO A.Debug "loading game"
   ud <- getAffection
   nhs <- newHaskelloids
-  kid <- partSubscribe (subKeyboard $ subsystems ud) (handleGameKeys stateChange)
+  kid <- partSubscribe (subKeyboard $ subsystems ud) (handleGameKeys stateChange clean)
   putAffection ud
     { stateUUIDs = UUIDClean [] [kid]
     , haskelloids = nhs
@@ -42,18 +52,17 @@ loadGame stateChange = do
     , wonlost = Nothing
     }
 
-handleGameKeys :: Affection UserData () -> KeyboardMessage -> Affection UserData ()
-handleGameKeys stateChange kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
+handleGameKeys :: Affection UserData () -> Affection UserData () -> KeyboardMessage -> Affection UserData ()
+handleGameKeys stateChange clean kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
   case SDL.keysymKeycode (msgKbdKeysym kbdev) of
     SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
-      liftIO $ logIO A.Debug "TODO: PEW!"
+      liftIO $ logIO A.Debug "PEW!"
+      shoot
     SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
       ud <- getAffection
+      unless (isNothing $ wonlost ud) $ do
         liftIO $ logIO A.Debug "Reloading"
-      putAffection ud
-        { stateUUIDs = UUIDClean [] []
-        }
-      loadGame stateChange
+        clean
     SDL.KeycodeEscape -> do
       liftIO $ logIO A.Debug "Leave to Menu"
       stateChange
@@ -63,6 +72,17 @@ handleGameKeys stateChange kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
     SDL.KeycodeD -> rotateShip (-dRot)
     _ -> return ()
 
+shoot :: Affection UserData ()
+shoot = do
+  ud <- getAffection
+  let Ship{..} = ship ud
+      npew = Pew ppos pVel pewTTL
+      ppos = sPos + ((V2 0 25) `rotVec` sRot)
+      pVel = sVel + ((V2 0 pewVel) `rotVec` sRot)
+  putAffection ud
+    { shots = npew : shots ud
+    }
+
 accelShip :: Float -> Affection UserData ()
 accelShip vel = do
   ud <- getAffection
@@ -96,10 +116,13 @@ updateGame :: Double -> Affection UserData ()
 updateGame sec = do
   ud <- getAffection
   let nhs = map (updateHaskelloid sec) (haskelloids ud)
+      npews = filter (\p -> pTTL p > 0) $ map (updatePew sec) (shots ud)
   putAffection ud
     { haskelloids = nhs
+    , shots = npews
     , ship = updateShip sec (ship ud)
     }
+  checkShotDown
   ud2 <- getAffection
   when
     (  (  any (checkCollision (ship ud2)) (haskelloids ud2)
@@ -111,6 +134,51 @@ updateGame sec = do
       { wonlost = Just Lost
       }
     )
+  when (isNothing (wonlost ud2) && null (haskelloids ud2))
+    (putAffection ud2
+      { wonlost = Just Won
+      }
+    )
+
+checkShotDown :: Affection UserData ()
+checkShotDown =
+  do
+    ud <- getAffection
+    let shoots = shots ud
+        hasks = haskelloids ud
+        pairs = catMaybes $ concatMap (crossOut hasks) shoots
+        deadHasks = map fst pairs
+        nhask = foldl (\acc a -> filter (\x -> a /= x) acc) hasks deadHasks
+        npews = foldl (\acc a -> filter (\x -> a /= x) acc) shoots (map snd pairs)
+    children <- liftIO $ concat <$> mapM (\Haskelloid{..} -> do
+      n1velx <- randomRIO (-10, 10)
+      n1vely <- randomRIO (-10, 10)
+      n1rot <- randomRIO (-180, 180)
+      n1pitch <- randomRIO (-pi, pi)
+      n2velx <- randomRIO (-10, 10)
+      n2vely <- randomRIO (-10, 10)
+      n2rot <- randomRIO (-180, 180)
+      n2pitch <- randomRIO (-pi, pi)
+      let ndiv = hDiv + 1
+      if ndiv > 5
+      then return []
+      else return $
+        [ Haskelloid hPos (V2 n1velx n1vely) n1rot n1pitch ndiv hImg
+        , Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg
+        ]
+      ) deadHasks
+    putAffection ud
+      { shots = npews
+      , haskelloids = nhask ++ children
+      }
+  where
+    crossOut :: [Haskelloid] -> Pew -> [Maybe (Haskelloid, Pew)]
+    crossOut hs p =
+      foldl (\acc h ->
+        if distance (pPos p) (hPos h) < (50 / fromIntegral (hDiv h))
+        then Just (h, p) : acc
+        else Nothing : acc
+        ) [] hs
 
 checkCollision :: Ship -> Haskelloid -> Bool
 checkCollision s h =
@@ -129,10 +197,19 @@ updateShip ddt s@Ship{..} = s
   where
     dt = realToFrac ddt
 
+updatePew :: Double -> Pew -> Pew
+updatePew ddt p@Pew{..} = p
+  { pPos = wrapAround (pPos + fmap (dt *) pVel) 0
+  , pTTL = pTTL - ddt
+  }
+  where
+    dt = realToFrac ddt
+
 drawGame :: Affection UserData ()
 drawGame = do
   ud <- getAffection
   mapM_ drawHaskelloid (haskelloids ud)
+  mapM_ drawPew (shots ud)
   case wonlost ud of
     Just Lost -> liftIO $ do
       let ctx = nano ud
@@ -154,9 +231,9 @@ drawGame = do
       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)
+      fillColor ctx (rgba 128 255 0 255)
       fontSize ctx 40
-      textBox ctx 0 350 800 "Press [Esc] to exit"
+      textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
       restore ctx
     Nothing -> drawShip (ship ud)
 
@@ -166,3 +243,15 @@ drawShip Ship{..} = do
   liftIO $ drawImage ctx (sImg) (sPos - fmap (/2) dim) dim sRot 255
   where
     dim = V2 40 40
+
+drawPew :: Pew -> Affection UserData ()
+drawPew Pew{..} = do
+  ctx <- nano <$> getAffection
+  liftIO $ do
+    let (V2 x y) = fmap CFloat pPos
+    save ctx
+    beginPath ctx
+    fillColor ctx (rgba 255 128 0 255)
+    circle ctx x y 2
+    fill ctx
+    restore ctx

src/Main.hs

@@ -31,7 +31,7 @@ main = do
     , windowConfig   = SDL.defaultWindow
       { SDL.windowOpenGL = Just SDL.defaultOpenGL
         { SDL.glProfile        = SDL.Core SDL.Normal 3 2
-        -- , SDL.glColorPrecision = V4 0 8 8 8
+        , SDL.glColorPrecision = V4 8 8 8 1
         }
       }
     , initScreenMode = SDL.Windowed
@@ -61,6 +61,7 @@ pre = do
         SDL.KeycodeF -> do
           dt <- getDelta
           liftIO $ logIO A.Debug $ "FPS: " ++ show (1/dt)
+        SDL.KeycodeO -> toggleScreen
         _ -> return ()
   return ()
 

src/StateMachine.hs

@@ -11,7 +11,7 @@ import Menu
 instance StateMachine State UserData where
   smLoad Menu = loadMenu (smClean Menu >> smLoad InGame)
 
-  smLoad InGame = loadGame (smClean InGame >> smLoad Menu)
+  smLoad InGame = loadGame (smClean InGame >> smLoad Menu) (smClean InGame >> smLoad InGame)
 
   smUpdate Menu = updateMenu
 

src/Types.hs

@@ -37,7 +37,7 @@ data Pew = Pew
   { pPos :: V2 Float
   , pVel :: V2 Float
   , pTTL :: Double
-  }
+  } deriving (Eq)
 
 data Haskelloid = Haskelloid
   { hPos :: V2 Float