Allow for interpolating colors from center to edge of ellipses

2021-03-10 12:12:59 +01:00
parent 5a16086743
commit d3c8504d21
8 changed files with 128 additions and 78 deletions
@@ -68,8 +68,7 @@ data Picture
    | Text Int String
    | Polygon Int [Point2]
    | PolygonCol Int [(Point2,RGBA)]
-    | Circle Int Float
-    | Ellipse Int Point2 Point2 Float
+    | Circle Int RGBA RGBA Float
    | ThickArc Int Float Float Float Float
    | Line Int [Point2]
    | LineCol Int [(Point2,RGBA)]
@@ -105,7 +105,7 @@ preloadRender = do
    fcs <- makeSourcedShader "lightmapCircle" [VertexShader,GeometryShader,FragmentShader]
    bgs <- makeSourcedShader "background" [VertexShader,GeometryShader,FragmentShader]
    wss <- makeSourcedShader "wallShadow" [VertexShader,GeometryShader,FragmentShader]
-    es  <- makeSourcedShader "ellipse"     [VertexShader,GeometryShader,FragmentShader]
+    es  <- makeSourcedShader "ellipseInterpolate"     [VertexShader,GeometryShader,FragmentShader]

    wssLightPosUniLoc   <- GL.uniformLocation (fst wss) "lightPos"

@@ -118,80 +118,68 @@ charToTuple :: Char -> (Point3,Point4,Point3)
 charToTuple c = ((0,0,0),white,(offset,dimText,2*dimText))
    where offset = fromIntegral (fromEnum c) - 32

-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
+--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

 collapseBranch :: (RenderType -> RenderType) -> FTree RenderType -> FTree RenderType
 collapseBranch f (FBranch g t) = FBranch (f . g) t
 collapseBranch f (FBranches ts) = FBranches $ map (collapseBranch f) ts
 collapseBranch f (FLeaf x) = FLeaf (f x)

+filtB :: Maybe Int -> Int -> LTree RenderType -> LTree RenderType
+{-# INLINE filtB #-}
+filtB mx i t | Just i == mx || Nothing == mx = t
+             | otherwise                     = LBranches []
+
 picToLTree :: Maybe Int -> Picture -> LTree RenderType
 {-# INLINE picToLTree #-}
 picToLTree mx (Polygon i ps)
-    | Just i == mx = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-    | Nothing == mx = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-    | otherwise = LBranches []
-picToLTree mx (PolygonCol i vs) 
-    | Just i == mx || Nothing == mx = 
-        let (ps,cs) = unzip vs
-        in  LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
-    | otherwise = LBranches []
-picToLTree mx (Circle i r) 
-    | Just i == mx || Nothing == mx = LLeaf $ RenderEllipse
-                                                [((-r, r,0), black)
-                                                ,((-r,-r,0), black)
-                                                ,(( r,-r,0), black)
-                                                ]
-    | otherwise = LBranches []
-picToLTree mx (Ellipse i (ax,ay) (bx,by) r) 
-    | Just i == mx || Nothing == mx = LLeaf $ RenderEllipse [((ax,ay+r,0),black)
-                                       ,((ax,ay-r,0),black)
-                                       ,((bx,by-r,0),black)
-                                       ]
-    | otherwise = LBranches []
+    = 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
+        where (ps,cs) = unzip vs
+picToLTree mx (Circle i colC colE r)
+    = filtB mx i $ LLeaf $ RenderEllipse [( (-r, r,0), colC)
+                                         ,( (-r,-r,0), colE)
+                                         ,( ( r,-r,0), black)
+                                         ]
 picToLTree mx (ThickArc i startA endA rad wdth) 
-    | Just i == mx || Nothing == mx = LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
-    | otherwise = LBranches []
+    = filtB mx i $ LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
 picToLTree mx (Line i ps) 
-    | Just i == mx || Nothing == mx = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
-    | otherwise = LBranches []
+    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
 picToLTree mx (LineCol i vs) 
-    | Just i == mx || Nothing == mx = 
-        let (ps,cs) = unzip vs
-        in  LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
-    | otherwise = LBranches []
+    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
+        where (ps,cs) = unzip vs
 picToLTree mx (Text i s) 
-    | Just i == mx || Nothing == mx = LLeaf $ RenderText $ stringToList s
-    | otherwise = LBranches []
+    = filtB mx i $ LLeaf $ RenderText $ stringToList s
 picToLTree j Blank = LBranches []
 picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
 picToLTree j (OverPic f f' r f'' (OverPic g g' s g'' pic))