multiple balls

frpball.cabal

@@ -29,6 +29,7 @@ executable frpball
                      , text
                      , stm
                      , mtl
+                     , random
   hs-source-dirs:      src
   ghc-options:       -Wall
   default-language:    Haskell2010

src/Main.hs

@@ -22,6 +22,9 @@ import Reactive.Banana.Frameworks as RBF
 import Reactive.Banana.Combinators as RBC
 
 import Data.Maybe (fromMaybe)
+import Data.List (zip4)
+
+import System.Random (randomRIO)
 
 -- internal imports
 
@@ -64,6 +67,7 @@ main = do
       , (V4 1 1 0 1,  V3 0 0 1)
       ]
 
+    let orderList = [1 .. 100]
     hexBuffer :: Buffer os AttrInput <- newBuffer 18
     writeBuffer
       hexBuffer
@@ -94,9 +98,20 @@ main = do
       ]
 
     uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1
-    positionUniformBuffer :: Buffer os (Uniform (B2 Float)) <- newBuffer 1
+    positionUniformBuffers :: [Buffer os (Uniform (B2 Float))] <- mapM
+      (\_ -> newBuffer 1)
+      orderList
+    positions <- liftIO $ mapM
+      (\_ -> do
+        x <- randomRIO (0, 800)
+        y <- randomRIO (0, 600)
+        return $ V2 x y
+        )
+      orderList
 
-    hexShader <- compileShader $ do
+    hexShaders <- mapM
+      (\positionUniformBuffer ->
+        compileShader $ do
           hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <-
             toPrimitiveStream id ::
               Shader
@@ -138,6 +153,8 @@ main = do
               )
               )
             hexFragmentStream
+        )
+      positionUniformBuffers
 
     shader <- compileShader $ do
       primitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <-
@@ -179,15 +196,21 @@ main = do
     listen@(_, eventFire) <- liftIO $ newAddHandler
     deltaTimer@(_, deltaFire) <- liftIO $ newAddHandler
     uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float)
-    transUniVar :: TMVar (V2 Float) <- liftIO $ newTMVarIO (V2 1 1)
+    transUniVars :: [TMVar (V2 Float)] <- liftIO $ mapM
+      (\rposition -> newTMVarIO rposition)
+      positions
     deltaVar :: TMVar Float <- liftIO (newTMVarIO =<< SDL.time)
     network <- liftIO $ compile
-      (networkDescription listen deltaTimer uniVar transUniVar)
+      (networkDescription listen deltaTimer uniVar transUniVars)
     forever $ do
       mrot <- liftIO $ atomically $ tryReadTMVar uniVar
       writeBuffer uniformBuffer 0 [fromMaybe 0 mrot]
+      mapM_
+        (\(transUniVar, positionUniformBuffer) -> do
           mtrans <- liftIO $ atomically $ tryReadTMVar transUniVar
           writeBuffer positionUniformBuffer 0 [fromMaybe (V2 1 1) mtrans]
+        )
+        (zip transUniVars positionUniformBuffers)
       liftIO $ actuate network
       render $ do
         clearWindowColor win (V3 0 0 0)
@@ -196,7 +219,11 @@ main = do
         let primitiveArray = toPrimitiveArray TriangleList vertexArray
         let hexPrimitiveArray = toPrimitiveArray TriangleList hexVertexArray
         shader primitiveArray
+        mapM_
+          (\hexShader ->
             hexShader hexPrimitiveArray
+          )
+          hexShaders
       swapWindowBuffers win
       liftIO $ do
         evs <- SDL.pollEvents
@@ -211,29 +238,44 @@ networkDescription
   :: (AddHandler [SDL.Event], ([SDL.Event] -> IO ()))
   -> (AddHandler Float, (Float -> IO ()))
   -> TMVar Float
-  -> TMVar (V2 Float)
+  -> [TMVar (V2 Float)]
   -> MomentIO ()
-networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo
+networkDescription (listenerAH, _) (deltaAH, _) rotvar transvars = mdo
-  (ballPosAH, ballPosFire) <- liftIO $ newAddHandler
+  posAHFires <- liftIO $ mapM (const newAddHandler) [1 .. length transvars]
-  (ballVelAH, ballVelFire) <- liftIO $ newAddHandler
+  velAHFires <- liftIO $ mapM (const newAddHandler) [1 .. length transvars]
-  (ballAccAH, ballAccFire) <- liftIO $ newAddHandler
+  accAHFires <- liftIO $ mapM (const newAddHandler) [1 .. length transvars]
+  -- (ballPosAH, ballPosFire) <- liftIO $ newAddHandler
+  -- (ballVelAH, ballVelFire) <- liftIO $ newAddHandler
+  -- (ballAccAH, ballAccFire) <- liftIO $ newAddHandler
   (mousePosAH, mousePosFire) <- liftIO $ newAddHandler
   (mouseMotionAH, mouseMotionFire) <- liftIO $ newAddHandler
   (mouseClickAH, mouseClickFire) <- liftIO $ newAddHandler
   (mouseReleaseAH, mouseReleaseFire) <- liftIO $ newAddHandler
   (mouseClickPosAH, mouseClickPosFire) <- liftIO $ newAddHandler
