From 5e5c140052fe156a393e1858928d113a938b2fad Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 29 Sep 2019 15:01:00 +0200 Subject: [PATCH] move ball on click --- src/Main.hs | 111 +++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 84 insertions(+), 27 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index b52695d..8e86b07 100644 --- a/src/Main.hs +++ b/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