multiple balls

This commit is contained in:
nek0 2019-10-12 10:34:54 +02:00
parent c0af4e7dd8
commit e50420d8f6
2 changed files with 188 additions and 116 deletions

View file

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

View file

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