experiment

This commit is contained in:
nek0 2019-08-29 21:29:16 +02:00
parent a9a15fdec1
commit 66c04a80e3
3 changed files with 61 additions and 27 deletions

View file

@ -28,6 +28,7 @@ executable frpball
, gl , gl
, text , text
, stm , stm
, mtl
hs-source-dirs: src hs-source-dirs: src
ghc-options: -Wall ghc-options: -Wall
default-language: Haskell2010 default-language: Haskell2010

View file

@ -3,6 +3,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Main where module Main where
@ -11,11 +12,15 @@ import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL import qualified SDL.Raw.Enum as SDL
import SDL (($=)) import SDL (($=))
import Control.Concurrent.STM
import Control.Concurrent.STM.TMVar
import Graphics.GPipe import Graphics.GPipe
import Linear import Linear
import Control.Monad import Control.Monad
import Control.Monad.Trans
import Control.Concurrent import Control.Concurrent
import Reactive.Banana.Frameworks as RBF import Reactive.Banana.Frameworks as RBF
@ -37,8 +42,6 @@ main = do
-- } -- }
void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
-- context <- SDL.glCreateContext window -- context <- SDL.glCreateContext window
listen@(_, fire) <- newAddHandler
network <- compile (networkDescription listen)
runContextT (FRPBallCtxConfig "frpball" runContextT (FRPBallCtxConfig "frpball"
SDL.defaultWindow SDL.defaultWindow
{ SDL.windowInitialSize = V2 800 600 { SDL.windowInitialSize = V2 800 600
@ -63,8 +66,20 @@ main = do
, (V4 0 (-1) 0 1, V3 0 1 0) , (V4 0 (-1) 0 1, V3 0 1 0)
, (V4 1 1 0 1, V3 0 0 1) , (V4 1 1 0 1, V3 0 0 1)
] ]
uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1
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))
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 fragmentStream <- rasterize
(const (const
( FrontAndBack ( FrontAndBack
@ -72,7 +87,7 @@ main = do
, DepthRange 0 1 , DepthRange 0 1
) )
) )
primitiveStream primitiveStream4
drawWindowColor drawWindowColor
(const (const
( win ( win
@ -82,8 +97,13 @@ main = do
fragmentStream fragmentStream
-- SDL.showWindow window -- 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 forever $ do
liftIO $ actuate network
render $ do render $ do
clearWindowColor win (V3 0 0 0) clearWindowColor win (V3 0 0 0)
vertexArray <- newVertexArray vertexBuffer vertexArray <- newVertexArray vertexBuffer
@ -94,14 +114,16 @@ main = do
evs <- SDL.pollEvents evs <- SDL.pollEvents
fire evs fire evs
networkDescription -- networkDescription
:: (AddHandler [SDL.Event], b) -- :: (ContextHandler ctx ~ ContextHandler FRPBallCtx)
-> MomentIO () -- => (AddHandler [SDL.Event], x)
networkDescription (listenerah, listenerfire) = mdo -- -> TMVar (Buffer os (Uniform (B Float)))
-- -> MomentIO ()
networkDescription (listenerah, listenerfire) uniformWrite = 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 mouseah emouse <- fromAddHandler =<< registerMouseEvent uniformWrite mouseah
let reaction = fmap print emouse let reaction = fmap print emouse
let -- eventChangedReaction :: RB.Event (Future (IO ())) let -- eventChangedReaction :: RB.Event (Future (IO ()))
eventChangedReaction = fmap eventChangedReaction = fmap
@ -113,21 +135,31 @@ networkDescription (listenerah, listenerfire) = mdo
-- reactimate' eventChanged -- reactimate' eventChanged
registerListenerEvent registerListenerEvent
:: (MonadIO m, Foldable t) :: (MonadIO m)
=> AddHandler (t a) => AddHandler ([SDL.Event])
-> (t a -> IO ()) -> ([SDL.Event] -> IO ())
-> m (AddHandler (t a)) -> m (AddHandler [SDL.Event])
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 evs if null evs then return () else mousefire
(filter (\ev -> case SDL.eventPayload ev of
SDL.MouseMotionEvent _ -> True
_ -> False
) evs
)
return listenerah return listenerah
registerMouseEvent -- registerMouseEvent
:: (MonadIO m, Show a) -- :: (MonadIO m, ContextHandler ctx ~ ContextHandler FRPBallCtx)
=> AddHandler a -- => Buffer os (Uniform (B Float))
-> m (AddHandler a) -- -> AddHandler [SDL.Event]
registerMouseEvent mouseah = do -- -> m (AddHandler [SDL.Event])
_ <- liftIO $ registerMouseEvent uniformWrite mouseah = do
register mouseah print _ <- 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 return mouseah

View file

@ -11,6 +11,7 @@ import Control.Monad (forM_)
import Control.Concurrent.STM (atomically) import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TMVar
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -29,7 +30,7 @@ data MouseEvent = MouseEvent
data FRPBallCtx = FRPBallCtx data FRPBallCtx = FRPBallCtx
{ frpContexts :: TVar [SDL.GLContext] { frpContexts :: TVar [SDL.GLContext]
, frpWindow :: TVar [SDL.Window] , frpWindow :: TMVar SDL.Window
, frpThread :: SDL.ThreadID , frpThread :: SDL.ThreadID
} }
@ -46,7 +47,7 @@ instance ContextHandler FRPBallCtx where
contextHandlerCreate (FRPBallCtxConfig ititle iwinconfig) = do contextHandlerCreate (FRPBallCtxConfig ititle iwinconfig) = do
tid <- SDL.threadID tid <- SDL.threadID
win <- newTVarIO [] -- SDL.createWindow ititle iwinconfig win <- atomically $ newEmptyTMVar
ctx <- newTVarIO [] ctx <- newTVarIO []
return $ FRPBallCtx ctx win tid return $ FRPBallCtx ctx win tid
@ -55,16 +56,16 @@ instance ContextHandler FRPBallCtx where
createContext frpctx (Just (bits, config)) = do createContext frpctx (Just (bits, config)) = do
win <- SDL.createWindow (fst config) (snd config) win <- SDL.createWindow (fst config) (snd config)
atomically $ modifyTVar (frpWindow frpctx) (win :) atomically $ putTMVar (frpWindow frpctx) win
ctx <- SDL.glCreateContext win ctx <- SDL.glCreateContext win
atomically $ modifyTVar (frpContexts frpctx) (ctx :) atomically $ modifyTVar (frpContexts frpctx) (ctx :)
SDL.showWindow win SDL.showWindow win
return win return win
createContext frpctx Nothing = do createContext frpctx Nothing = do
ctx <- SDL.glCreateContext =<< (head <$> readTVarIO (frpWindow frpctx)) ctx <- SDL.glCreateContext =<< atomically (readTMVar $ frpWindow frpctx)
atomically $ modifyTVar (frpContexts frpctx) (ctx :) atomically $ modifyTVar (frpContexts frpctx) (ctx :)
head <$> readTVarIO (frpWindow frpctx) atomically (readTMVar $ frpWindow frpctx)
contextDoAsync ctx mwin act = contextDoAsync ctx mwin act =
liftIO act liftIO act
@ -82,7 +83,7 @@ instance ContextHandler FRPBallCtx where
glFinish glFinish
ctxs <- readTVarIO $ frpContexts frpctx ctxs <- readTVarIO $ frpContexts frpctx
forM_ ctxs $ \mmContext -> do forM_ ctxs $ \mmContext -> do
GPipe.contextDelete frpctx =<< (head <$> readTVarIO (frpWindow frpctx)) GPipe.contextDelete frpctx =<< (atomically $ readTMVar $ frpWindow frpctx)
SDL.glDeleteContext mmContext SDL.glDeleteContext mmContext
type AttrInput = (B4 Float, B3 Float) type AttrInput = (B4 Float, B3 Float)