From 1f574a3e40d7545c0949be2479d8a2006a41be3d Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 10 Oct 2019 06:13:51 +0200 Subject: [PATCH] FRP! --- src/Main.hs | 235 +++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 178 insertions(+), 57 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 369742f..931d44a 100644 --- a/src/Main.hs +++ b/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 () - 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