move ball on click

src/Main.hs

@@ -69,30 +69,31 @@ main = do
       0
       [ (V4 (-1/2) 1 0 1, V3 1 0 0)
       , (V4 (1/2) 1 0 1, V3 1 0 0)
-      , (V4 0 0 0 0, V3 1 0 0)
+      , (V4 0 0 0 1, V3 1 0 0)
 
       , (V4 (1/2) 1 0 1, V3 1 0 0)
       , (V4 1 0 0 1, V3 1 0 0)
-      , (V4 0 0 0 0, V3 1 0 0)
+      , (V4 0 0 0 1, V3 1 0 0)
 
       , (V4 1 0 0 1, V3 1 0 0)
       , (V4 (1/2) (-1) 0 1, V3 1 0 0)
-      , (V4 0 0 0 0, V3 1 0 0)
+      , (V4 0 0 0 1, V3 1 0 0)
 
       , (V4 (1/2) (-1) 0 1, V3 1 0 0)
       , (V4 (-1/2) (-1) 0 1, V3 1 0 0)
-      , (V4 0 0 0 0, V3 1 0 0)
+      , (V4 0 0 0 1, V3 1 0 0)
 
       , (V4 (-1/2) (-1) 0 1, V3 1 0 0)
       , (V4 (-1) 0 0 1, V3 1 0 0)
-      , (V4 0 0 0 0, V3 1 0 0)
+      , (V4 0 0 0 1, V3 1 0 0)
 
       , (V4 (-1) 0 0 1, V3 1 0 0)
       , (V4 (-1/2) 1 0 1, V3 1 0 0)
-      , (V4 0 0 0 0, V3 1 0 0)
+      , (V4 0 0 0 1, V3 1 0 0)
       ]
 
     uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1
+    positionUniformBuffer :: Buffer os (Uniform (B2 Float)) <- newBuffer 1
 
     hexShader <- compileShader $ do
       hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <-
@@ -101,11 +102,20 @@ main = do
             os
             (PrimitiveArray Triangles AttrInput)
             (PrimitiveStream Triangles (VertexFormat AttrInput))
+      positionUniform <- getUniform (const (positionUniformBuffer, 0))
       let scaleFact = 0.05
-          scaleMatrix a = V4 (V4 a 0 0 0)
+          scaleMatrix a =
-                             (V4 0 a 0 0)
+            V4
-                             (V4 0 0 1 0)
+              (V4 a 0 0 0)
-                             (V4 0 0 0 1)
+              (V4 0 a 0 0)
+              (V4 0 0 1 0)
+              (V4 0 0 0 1)
+          transMatrix (V2 ax ay) =
+            V4
+              (V4 1 0 0 ax)
+              (V4 0 1 0 (-ay))
+              (V4 0 0 1 1)
+              (V4 0 0 0 1)
       hexFragmentStream <- rasterize
         (const
           ( FrontAndBack
@@ -113,7 +123,12 @@ main = do
           , DepthRange 0 1
           )
           )
