diff --git a/src/Main.hs b/src/Main.hs index c4c8551..b52695d 100644 --- a/src/Main.hs +++ b/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