Commits

paradoxiology committed 140cd7e

Update input event handling routine

The program can now differentiate input keys' Up and Down states

  • Participants
  • Parent commits c5568dc

Comments (0)

Files changed (1)

 handleEvents (EventResize (newWidth, newHeight)) oldWorld = 
   oldWorld{worldEnv = WorldEnv (fromIntegral newWidth) (fromIntegral newHeight)}
 
-handleEvents event oldWorld@(WireWorld{pendingEvents = events}) =
-  oldWorld{pendingEvents = event:events}
+handleEvents event@(EventKey key state _ _) oldWorld@(WireWorld{pendingEvents = events}) =
+  case state of
+    Up -> oldWorld{pendingEvents = event : deleteKeyEvent key events}
+            where deleteKeyEvent k = filter $ \(EventKey k' _ _ _) -> k' /= k
+
+    _  -> oldWorld{pendingEvents = event:events}
+
+handleEvents _ w = w
+
+deleteUpKeyEvents :: [Event] -> [Event]
+deleteUpKeyEvents = filter $ \(EventKey _ keyState _ _) -> keyState /= Up
 
 render :: WireWorld -> Picture
 render world = pictures $ map mkCircle (balls world)
 
 update :: Float -> WireWorld -> WireWorld
-update dt oldWorld = WireWorld w' bs' [] g' env
+update dt oldWorld = WireWorld w' bs' (deleteUpKeyEvents events) g' env
   where
     events = pendingEvents oldWorld
     env = worldEnv oldWorld
 mkCircle :: Ball -> Picture
 mkCircle (Ball (Vec2 x y) c) = Translate x y $ color c $ circleSolid 10
 
+isKeyActive :: KeyState -> SpecialKey -> [Event] -> Bool
+isKeyActive keyState k  = any checkKeyActive
+  where 
+    checkKeyActive (EventKey (SpecialKey sk) state _ _) = state == keyState && sk == k
+    checkKeyActive _                                   = False
+
 isKeyDown :: SpecialKey -> [Event] -> Bool
-isKeyDown k  = any checkKeyDown
-  where 
-    checkKeyDown (EventKey (SpecialKey sk) Down _ _) = sk == k
-    checkKeyDown _                                   = False
+isKeyDown = isKeyActive Down
+
+isKeyUp :: SpecialKey -> [Event] -> Bool
+isKeyUp = isKeyActive Up
 
 animateBalls :: GlossWire [Event] [Ball]
 animateBalls = proc events -> do
 --   returnA  -< ballPoss
 
 userSpawnBall :: GlossWire [Event] (Maybe (GlossWire [Event] Ball))
-userSpawnBall =  pure (Just $ for 10 . randomBall) . when (isKeyDown KeySpace) 
+userSpawnBall =  pure (Just $ for 10 . randomBall) . when (isKeyUp KeySpace) 
              <|> pure Nothing
 
 periodicSpawnBall :: GlossWire a (Maybe (GlossWire [Event] Ball))
 accelerate = arr (gravityAcc &+) . userAccWire
   where
     gravityAcc  =  Vec2 0 (-500)
-    userAccWire =  pure (mkVec2 (-20000, 0)) . when (isKeyDown KeyLeft)
-               <|> pure (mkVec2 (20000, 0)) . when (isKeyDown KeyRight)
-               <|> pure (mkVec2 (0, -20000)) . when (isKeyDown KeyDown)
-               <|> pure (mkVec2 (0, 20000)) . when (isKeyDown KeyUp)
+    userAccWire =  pure (mkVec2 (-2000, 0)) . when (isKeyDown KeyLeft)
+               <|> pure (mkVec2 (2000, 0)) . when (isKeyDown KeyRight)
+               <|> pure (mkVec2 (0, -2000)) . when (isKeyDown KeyDown)
+               <|> pure (mkVec2 (0, 2000)) . when (isKeyDown KeyUp)
                <|> pure zero
 
 velocity ::  GlossWire (Vec2, CollisionType) Vec2