diff --git a/src/Main.hs b/src/Main.hs index 8c982ef..cc015fd 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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