drag ball around per click

This commit is contained in:
nek0 2019-09-29 18:15:04 +02:00
parent 5e5c140052
commit 409b56f846

View file

@ -19,6 +19,7 @@ import Control.Monad
import Control.Monad.Trans import Control.Monad.Trans
import Reactive.Banana.Frameworks as RBF import Reactive.Banana.Frameworks as RBF
import Reactive.Banana.Combinators as RBC
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@ -112,8 +113,8 @@ main = do
(V4 0 0 0 1) (V4 0 0 0 1)
transMatrix (V2 ax ay) = transMatrix (V2 ax ay) =
V4 V4
(V4 1 0 0 ax) (V4 1 0 0 (ax - 1))
(V4 0 1 0 (-ay)) (V4 0 1 0 ((-ay) + 1))
(V4 0 0 1 1) (V4 0 0 1 1)
(V4 0 0 0 1) (V4 0 0 0 1)
hexFragmentStream <- rasterize hexFragmentStream <- rasterize
@ -177,14 +178,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)
transUniVar <- liftIO $ newTMVarIO (V2 0 0) :: transUniVar <- liftIO $ newTMVarIO (V2 1 1) ::
ContextT FRPBallCtx os IO (TMVar (V2 Float)) ContextT FRPBallCtx os IO (TMVar (V2 Float))
network <- liftIO $ compile (networkDescription listen uniVar transUniVar) 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 mtrans <- liftIO $ atomically $ tryReadTMVar transUniVar
writeBuffer positionUniformBuffer 0 [fromMaybe (V2 0 0) mtrans] writeBuffer positionUniformBuffer 0 [fromMaybe (V2 1 1) mtrans]
liftIO $ actuate network liftIO $ actuate network
render $ do render $ do
clearWindowColor win (V3 0 0 0) clearWindowColor win (V3 0 0 0)
@ -206,42 +207,41 @@ networkDescription
-> MomentIO () -> MomentIO ()
networkDescription (listenerah, _) rotvar transvar = mdo networkDescription (listenerah, _) rotvar transvar = mdo
(mouseah, mousefire) <- liftIO $ newAddHandler (mouseah, mousefire) <- liftIO $ newAddHandler
(clickah, clickfire) <- liftIO $ newAddHandler (passah, passfire) <- liftIO $ newAddHandler
(clickholdah, clickholdfire) <- liftIO $ newAddHandler
blistener <- fromChanges [] =<< registerListenerEvent blistener <- fromChanges [] =<< registerListenerEvent
listenerah listenerah
mousefire mousefire
clickfire clickholdfire
_ <- changes blistener _ <- changes blistener
emouse <- fromAddHandler =<< registerMouseEvent mouseah emouse <- fromAddHandler =<< registerMouseEvent passfire mouseah
eclick <- fromAddHandler =<< registerClickEvent clickah 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 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 x
past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar) past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar)
void $ atomically $ swapTMVar rotvar (past + input) void $ atomically $ swapTMVar rotvar (past + input)
print input) print input)
emouse emouse
clickReaction = fmap (\x -> do clickReaction = fmap (\x -> do
let input = let input = (fmap (\foo -> foo - 1) x) / V2 400 300
(\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 void $ atomically $ swapTMVar transvar input
print input) print input)
eclick mouseMoveBehaviour
reactimate moveReaction reactimate moveReaction
reactimate clickReaction reactimate' =<< (whenE clickHoldBehaviour <$> changes clickReaction)
registerListenerEvent registerListenerEvent
:: (MonadIO m) :: (MonadIO m)
=> AddHandler ([SDL.Event]) => AddHandler ([SDL.Event])
-> ([SDL.Event] -> IO ()) ->(SDL.Event -> IO ())
-> ([SDL.Event] -> IO ()) -> (Bool -> IO ())
-> m (AddHandler [SDL.Event]) -> m (AddHandler [SDL.Event])
registerListenerEvent listenerah mousefire clickfire = do registerListenerEvent listenerah mousefire clickholdfire = do
void $ liftIO $ void $ liftIO $
register listenerah $ \evs -> do register listenerah $ \evs -> do
let filteredMoveEvents = filter (\ev -> case SDL.eventPayload ev of let filteredMoveEvents = filter (\ev -> case SDL.eventPayload ev of
@ -249,31 +249,43 @@ registerListenerEvent listenerah mousefire clickfire = do
_ -> False _ -> False
) evs ) evs
filteredClickEvents = filter (\ev -> case SDL.eventPayload ev of filteredClickEvents = filter (\ev -> case SDL.eventPayload ev of
SDL.MouseButtonEvent SDL.MouseMotionEvent
(SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonLeft 1 _) -> (SDL.MouseMotionEventData _ _ [SDL.ButtonLeft] _ _) ->
True True
_ -> False _ -> False
) evs ) evs
if null filteredMoveEvents if null filteredMoveEvents
then return () then return ()
else mousefire filteredMoveEvents else mousefire (head $ reverse $ filteredMoveEvents)
if null filteredClickEvents if null filteredClickEvents
then return () then clickholdfire False
else clickfire filteredClickEvents else clickholdfire True
return listenerah return listenerah
registerMouseEvent registerMouseEvent
:: MonadIO m :: MonadIO m
=> AddHandler [SDL.Event] => (V2 Float -> IO ())
-> m (AddHandler [SDL.Event]) -> AddHandler SDL.Event
registerMouseEvent mouseah = do -> m (AddHandler SDL.Event)
void $ liftIO $ register mouseah $ \_ -> return () 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 return mouseah
registerClickEvent registerPassEvent
:: MonadIO m :: MonadIO m
=> AddHandler [SDL.Event] => AddHandler (V2 Float)
-> m (AddHandler [SDL.Event]) -> m (AddHandler (V2 Float))
registerClickEvent clickah = do registerPassEvent passah = do
void $ liftIO $ register clickah $ \_ -> return () void $ liftIO $ register passah $ \_ -> return ()
return clickah return passah
registerClickHoldEvent
:: MonadIO m
=> AddHandler Bool
-> m (AddHandler Bool)
registerClickHoldEvent clickholdah = do
void $ liftIO $ register clickholdah $ \_ -> return ()
return clickholdah