-  ballPos :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do
+  ballPoss :: [Event (V2 Float)] <- mapM
+    (\(ballPosAH, _) -> 
+      fromAddHandler =<< (liftIO $ do
         void $ register ballPosAH (\_ -> return())
         return ballPosAH
         )
-  ballVel :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do
+      )
+    posAHFires
+  ballVels :: [Event (V2 Float)] <- mapM
+    (\(ballVelAH, _) ->
+      fromAddHandler =<< (liftIO $ do
         void $ register ballVelAH (\_ -> return())
         return ballVelAH
         )
-  ballAcc :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do
+      )
+    velAHFires
+  ballAccs :: [Event (V2 Float)] <- mapM
+    (\(ballAccAH, _) ->
+      fromAddHandler =<< (liftIO $ do
         void $ register ballAccAH (\_ -> return())
         return ballAccAH
         )
+      )
+    accAHFires
   mousePos :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do
     void $ register mousePosAH (\_ -> return())
     return mousePosAH
@@ -278,17 +320,21 @@ networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo
           )
         mousePos
 
-  ballPosBehaviour <- stepper (V2 400 300) ballPos
+  ballPosBehaviours <- mapM
-  ballVelBehaviour <- stepper (V2 0 0) ballVel
+    (\(ballPos, uni) -> do
-  ballAccBehaviour <- stepper (V2 0 0) ballAcc
+      position <- liftIO $ fromMaybe (V2 400 300) <$>
+        (atomically $ tryReadTMVar uni)
+      stepper position ballPos
+      )
+    (zip ballPoss transvars)
+  ballVelBehaviours <- mapM (\ballVel -> stepper (V2 0 0) ballVel) ballVels
+  ballAccBehaviours <- mapM (\ballAcc -> stepper (V2 0 0) ballAcc) ballAccs
   mousePosBehaviour <- stepper (V2 400 300) mousePos
   mouseMotionBehaviour <- stepper (V2 0 0) mouseMotion
   mouseClickBehaviour <- stepper False mouseClick
   mouseReleaseBehaviour <- stepper True mouseRelease
   mouseClickPosBehaviour <- stepper Nothing mouseClickPos
 
-  ball :: V2 Float <- valueB ballPosBehaviour
-
   let triangleReaction = fmap (\x -> do
         let input = (\(V2 xx _) -> xx / 100 :: Float) x
         past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar)
@@ -296,13 +342,21 @@ networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo
         -- print input
         )
         mouseMotionBehaviour
-      ballReaction = fmap (\x -> do
+      ballReactions = map
+        (\(ballPosBehaviour, uni) ->
+          fmap
+            (\x -> do
               let input = (fmap (\foo -> foo - 1) x) / V2 400 300
-        void $ atomically $ swapTMVar transvar input
+              void $ atomically $ swapTMVar uni input
               -- print input
               )
             ballPosBehaviour
-      ballAccReaction = fmap (\acc -> do
+          )
+        (zip ballPosBehaviours transvars)
+      ballAccReactions = map
+        (\((_, ballAccFire), ballPosBehaviour) ->
+          fmap
+            (\acc -> do
               ballAccFire acc
               -- print acc
               ) $ apply
@@ -315,7 +369,12 @@ networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo
                 ballPosBehaviour
                 )
               delta
-      ballVelReaction = fmap (\vel ->
+          )
+        (zip accAHFires ballPosBehaviours)
+      ballVelReactions = map
+        (\((_, ballVelFire), ballAccBehaviour, ballVelBehaviour) ->
+          fmap
+            (\vel ->
               ballVelFire vel
               ) $ apply
               (liftA2
@@ -324,10 +383,20 @@ networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo
                 ballVelBehaviour
                 )
               delta
-      ballMoveReaction = fmap (\x -> do
+          )
+        (zip3 velAHFires ballAccBehaviours ballVelBehaviours)
+      ballMoveReactions = map
+        (\( ( _
+            , ballPosFire
+            )
+          , ballPosBehaviour
+          , ballVelBehaviour
+          , ballAccBehaviour) ->
+            fmap
+              (\x -> do
                 ballPosFire x
                 -- print x
-        ) $ apply
+                ) (apply
                     (liftA3
                       (\bPos bVel bAcc ->
                         (\dtime -> (fmap (* (dtime * 0.5)) bAcc) +
@@ -339,14 +408,16 @@ networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo
                         ballVelBehaviour
                         ballAccBehaviour
                       )
-          delta
+                    delta)
+          )
+        (zip4 posAHFires ballPosBehaviours ballVelBehaviours ballAccBehaviours)
 
   reactimate' =<< changes triangleReaction
-  reactimate' =<< changes ballReaction
+  mapM_ (\ballReaction -> reactimate' =<< changes ballReaction) ballReactions
-  reactimate ballVelReaction
+  mapM_ (\ballVelReaction -> reactimate ballVelReaction) ballVelReactions
-  reactimate ballAccReaction
+  mapM_ (\ballAccReaction -> reactimate ballAccReaction) ballAccReactions
   -- reactimate $ whenE mouseClickBehaviour ballMoveReaction
-  reactimate ballMoveReaction
+  mapM_ (\ballMoveReaction -> reactimate ballMoveReaction) ballMoveReactions
   -- reactimate' =<< changes clickReaction
   -- reactimate ballReaction