FRP!
This commit is contained in:
parent
6a4f1abe8c
commit
1f574a3e40
1 changed files with 178 additions and 57 deletions
233
src/Main.hs
233
src/Main.hs
|
|
@ -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 ()
|
||||
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
|
||||
clickholdfire
|
||||
(any (\x -> SDL.Pressed == SDL.mouseButtonEventMotion
|
||||
((\(SDL.MouseButtonEvent dat) -> dat) $
|
||||
SDL.eventPayload x)) filteredClickEvents)
|
||||
return listenerah
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue