start constructing a "ball"

src/Main.hs

@@ -63,10 +63,73 @@ main = do
       , (V4 1 1 0 1,  V3 0 0 1)
       ]
 
+    hexBuffer :: Buffer os AttrInput <- newBuffer 18
+    writeBuffer
+      hexBuffer
+      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 (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 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 (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 (-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 (-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)
+      ]
+
     uniformBuffer :: Buffer os (Uniform (B Float)) <- newBuffer 1
 
+    hexShader <- compileShader $ do
+      hexPrimitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <-
+        toPrimitiveStream id ::
+          Shader
+            os
+            (PrimitiveArray Triangles AttrInput)
+            (PrimitiveStream Triangles (VertexFormat AttrInput))
+      let scaleFact = 0.05
+          scaleMatrix a = V4 (V4 a 0 0 0)
+                             (V4 0 a 0 0)
+                             (V4 0 0 1 0)
+                             (V4 0 0 0 1)
+      hexFragmentStream <- rasterize
+        (const
+          ( FrontAndBack
+          , ViewPort (V2 0 0) (V2 800 600)
+          , DepthRange 0 1
+          )
+          )
+        (fmap (\(position, color) -> (scaleMatrix scaleFact !* position, color))
+          hexPrimitiveStream)
+      drawWindowColor
+        (const
+          ( win
+          , ContextColorOption NoBlending (V3 True True True)
+          )
+          )
+        hexFragmentStream
+
     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
             (\(position, color) -> (position - V4 1 1 0 0, color / 10))
@@ -77,7 +140,9 @@ main = do
                                 (V4 0    0    1 0)  
                                 (V4 0    0    0 1)  
           first fun (position, color) = (fun position, color)
-          primitiveStream4 = fmap (first (rotationMatrix (uniform) !*)) primitiveStream3
+          primitiveStream4 = fmap
+            (first (rotationMatrix uniform !*))
+            primitiveStream3
       fragmentStream <- rasterize
         (const
           ( FrontAndBack
@@ -97,17 +162,19 @@ main = do
     -- SDL.showWindow window
     listen@(_, fire) <- liftIO $ newAddHandler
     uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float)
-    let writeUniform = writeBuffer uniformBuffer 0 :: [Float] -> ContextT FRPBallCtx os IO ()
     network <- liftIO $ compile (networkDescription listen uniVar)
     forever $ do
       mrot <- liftIO $ atomically $ tryReadTMVar uniVar
-      writeUniform [fromMaybe 0 mrot]
+      writeBuffer uniformBuffer 0 [fromMaybe 0 mrot]
       liftIO $ actuate network
       render $ do
         clearWindowColor win (V3 0 0 0)
         vertexArray <- newVertexArray vertexBuffer
+        hexVertexArray <- newVertexArray hexBuffer
         let primitiveArray = toPrimitiveArray TriangleList vertexArray
+        let hexPrimitiveArray = toPrimitiveArray TriangleList hexVertexArray
         shader primitiveArray
+        hexShader hexPrimitiveArray
       swapWindowBuffers win
       liftIO $ do
         evs <- SDL.pollEvents
@@ -121,7 +188,7 @@ networkDescription (listenerah, _) univar = mdo
   (mouseah, mousefire)      <- liftIO $ newAddHandler
   blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
   _ <- changes blistener
-  emouse <- fromAddHandler =<< registerMouseEvent univar mouseah
+  emouse <- fromAddHandler =<< registerMouseEvent mouseah
   let reaction = fmap (\x -> do
         let input = (\(V2 xx _) ->
               fromIntegral xx / 100 :: Float) $ SDL.mouseMotionEventRelMotion $
@@ -129,14 +196,7 @@ networkDescription (listenerah, _) univar = mdo
         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
 
 registerListenerEvent
   :: (MonadIO m)
@@ -155,9 +215,8 @@ registerListenerEvent listenerah mousefire = do
 
 registerMouseEvent
   :: MonadIO m
-  => TMVar Float
+  => AddHandler [SDL.Event]
-  -> AddHandler [SDL.Event]
   -> m (AddHandler [SDL.Event])
-registerMouseEvent univar mouseah = do
+registerMouseEvent mouseah = do
   _ <- liftIO $ register mouseah $ \_ -> return ()
   return mouseah