From c0af4e7dd843f568455697df6f881a79c7dfdbfc Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 10 Oct 2019 11:06:58 +0200 Subject: [PATCH] yay! --- frpball.cabal | 6 +++--- src/Main.hs | 57 ++++++++++++++++++++++++++++++++++----------------- 2 files changed, 41 insertions(+), 22 deletions(-) diff --git a/frpball.cabal b/frpball.cabal index fd74266..c9b567d 100644 --- a/frpball.cabal +++ b/frpball.cabal @@ -20,10 +20,10 @@ executable frpball other-modules: Types default-extensions: OverloadedStrings -- other-extensions: - build-depends: base ^>=4.12.0.0 + build-depends: base >=4.12.0.0 && <5 , reactive-banana - , sdl2 ^>=2.5.0.0 - , GPipe ^>=2.2.4 + , sdl2 >=2.5.0.0 && <2.6 + , GPipe >=2.2.4 , linear , gl , text diff --git a/src/Main.hs b/src/Main.hs index 931d44a..b0f9a29 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -204,7 +204,7 @@ main = do oldTime <- fromMaybe (currentTime - 0.1) <$> (atomically $ tryReadTMVar deltaVar) eventFire evs - deltaFire (currentTime - oldTime) + deltaFire (5 * (currentTime - oldTime)) atomically $ swapTMVar deltaVar currentTime networkDescription @@ -271,16 +271,21 @@ networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo return deltaAH ) - let mouseClickPos :: Event (V2 Float) = whenE mouseClickBehaviour mousePos + let mouseClickPos :: Event (Maybe (V2 Float)) = apply + (pure (\click -> (\pos -> if click then Just pos else Nothing) + ) <*> + 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 + mousePosBehaviour <- stepper (V2 400 300) mousePos mouseMotionBehaviour <- stepper (V2 0 0) mouseMotion mouseClickBehaviour <- stepper False mouseClick mouseReleaseBehaviour <- stepper True mouseRelease - mouseClickPosBehaviour <- stepper (V2 0 0) mouseClickPos + mouseClickPosBehaviour <- stepper Nothing mouseClickPos ball :: V2 Float <- valueB ballPosBehaviour @@ -297,37 +302,51 @@ networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo -- print input ) ballPosBehaviour - ballAccReaction = fmap (\acc -> + ballAccReaction = fmap (\acc -> do ballAccFire acc - ) - (liftA2 - (\mPos bPos -> mPos - bPos) - mousePosBehaviour - ballPosBehaviour - ) + -- print acc + ) $ apply + (liftA2 + (\mmPos bPos -> (\delta -> case mmPos of + Just mPos -> fmap (* 0.99) (mPos - bPos) + Nothing -> V2 0 0 + )) + mouseClickPosBehaviour + ballPosBehaviour + ) + delta ballVelReaction = fmap (\vel -> ballVelFire vel - ) $ - apply - (pure (\acc -> (\dtime -> fmap (/ dtime) acc)) <*> ballAccBehaviour) + ) $ apply + (liftA2 + (\acc vel -> (\dtime -> fmap (* dtime) acc + vel)) + ballAccBehaviour + ballVelBehaviour + ) delta ballMoveReaction = fmap (\x -> do ballPosFire x - print x + -- print x ) $ apply - (liftA2 - (\bPos bVel -> - (\dtime -> bPos + (fmap (dtime *) bVel)) + (liftA3 + (\bPos bVel bAcc -> + (\dtime -> (fmap (* (dtime * 0.5)) bAcc) + + (fmap (* dtime) bVel) + + bPos + ) ) ballPosBehaviour ballVelBehaviour + ballAccBehaviour ) delta reactimate' =<< changes triangleReaction reactimate' =<< changes ballReaction reactimate ballVelReaction - reactimate $ whenE mouseClickBehaviour ballMoveReaction + reactimate ballAccReaction + -- reactimate $ whenE mouseClickBehaviour ballMoveReaction + reactimate ballMoveReaction -- reactimate' =<< changes clickReaction -- reactimate ballReaction