diff --git a/frpball.cabal b/frpball.cabal index 3482a84..41e9b9a 100644 --- a/frpball.cabal +++ b/frpball.cabal @@ -22,8 +22,8 @@ executable frpball -- other-extensions: build-depends: base ^>=4.12.0.0 , reactive-banana - , sdl2 - , GPipe + , sdl2 ^>=2.5.0.0 + , GPipe ^>=2.2.4 , linear , gl , text diff --git a/src/Main.hs b/src/Main.hs index 797b4f3..5ecfe5b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -39,16 +39,23 @@ main = do -- context <- SDL.glCreateContext window listen@(_, fire) <- newAddHandler network <- compile (networkDescription listen) - runContextT FRPBallCtxConfig $ do + runContextT (FRPBallCtxConfig "frpball" + SDL.defaultWindow + { SDL.windowInitialSize = V2 800 600 + , SDL.windowResizable = True + , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + }) $ do win <- newWindow (WindowFormatColor RGB8) ("frpball", SDL.defaultWindow { SDL.windowInitialSize = V2 800 600 , SDL.windowResizable = True - , SDL.windowOpenGL = Just SDL.defaultOpenGL + , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL { SDL.glProfile = SDL.Core SDL.Normal 3 3 } } ) - vertexBuffer :: Buffer os (B4 Float, B3 Float) <- newBuffer 3 + vertexBuffer :: Buffer os AttrInput <- newBuffer 3 writeBuffer vertexBuffer 0 @@ -57,7 +64,7 @@ main = do , (V4 1 1 0 1, V3 0 0 1) ] shader <- compileShader $ do - primitiveStream <- toPrimitiveStream id + primitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- toPrimitiveStream id :: Shader os (PrimitiveArray Triangles AttrInput) (PrimitiveStream Triangles (VertexFormat AttrInput)) fragmentStream <- rasterize (const ( FrontAndBack @@ -73,13 +80,19 @@ main = do ) ) fragmentStream + -- SDL.showWindow window - liftIO $ do - actuate network - forever $ do + liftIO $ actuate network + forever $ do + render $ do + clearWindowColor win (V3 0 0 0) + vertexArray <- newVertexArray vertexBuffer + let primitiveArray = toPrimitiveArray TriangleList vertexArray + shader primitiveArray + swapWindowBuffers win + liftIO $ do evs <- SDL.pollEvents fire evs - threadDelay $ 23 * 10 ^ 6 networkDescription :: (AddHandler [SDL.Event], b) diff --git a/src/Types.hs b/src/Types.hs index 7ce5ea2..65de96b 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -29,7 +29,7 @@ data MouseEvent = MouseEvent data FRPBallCtx = FRPBallCtx { frpContexts :: TVar [SDL.GLContext] - , frpWindow :: Maybe SDL.Window + , frpWindow :: TVar [SDL.Window] , frpThread :: SDL.ThreadID } @@ -40,13 +40,13 @@ type Window = SDL.Window type WindowConfig = SDL.WindowConfig instance ContextHandler FRPBallCtx where - data ContextHandlerParameters FRPBallCtx = FRPBallCtxConfig + data ContextHandlerParameters FRPBallCtx = FRPBallCtxConfig T.Text SDL.WindowConfig type ContextWindow FRPBallCtx = SDL.Window type WindowParameters FRPBallCtx = (T.Text, SDL.WindowConfig) - contextHandlerCreate bla = do + contextHandlerCreate (FRPBallCtxConfig ititle iwinconfig) = do tid <- SDL.threadID - win <- return Nothing + win <- newTVarIO [] -- SDL.createWindow ititle iwinconfig ctx <- newTVarIO [] return $ FRPBallCtx ctx win tid @@ -55,15 +55,16 @@ instance ContextHandler FRPBallCtx where createContext frpctx (Just (bits, config)) = do win <- SDL.createWindow (fst config) (snd config) - ctx <- SDL.glCreateContext (fromJust $ frpWindow frpctx) + atomically $ modifyTVar (frpWindow frpctx) (win :) + ctx <- SDL.glCreateContext win atomically $ modifyTVar (frpContexts frpctx) (ctx :) SDL.showWindow win return win createContext frpctx Nothing = do - ctx <- SDL.glCreateContext (fromJust $ frpWindow frpctx) + ctx <- SDL.glCreateContext =<< (head <$> readTVarIO (frpWindow frpctx)) atomically $ modifyTVar (frpContexts frpctx) (ctx :) - return $ fromJust $ frpWindow frpctx + head <$> readTVarIO (frpWindow frpctx) contextDoAsync ctx mwin act = liftIO act @@ -81,5 +82,9 @@ instance ContextHandler FRPBallCtx where glFinish ctxs <- readTVarIO $ frpContexts frpctx forM_ ctxs $ \mmContext -> do - GPipe.contextDelete frpctx (fromJust $ frpWindow frpctx) + GPipe.contextDelete frpctx =<< (head <$> readTVarIO (frpWindow frpctx)) SDL.glDeleteContext mmContext + +type AttrInput = (B4 Float, B3 Float) + +type RIStream = (Float, AttrInput)