From e50420d8f6e279f22759f27a246ef6af4d158c37 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 12 Oct 2019 10:34:54 +0200 Subject: [PATCH] multiple balls --- frpball.cabal | 1 + src/Main.hs | 303 +++++++++++++++++++++++++++++++------------------- 2 files changed, 188 insertions(+), 116 deletions(-) diff --git a/frpball.cabal b/frpball.cabal index c9b567d..a0c01ca 100644 --- a/frpball.cabal +++ b/frpball.cabal @@ -29,6 +29,7 @@ executable frpball , text , stm , mtl + , random hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs index b0f9a29..41cf884 100644 --- a/src/Main.hs +++ b/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,50 +98,63 @@ 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 - hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- - toPrimitiveStream id :: - Shader - os - (PrimitiveArray Triangles AttrInput) - (PrimitiveStream Triangles (VertexFormat AttrInput)) - positionUniform <- getUniform (const (positionUniformBuffer, 0)) - let scaleFact = 0.05 - scaleMatrix a = - V4 - (V4 a 0 0 0) - (V4 0 a 0 0) - (V4 0 0 1 0) - (V4 0 0 0 1) - transMatrix (V2 ax ay) = - V4 - (V4 1 0 0 (ax - 1)) - (V4 0 1 0 ((-ay) + 1)) - (V4 0 0 1 1) - (V4 0 0 0 1) - hexFragmentStream <- rasterize - (const - ( FrontAndBack - , ViewPort (V2 0 0) (V2 800 600) - , DepthRange 0 1 - ) - ) - (fmap (\(position, color) -> - ( (transMatrix positionUniform !*! - scaleMatrix scaleFact) !* - position - , color - )) - hexPrimitiveStream) - drawWindowColor - (const - ( win - , ContextColorOption NoBlending (V3 True True True) - ) - ) - hexFragmentStream + hexShaders <- mapM + (\positionUniformBuffer -> + compileShader $ do + hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- + toPrimitiveStream id :: + Shader + os + (PrimitiveArray Triangles AttrInput) + (PrimitiveStream Triangles (VertexFormat AttrInput)) + positionUniform <- getUniform (const (positionUniformBuffer, 0)) + let scaleFact = 0.05 + scaleMatrix a = + V4 + (V4 a 0 0 0) + (V4 0 a 0 0) + (V4 0 0 1 0) + (V4 0 0 0 1) + transMatrix (V2 ax ay) = + V4 + (V4 1 0 0 (ax - 1)) + (V4 0 1 0 ((-ay) + 1)) + (V4 0 0 1 1) + (V4 0 0 0 1) + hexFragmentStream <- rasterize + (const + ( FrontAndBack + , ViewPort (V2 0 0) (V2 800 600) + , DepthRange 0 1 + ) + ) + (fmap (\(position, color) -> + ( (transMatrix positionUniform !*! + scaleMatrix scaleFact) !* + position + , color + )) + hexPrimitiveStream) + drawWindowColor + (const + ( win + , ContextColorOption NoBlending (V3 True True True) + ) + ) + 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] - mtrans <- liftIO $ atomically $ tryReadTMVar transUniVar - writeBuffer positionUniformBuffer 0 [fromMaybe (V2 1 1) mtrans] + 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 - hexShader hexPrimitiveArray + 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 - (ballPosAH, ballPosFire) <- liftIO $ newAddHandler - (ballVelAH, ballVelFire) <- liftIO $ newAddHandler - (ballAccAH, ballAccFire) <- liftIO $ newAddHandler +networkDescription (listenerAH, _) (deltaAH, _) rotvar transvars = mdo + posAHFires <- liftIO $ mapM (const newAddHandler) [1 .. length transvars] + velAHFires <- liftIO $ mapM (const newAddHandler) [1 .. length transvars] + 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 - void $ register ballPosAH (\_ -> return()) - return ballPosAH - ) - ballVel :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do - void $ register ballVelAH (\_ -> return()) - return ballVelAH - ) - ballAcc :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do - void $ register ballAccAH (\_ -> return()) - return ballAccAH - ) + ballPoss :: [Event (V2 Float)] <- mapM + (\(ballPosAH, _) -> + fromAddHandler =<< (liftIO $ do + void $ register ballPosAH (\_ -> return()) + return ballPosAH + ) + ) + posAHFires + ballVels :: [Event (V2 Float)] <- mapM + (\(ballVelAH, _) -> + fromAddHandler =<< (liftIO $ do + void $ register ballVelAH (\_ -> return()) + return ballVelAH + ) + ) + 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 - ballVelBehaviour <- stepper (V2 0 0) ballVel - ballAccBehaviour <- stepper (V2 0 0) ballAcc + ballPosBehaviours <- mapM + (\(ballPos, uni) -> do + 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,57 +342,82 @@ networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo -- print input ) mouseMotionBehaviour - ballReaction = fmap (\x -> do - let input = (fmap (\foo -> foo - 1) x) / V2 400 300 - void $ atomically $ swapTMVar transvar input - -- print input - ) - ballPosBehaviour - ballAccReaction = fmap (\acc -> do - ballAccFire acc - -- print acc - ) $ apply - (liftA2 - (\mmPos bPos -> (\delta -> case mmPos of - Just mPos -> fmap (* 0.99) (mPos - bPos) - Nothing -> V2 0 0 - )) - mouseClickPosBehaviour - ballPosBehaviour - ) - delta - ballVelReaction = fmap (\vel -> - ballVelFire vel - ) $ apply - (liftA2 - (\acc vel -> (\dtime -> fmap (* dtime) acc + vel)) - ballAccBehaviour - ballVelBehaviour - ) - delta - ballMoveReaction = fmap (\x -> do - ballPosFire x - -- print x - ) $ apply - (liftA3 - (\bPos bVel bAcc -> - (\dtime -> (fmap (* (dtime * 0.5)) bAcc) + - (fmap (* dtime) bVel) + - bPos - ) + ballReactions = map + (\(ballPosBehaviour, uni) -> + fmap + (\x -> do + let input = (fmap (\foo -> foo - 1) x) / V2 400 300 + void $ atomically $ swapTMVar uni input + -- print input ) - ballPosBehaviour - ballVelBehaviour - ballAccBehaviour + ballPosBehaviour + ) + (zip ballPosBehaviours transvars) + ballAccReactions = map + (\((_, ballAccFire), ballPosBehaviour) -> + fmap + (\acc -> do + ballAccFire acc + -- print acc + ) $ apply + (liftA2 + (\mmPos bPos -> (\delta -> case mmPos of + Just mPos -> fmap (* 0.99) (mPos - bPos) + Nothing -> V2 0 0 + )) + mouseClickPosBehaviour + ballPosBehaviour + ) + delta + ) + (zip accAHFires ballPosBehaviours) + ballVelReactions = map + (\((_, ballVelFire), ballAccBehaviour, ballVelBehaviour) -> + fmap + (\vel -> + ballVelFire vel + ) $ apply + (liftA2 + (\acc vel -> (\dtime -> fmap (* dtime) acc + vel)) + ballAccBehaviour + ballVelBehaviour + ) + delta + ) + (zip3 velAHFires ballAccBehaviours ballVelBehaviours) + ballMoveReactions = map + (\( ( _ + , ballPosFire ) - delta + , ballPosBehaviour + , ballVelBehaviour + , ballAccBehaviour) -> + fmap + (\x -> do + ballPosFire x + -- print x + ) (apply + (liftA3 + (\bPos bVel bAcc -> + (\dtime -> (fmap (* (dtime * 0.5)) bAcc) + + (fmap (* dtime) bVel) + + bPos + ) + ) + ballPosBehaviour + ballVelBehaviour + ballAccBehaviour + ) + delta) + ) + (zip4 posAHFires ballPosBehaviours ballVelBehaviours ballAccBehaviours) reactimate' =<< changes triangleReaction - reactimate' =<< changes ballReaction - reactimate ballVelReaction - reactimate ballAccReaction + mapM_ (\ballReaction -> reactimate' =<< changes ballReaction) ballReactions + mapM_ (\ballVelReaction -> reactimate ballVelReaction) ballVelReactions + mapM_ (\ballAccReaction -> reactimate ballAccReaction) ballAccReactions -- reactimate $ whenE mouseClickBehaviour ballMoveReaction - reactimate ballMoveReaction + mapM_ (\ballMoveReaction -> reactimate ballMoveReaction) ballMoveReactions -- reactimate' =<< changes clickReaction -- reactimate ballReaction