This commit is contained in:
nek0 2019-10-10 06:13:51 +02:00
parent 6a4f1abe8c
commit 1f574a3e40
1 changed files with 178 additions and 57 deletions

View File

@ -176,11 +176,13 @@ main = do
fragmentStream
-- SDL.showWindow window
listen@(_, fire) <- liftIO $ newAddHandler
listen@(_, eventFire) <- liftIO $ newAddHandler
deltaTimer@(_, deltaFire) <- liftIO $ newAddHandler
uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float)
transUniVar <- liftIO $ newTMVarIO (V2 1 1) ::
ContextT FRPBallCtx os IO (TMVar (V2 Float))
network <- liftIO $ compile (networkDescription listen uniVar transUniVar)
transUniVar :: TMVar (V2 Float) <- liftIO $ newTMVarIO (V2 1 1)
deltaVar :: TMVar Float <- liftIO (newTMVarIO =<< SDL.time)
network <- liftIO $ compile
(networkDescription listen deltaTimer uniVar transUniVar)
forever $ do
mrot <- liftIO $ atomically $ tryReadTMVar uniVar
writeBuffer uniformBuffer 0 [fromMaybe 0 mrot]
@ -198,57 +200,151 @@ main = do
swapWindowBuffers win
liftIO $ do
evs <- SDL.pollEvents
fire evs
currentTime :: Float <- SDL.time
oldTime <- fromMaybe (currentTime - 0.1) <$>
(atomically $ tryReadTMVar deltaVar)
eventFire evs
deltaFire (currentTime - oldTime)
atomically $ swapTMVar deltaVar currentTime
networkDescription
:: (AddHandler [SDL.Event], b)
:: (AddHandler [SDL.Event], ([SDL.Event] -> IO ()))
-> (AddHandler Float, (Float -> IO ()))
-> TMVar Float
-> TMVar (V2 Float)
-> MomentIO ()
networkDescription (listenerah, _) rotvar transvar = mdo
(mouseah, mousefire) <- liftIO $ newAddHandler
(passah, passfire) <- liftIO $ newAddHandler
(clickholdah, clickholdfire) <- liftIO $ newAddHandler
blistener <- fromChanges [] =<< registerListenerEvent
listenerah
mousefire
clickholdfire
_ <- changes blistener
emouse <- fromAddHandler =<< registerMouseEvent passfire mouseah
epass <- fromAddHandler =<< registerPassEvent passah
eClickHold <- fromAddHandler =<< registerClickHoldEvent passfire 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 x
networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo
(ballPosAH, ballPosFire) <- liftIO $ newAddHandler
(ballVelAH, ballVelFire) <- liftIO $ newAddHandler
(ballAccAH, ballAccFire) <- liftIO $ newAddHandler
(mousePosAH, mousePosFire) <- liftIO $ newAddHandler
(mouseMotionAH, mouseMotionFire) <- liftIO $ newAddHandler
(mouseClickAH, mouseClickFire) <- liftIO $ newAddHandler
(mouseReleaseAH, mouseReleaseFire) <- liftIO $ newAddHandler
(mouseClickPosAH, mouseClickPosFire) <- liftIO $ newAddHandler
ballPos :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do
void $ register ballPosAH (\_ -> return())
return ballPosAH
)
ballVel :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do
void $ register ballVelAH (\_ -> return())
return ballVelAH
)
ballAcc :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do
void $ register ballAccAH (\_ -> return())
return ballAccAH
)
mousePos :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do
void $ register mousePosAH (\_ -> return())
return mousePosAH
)
mouseMotion :: Event (V2 Float) <- fromAddHandler =<< (liftIO $ do
void $ register mouseMotionAH (\_ -> return())
return mouseMotionAH
)
mouseClick :: Event Bool <- fromAddHandler =<< (liftIO $ do
void $ register mouseClickAH (\_ -> do
SDL.P vect <- SDL.getAbsoluteMouseLocation
mousePosFire $ fmap fromIntegral vect
)
return mouseClickAH
)
mouseRelease :: Event Bool <- fromAddHandler =<< (liftIO $ do
void $ register mouseReleaseAH (\_ -> do
SDL.P vect <- SDL.getAbsoluteMouseLocation
mousePosFire $ fmap fromIntegral vect
)
return mouseReleaseAH
)
listener :: Event [SDL.Event] <- fromAddHandler =<< (liftIO $ do
void $ register listenerAH
(registerListenerEvent
mousePosFire
mouseMotionFire
mouseClickFire
mouseReleaseFire
)
return listenerAH
)
delta :: Event Float <- fromAddHandler =<< (liftIO $ do
void $ register deltaAH (\_ -> return ())
return deltaAH
)
let mouseClickPos :: Event (V2 Float) = whenE mouseClickBehaviour mousePos
ballPosBehaviour <- stepper (V2 400 300) ballPos
ballVelBehaviour <- stepper (V2 0 0) ballVel
ballAccBehaviour <- stepper (V2 0 0) ballAcc
mousePosBehaviour <- stepper (V2 0 0) mousePos
mouseMotionBehaviour <- stepper (V2 0 0) mouseMotion
mouseClickBehaviour <- stepper False mouseClick
mouseReleaseBehaviour <- stepper True mouseRelease
mouseClickPosBehaviour <- stepper (V2 0 0) mouseClickPos
ball :: V2 Float <- valueB ballPosBehaviour
let triangleReaction = fmap (\x -> do
let input = (\(V2 xx _) -> xx / 100 :: Float) x
past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar)
void $ atomically $ swapTMVar rotvar (past + input)
print input)
emouse
clickReaction = fmap (\x -> do
-- print input
)
mouseMotionBehaviour
ballReaction = fmap (\x -> do
let input = (fmap (\foo -> foo - 1) x) / V2 400 300
void $ atomically $ swapTMVar transvar input
-- print input)
-- print input
)
mouseMoveBehaviour
printReaction = fmap print blistener
ecPrint <- changes printReaction
reactimate' ecPrint
reactimate moveReaction
ecReaction <- changes clickReaction
reactimate' $ whenE clickHoldBehaviour ecReaction
ballPosBehaviour
ballAccReaction = fmap (\acc ->
ballAccFire acc
)
(liftA2
(\mPos bPos -> mPos - bPos)
mousePosBehaviour
ballPosBehaviour
)
ballVelReaction = fmap (\vel ->
ballVelFire vel
) $
apply
(pure (\acc -> (\dtime -> fmap (/ dtime) acc)) <*> ballAccBehaviour)
delta
ballMoveReaction = fmap (\x -> do
ballPosFire x
print x
) $ apply
(liftA2
(\bPos bVel ->
(\dtime -> bPos + (fmap (dtime *) bVel))
)
ballPosBehaviour
ballVelBehaviour
)
delta
reactimate' =<< changes triangleReaction
reactimate' =<< changes ballReaction
reactimate ballVelReaction
reactimate $ whenE mouseClickBehaviour ballMoveReaction
-- reactimate' =<< changes clickReaction
-- reactimate ballReaction
-- ecPrint <- changes printReaction
-- reactimate' ecPrint
-- reactimate moveReaction
-- ecReaction <- changes clickReaction
-- reactimate' $ whenE clickHoldBehaviour ecReaction
registerListenerEvent
:: (MonadIO m)
=> AddHandler ([SDL.Event])
->(SDL.Event -> IO ())
:: (V2 Float -> IO ())
-> (V2 Float -> IO ())
-> (Bool -> IO ())
-> m (AddHandler [SDL.Event])
registerListenerEvent listenerah mousefire clickholdfire = do
void $ liftIO $
register listenerah $ \evs -> do
-> (Bool -> IO ())
-> ([SDL.Event] -> IO ())
registerListenerEvent mousePosFire mouseMotionFire mouseClickFire mouseReleaseFire =
\evs -> do
let filteredMoveEvents = filter (\ev -> case SDL.eventPayload ev of
SDL.MouseMotionEvent
(SDL.MouseMotionEventData _ _ _ _ _) ->
@ -256,26 +352,44 @@ registerListenerEvent listenerah mousefire clickholdfire = do
_ -> False
) evs
filteredClickEvents = filter (\ev -> case SDL.eventPayload ev of
-- SDL.MouseMotionEvent
-- (SDL.MouseMotionEventData _ _ [SDL.ButtonLeft] _ _) ->
-- True
SDL.MouseMotionEvent
(SDL.MouseMotionEventData _ _ [SDL.ButtonLeft] _ _) ->
True
SDL.MouseButtonEvent
(SDL.MouseButtonEventData _ _ _ SDL.ButtonLeft _ _) ->
(SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonLeft _ _) ->
True
_ -> False
) evs
filteredReleaseEvents = filter (\ev -> case SDL.eventPayload ev of
SDL.MouseButtonEvent
(SDL.MouseButtonEventData _ SDL.Released _ SDL.ButtonLeft _ _) ->
True
_ -> False
) evs
if null filteredMoveEvents
then return ()
else mousefire (head $ filteredMoveEvents)
if null filteredClickEvents
then
return ()
else
clickholdfire
(any (\x -> SDL.Pressed == SDL.mouseButtonEventMotion
((\(SDL.MouseButtonEvent dat) -> dat) $
SDL.eventPayload x)) filteredClickEvents)
return listenerah
then do
mouseMotionFire (V2 0 0)
else do
mouseMotionFire $
(\(SDL.Event _ (SDL.MouseMotionEvent dat)) ->
fmap fromIntegral (SDL.mouseMotionEventRelMotion dat)
)
(head $ filteredMoveEvents)
mousePosFire $
(\(SDL.Event _ (SDL.MouseMotionEvent dat)) ->
(\(SDL.P a) -> fmap fromIntegral a) (SDL.mouseMotionEventPos dat)
)
(head $ filteredMoveEvents)
if not (null filteredClickEvents)
then do
mouseClickFire True
mouseReleaseFire False
else if not (null filteredReleaseEvents)
then do
mouseClickFire False
mouseReleaseFire True
else
return ()
registerMouseEvent
:: MonadIO m
@ -312,3 +426,10 @@ registerClickHoldEvent passfire clickholdah = do
SDL.P vect <- SDL.getAbsoluteMouseLocation
passfire $ fmap fromIntegral vect
return clickholdah
plainChanges :: Behavior a -> MomentIO (Event a)
plainChanges b = do
(e, handle) <- newEvent
eb <- changes b
reactimate' $ (fmap handle) <$> eb
return e