Tweak picture layers

2021-07-21 17:52:38 +02:00
parent 0aa437d035
commit 9f37ecb204
13 changed files with 134 additions and 80 deletions
@@ -4,7 +4,7 @@ module Picture.Data
    where
 import Geometry.Data

-import Data.Foldable
+--import Data.Foldable

 --import Data.Monoid
 --import Data.Traversable
@@ -82,16 +82,16 @@ flat4 (x,y,z,w) = [x,y,z,w]

 data Picture
    = Blank
-    | Text Int String
-    | Polygon Int [Point2]
-    | PolygonZ Int [Point2] Float
-    | BezierQuad Int [(Point2,RGBA,Point2,Point2)]
-    | PolygonCol Int [(Point2,RGBA)]
-    | Poly3D Int [(Point3,RGBA)]
-    | Circle Int RGBA RGBA Float
-    | ThickArc Int Float Float Float Float
-    | Line Int [Point2]
-    | LineCol Int [(Point2,RGBA)]
+    | Text String
+    | Polygon [Point2]
+    | PolygonZ [Point2] Float
+    | BezierQuad [(Point2,RGBA,Point2,Point2)]
+    | PolygonCol [(Point2,RGBA)]
+    | Poly3D [(Point3,RGBA)]
+    | Circle RGBA RGBA Float
+    | ThickArc Float Float Float Float
+    | Line [Point2]
+    | LineCol [(Point2,RGBA)]
    | Pictures [Picture]
    | OverPic (Point3 -> Point3) (Point4 -> Point4) Picture
    | OnLayer Int Picture
@@ -7,5 +7,5 @@ toPolyhedra :: Picture -> [[Point3]]
 toPolyhedra (OnLayer _ pic) = toPolyhedra pic
 toPolyhedra (Pictures pics) = concatMap toPolyhedra pics
 toPolyhedra (OverPic f _ pic) = map (map f) $ toPolyhedra pic
-toPolyhedra (Poly3D _ vs) = [map fst vs]
+toPolyhedra (Poly3D vs) = [map fst vs]
 toPolyhedra _ = []
@@ -9,7 +9,8 @@ import Geometry.Data

 import Data.Bifunctor
 import Data.List
-import Data.Maybe (isNothing)
+--import Control.Applicative
+--import Data.Maybe (isNothing)

 -- todo: refactor out the layer check somehow
 -- consider generalising to alternative rather than using LTree
@@ -19,25 +20,25 @@ picToLTree
    -> Picture
    -> LTree RenderType
 {-# INLINE picToLTree #-}
-picToLTree mx (Polygon i ps)
-    = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-picToLTree mx (PolygonZ i ps z)
-    = filtB mx i $ LLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
-picToLTree mx (PolygonCol i vs)
-    = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+picToLTree _ (Polygon ps)
+    = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+picToLTree _ (PolygonZ ps z)
+    = LLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
+picToLTree _ (PolygonCol vs)
+    = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
  where 
    (ps,cs) = unzip vs
-picToLTree mx (Poly3D i vs) = filtB mx i $ LLeaf $ RenderPoly $ polyToTris vs
-picToLTree mx (BezierQuad i vs) = filtB mx i $ LLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
+picToLTree _ (Poly3D vs) = LLeaf $ RenderPoly $ polyToTris vs
+picToLTree _ (BezierQuad vs) = LLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
  where 
    (ps,cols,offps,rads) = unzip4 vs
    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
-picToLTree mx (Circle i colC colE r) = filtB mx i $ LLeaf $ RenderEllipse 
+picToLTree _ (Circle colC colE r) = LLeaf $ RenderEllipse 
    [( (-r, r,0), colC)
    ,( (-r,-r,0), colE)
    ,( ( r,-r,0), black)
    ]
-picToLTree mx (ThickArc i startA endA rad wdth) = filtB mx i $ LLeaf $ RenderArc 
+picToLTree _ (ThickArc startA endA rad wdth) = LLeaf $ RenderArc 
    [(  (0,0,0),black,(0,0,wdth))
    ,((xa,ya,0),black,(1,0,wdth))
    ,((xb,yb,0),black,(1,1,wdth))
@@ -49,12 +50,12 @@ picToLTree mx (ThickArc i startA endA rad wdth) = filtB mx i $ LLeaf $ RenderArc
    (xa,ya) = rotateV startA (rad,0)
    (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
    (xc,yc) = rotateV endA (rad,0)
-picToLTree mx (Line i ps) 
-    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
-picToLTree mx (LineCol i vs) 
-    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
+picToLTree _ (Line ps) 
+    = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
+picToLTree _ (LineCol vs) 
+    = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
  where (ps,cs) = unzip vs
-picToLTree mx (Text i s) = filtB mx i $ LLeaf $ RenderText $ stringToList s
+picToLTree _ (Text s) = LLeaf $ RenderText $ stringToList s
 picToLTree _ Blank = LBranches []
 picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
 picToLTree j (OverPic f f' (OverPic g g' pic)) = picToLTree j $ OverPic (f . g) (f' . g') pic
@@ -64,11 +65,56 @@ picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic
                                    | otherwise = LBranches []
 picToLTree Nothing  (OnLayer _ pic) = picToLTree Nothing pic

-filtB :: Maybe Int -> Int -> LTree RenderType -> LTree RenderType
-{-# INLINE filtB #-}
-filtB mx i t 
-    | Just i == mx || isNothing mx = t
-    | otherwise                    = LBranches []
+--picToRenderType 
+--    :: Picture
+--    -> RenderType
+--{-# INLINE picToRenderType #-}
+--picToRenderType (Polygon ps)
+--    = RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+--picToRenderType (PolygonZ ps z)
+--    = RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
+--picToRenderType (PolygonCol vs)
+--    = RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+--  where 
+--    (ps,cs) = unzip vs
+--picToRenderType (Poly3D vs) = RenderPoly $ polyToTris vs
+--picToRenderType (BezierQuad vs) = RenderBezQ $ zip3 (map zeroZ ps) cols rs
+--  where 
+--    (ps,cols,offps,rads) = unzip4 vs
+--    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
+--picToRenderType (Circle colC colE r) = RenderEllipse 
+--    [( (-r, r,0), colC)
+--    ,( (-r,-r,0), colE)
+--    ,( ( r,-r,0), black)
+--    ]
+--picToRenderType (ThickArc startA endA rad wdth) = RenderArc 
+--    [(  (0,0,0),black,(0,0,wdth))
+--    ,((xa,ya,0),black,(1,0,wdth))
+--    ,((xb,yb,0),black,(1,1,wdth))
+--    ,(  (0,0,0),black,(0,0,wdth))
+--    ,((xb,yb,0),black,(1,1,wdth))
+--    ,((xc,yc,0),black,(0,1,wdth))
+--    ]
+--  where
+--    (xa,ya) = rotateV startA (rad,0)
+--    (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
+--    (xc,yc) = rotateV endA (rad,0)
+--picToRenderType (Line ps) 
+--    = RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
+--picToRenderType (LineCol vs) 
+--    = RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
+--  where (ps,cs) = unzip vs
+--picToRenderType _ = error "Tried to make a render type from a tree picture"
+--picToRenderType (Text s) = RenderText $ stringToList s
+--
+--picToAlternative
+--    :: Alternative t
+--    => Maybe Int
+--    -> Picture
+--    -> t RenderType
+--picToAlternative _ Blank = empty
+--picToAlternative j (Pictures pics) = undefined
+    

 doubleLine :: [a] -> [a]
 {-# INLINE doubleLine #-}