First implementation of quadratic bezier curve shader

src/Picture/Data.hs

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

src/Picture/Preload.hs

@@ -49,6 +49,9 @@ preloadRender = do
                                 [(0,3),(1,4),(2,3)] Points pokeCharStrat
                                 "data/texture/charMap.png"
 
+    bezierQuadShader
+           <- makeShader "bezierQuad" [vert,geom,frag] [(0,3),(1,4)]    Triangles pokeBezQStrat
+
 --the following vbo is set up to contain one fixed vertex
     dummyvbo <- genObjectName
     dummyptr <- mallocArray numDrawableElements
@@ -61,7 +64,7 @@ preloadRender = do
     backgroundvao <- setupVAO [(0,4),(1,2)]
     
     return $ RenderData
-        { _listShaders = [bslist,lslist,cslist,aslist,eslist]
+        { _listShaders = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
         , _dummyVBO = dummyvbo
         , _dummyPtr = dummyptr
         , _lightSourceShader = lsShad
@@ -79,7 +82,13 @@ cleanUpRenderPreload pd = do
     freeShaderPointers $ _backgroundShader pd
     free $ _dummyPtr pd
 
+{-# 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 _ = []
+
 {-# INLINE pokeTriStrat #-}
+pokeTriStrat :: RenderType -> [[[Float]]]
 pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
 pokeTriStrat _ = []
 

src/Picture/Tree.hs

@@ -8,13 +8,17 @@ import Geometry
 import Data.Bifunctor
 import Data.List
 
+-- todo: refactor out the layer check somehow
+-- consider generalising to alternative rather than using LTree
 picToLTree :: Maybe Int -> Picture -> LTree RenderType
 {-# INLINE picToLTree #-}
 picToLTree mx (Polygon i ps)
     = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-picToLTree mx (PolygonCol i vs) = 
-    filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+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 (Circle i colC colE r)
     = filtB mx i $ LLeaf $ RenderEllipse [( (-r, r,0), colC)
                                          ,( (-r,-r,0), colE)
@@ -64,6 +68,7 @@ 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 (RenderEllipse vs) = RenderEllipse $ map (first f) vs
@@ -77,6 +82,7 @@ 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
@@ -112,35 +118,3 @@ rotate3 :: Float -> Point3 -> Point3
 rotate3 a (x,y,z) = (x',y',z)
     where (x',y') = rotateV a (x,y)
 
---picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
---{-# INLINE picToAlt #-}
---picToAlt x (Polygon i ps) 
---    | i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
---    | otherwise = Ap.empty
---picToAlt x (PolygonCol i vs) 
---    | i /= x = Ap.empty 
---    | otherwise = 
---        let (ps,cs) = unzip vs
---        in  Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
---picToAlt x (Circle i r) 
---    | i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
---    | otherwise = Ap.empty
---picToAlt x (Ellipse i (ax,ay) (bx,by) r) 
---    | i == x = Ap.pure $ RenderEllipse [((ax,ay+r,0),black)
---                                       ,((ax,ay-r,0),black)
---                                       ,((bx,by-r,0),black)
---                                       ]
---    | otherwise = Ap.empty
---picToAlt x (ThickArc i startA endA rad wdth) 
---    | i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
---    | otherwise = Ap.empty
---picToAlt x (Line i ps) 
---    | i == x = Ap.pure $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
---    | otherwise = Ap.empty
---picToAlt x (Text i s) 
---    | i == x = Ap.pure $ RenderText $ stringToList s
---    | otherwise = Ap.empty
---picToAlt j Blank = Ap.empty
---picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics
-
-