Merge Picture and RenderType datatypes
This commit is contained in:
+1
-1
@@ -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)
|
||||
)
|
||||
|
||||
@@ -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
|
||||
]
|
||||
|
||||
|
||||
+8
-8
@@ -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
|
||||
|
||||
+49
-19
@@ -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')
|
||||
|
||||
+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)
|
||||
|
||||
+6
-1
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user