-        (fmap (\(position, color) -> (scaleMatrix scaleFact !* position, color))
+        (fmap (\(position, color) ->
+          ( (transMatrix positionUniform !*!
+            scaleMatrix scaleFact) !*
+            position
+          , color
+          ))
           hexPrimitiveStream)
       drawWindowColor
         (const
@@ -130,7 +145,7 @@ main = do
             os
             (PrimitiveArray Triangles AttrInput)
             (PrimitiveStream Triangles (VertexFormat AttrInput))
-      uniform <- getUniform (const (uniformBuffer,0))
+      uniform <- getUniform (const (uniformBuffer, 0))
       let primitiveStream2 = fmap
             (\(position, color) -> (position - V4 1 1 0 0, color / 10))
             primitiveStream
@@ -162,10 +177,14 @@ main = do
     -- SDL.showWindow window
     listen@(_, fire) <- liftIO $ newAddHandler
     uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float)
-    network <- liftIO $ compile (networkDescription listen uniVar)
+    transUniVar <- liftIO $ newTMVarIO (V2 0 0) ::
+      ContextT FRPBallCtx os IO (TMVar (V2 Float))
+    network <- liftIO $ compile (networkDescription listen uniVar transUniVar)
     forever $ do
       mrot <- liftIO $ atomically $ tryReadTMVar uniVar
       writeBuffer uniformBuffer 0 [fromMaybe 0 mrot]
+      mtrans <- liftIO $ atomically $ tryReadTMVar transUniVar
+      writeBuffer positionUniformBuffer 0 [fromMaybe (V2 0 0) mtrans]
       liftIO $ actuate network
       render $ do
         clearWindowColor win (V3 0 0 0)
@@ -183,34 +202,64 @@ main = do
 networkDescription
   :: (AddHandler [SDL.Event], b)
   -> TMVar Float
+  -> TMVar (V2 Float)
   -> MomentIO ()
-networkDescription (listenerah, _) univar = mdo
+networkDescription (listenerah, _) rotvar transvar = mdo
-  (mouseah, mousefire)      <- liftIO $ newAddHandler
+  (mouseah, mousefire) <- liftIO $ newAddHandler
-  blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
+  (clickah, clickfire) <- liftIO $ newAddHandler
+  blistener <- fromChanges [] =<< registerListenerEvent
+    listenerah
+    mousefire
+    clickfire
   _ <- changes blistener
   emouse <- fromAddHandler =<< registerMouseEvent mouseah
-  let reaction = fmap (\x -> do
+  eclick <- fromAddHandler =<< registerClickEvent clickah
+  let moveReaction = fmap (\x -> do
         let input = (\(V2 xx _) ->
               fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $
                 (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head x
-        past <- fromMaybe 0 <$> (atomically $ tryReadTMVar univar)
+        past <- fromMaybe 0 <$> (atomically $ tryReadTMVar rotvar)
-        void $ atomically $ swapTMVar univar (past + input)
+        void $ atomically $ swapTMVar rotvar (past + input)
-        print input) emouse
+        print input)
-  reactimate reaction
+        emouse
+      clickReaction = fmap (\x -> do
+        let input =
+              (\vect -> fmap (\foo -> foo - 1) (vect / V2 400 300)) $
+              (\(SDL.MouseButtonEvent (SDL.MouseButtonEventData _ _ _ _ _ (SDL.P ps))) ->
+                fmap fromIntegral ps :: V2 Float) $
+              SDL.eventPayload $
+              head x
+        void $ atomically $ swapTMVar transvar input
+        print input)
+        eclick
+  reactimate moveReaction
+  reactimate clickReaction
 
 registerListenerEvent
   :: (MonadIO m)
   => AddHandler ([SDL.Event])
   -> ([SDL.Event] -> IO ())
+  -> ([SDL.Event] -> IO ())
   -> m (AddHandler [SDL.Event])
-registerListenerEvent listenerah mousefire = do
+registerListenerEvent listenerah mousefire clickfire = do
-  _ <- liftIO $ do
+  void $ liftIO $
     register listenerah $ \evs -> do
-      let fevs = filter (\ev -> case SDL.eventPayload ev of
+      let filteredMoveEvents = filter (\ev -> case SDL.eventPayload ev of
             SDL.MouseMotionEvent _ -> True
-            _                  -> False
+            _ -> False
             ) evs
-      if null fevs then return () else mousefire fevs
+          filteredClickEvents = filter (\ev -> case SDL.eventPayload ev of
+            SDL.MouseButtonEvent
+              (SDL.MouseButtonEventData _ SDL.Pressed _ SDL.ButtonLeft 1 _) ->
+                True
+            _ -> False
+            ) evs
+      if null filteredMoveEvents
+      then return ()
+      else mousefire filteredMoveEvents
+      if null filteredClickEvents
+      then return ()
+      else clickfire filteredClickEvents
   return listenerah
 
 registerMouseEvent
@@ -218,5 +267,13 @@ registerMouseEvent
   => AddHandler [SDL.Event]
   -> m (AddHandler [SDL.Event])
 registerMouseEvent mouseah = do
-  _ <- liftIO $ register mouseah $ \_ -> return ()
+  void $ liftIO $ register mouseah $ \_ -> return ()
   return mouseah
+
+registerClickEvent
+  :: MonadIO m
+  => AddHandler [SDL.Event]
+  -> m (AddHandler [SDL.Event])
+registerClickEvent clickah = do
+  void $ liftIO $ register clickah $ \_ -> return ()
+  return clickah