beautiful rotation

src/Main.hs

@@ -7,22 +7,18 @@
 
 module Main where
 
-import qualified SDL
+import qualified SDL hiding (V2(..))
 import qualified SDL.Raw.Video as SDL (glSetAttribute)
 import qualified SDL.Raw.Enum as SDL
-import SDL (($=))
 
 import Control.Concurrent.STM
 
 import Graphics.GPipe
 
-import Linear
-
 import Control.Monad
 import Control.Monad.Trans
 
 import Reactive.Banana.Frameworks as RBF
-import Reactive.Banana as RB
 
 import Data.Maybe (fromMaybe)
 
@@ -72,13 +68,15 @@ 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
+            (\(position, color) -> (position - V4 1 1 0 0, color / 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)
+          first fun (position, color) = (fun position, color)
           primitiveStream4 = fmap (first (rotationMatrix (uniform) !*)) primitiveStream3
       fragmentStream <- rasterize
         (const
@@ -115,25 +113,27 @@ main = do
         evs <- SDL.pollEvents
         fire evs
 
--- networkDescription
---   :: (ContextHandler ctx ~ ContextHandler FRPBallCtx)
---   => (AddHandler [SDL.Event], x)
---   -> TMVar (Buffer os (Uniform (B Float)))
---   -> MomentIO ()
-networkDescription (listenerah, listenerfire) univar = mdo
+networkDescription
+  :: (AddHandler [SDL.Event], b)
+  -> TMVar Float
+  -> MomentIO ()
+networkDescription (listenerah, _) univar = mdo
   (mouseah, mousefire)      <- liftIO $ newAddHandler
   blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
-  eventChanged <- changes blistener
+  _ <- changes blistener
   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]) ->
-          fmap (\y -> if null y then return () else print y) x)
-        eventChanged
+        let input = (\(V2 xx _) ->
+              fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $
+                (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head x
+        past <- fromMaybe 0 <$> (atomically $ tryReadTMVar univar)
+        void $ atomically $ swapTMVar univar (past + input)
+        print input) emouse
+  -- let eventChangedReaction :: RB.Event (Future (IO ()))
+  --     eventChangedReaction = fmap
+  --       (\(x :: Future [SDL.Event]) ->
+  --         fmap (\y -> if null y then return () else print y) x)
+  --       eventChanged
   -- liftIO $ mousefire "Hello!"
   reactimate reaction
   -- reactimate' eventChanged
@@ -153,15 +153,11 @@ registerListenerEvent listenerah mousefire = do
       if null fevs then return () else mousefire fevs
   return listenerah
 
--- registerMouseEvent
---   :: (MonadIO m, ContextHandler ctx ~ ContextHandler FRPBallCtx)
---   => Buffer os (Uniform (B Float))
---   -> AddHandler [SDL.Event]
---   -> m (AddHandler [SDL.Event])
+registerMouseEvent
+  :: MonadIO m
+  => TMVar Float
+  -> AddHandler [SDL.Event]
+  -> m (AddHandler [SDL.Event])
 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
-      void $ atomically $ swapTMVar univar input
-      ) :: [SDL.Event] -> IO ()
-      )
+  _ <- liftIO $ register mouseah $ \_ -> return ()
   return mouseah