From 409b56f8465727b9892eedd6787821c17ebfcefe Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 29 Sep 2019 18:15:04 +0200 Subject: [PATCH] drag ball around per click --- src/Main.hs | 82 ++++++++++++++++++++++++++++++----------------------- 1 file changed, 47 insertions(+), 35 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 8e86b07..7da50c9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,6 +19,7 @@ import Control.Monad import Control.Monad.Trans import Reactive.Banana.Frameworks as RBF +import Reactive.Banana.Combinators as RBC import Data.Maybe (fromMaybe) @@ -112,8 +113,8 @@ main = do (V4 0 0 0 1) transMatrix (V2 ax ay) = V4 - (V4 1 0 0 ax) - (V4 0 1 0 (-ay)) + (V4 1 0 0 (ax - 1)) + (V4 0 1 0 ((-ay) + 1)) (V4 0 0 1 1) (V4 0 0 0 1) hexFragmentStream <- rasterize @@ -177,14 +178,14 @@ main = do -- SDL.showWindow window listen@(_, fire) <- liftIO $ newAddHandler uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float) - transUniVar <- liftIO $ newTMVarIO (V2 0 0) :: + transUniVar <- liftIO $ newTMVarIO (V2 1 1) :: 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] + writeBuffer positionUniformBuffer 0 [fromMaybe (V2 1 1) mtrans] liftIO $ actuate network render $ do clearWindowColor win (V3 0 0 0) @@ -206,42 +207,41 @@ networkDescription -> MomentIO () networkDescription (listenerah, _) rotvar transvar = mdo (mouseah, mousefire) <- liftIO $ newAddHandler - (clickah, clickfire) <- liftIO $ newAddHandler + (passah, passfire) <- liftIO $ newAddHandler + (clickholdah, clickholdfire) <- liftIO $ newAddHandler blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire - clickfire + clickholdfire _ <- changes blistener - emouse <- fromAddHandler =<< registerMouseEvent mouseah - eclick <- fromAddHandler =<< registerClickEvent clickah + emouse <- fromAddHandler =<< registerMouseEvent passfire mouseah + epass <- fromAddHandler =<< registerPassEvent passah + eClickHold <- fromAddHandler =<< registerClickHoldEvent clickholdah + clickHoldBehaviour <- RBC.stepper False eClickHold + mouseMoveBehaviour <- RBC.stepper (V2 1 1) epass let moveReaction = fmap (\x -> do let input = (\(V2 xx _) -> fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $ - (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head x + (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload x 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 + let input = (fmap (\foo -> foo - 1) x) / V2 400 300 void $ atomically $ swapTMVar transvar input print input) - eclick + mouseMoveBehaviour reactimate moveReaction - reactimate clickReaction + reactimate' =<< (whenE clickHoldBehaviour <$> changes clickReaction) registerListenerEvent :: (MonadIO m) => AddHandler ([SDL.Event]) - -> ([SDL.Event] -> IO ()) - -> ([SDL.Event] -> IO ()) + ->(SDL.Event -> IO ()) + -> (Bool -> IO ()) -> m (AddHandler [SDL.Event]) -registerListenerEvent listenerah mousefire clickfire = do +registerListenerEvent listenerah mousefire clickholdfire = do void $ liftIO $ register listenerah $ \evs -> do let filteredMoveEvents = filter (\ev -> case SDL.eventPayload ev of @@ -249,31 +249,43 @@ registerListenerEvent listenerah mousefire clickfire = do _ -> False ) evs filteredClickEvents = filter (\ev -> case SDL.eventPayload ev of - SDL.MouseButtonEvent - (SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonLeft 1 _) -> + SDL.MouseMotionEvent + (SDL.MouseMotionEventData _ _ [SDL.ButtonLeft] _ _) -> True _ -> False ) evs if null filteredMoveEvents then return () - else mousefire filteredMoveEvents + else mousefire (head $ reverse $ filteredMoveEvents) if null filteredClickEvents - then return () - else clickfire filteredClickEvents + then clickholdfire False + else clickholdfire True return listenerah registerMouseEvent :: MonadIO m - => AddHandler [SDL.Event] - -> m (AddHandler [SDL.Event]) -registerMouseEvent mouseah = do - void $ liftIO $ register mouseah $ \_ -> return () + => (V2 Float -> IO ()) + -> AddHandler SDL.Event + -> m (AddHandler SDL.Event) +registerMouseEvent passFire mouseah = do + void $ liftIO $ register mouseah $ + \(SDL.Event _ (SDL.MouseMotionEvent dat)) -> + passFire (fmap fromIntegral $ (\(SDL.P a) -> a) $ + SDL.mouseMotionEventPos dat) return mouseah -registerClickEvent +registerPassEvent :: MonadIO m - => AddHandler [SDL.Event] - -> m (AddHandler [SDL.Event]) -registerClickEvent clickah = do - void $ liftIO $ register clickah $ \_ -> return () - return clickah + => AddHandler (V2 Float) + -> m (AddHandler (V2 Float)) +registerPassEvent passah = do + void $ liftIO $ register passah $ \_ -> return () + return passah + +registerClickHoldEvent + :: MonadIO m + => AddHandler Bool + -> m (AddHandler Bool) +registerClickHoldEvent clickholdah = do + void $ liftIO $ register clickholdah $ \_ -> return () + return clickholdah