it works interactively now

This commit is contained in:
nek0 2019-09-28 09:18:15 +02:00
parent 66c04a80e3
commit 39da367f51
1 changed files with 21 additions and 19 deletions

View File

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