Render curve special points.

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))
@@ -46,6 +47,17 @@ makeFrame (cubemap :: TextureCube)
                                 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
                                    w = p'%w
@@ -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")