move ball on click

This commit is contained in:
nek0 2019-09-29 15:01:00 +02:00
parent 84c5951625
commit 5e5c140052

View file

@ -69,30 +69,31 @@ main = do
0 0
[ (V4 (-1/2) 1 0 1, V3 1 0 0) [ (V4 (-1/2) 1 0 1, V3 1 0 0)
, (V4 (1/2) 1 0 1, V3 1 0 0) , (V4 (1/2) 1 0 1, V3 1 0 0)
, (V4 0 0 0 0, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0)
, (V4 (1/2) 1 0 1, V3 1 0 0) , (V4 (1/2) 1 0 1, V3 1 0 0)
, (V4 1 0 0 1, V3 1 0 0) , (V4 1 0 0 1, V3 1 0 0)
, (V4 0 0 0 0, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0)
, (V4 1 0 0 1, V3 1 0 0) , (V4 1 0 0 1, V3 1 0 0)
, (V4 (1/2) (-1) 0 1, V3 1 0 0) , (V4 (1/2) (-1) 0 1, V3 1 0 0)
, (V4 0 0 0 0, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0)
, (V4 (1/2) (-1) 0 1, V3 1 0 0) , (V4 (1/2) (-1) 0 1, V3 1 0 0)
, (V4 (-1/2) (-1) 0 1, V3 1 0 0) , (V4 (-1/2) (-1) 0 1, V3 1 0 0)
, (V4 0 0 0 0, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0)
, (V4 (-1/2) (-1) 0 1, V3 1 0 0) , (V4 (-1/2) (-1) 0 1, V3 1 0 0)
, (V4 (-1) 0 0 1, V3 1 0 0) , (V4 (-1) 0 0 1, V3 1 0 0)
, (V4 0 0 0 0, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0)
, (V4 (-1) 0 0 1, V3 1 0 0) , (V4 (-1) 0 0 1, V3 1 0 0)
, (V4 (-1/2) 1 0 1, V3 1 0 0) , (V4 (-1/2) 1 0 1, V3 1 0 0)
, (V4 0 0 0 0, V3 1 0 0) , (V4 0 0 0 1, V3 1 0 0)
] ]
uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1 uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1
positionUniformBuffer :: Buffer os (Uniform (B2 Float)) <- newBuffer 1
hexShader <- compileShader $ do hexShader <- compileShader $ do
hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <-
@ -101,11 +102,20 @@ main = do
os os
(PrimitiveArray Triangles AttrInput) (PrimitiveArray Triangles AttrInput)
(PrimitiveStream Triangles (VertexFormat AttrInput)) (PrimitiveStream Triangles (VertexFormat AttrInput))
positionUniform <- getUniform (const (positionUniformBuffer, 0))
let scaleFact = 0.05 let scaleFact = 0.05
scaleMatrix a = V4 (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)
(V4 0 0 1 0)
(V4 0 0 0 1)
transMatrix (V2 ax ay) =
V4
(V4 1 0 0 ax)
(V4 0 1 0 (-ay))
(V4 0 0 1 1)
(V4 0 0 0 1)
hexFragmentStream <- rasterize hexFragmentStream <- rasterize
(const (const
( FrontAndBack ( FrontAndBack
@ -113,7 +123,12 @@ main = do
, DepthRange 0 1 , DepthRange 0 1
) )
) )
(fmap (\(position, color) -> (scaleMatrix scaleFact !* position, color)) (fmap (\(position, color) ->
( (transMatrix positionUniform !*!
scaleMatrix scaleFact) !*
position
, color
))
hexPrimitiveStream) hexPrimitiveStream)
drawWindowColor drawWindowColor
(const (const
@ -130,7 +145,7 @@ main = do
os os
(PrimitiveArray Triangles AttrInput) (PrimitiveArray Triangles AttrInput)
(PrimitiveStream Triangles (VertexFormat AttrInput)) (PrimitiveStream Triangles (VertexFormat AttrInput))
uniform <- getUniform (const (uniformBuffer,0)) uniform <- getUniform (const (uniformBuffer, 0))
let primitiveStream2 = fmap let primitiveStream2 = fmap
(\(position, color) -> (position - V4 1 1 0 0, color / 10)) (\(position, color) -> (position - V4 1 1 0 0, color / 10))
primitiveStream primitiveStream
@ -162,10 +177,14 @@ main = do
-- SDL.showWindow window -- SDL.showWindow window
listen@(_, fire) <- liftIO $ newAddHandler listen@(_, fire) <- liftIO $ newAddHandler
uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float) uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float)
network <- liftIO $ compile (networkDescription listen uniVar) transUniVar <- liftIO $ newTMVarIO (V2 0 0) ::
ContextT FRPBallCtx os IO (TMVar (V2 Float))
network <- liftIO $ compile (networkDescription listen uniVar transUniVar)
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
writeBuffer positionUniformBuffer 0 [fromMaybe (V2 0 0) mtrans]
liftIO $ actuate network liftIO $ actuate network
render $ do render $ do
clearWindowColor win (V3 0 0 0) clearWindowColor win (V3 0 0 0)
@ -183,34 +202,64 @@ main = do
networkDescription networkDescription
:: (AddHandler [SDL.Event], b) :: (AddHandler [SDL.Event], b)
-> TMVar Float -> TMVar Float
-> TMVar (V2 Float)
-> MomentIO () -> MomentIO ()
networkDescription (listenerah, _) univar = mdo networkDescription (listenerah, _) rotvar transvar = mdo
(mouseah, mousefire) <- liftIO $ newAddHandler (mouseah, mousefire) <- liftIO $ newAddHandler
blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire (clickah, clickfire) <- liftIO $ newAddHandler
blistener <- fromChanges [] =<< registerListenerEvent
listenerah
mousefire
clickfire
_ <- changes blistener _ <- changes blistener
emouse <- fromAddHandler =<< registerMouseEvent mouseah emouse <- fromAddHandler =<< registerMouseEvent mouseah
let reaction = fmap (\x -> do eclick <- fromAddHandler =<< registerClickEvent clickah
let moveReaction = fmap (\x -> do
let input = (\(V2 xx _) -> let input = (\(V2 xx _) ->
fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $ fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $
(\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head x (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head x
past <- fromMaybe 0 <$> (atomically $ tryReadTMVar univar) past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar)
void $ atomically $ swapTMVar univar (past + input) void $ atomically $ swapTMVar rotvar (past + input)
print input) emouse print input)
reactimate reaction emouse
clickReaction = fmap (\x -> do
let input =
(\vect -> fmap (\foo -> foo - 1) (vect / V2 400 300)) $
(\(SDL.MouseButtonEvent (SDL.MouseButtonEventData _ _ _ _ _ (SDL.P ps))) ->
fmap fromIntegral ps :: V2 Float) $
SDL.eventPayload $
head x
void $ atomically $ swapTMVar transvar input
print input)
eclick
reactimate moveReaction
reactimate clickReaction
registerListenerEvent registerListenerEvent
:: (MonadIO m) :: (MonadIO m)
=> AddHandler ([SDL.Event]) => AddHandler ([SDL.Event])
-> ([SDL.Event] -> IO ()) -> ([SDL.Event] -> IO ())
-> ([SDL.Event] -> IO ())
-> m (AddHandler [SDL.Event]) -> m (AddHandler [SDL.Event])
registerListenerEvent listenerah mousefire = do registerListenerEvent listenerah mousefire clickfire = do
_ <- liftIO $ do void $ liftIO $
register listenerah $ \evs -> do register listenerah $ \evs -> do
let fevs = filter (\ev -> case SDL.eventPayload ev of let filteredMoveEvents = filter (\ev -> case SDL.eventPayload ev of
SDL.MouseMotionEvent _ -> True SDL.MouseMotionEvent _ -> True
_ -> False _ -> False
) evs ) evs
if null fevs then return () else mousefire fevs filteredClickEvents = filter (\ev -> case SDL.eventPayload ev of
SDL.MouseButtonEvent
(SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonLeft 1 _) ->
True
_ -> False
) evs
if null filteredMoveEvents
then return ()
else mousefire filteredMoveEvents
if null filteredClickEvents
then return ()
else clickfire filteredClickEvents
return listenerah return listenerah
registerMouseEvent registerMouseEvent
@ -218,5 +267,13 @@ registerMouseEvent
=> AddHandler [SDL.Event] => AddHandler [SDL.Event]
-> m (AddHandler [SDL.Event]) -> m (AddHandler [SDL.Event])
registerMouseEvent mouseah = do registerMouseEvent mouseah = do
_ <- liftIO $ register mouseah $ \_ -> return () void $ liftIO $ register mouseah $ \_ -> return ()
return mouseah return mouseah
registerClickEvent
:: MonadIO m
=> AddHandler [SDL.Event]
-> m (AddHandler [SDL.Event])
registerClickEvent clickah = do
void $ liftIO $ register clickah $ \_ -> return ()
return clickah