experiment

frpball.cabal

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

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

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)