Implement color for quadratic bezier curves

shader/bezierQuad.frag

@@ -1,6 +1,8 @@
 #version 430 core
 in vec4 gColor;
 in vec3 gBoundingBox;
+in float gRadStart;
+in float gRadEnd;
 
 out vec4 fColor;
 
@@ -8,7 +10,8 @@ float x = gBoundingBox.x;
 float y = gBoundingBox.y;
 float z = gBoundingBox.z;
 
-float w = 0.1;
+float w = gRadEnd;
+float w2 = gRadStart;
 
 float f (float a, float b)
 {   
@@ -17,10 +20,9 @@ float f (float a, float b)
 }
 void main()
 {
-
   //float d = x - y - 1 + 2* sqrt(y);
   float d = sqrt(x) + sqrt(y) - 1;
-  float e = sqrt(f(x,w)) + sqrt(f(y,w)) - 1;
+  float e = sqrt(f(x,w)) + sqrt(f(y,w2)) - 1.0;
   if ( d < 0 || e > 0) { discard; }
   fColor = gColor;
 //  if ( d < 0) { fColor = vec4 (0,1,0,1); }

shader/bezierQuad.geom

@@ -2,7 +2,10 @@
 layout (triangles) in;
 layout (triangle_strip, max_vertices = 3) out;
 in vec4 vColor[];
+in float vRad[];
 out vec4 gColor;
+out float gRadStart;
+out float gRadEnd;
 out vec3 gBoundingBox;
 
 void main()
@@ -11,6 +14,8 @@ void main()
   vec3 pb = gl_in[1].gl_Position.xyz;
   vec3 pc = gl_in[2].gl_Position.xyz;
 
+  gRadStart = vRad[0];
+  gRadEnd   = vRad[2];
 //  vec3 pa = vec3(paa.xy + 0.1 * (paa.xy - pca.xy), paa.z);
 //  vec3 pc = vec3(pca.xy + 0.1 * (pca.xy - paa.xy), pca.z);
 

shader/bezierQuad.vert

@@ -1,7 +1,9 @@
 #version 430 core
 layout (location = 0) in vec3 position;
 layout (location = 1) in vec4 color;
+layout (location = 2) in float rad;
 out vec4 vColor;
+out float vRad;
 
 uniform vec2 winSize;
 uniform float zoom;
@@ -13,4 +15,5 @@ void main()
 {
   gl_Position = worldMat * vec4(position.xyz,1);
   vColor = color;
+  vRad   = rad;
 }

src/Dodge/Rendering.hs

@@ -121,7 +121,7 @@ worldPictures w
                 where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
 
 testPic :: World -> [Picture]
-testPic w = [setLayer 1 $ onLayerL [99] $ color red $ bezierQuad (-200,200) (-200,-200) (200,200) ]
+testPic w = [setLayer 1 $ onLayerL [99] $ bezierQuad white red 5 50 (-200,200) (-200,-200) (00,00) ]
 -- $ uncurry translate (mouseWorldPos w) 
 
 

src/Picture.hs

@@ -69,8 +69,20 @@ polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
 polygonCol = PolygonCol 0
 
-bezierQuad :: Point2 -> Point2 -> Point2 -> Picture
-bezierQuad a b c = BezierQuad 0 [a,b,c]
+-- note that much of work computing the width of the bezier curve is done here
+-- not sure that moving the control point does much...
+bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
+bezierQuad cola colc ra rc a b c = BezierQuad 0 [(aX,cola                 ,raX)
+                                                ,(bx,mixColors 0.5 0.5 cola colc,1)
+                                                ,(cX,colc                 ,rcX)]
+    where v = a -.- c
+          nv = normalizeV v
+          aX = a +.+ ra * 0.5 *.* nv
+          cX = c -.- rc * 0.5 *.* nv
+          raX = ra / magV (aX -.- cX)
+          rcX = rc / magV (aX -.- cX)
+          bx = b +.+ (0.5 * ra *.* normalizeV (b -.- a))
+                 +.+ (0.5 * rc *.* normalizeV (b -.- c))
 
 color :: RGBA -> Picture -> Picture
 {-# INLINE color #-}

src/Picture/Data.hs

@@ -22,7 +22,7 @@ import Data.Traversable
 
 data RenderType
     = RenderPoly [(Point3,Point4)]
-    | RenderBezQ [(Point3,Point4)]
+    | RenderBezQ [(Point3,Point4,Float)]
     | RenderText [(Point3,Point4,Point3)]
     | RenderArc  (Point3,Point4,Point4)
     | RenderLine [(Point3,Point4)]
@@ -75,7 +75,7 @@ data Picture
     = Blank
     | Text Int String
     | Polygon Int [Point2]
-    | BezierQuad Int [Point2]
+    | BezierQuad Int [(Point2,RGBA,Float)]
     | PolygonCol Int [(Point2,RGBA)]
     | Circle Int RGBA RGBA Float
     | ThickArc Int Float Float Float Float

src/Picture/Preload.hs

@@ -50,7 +50,7 @@ preloadRender = do
                                 "data/texture/charMap.png"
 
     bezierQuadShader
-           <- makeShader "bezierQuad" [vert,geom,frag] [(0,3),(1,4)]    Triangles pokeBezQStrat
+           <- makeShader "bezierQuad" [vert,geom,frag] [(0,3),(1,4),(2,1)]    Triangles pokeBezQStrat
 
 --the following vbo is set up to contain one fixed vertex
     dummyvbo <- genObjectName
@@ -84,7 +84,7 @@ cleanUpRenderPreload pd = do
 
 {-# INLINE pokeBezQStrat #-}
 pokeBezQStrat :: RenderType -> [[[Float]]]
-pokeBezQStrat (RenderBezQ vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
+pokeBezQStrat (RenderBezQ vs) = fmap (\((x,y,z),(r,g,b,a),s) -> [[x,y,z],[r,g,b,a],[s]]) vs
 pokeBezQStrat _ = []
 
 {-# INLINE pokeTriStrat #-}

src/Picture/Tree.hs

@@ -17,8 +17,10 @@ picToLTree mx (Polygon i ps)
 picToLTree mx (PolygonCol i vs)
     = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
         where (ps,cs) = unzip vs
-picToLTree mx (BezierQuad i ps) 
-    = filtB mx i $ LLeaf $ RenderBezQ $ zip (map zeroZ $ ps) $ repeat black
+picToLTree mx (BezierQuad i vs) 
+    = filtB mx i $ LLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
+        where (ps,cols,rs) = unzip3 vs
+                                      
 picToLTree mx (Circle i colC colE r)
     = filtB mx i $ LLeaf $ RenderEllipse [( (-r, r,0), colC)
                                          ,( (-r,-r,0), colE)
@@ -68,9 +70,9 @@ scaleT (x,y) (a,b,(o,s,t)) = (a,b,(o,s*x,t*y))
 overPos :: (Point3 -> Point3) -> RenderType -> RenderType
 {-# INLINE overPos #-}
 overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
-overPos f (RenderBezQ vs) = RenderBezQ $ map (first $ f) vs
 overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs
 overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
+overPos f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs
 overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
 overPos f (RenderArc (a,b,c))  = RenderArc (f a,b,c)
 
@@ -82,10 +84,10 @@ overRot _ ren = ren
 overCol :: (Point4 -> Point4) -> RenderType -> RenderType
 {-# INLINE overCol #-}
 overCol f (RenderPoly vs)      = RenderPoly $ map (second $ f) vs
-overCol f (RenderBezQ vs)      = RenderBezQ $ map (second $ f) vs
 overCol f (RenderLine vs)      = RenderLine $ map (second $ f) vs
 overCol f (RenderEllipse vs)   = RenderEllipse $ map (second $ f) vs
 overCol f (RenderText vs)      = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
+overCol f (RenderBezQ vs)      = RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs
 overCol f (RenderArc (a,b,c))   = RenderArc (a,f b,c)
 
 overSca :: (Point2 -> Point2) -> RenderType -> RenderType