Merge Picture and RenderType datatypes
This commit is contained in:
+14
-14
@@ -99,20 +99,20 @@ flat4 (x,y,z,w) = [x,y,z,w]
|
||||
{-# INLINE flat3 #-}
|
||||
{-# INLINE flat4 #-}
|
||||
|
||||
data Picture
|
||||
= Blank
|
||||
| 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
|
||||
| Pictures [Picture]
|
||||
| OverPic (Point3 -> Point3) (Point4 -> Point4) Picture
|
||||
| OnLayer Int Picture
|
||||
type Picture = [(Int,RenderType)]
|
||||
-- = Blank
|
||||
-- | 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
|
||||
-- | Pictures [Picture]
|
||||
-- | OverPic (Point3 -> Point3) (Point4 -> Point4) Picture
|
||||
-- | OnLayer Int Picture
|
||||
|
||||
blank :: Picture
|
||||
{-# INLINE blank #-}
|
||||
blank = Blank
|
||||
blank = []
|
||||
|
||||
@@ -3,9 +3,9 @@ module Picture.ToPolyhedra
|
||||
import Picture.Data
|
||||
import Geometry.Data
|
||||
|
||||
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 _ = []
|
||||
--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 _ = []
|
||||
|
||||
+58
-188
@@ -1,11 +1,8 @@
|
||||
{- Transform a picture into renderable objects. -}
|
||||
module Picture.Tree
|
||||
( picToLTree
|
||||
, picToLTree'
|
||||
, picToFTree
|
||||
, picToRenderList
|
||||
, picToAlt
|
||||
, picToRList
|
||||
( overPos
|
||||
, overCol
|
||||
, stringToList
|
||||
)
|
||||
where
|
||||
import Picture.Data
|
||||
@@ -20,189 +17,62 @@ import qualified Data.DList as DL
|
||||
import Control.Applicative
|
||||
--import Data.Maybe (isNothing)
|
||||
|
||||
picToLTree'
|
||||
:: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
|
||||
-> Picture
|
||||
-> LTree RenderType
|
||||
picToLTree' x p = rnf (picToLTree x p) `seq` picToLTree x p
|
||||
|
||||
-- todo: refactor out the layer check somehow
|
||||
-- consider generalising to alternative rather than using LTree
|
||||
-- | Transform a picture into a tree of renderable objects
|
||||
picToLTree
|
||||
:: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
|
||||
-> Picture
|
||||
-> LTree RenderType
|
||||
--{-# INLINE picToLTree #-}
|
||||
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 _ (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 _ (Circle colC colE r) = LLeaf $ RenderEllipse
|
||||
[( (-r, r,0), colC)
|
||||
,( (-r,-r,0), colE)
|
||||
,( ( r,-r,0), black)
|
||||
]
|
||||
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))
|
||||
,( (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)
|
||||
picToLTree _ (Text s) = LLeaf $ RenderText $ stringToList s
|
||||
picToLTree _ Blank = LBranches []
|
||||
picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
|
||||
--picToLTree j (Pictures pics) = LBranches . forceFoldable $ map (picToLTree j) pics
|
||||
picToLTree j (OverPic f f' (OverPic g g' pic)) = picToLTree j $ OverPic (f . g) (f' . g') pic
|
||||
picToLTree j (OverPic f f' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f') ps)
|
||||
picToLTree j (OverPic f f' pic) = overPos f . overCol f' <$> picToLTree j pic
|
||||
picToLTree (Just j) (OnLayer i pic)
|
||||
| j == i = picToLTree Nothing pic
|
||||
| otherwise = LBranches []
|
||||
picToLTree Nothing (OnLayer _ pic) = picToLTree Nothing pic
|
||||
|
||||
picToFTree
|
||||
:: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
|
||||
-> Picture
|
||||
-> FTree RenderType
|
||||
--{-# INLINE picToFTree #-}
|
||||
picToFTree _ (Polygon ps)
|
||||
= FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
picToFTree _ (PolygonZ ps z)
|
||||
= FLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
|
||||
picToFTree _ (PolygonCol vs)
|
||||
= FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
where
|
||||
(ps,cs) = unzip vs
|
||||
picToFTree _ (Poly3D vs) = FLeaf $ RenderPoly $ polyToTris vs
|
||||
picToFTree _ (BezierQuad vs) = FLeaf $ 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
|
||||
picToFTree _ (Circle colC colE r) = FLeaf $ RenderEllipse
|
||||
[( (-r, r,0), colC)
|
||||
,( (-r,-r,0), colE)
|
||||
,( ( r,-r,0), black)
|
||||
]
|
||||
picToFTree _ (ThickArc startA endA rad wdth) = FLeaf $ 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)
|
||||
picToFTree _ (Text s) = FLeaf $ RenderText $ stringToList s
|
||||
picToFTree _ Blank = FBranches []
|
||||
picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
|
||||
picToFTree j (OverPic f f' pic) = FBranch (overPos f . overCol f') $ picToFTree j pic
|
||||
picToFTree (Just j) (OnLayer i pic) | j == i = picToFTree Nothing pic
|
||||
| otherwise = FBranches []
|
||||
picToFTree Nothing (OnLayer _ pic) = picToFTree Nothing pic
|
||||
|
||||
-- might want to use the Alt newType
|
||||
picToAlt
|
||||
:: (Alternative t, Monoid (t RenderType))
|
||||
=> Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
|
||||
-> Picture
|
||||
-> t RenderType
|
||||
{-# INLINE picToAlt #-}
|
||||
picToAlt _ Blank = empty
|
||||
picToAlt j (Pictures pics) = foldMap (picToAlt j) pics
|
||||
picToAlt j (OverPic f f' (OverPic g g' pic)) = picToAlt j $ OverPic (f . g) (f' . g') pic
|
||||
--picToAlt j (OverPic f f' (Pictures ps)) = concat $ fmap (picToAlt j . OverPic f f') ps
|
||||
picToAlt j (OverPic f f' pic) = overPos f . overCol f' <$> picToAlt j pic
|
||||
picToAlt (Just j) (OnLayer i pic)
|
||||
| j == i = picToAlt Nothing pic
|
||||
| otherwise = empty
|
||||
picToAlt Nothing (OnLayer _ pic) = picToAlt Nothing pic
|
||||
picToAlt _ pic = pure $ picToRenderType pic
|
||||
|
||||
picToRList
|
||||
:: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
|
||||
-> Picture
|
||||
-> DL.DList RenderType
|
||||
picToRList = picToAlt
|
||||
|
||||
picToRenderList
|
||||
:: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
|
||||
-> Picture
|
||||
-> [RenderType]
|
||||
{-# INLINE picToRenderList #-}
|
||||
picToRenderList _ Blank = []
|
||||
picToRenderList j (Pictures pics) = concatMap (picToRenderList j) pics
|
||||
picToRenderList j (OverPic f f' (OverPic g g' pic)) = picToRenderList j $ OverPic (f . g) (f' . g') pic
|
||||
picToRenderList j (OverPic f f' (Pictures ps)) = concatMap (picToRenderList j . OverPic f f') ps
|
||||
picToRenderList j (OverPic f f' pic) = overPos f . overCol f' <$> picToRenderList j pic
|
||||
picToRenderList (Just j) (OnLayer i pic)
|
||||
| j == i = picToRenderList Nothing pic
|
||||
| otherwise = []
|
||||
picToRenderList Nothing (OnLayer _ pic) = picToRenderList Nothing pic
|
||||
picToRenderList _ pic = [picToRenderType pic]
|
||||
|
||||
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 (Text s) = RenderText $ stringToList s
|
||||
picToRenderType _ = error "Tried to make a render type from a tree picture"
|
||||
--
|
||||
--picToAlternative
|
||||
-- :: Alternative t
|
||||
-- => Maybe Int
|
||||
--picToLTree'
|
||||
-- :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
|
||||
-- -> Picture
|
||||
-- -> t RenderType
|
||||
--picToAlternative _ Blank = empty
|
||||
--picToAlternative j (Pictures pics) = undefined
|
||||
-- -> LTree RenderType
|
||||
--picToLTree' x p = rnf (picToLTree x p) `seq` picToLTree x p
|
||||
--
|
||||
---- todo: refactor out the layer check somehow
|
||||
---- consider generalising to alternative rather than using LTree
|
||||
---- | Transform a picture into a tree of renderable objects
|
||||
--picToLTree
|
||||
-- :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
|
||||
-- -> Picture
|
||||
-- -> LTree RenderType
|
||||
----{-# INLINE picToLTree #-}
|
||||
--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 _ (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 _ (Circle colC colE r) = LLeaf $ RenderEllipse
|
||||
-- [( (-r, r,0), colC)
|
||||
-- ,( (-r,-r,0), colE)
|
||||
-- ,( ( r,-r,0), black)
|
||||
-- ]
|
||||
--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))
|
||||
-- ,( (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)
|
||||
--picToLTree _ (Text s) = LLeaf $ RenderText $ stringToList s
|
||||
--picToLTree _ Blank = LBranches []
|
||||
--picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
|
||||
----picToLTree j (Pictures pics) = LBranches . forceFoldable $ map (picToLTree j) pics
|
||||
--picToLTree j (OverPic f f' (OverPic g g' pic)) = picToLTree j $ OverPic (f . g) (f' . g') pic
|
||||
--picToLTree j (OverPic f f' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f') ps)
|
||||
--picToLTree j (OverPic f f' pic) = overPos f . overCol f' <$> picToLTree j pic
|
||||
--picToLTree (Just j) (OnLayer i pic)
|
||||
-- | j == i = picToLTree Nothing pic
|
||||
-- | otherwise = LBranches []
|
||||
--picToLTree Nothing (OnLayer _ pic) = picToLTree Nothing pic
|
||||
|
||||
|
||||
white, black :: Color
|
||||
white = (1,1,1,1)
|
||||
|
||||
Reference in New Issue
Block a user