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,50 +98,63 @@ 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
hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- (\positionUniformBuffer ->
toPrimitiveStream id :: compileShader $ do
Shader hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <-
os toPrimitiveStream id ::
(PrimitiveArray Triangles AttrInput) Shader
(PrimitiveStream Triangles (VertexFormat AttrInput)) os
positionUniform <- getUniform (const (positionUniformBuffer, 0)) (PrimitiveArray Triangles AttrInput)
let scaleFact = 0.05 (PrimitiveStream Triangles (VertexFormat AttrInput))
scaleMatrix a = positionUniform <- getUniform (const (positionUniformBuffer, 0))
V4 let scaleFact = 0.05
(V4 a 0 0 0) scaleMatrix a =
(V4 0 a 0 0) V4
(V4 0 0 1 0) (V4 a 0 0 0)
(V4 0 0 0 1) (V4 0 a 0 0)
transMatrix (V2 ax ay) = (V4 0 0 1 0)
V4 (V4 0 0 0 1)
(V4 1 0 0 (ax - 1)) transMatrix (V2 ax ay) =
(V4 0 1 0 ((-ay) + 1)) V4
(V4 0 0 1 1) (V4 1 0 0 (ax - 1))
(V4 0 0 0 1) (V4 0 1 0 ((-ay) + 1))
hexFragmentStream <- rasterize (V4 0 0 1 1)
(const (V4 0 0 0 1)
( FrontAndBack hexFragmentStream <- rasterize
, ViewPort (V2 0 0) (V2 800 600) (const
, DepthRange 0 1 ( FrontAndBack
) , ViewPort (V2 0 0) (V2 800 600)
) , DepthRange 0 1
(fmap (\(position, color) -> )
( (transMatrix positionUniform !*! )
scaleMatrix scaleFact) !* (fmap (\(position, color) ->
position ( (transMatrix positionUniform !*!
, color scaleMatrix scaleFact) !*
)) position
hexPrimitiveStream) , color
drawWindowColor ))
(const hexPrimitiveStream)
( win drawWindowColor
, ContextColorOption NoBlending (V3 True True True) (const
) ( win
) , ContextColorOption NoBlending (V3 True True True)
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]
mtrans <- liftIO $ atomically $ tryReadTMVar transUniVar mapM_
writeBuffer positionUniformBuffer 0 [fromMaybe (V2 1 1) mtrans] (\(transUniVar, positionUniformBuffer) -> do
mtrans <- liftIO $ atomically $ tryReadTMVar transUniVar
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
hexShader hexPrimitiveArray mapM_
(\hexShader ->
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
void $ register ballPosAH (\_ -> return()) (\(ballPosAH, _) ->
return ballPosAH fromAddHandler =<< (liftIO $ do
) void $ register ballPosAH (\_ -> return())
ballVel :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do return ballPosAH
void $ register ballVelAH (\_ -> return()) )
return ballVelAH )
) posAHFires
ballAcc :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do ballVels :: [Event (V2 Float)] <- mapM
void $ register ballAccAH (\_ -> return()) (\(ballVelAH, _) ->
return ballAccAH 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 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,57 +342,82 @@ networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo
-- print input -- print input
) )
mouseMotionBehaviour mouseMotionBehaviour
ballReaction = fmap (\x -> do ballReactions = map
let input = (fmap (\foo -> foo - 1) x) / V2 400 300 (\(ballPosBehaviour, uni) ->
void $ atomically $ swapTMVar transvar input fmap
-- print input (\x -> do
) let input = (fmap (\foo -> foo - 1) x) / V2 400 300
ballPosBehaviour void $ atomically $ swapTMVar uni input
ballAccReaction = fmap (\acc -> do -- print input
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
)
) )
ballPosBehaviour ballPosBehaviour
ballVelBehaviour )
ballAccBehaviour (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 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