it works interactively now

This commit is contained in:
nek0 2019-09-28 09:18:15 +02:00
parent 66c04a80e3
commit 39da367f51

View file

@ -13,7 +13,6 @@ import qualified SDL.Raw.Enum as SDL
import SDL (($=)) import SDL (($=))
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.STM.TMVar
import Graphics.GPipe import Graphics.GPipe
@ -21,11 +20,12 @@ import Linear
import Control.Monad import Control.Monad
import Control.Monad.Trans import Control.Monad.Trans
import Control.Concurrent
import Reactive.Banana.Frameworks as RBF import Reactive.Banana.Frameworks as RBF
import Reactive.Banana as RB import Reactive.Banana as RB
import Data.Maybe (fromMaybe)
-- internal imports -- internal imports
import Types import Types
@ -72,7 +72,7 @@ main = do
shader <- compileShader $ do shader <- compileShader $ do
primitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- toPrimitiveStream id :: Shader os (PrimitiveArray Triangles AttrInput) (PrimitiveStream Triangles (VertexFormat AttrInput)) primitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- toPrimitiveStream id :: Shader os (PrimitiveArray Triangles AttrInput) (PrimitiveStream Triangles (VertexFormat AttrInput))
uniform <- getUniform (const (uniformBuffer,0)) uniform <- getUniform (const (uniformBuffer,0))
let primitiveStream2 = fmap (\(pos,clr) -> (pos - V4 1 1 0 0, clr / 10)) primitiveStream let primitiveStream2 = fmap (\(pos, clr) -> (pos - V4 1 1 0 0, clr / 10)) primitiveStream
primitiveStream3 = primitiveStream `mappend` primitiveStream2 primitiveStream3 = primitiveStream `mappend` primitiveStream2
rotationMatrix a = V4 (V4 (cos a) (-sin a) 0 0) rotationMatrix a = V4 (V4 (cos a) (-sin a) 0 0)
(V4 (sin a) (cos a) 0 0) (V4 (sin a) (cos a) 0 0)
@ -98,11 +98,12 @@ main = do
-- SDL.showWindow window -- SDL.showWindow window
listen@(_, fire) <- liftIO $ newAddHandler listen@(_, fire) <- liftIO $ newAddHandler
uniformBufferVar <- liftIO $ newTMVarIO uniformBuffer :: ContextT FRPBallCtx os IO (TMVar (Buffer os (Uniform (B Float)))) uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float)
let writeUniform = writeBuffer uniformBuffer 0 :: [Float] -> ContextT FRPBallCtx os IO () let writeUniform = writeBuffer uniformBuffer 0 :: [Float] -> ContextT FRPBallCtx os IO ()
writeUniform [0] network <- liftIO $ compile (networkDescription listen uniVar)
network <- liftIO $ compile (networkDescription listen writeUniform)
forever $ do forever $ do
mrot <- liftIO $ atomically $ tryReadTMVar uniVar
writeUniform [fromMaybe 0 mrot]
liftIO $ actuate network liftIO $ actuate network
render $ do render $ do
clearWindowColor win (V3 0 0 0) clearWindowColor win (V3 0 0 0)
@ -119,12 +120,15 @@ main = do
-- => (AddHandler [SDL.Event], x) -- => (AddHandler [SDL.Event], x)
-- -> TMVar (Buffer os (Uniform (B Float))) -- -> TMVar (Buffer os (Uniform (B Float)))
-- -> MomentIO () -- -> MomentIO ()
networkDescription (listenerah, listenerfire) uniformWrite = mdo networkDescription (listenerah, listenerfire) univar = mdo
(mouseah, mousefire) <- liftIO $ newAddHandler (mouseah, mousefire) <- liftIO $ newAddHandler
blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
eventChanged <- changes blistener eventChanged <- changes blistener
emouse <- fromAddHandler =<< registerMouseEvent uniformWrite mouseah emouse <- fromAddHandler =<< registerMouseEvent univar mouseah
let reaction = fmap print emouse let reaction = fmap (\x -> do
let input = (\(V2 x _) -> fromIntegral x :: Float) $ SDL.mouseMotionEventRelMotion $ (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head x
void $ atomically $ swapTMVar univar input
print x) emouse
let -- eventChangedReaction :: RB.Event (Future (IO ())) let -- eventChangedReaction :: RB.Event (Future (IO ()))
eventChangedReaction = fmap eventChangedReaction = fmap
(\(x :: Future [SDL.Event]) -> (\(x :: Future [SDL.Event]) ->
@ -142,12 +146,11 @@ registerListenerEvent
registerListenerEvent listenerah mousefire = do registerListenerEvent listenerah mousefire = do
_ <- liftIO $ do _ <- liftIO $ do
register listenerah $ \evs -> do register listenerah $ \evs -> do
if null evs then return () else mousefire let fevs = filter (\ev -> case SDL.eventPayload ev of
(filter (\ev -> case SDL.eventPayload ev of SDL.MouseMotionEvent _ -> True
SDL.MouseMotionEvent _ -> True _ -> False
_ -> False ) evs
) evs if null fevs then return () else mousefire fevs
)
return listenerah return listenerah
-- registerMouseEvent -- registerMouseEvent
@ -155,11 +158,10 @@ registerListenerEvent listenerah mousefire = do
-- => Buffer os (Uniform (B Float)) -- => Buffer os (Uniform (B Float))
-- -> AddHandler [SDL.Event] -- -> AddHandler [SDL.Event]
-- -> m (AddHandler [SDL.Event]) -- -> m (AddHandler [SDL.Event])
registerMouseEvent uniformWrite mouseah = do registerMouseEvent univar mouseah = do
_ <- liftIO $ register mouseah ((\evs -> do _ <- liftIO $ register mouseah ((\evs -> do
let input = [(\(V2 x y) -> fromIntegral x :: Float) $ SDL.mouseMotionEventRelMotion $ (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head evs] let input = (\(V2 x y) -> fromIntegral x :: Float) $ SDL.mouseMotionEventRelMotion $ (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head evs
return $ (uniformWrite input) void $ atomically $ swapTMVar univar input
return ()
) :: [SDL.Event] -> IO () ) :: [SDL.Event] -> IO ()
) )
return mouseah return mouseah