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
, stm
, mtl
, random
hs-source-dirs: src
ghc-options: -Wall
default-language: Haskell2010

View file

@ -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