From 66c04a80e397c76e635a62ec512fc25f939fa43c Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 29 Aug 2019 21:29:16 +0200 Subject: [PATCH] experiment --- frpball.cabal | 1 + src/Main.hs | 74 ++++++++++++++++++++++++++++++++++++--------------- src/Types.hs | 13 ++++----- 3 files changed, 61 insertions(+), 27 deletions(-) diff --git a/frpball.cabal b/frpball.cabal index 41e9b9a..fd74266 100644 --- a/frpball.cabal +++ b/frpball.cabal @@ -28,6 +28,7 @@ executable frpball , gl , text , stm + , mtl hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs index 5ecfe5b..8c982ef 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Main where @@ -11,11 +12,15 @@ import qualified SDL.Raw.Video as SDL (glSetAttribute) import qualified SDL.Raw.Enum as SDL import SDL (($=)) +import Control.Concurrent.STM +import Control.Concurrent.STM.TMVar + import Graphics.GPipe import Linear import Control.Monad +import Control.Monad.Trans import Control.Concurrent import Reactive.Banana.Frameworks as RBF @@ -37,8 +42,6 @@ main = do -- } void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 -- context <- SDL.glCreateContext window - listen@(_, fire) <- newAddHandler - network <- compile (networkDescription listen) runContextT (FRPBallCtxConfig "frpball" SDL.defaultWindow { SDL.windowInitialSize = V2 800 600 @@ -63,8 +66,20 @@ main = do , (V4 0 (-1) 0 1, V3 0 1 0) , (V4 1 1 0 1, V3 0 0 1) ] + + uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1 + 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 + primitiveStream3 = primitiveStream `mappend` primitiveStream2 + rotationMatrix a = V4 (V4 (cos a) (-sin a) 0 0) + (V4 (sin a) (cos a) 0 0) + (V4 0 0 1 0) + (V4 0 0 0 1) + first fun (pos, col) = (fun pos, col) + primitiveStream4 = fmap (first (rotationMatrix (uniform) !*)) primitiveStream3 fragmentStream <- rasterize (const ( FrontAndBack @@ -72,7 +87,7 @@ main = do , DepthRange 0 1 ) ) - primitiveStream + primitiveStream4 drawWindowColor (const ( win @@ -82,8 +97,13 @@ main = do fragmentStream -- SDL.showWindow window - liftIO $ actuate network + listen@(_, fire) <- liftIO $ newAddHandler + uniformBufferVar <- liftIO $ newTMVarIO uniformBuffer :: ContextT FRPBallCtx os IO (TMVar (Buffer os (Uniform (B Float)))) + let writeUniform = writeBuffer uniformBuffer 0 :: [Float] -> ContextT FRPBallCtx os IO () + writeUniform [0] + network <- liftIO $ compile (networkDescription listen writeUniform) forever $ do + liftIO $ actuate network render $ do clearWindowColor win (V3 0 0 0) vertexArray <- newVertexArray vertexBuffer @@ -94,14 +114,16 @@ main = do evs <- SDL.pollEvents fire evs -networkDescription - :: (AddHandler [SDL.Event], b) - -> MomentIO () -networkDescription (listenerah, listenerfire) = mdo +-- networkDescription +-- :: (ContextHandler ctx ~ ContextHandler FRPBallCtx) +-- => (AddHandler [SDL.Event], x) +-- -> TMVar (Buffer os (Uniform (B Float))) +-- -> MomentIO () +networkDescription (listenerah, listenerfire) uniformWrite = mdo (mouseah, mousefire) <- liftIO $ newAddHandler blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire eventChanged <- changes blistener - emouse <- fromAddHandler =<< registerMouseEvent mouseah + emouse <- fromAddHandler =<< registerMouseEvent uniformWrite mouseah let reaction = fmap print emouse let -- eventChangedReaction :: RB.Event (Future (IO ())) eventChangedReaction = fmap @@ -113,21 +135,31 @@ networkDescription (listenerah, listenerfire) = mdo -- reactimate' eventChanged registerListenerEvent - :: (MonadIO m, Foldable t) - => AddHandler (t a) - -> (t a -> IO ()) - -> m (AddHandler (t a)) + :: (MonadIO m) + => AddHandler ([SDL.Event]) + -> ([SDL.Event] -> IO ()) + -> m (AddHandler [SDL.Event]) registerListenerEvent listenerah mousefire = do _ <- liftIO $ do register listenerah $ \evs -> do - if null evs then return () else mousefire evs + if null evs then return () else mousefire + (filter (\ev -> case SDL.eventPayload ev of + SDL.MouseMotionEvent _ -> True + _ -> False + ) evs + ) return listenerah -registerMouseEvent - :: (MonadIO m, Show a) - => AddHandler a - -> m (AddHandler a) -registerMouseEvent mouseah = do - _ <- liftIO $ - register mouseah print +-- registerMouseEvent +-- :: (MonadIO m, ContextHandler ctx ~ ContextHandler FRPBallCtx) +-- => Buffer os (Uniform (B Float)) +-- -> AddHandler [SDL.Event] +-- -> m (AddHandler [SDL.Event]) +registerMouseEvent uniformWrite 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 () + ) :: [SDL.Event] -> IO () + ) return mouseah diff --git a/src/Types.hs b/src/Types.hs index 65de96b..2af477c 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -11,6 +11,7 @@ import Control.Monad (forM_) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TMVar import Control.Monad.IO.Class (liftIO) @@ -29,7 +30,7 @@ data MouseEvent = MouseEvent data FRPBallCtx = FRPBallCtx { frpContexts :: TVar [SDL.GLContext] - , frpWindow :: TVar [SDL.Window] + , frpWindow :: TMVar SDL.Window , frpThread :: SDL.ThreadID } @@ -46,7 +47,7 @@ instance ContextHandler FRPBallCtx where contextHandlerCreate (FRPBallCtxConfig ititle iwinconfig) = do tid <- SDL.threadID - win <- newTVarIO [] -- SDL.createWindow ititle iwinconfig + win <- atomically $ newEmptyTMVar ctx <- newTVarIO [] return $ FRPBallCtx ctx win tid @@ -55,16 +56,16 @@ instance ContextHandler FRPBallCtx where createContext frpctx (Just (bits, config)) = do win <- SDL.createWindow (fst config) (snd config) - atomically $ modifyTVar (frpWindow frpctx) (win :) + atomically $ putTMVar (frpWindow frpctx) win ctx <- SDL.glCreateContext win atomically $ modifyTVar (frpContexts frpctx) (ctx :) SDL.showWindow win return win createContext frpctx Nothing = do - ctx <- SDL.glCreateContext =<< (head <$> readTVarIO (frpWindow frpctx)) + ctx <- SDL.glCreateContext =<< atomically (readTMVar $ frpWindow frpctx) atomically $ modifyTVar (frpContexts frpctx) (ctx :) - head <$> readTVarIO (frpWindow frpctx) + atomically (readTMVar $ frpWindow frpctx) contextDoAsync ctx mwin act = liftIO act @@ -82,7 +83,7 @@ instance ContextHandler FRPBallCtx where glFinish ctxs <- readTVarIO $ frpContexts frpctx forM_ ctxs $ \mmContext -> do - GPipe.contextDelete frpctx =<< (head <$> readTVarIO (frpWindow frpctx)) + GPipe.contextDelete frpctx =<< (atomically $ readTMVar $ frpWindow frpctx) SDL.glDeleteContext mmContext type AttrInput = (B4 Float, B3 Float)