This commit is contained in:
nek0 2019-10-10 11:06:58 +02:00
parent 1f574a3e40
commit c0af4e7dd8
2 changed files with 41 additions and 22 deletions

View file

@ -20,10 +20,10 @@ executable frpball
other-modules: Types other-modules: Types
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.12.0.0 build-depends: base >=4.12.0.0 && <5
, reactive-banana , reactive-banana
, sdl2 ^>=2.5.0.0 , sdl2 >=2.5.0.0 && <2.6
, GPipe ^>=2.2.4 , GPipe >=2.2.4
, linear , linear
, gl , gl
, text , text

View file

@ -204,7 +204,7 @@ main = do
oldTime <- fromMaybe (currentTime - 0.1) <$> oldTime <- fromMaybe (currentTime - 0.1) <$>
(atomically $ tryReadTMVar deltaVar) (atomically $ tryReadTMVar deltaVar)
eventFire evs eventFire evs
deltaFire (currentTime - oldTime) deltaFire (5 * (currentTime - oldTime))
atomically $ swapTMVar deltaVar currentTime atomically $ swapTMVar deltaVar currentTime
networkDescription networkDescription
@ -271,16 +271,21 @@ networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo
return deltaAH 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 ballPosBehaviour <- stepper (V2 400 300) ballPos
ballVelBehaviour <- stepper (V2 0 0) ballVel ballVelBehaviour <- stepper (V2 0 0) ballVel
ballAccBehaviour <- stepper (V2 0 0) ballAcc ballAccBehaviour <- stepper (V2 0 0) ballAcc
mousePosBehaviour <- stepper (V2 0 0) mousePos mousePosBehaviour <- stepper (V2 400 300) mousePos
mouseMotionBehaviour <- stepper (V2 0 0) mouseMotion mouseMotionBehaviour <- stepper (V2 0 0) mouseMotion
mouseClickBehaviour <- stepper False mouseClick mouseClickBehaviour <- stepper False mouseClick
mouseReleaseBehaviour <- stepper True mouseRelease mouseReleaseBehaviour <- stepper True mouseRelease
mouseClickPosBehaviour <- stepper (V2 0 0) mouseClickPos mouseClickPosBehaviour <- stepper Nothing mouseClickPos
ball :: V2 Float <- valueB ballPosBehaviour ball :: V2 Float <- valueB ballPosBehaviour
@ -297,37 +302,51 @@ networkDescription (listenerAH, _) (deltaAH, _) rotvar transvar = mdo
-- print input -- print input
) )
ballPosBehaviour ballPosBehaviour
ballAccReaction = fmap (\acc -> ballAccReaction = fmap (\acc -> do
ballAccFire acc ballAccFire acc
) -- print acc
(liftA2 ) $ apply
(\mPos bPos -> mPos - bPos) (liftA2
mousePosBehaviour (\mmPos bPos -> (\delta -> case mmPos of
ballPosBehaviour Just mPos -> fmap (* 0.99) (mPos - bPos)
) Nothing -> V2 0 0
))
mouseClickPosBehaviour
ballPosBehaviour
)
delta
ballVelReaction = fmap (\vel -> ballVelReaction = fmap (\vel ->
ballVelFire vel ballVelFire vel
) $ ) $ apply
apply (liftA2
(pure (\acc -> (\dtime -> fmap (/ dtime) acc)) <*> ballAccBehaviour) (\acc vel -> (\dtime -> fmap (* dtime) acc + vel))
ballAccBehaviour
ballVelBehaviour
)
delta delta
ballMoveReaction = fmap (\x -> do ballMoveReaction = fmap (\x -> do
ballPosFire x ballPosFire x
print x -- print x
) $ apply ) $ apply
(liftA2 (liftA3
(\bPos bVel -> (\bPos bVel bAcc ->
(\dtime -> bPos + (fmap (dtime *) bVel)) (\dtime -> (fmap (* (dtime * 0.5)) bAcc) +
(fmap (* dtime) bVel) +
bPos
)
) )
ballPosBehaviour ballPosBehaviour
ballVelBehaviour ballVelBehaviour
ballAccBehaviour
) )
delta delta
reactimate' =<< changes triangleReaction reactimate' =<< changes triangleReaction
reactimate' =<< changes ballReaction reactimate' =<< changes ballReaction
reactimate ballVelReaction reactimate ballVelReaction
reactimate $ whenE mouseClickBehaviour ballMoveReaction reactimate ballAccReaction
-- reactimate $ whenE mouseClickBehaviour ballMoveReaction
reactimate ballMoveReaction
-- reactimate' =<< changes clickReaction -- reactimate' =<< changes clickReaction
-- reactimate ballReaction -- reactimate ballReaction