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 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