Commits

paradoxiology committed d955ab5

Fix the leaky periodicShots

Comments (0)

Files changed (2)

 type GlossWire a b = Wire (Timed Float ()) () G a b
 
 data WireWorld = WireWorld
-  { wire :: GlossWire [Event] [Ball]
-  , balls  :: [Ball]
+  { wire          :: GlossWire [Event] [Ball]
+  , balls         :: [Ball]
   , pendingEvents :: [Event]
-  , randGen :: !StdGen -- Without the bang, the program will space leak
-  , worldEnv :: WorldEnv
+  , randGen       :: !StdGen -- Without the bang, the program will space leak
+  , worldEnv      :: WorldEnv
   }
 
 data Ball = Ball !Vec2 !Color deriving (Show)
   let newBalls = catMaybes [newUserBall, newDropBall]
   balls' <- mergeWires [] -< (events, newBalls)
   returnA  -< balls'
--- balls = proc events -> do
---   newBall  <- userSpawnBall -< events
---   ballPoss <- mergeWires [] -< (events, maybe [] (:[]) newBall)
---   returnA  -< ballPoss
 
 userSpawnBall :: GlossWire [Event] (Maybe (GlossWire [Event] Ball))
 userSpawnBall =  pure (Just $ for 10 . randomBall) . when (isKeyUp KeySpace) 
              <|> pure Nothing
 
 periodicSpawnBall :: GlossWire a (Maybe (GlossWire [Event] Ball))
-periodicSpawnBall = for 2 . pure Nothing --> 
-                    oneShot . pure (Just $ for 10 . randomBall) -->
-                    periodicSpawnBall
+periodicSpawnBall  =  pure (Just $ for 10 . randomBall) . periodicShots 2
+                  <|> pure Nothing
 
 randomBall :: GlossWire [Event] Ball
 randomBall = mkGen $ \ds events -> do
             | y > bHeight = 2 * bHeight - y
             | otherwise = y
 
-        col | x < (-bWidth) || (x > bWidth) = HorizontalCollision
+        col | x < (-bWidth)  || (x > bWidth)  = HorizontalCollision
             | y < (-bHeight) || (y > bHeight) = VerticalCollision
             | otherwise = NoCollision
             
 import Control.Wire
 
 import Data.Vect
+import Data.Fixed
 
 import Prelude hiding ((.), id)
 
 oneShot :: (Monoid e) => Wire s e m a a
 oneShot = mkPureN $ \a -> (Right a, inhibit mempty)
             
--- Produce one value for one instance periodically 
--- FIXME: This function space-leaks, most likely due to non-tail recursive use of (-->)
-periodicShots :: (Monad m, HasTime t s, Monoid e) => t -> Wire s e m a a
-periodicShots p = oneShot <|> (oneShot --> periodicShots p) . after p
-
+-- Produce one value for one instance from now periodically
+periodicShots :: (HasTime t s, Monoid e) => t -> Wire s e m a a
+periodicShots int | int <= 0 =  error "periodicShots: Non-positive interval"
+periodicShots int = mkPureN $ \x -> (Right x, go int)
+  where
+    go 0 = go int
+    go t' =
+        mkPure $ \ds x ->
+            let t = t' - dtime ds
+            in if t <= 0
+                 then (Right x, go (mod' t int))
+                 else (Left mempty, go t)