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