From d763106d889c94bfb55096cdd154aeaf7d48f9df Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 3 Jun 2019 22:46:05 -0400 Subject: Render curve special points. --- GPURing.hs | 6 +++--- MeshSketch.hs | 47 +++++++++++++++++++++++++++++------------------ hello_obj2.lc | 24 +++++++++++++++++++----- 3 files changed, 51 insertions(+), 26 deletions(-) diff --git a/GPURing.hs b/GPURing.hs index 3002c9e..904c551 100644 --- a/GPURing.hs +++ b/GPURing.hs @@ -25,15 +25,15 @@ import LambdaCube.GL.Input hiding (createObjectCommands) -- > ringBuffer <- newRing capacity (VectorRing.new capacity) type Update keys = (keys -> Writer [DSum AttributeKey GLUniformValue] ()) -new :: Data keys => String -> GLStorage -> (String -> String) -> Int -> IO (TargetBuffer (Update keys)) -new streamName storage toAttr sz = fix $ \retProxy -> do +new :: Data keys => Primitive -> String -> GLStorage -> (String -> String) -> Int -> IO (TargetBuffer (Update keys)) +new prim streamName storage toAttr sz = fix $ \retProxy -> do let paramProxy = paramProxy' retProxy where paramProxy' :: io (targetbuffer (keys -> writer)) -> Proxy keys paramProxy' _ = Proxy let ps = fieldParameters paramProxy toAttr putStrLn $ "Ring params: " ++ show ps gd0 <- uploadDynamicBuffer sz ps - let gd = gd0 { dPrimitive = LineStrip } + let gd = gd0 { dPrimitive = prim } Just keys <- return $ lookupAttrKeys (lookupAttributeKey gd . toAttr) obj <- addToObjectArray storage streamName [] gd -- readIORef (objCommands obj) >>= mapM_ print diff --git a/MeshSketch.hs b/MeshSketch.hs index dc0adf1..4ddfec0 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs @@ -96,21 +96,22 @@ ringPointAttr ('r':'p':c:cs) = toLower c : cs -- State created by uploadState. data State = State - { stAnimator :: Animator - , stCamera :: IORef Camera - , stFullscreen :: IO () - , stSkyboxes :: Skyboxes - , stSkybox :: IORef Int - , stSkyTexture :: IORef TextureCubeData - , stDragFrom :: IORef (Maybe (Vector Float,Camera)) - , stDataPoints :: MV.MVector RealWorld Vector.Point - , stDataRing :: RingBuffer Vector.Point - , stRingBuffer :: RingBuffer (GPU.Update RingPoint) - , stPenDown :: IORef Bool - , stPlane :: IORef (Maybe Plane) - , stDragPlane :: IORef (Maybe (Vector Float,Plane)) - , stRecentPts :: IORef (Giver (Vector Double)) - , stAngle :: IORef Int + { stAnimator :: Animator + , stCamera :: IORef Camera + , stFullscreen :: IO () + , stSkyboxes :: Skyboxes + , stSkybox :: IORef Int + , stSkyTexture :: IORef TextureCubeData + , stDragFrom :: IORef (Maybe (Vector Float,Camera)) + , stDataPoints :: MV.MVector RealWorld Vector.Point + , stDataRing :: RingBuffer Vector.Point + , stRingBuffer :: RingBuffer (GPU.Update RingPoint) + , stCurveSpecial :: RingBuffer (GPU.Update RingPoint) + , stPenDown :: IORef Bool + , stPlane :: IORef (Maybe Plane) + , stDragPlane :: IORef (Maybe (Vector Float,Plane)) + , stRecentPts :: IORef (Giver (Vector Double)) + , stAngle :: IORef Int } initCamera :: Camera @@ -172,7 +173,8 @@ uploadState obj glarea storage = do let bufsize = 1000 v <- MV.unsafeNew bufsize pts <- newRing bufsize (Vector.new v) - ring <- newRing bufsize (GPU.new "Points" storage ringPointAttr bufsize) + ring <- newRing bufsize (GPU.new LineStrip "Curve" storage ringPointAttr bufsize) + cpts <- newRing 100 (GPU.new PointList "Points" storage ringPointAttr 100) -- setup FrameClock w <- toWidget glarea @@ -215,6 +217,7 @@ uploadState obj glarea storage = do , stDataPoints = v , stDataRing = pts , stRingBuffer = ring + , stCurveSpecial = cpts , stPenDown = pendown , stPlane = plane , stDragPlane = dragPlane @@ -294,7 +297,10 @@ new = do "uvw" @: Attribute_V3F defObjectArray "plane" Triangles $ do "position" @: Attribute_V4F - defObjectArray "Points" Lines $ do + defObjectArray "Curve" Lines $ do + "position" @: Attribute_V3F + "color" @: Attribute_V3F + defObjectArray "Points" Points $ do "position" @: Attribute_V3F "color" @: Attribute_V3F defUniforms $ do @@ -607,8 +613,8 @@ pushRing w st endpt h k c = do n = round $ θ/(pi/12) m <- readIORef (stAngle st) let isSpecial = x<0.3 -- || δ<0.5 + bb <- worldCoordinates st (b!0) (b!1) plane go <- if (m /= n || isSpecial) then do - bb <- worldCoordinates st (b!0) (b!1) plane updateBack (stDataRing st) (Vector.Point (b!0) (b!1)) updateBack (stRingBuffer st) $ \RingPoint{..} -> do rpPosition @<- bb @@ -627,6 +633,10 @@ pushRing w st endpt h k c = do bool updateBack pushBack go (stRingBuffer st) $ \RingPoint{..} -> do rpPosition @<- aa rpColor @<- yellow + when isSpecial $ do + pushBack (stCurveSpecial st) $ \RingPoint{..} -> do + rpPosition @<- bb + rpColor @<- yellow withEndpt = do pushBack (stDataRing st) (Vector.Point h k) pushBack (stRingBuffer st) $ \RingPoint{..} -> do @@ -697,6 +707,7 @@ onEvent w realized ev = do writeIORef (stRecentPts st) Give0 clearRing (stRingBuffer st) clearRing (stDataRing st) + clearRing (stCurveSpecial st) d <- pushRing w st True h k red Just win <- getWidgetWindow w windowInvalidateRect win Nothing False diff --git a/hello_obj2.lc b/hello_obj2.lc index b68a04d..7e7defc 100644 --- a/hello_obj2.lc +++ b/hello_obj2.lc @@ -19,7 +19,8 @@ makeFrame (cubemap :: TextureCube) (texture :: Texture) (prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float)) (plane :: PrimitiveStream Triangle ((Vec 4 Float))) - (points :: PrimitiveStream Line (Vec 3 Float, Vec 3 Float)) + (lines :: PrimitiveStream Line (Vec 3 Float, Vec 3 Float)) + (points :: PrimitiveStream Point (Vec 3 Float, Vec 3 Float)) (plane_mat :: Mat 4 4 Float) = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1)) @@ -45,6 +46,17 @@ makeFrame (cubemap :: TextureCube) r = V4 1 1 1 0 *! (max c%x c%y) in ((r + V4 0 0 0 (0.8)))) & accumulateWith (DepthOp Less True, ColorOp blendplane (V4 True True True True)) + `overlay` + lines + & mapPrimitives (\(p,c) -> let p' = coordmap cam $ point p + w = p'%w + yellowish = normalize c `dot` V3 1 1 0 + p2 = if yellowish >= 0.9*sqrt 2 + then V4 p'%x p'%y 0.1 w + else V4 p'%x p'%y 0.11 w + in (p2, point c)) + + & renderPoints cam (LineCtx 1.0 LastVertex) `overlay` points & mapPrimitives (\(p,c) -> let p' = coordmap cam $ point p @@ -55,16 +67,17 @@ makeFrame (cubemap :: TextureCube) else V4 p'%x p'%y 0.11 w in (p2, point c)) - & renderPoints cam + & renderPoints cam (PointCtx (PointSize 5.0) 1.0 LowerLeft) renderPoints :: Mat 4 4 Float - -> PrimitiveStream Line (Vec 4 Float, Vec 4 Float) + -> RasterContext (Vec 4 Float, Vec 4 Float) pr + -> PrimitiveStream pr (Vec 4 Float, Vec 4 Float) -> ( (FragmentOperation Depth, FragmentOperation (Color (VecScalar 4 Float))) , FragmentStream 1 ((Vec 4 Float)) ) -renderPoints cam points = +renderPoints cam ctx points = points - & rasterizePrimitives (LineCtx 1.0 LastVertex) ((Flat)) + & rasterizePrimitives ctx ((Flat)) & mapFragments (\((c)) -> ((c))) & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True)) @@ -78,5 +91,6 @@ main = renderFrame $ (Texture2DSlot "diffuseTexture") (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw")) (fetch "plane" ((Attribute "position"))) + (fetch "Curve" (Attribute "position", Attribute "color")) (fetch "Points" (Attribute "position", Attribute "color")) (Uniform "PlaneModel") -- cgit v1.2.3