nek0/frpball
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

FRP!

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

235
src/Main.hs
View file

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