Commits

paradoxiology committed 7efefc3

Refactor to use Netwire Event

It now uses the more idiomatic Netwires Event as opposed to Maybe Wire

  • Participants
  • Parent commits 1d3899f

Comments (0)

Files changed (2)

 {-# LANGUAGE Arrows #-}
 
 import Control.Wire hiding (Event)
+import qualified Control.Wire as NW (Event)
 
 import Control.Monad.Random
 import Control.Monad.Reader (ReaderT, runReaderT, asks)
 
-import Data.Maybe (catMaybes)
-
 import Data.Vect
 
 import Graphics.Gloss
 animateBalls = proc events -> do
   newDropBall <- periodicSpawnBall -< ()
   newUserBall <- userSpawnBall -< events
-  let newBalls = catMaybes [newUserBall, newDropBall]
-  balls' <- mergeWires [] -< (events, newBalls)
+  let newBalls = concatE newDropBall newUserBall
+  balls' <- accumWiresE -< (events, newBalls)
   returnA  -< balls'
 
-userSpawnBall :: GlossWire [Event] (Maybe (GlossWire [Event] Ball))
-userSpawnBall =  pure (Just $ for 10 . randomBall) . when (isKeyUp KeySpace) 
-             <|> pure Nothing
+userSpawnBall :: GlossWire [Event] (NW.Event (GlossWire [Event] Ball))
+userSpawnBall = onThenE (isKeyUp KeySpace) (for 10 . randomBall)
 
-periodicSpawnBall :: GlossWire a (Maybe (GlossWire [Event] Ball))
-periodicSpawnBall  =  pure (Just $ for 10 . randomBall) . periodicShots 2
-                  <|> pure Nothing
+periodicSpawnBall :: GlossWire a (NW.Event (GlossWire [Event] Ball))
+periodicSpawnBall = periodic 2 . pure (for 10 . randomBall)
 
 randomBall :: GlossWire [Event] Ball
 randomBall = mkGen $ \ds events -> do
   integralVecWith,
   integralVecWith',
   integralVecWithM',
-  mergeWires,
+  concatE,
+  onThenE,
+  accumWiresE,
   oneShot,
   periodicShots
 )
 where
 
 import Control.Wire
+import Control.Wire.Unsafe.Event
 
 import Data.Vect
 import Data.Fixed
         res <- correct (x0 &+ dt *& dx)
         return $ x0 `seq` (Right (x0, snd res), go (fst res)) 
 
-mergeWires :: (Monad m, Monoid s) => [Wire s e m a b] -> Wire s e m (a, [Wire s e m a b]) [b]
-mergeWires wires = mkGen $ \ds (x, newWires) -> do
-  stepped <- mapM (\w -> stepWire w ds (Right x)) (newWires ++ wires)
-  -- Filter out inhibited wires, and extract the outputs and future wires out separately
-  let (o', wires') = unzip [(o, w') | (Right o, w') <- stepped]
-  return (Right o', mergeWires wires')
+concatE :: Event a -> Event a -> Event [a]
+concatE NoEvent   NoEvent    = Event []
+concatE (Event e) NoEvent    = Event [e]
+concatE NoEvent   (Event e') = Event [e']
+concatE (Event e) (Event e') = Event (e : e' : [])
+
+onThenE :: (a -> Bool) -> b -> Wire s e m a (Event b)
+onThenE f y = go
+  where
+    go = mkSFN $ \x -> if f x then (Event y, go) else (NoEvent, go)
+
+accumWiresE :: (Monad m, Monoid s) => Wire s e m (a, Event [Wire s e m a b]) [b]
+accumWiresE = go []
+  where
+    go wires = mkGen $ \ds (x, eWires) -> do
+      let newWires = event [] id eWires
+      stepped <- mapM (\w -> stepWire w ds (Right x)) (newWires ++ wires)
+      -- Filter out inhibited wires, and extract the outputs and future wires out separately
+      let (o', wires') = unzip [(o, w') | (Right o, w') <- stepped]
+      return (Right o', go wires')
 
 -- Produce one value now then inhibit
 oneShot :: (Monoid e) => Wire s e m a a