move ball on click
This commit is contained in:
parent
84c5951625
commit
5e5c140052
1 changed files with 84 additions and 27 deletions
111
src/Main.hs
111
src/Main.hs
|
|
@ -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)
|
||||
(V4 0 a 0 0)
|
||||
(V4 0 0 1 0)
|
||||
(V4 0 0 0 1)
|
||||
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
|
||||
(mouseah, mousefire) <- liftIO $ newAddHandler
|
||||
blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
|
||||
networkDescription (listenerah, _) rotvar transvar = mdo
|
||||
(mouseah, mousefire) <- liftIO $ newAddHandler
|
||||
(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
|
||||
_ -> 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
|
||||
|
|
|
|||
Loading…
Reference in a new issue