multiple balls
This commit is contained in:
parent
c0af4e7dd8
commit
e50420d8f6
2 changed files with 188 additions and 116 deletions
|
|
@ -29,6 +29,7 @@ executable frpball
|
|||
, text
|
||||
, stm
|
||||
, mtl
|
||||
, random
|
||||
hs-source-dirs: src
|
||||
ghc-options: -Wall
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
303
src/Main.hs
303
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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue