From f5873db68d99f1a6aaf3d242cf891dfe827dff3c Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 25 Jul 2021 02:12:55 +0200 Subject: [PATCH] Merge Picture and RenderType datatypes --- app/Main.hs | 2 +- src/Dodge/Creature/Inanimate.hs | 2 +- src/Dodge/Render.hs | 16 +-- src/Picture.hs | 68 ++++++--- src/Picture/Data.hs | 28 ++-- src/Picture/ToPolyhedra.hs | 12 +- src/Picture/Tree.hs | 246 ++++++++------------------------ src/Polyhedra.hs | 7 +- 8 files changed, 143 insertions(+), 238 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 931abcce0..ad63552fc 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -57,7 +57,7 @@ doSideEffects preData w = do let lastFrameTicks = _frameTimer preData when (_displaySecondsPerFrame $ _debugFlags w) $ void $ renderFoldable (_renderData preData) - (picToLTree Nothing . setLayer 1 . setDepth (-1) + (map snd $ setDepth (-1) . translate (-0.5) (-0.8) . scale 0.0005 0.0005 . text $ "ms/frame " ++ show (endTicks - lastFrameTicks) ) diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index a58eefeae..09e0353db 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/src/Dodge/Creature/Inanimate.hs @@ -36,7 +36,7 @@ lamp h = defaultInanimate } lampPic :: Float -> Picture lampPic h = pictures - [ setLayer 0 $ pictures . map (Poly3D . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 (h-1) + [ setLayer 0 $ pictures . map (helpPoly3D . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 (h-1) , setLayer 1 $ setDepth h $ color white $ circleSolid 3 ] diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 326a36de3..8052e17cc 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -80,20 +80,20 @@ doDrawing pdata w = do else renderBlankWalls pdata nWalls --_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType]) --_ <- renderFoldable pdata $ (picToAlt (Just 0) pic :: [RenderType]) - _ <- renderFoldable pdata $ picToLTree Nothing (polysToPic $ foregroundPics w) - _ <- renderFoldable pdata $ picToLTree (Just 0) pic + _ <- renderFoldable pdata $ map snd (polysToPic $ foregroundPics w) + _ <- renderFoldable pdata $ map snd $ filter ((==0).fst) pic _ <- renderShader (_textureArrayShader pdata) (_floorTiles w) bindFramebuffer Framebuffer $= fst (_fboBloom pdata) clear [ColorBuffer] blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - _ <- renderFoldable pdata $ picToLTree (Just 1) pic + _ <- renderFoldable pdata $ map snd $ filter ((==1).fst) pic bindFramebuffer Framebuffer $= fst (_fboColor pdata) clear [ColorBuffer] depthMask $= Disabled - _ <- renderFoldable pdata $ picToLTree (Just 3) pic - _ <- renderFoldable pdata $ picToLTree (Just 4) pic - _ <- renderFoldable pdata $ picToLTree (Just 5) pic + _ <- renderFoldable pdata $ map snd $ filter ((==3).fst) pic + _ <- renderFoldable pdata $ map snd $ filter ((==4).fst) pic + _ <- renderFoldable pdata $ map snd $ filter ((==5).fst) pic depthMask $= Enabled bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata) @@ -136,7 +136,7 @@ doDrawing pdata w = do drawShader (_fullscreenShader pdata) 4 depthFunc $= Just Lequal - _ <- renderFoldable pdata $ picToLTree (Just 2) pic + _ <- renderFoldable pdata $ map snd $ filter ((==2).fst) pic renderWindows pdata windowPoints depthFunc $= Just Always @@ -167,7 +167,7 @@ doDrawing pdata w = do depthMask $= Disabled blend $= Enabled blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - _ <- renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w) + _ <- renderFoldable pdata $ map snd (fixedCoordPictures w) depthMask $= Enabled eTicks <- SDL.ticks diff --git a/src/Picture.hs b/src/Picture.hs index 5de2f37d2..bb40d16da 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -54,8 +54,10 @@ import Geometry import Geometry.Vector3D import Geometry.Data import Picture.Data +import Picture.Tree ---import Data.Bifunctor +import Data.List +import Data.Bifunctor --import qualified Data.DList as DL --import Graphics.Rendering.OpenGL (lineWidth, ($=)) --import Control.Lens @@ -63,17 +65,22 @@ import Picture.Data black :: RGBA black = (0,0,0,1) +zl :: RenderType -> [(Int,RenderType)] +zl rt = [(0,rt)] + polygon :: [Point2] -> Picture {-# INLINE polygon #-} -polygon = Polygon +polygon ps = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black polygonZ :: [Point2] -> Float -> Picture {-# INLINE polygonZ #-} -polygonZ = PolygonZ +polygonZ ps z = zl $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z) polygonCol :: [(Point2,RGBA)] -> Picture {-# INLINE polygonCol #-} -polygonCol = PolygonCol +polygonCol vs = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs + where + (ps,cs) = unzip vs poly3 :: [Point3] -> Picture {-# INLINE poly3 #-} @@ -81,14 +88,14 @@ poly3 = poly3Col . map (, black) poly3Col :: [(Point3,RGBA)] -> Picture {-# INLINE poly3Col #-} -poly3Col = Poly3D +poly3Col vs = zl $ RenderPoly $ polyToTris vs -- note that much of work computing the width of the bezier curve is done here bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture bezierQuad cola colc ra rc a b c | a == b && b == c = blank | a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c - | otherwise = BezierQuad + | otherwise = bzhelp [-- ( (0,0) , cola, (0,0), (0,0) ) (aIn, cola, (fa aIn,fc aIn) , (1,0) ) ,(aIn, cola, (fa aIn,fc aIn) , (1,0) ) @@ -118,6 +125,12 @@ bezierQuad cola colc ra rc a b c fa' = extrapolate aIn cIn bIn fc' = extrapolate cIn aIn bIn +bzhelp vs = zl $ 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 + + -- given a one and two zeros of a linear function over x and y, -- determine the function -- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f @@ -135,7 +148,7 @@ extrapolate (ox,oy) (ax,ay) (bx,by) (x,y) = color :: RGBA -> Picture -> Picture {-# INLINE color #-} -color c = OverPic id (const c) +color c = map $ second $ overCol (const c) translate3 :: Float -> Float -> Point3 -> Point3 {-# INLINE translate3 #-} @@ -143,19 +156,19 @@ translate3 a b (x,y,z) = (x+a,y+b,z) translate :: Float -> Float -> Picture -> Picture {-# INLINE translate #-} -translate x y = OverPic (translate3 x y) id +translate x y = map $ second $ overPos (translate3 x y) setDepth :: Float -> Picture -> Picture {-# INLINE setDepth #-} -setDepth d = OverPic (\(x,y,_) -> (x,y,d)) id +setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d)) addDepth :: Float -> Picture -> Picture {-# INLINE addDepth #-} -addDepth d = OverPic (\(x,y,z) -> (x,y,z+d)) id +addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d)) setLayer :: Int -> Picture -> Picture {-# INLINE setLayer #-} -setLayer = OnLayer +setLayer = map . first . const scale3 :: Float -> Float -> Point3 -> Point3 {-# INLINE scale3 #-} @@ -163,15 +176,15 @@ scale3 a b (x,y,z) = (x*a,y*b,z) scale :: Float -> Float -> Picture -> Picture {-# INLINE scale #-} -scale x y = OverPic (scale3 x y) id +scale x y = map $ second $ overPos $ (scale3 x y) rotate :: Float -> Picture -> Picture {-# INLINE rotate #-} -rotate a = OverPic (rotate3 a) id +rotate a = map $ second $ overPos $ (rotate3 a) pictures :: [Picture] -> Picture {-# INLINE pictures #-} -pictures = Pictures +pictures = concat makeArc :: Float -> (Float,Float) -> [Point2] {-# INLINE makeArc #-} @@ -182,11 +195,15 @@ makeArc rad (a,b) = map (`rotateV` (0,rad)) angles circleSolid :: Float -> Picture {-# INLINE circleSolid #-} -circleSolid = Circle white white +circleSolid = circleSolidCol white white circleSolidCol :: Color -> Color -> Float -> Picture {-# INLINE circleSolidCol #-} -circleSolidCol = Circle +circleSolidCol colC colE r = zl $ RenderEllipse + [( (-r, r,0), colC) + ,( (-r,-r,0), colE) + ,( ( r,-r,0), black) + ] circle :: Float -> Picture {-# INLINE circle #-} @@ -194,7 +211,7 @@ circle rad = thickArc 0 (2*pi) rad 1 text :: String -> Picture {-# INLINE text #-} -text = Text +text s = zl $ RenderText $ stringToList s line :: [Point2] -> Picture {-# INLINE line #-} @@ -256,13 +273,26 @@ thickArc :: Float -> Float -> Float -> Float -> Picture thickArc startA endA rad wdth | endA - startA > pi = pictures [ thickArc (startA + pi) endA rad wdth - , ThickArc startA (startA + pi) r w + , thickArcHelp startA (startA + pi) r w ] - | otherwise = ThickArc startA endA r w + | otherwise = thickArcHelp startA endA r w where r = rad + 0.5 * wdth w = 1 - wdth / r +thickArcHelp startA endA rad wdth = zl $ 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) + withAlpha :: Float -> RGBA -> RGBA {-# INLINE withAlpha #-} withAlpha a (x,y,z,a') = (x,y,z,a*a') diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 7648af3ba..c34f8becb 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -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 = [] diff --git a/src/Picture/ToPolyhedra.hs b/src/Picture/ToPolyhedra.hs index 9ef9b6ca6..0e7fcc9a0 100644 --- a/src/Picture/ToPolyhedra.hs +++ b/src/Picture/ToPolyhedra.hs @@ -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 _ = [] diff --git a/src/Picture/Tree.hs b/src/Picture/Tree.hs index bc5c2d907..8deb3ac1c 100644 --- a/src/Picture/Tree.hs +++ b/src/Picture/Tree.hs @@ -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) diff --git a/src/Polyhedra.hs b/src/Polyhedra.hs index 3f572dc03..e47c998da 100644 --- a/src/Polyhedra.hs +++ b/src/Polyhedra.hs @@ -83,7 +83,12 @@ boxABC a b c = faceNA = rhombus c b polyToPics :: Polyhedra -> [Picture] -polyToPics = map Poly3D . _pyFaces +polyToPics = map helpPoly3D . _pyFaces + +helpPoly3D vs = zl $ RenderPoly $ polyToTris vs + where + zl :: RenderType -> [(Int,RenderType)] + zl rt = [(0,rt)] polysToPic :: [Polyhedra] -> Picture polysToPic = pictures . concatMap polyToPics