256 lines
9.6 KiB
Haskell
256 lines
9.6 KiB
Haskell
{- Transform a picture into renderable objects. -}
|
|
module Picture.Tree
|
|
( picToLTree
|
|
, picToLTree'
|
|
, picToFTree
|
|
, picToRenderList
|
|
, picToAlt
|
|
, picToRList
|
|
)
|
|
where
|
|
import Picture.Data
|
|
import Geometry
|
|
import Geometry.Data
|
|
--import StrictHelp
|
|
import Control.DeepSeq
|
|
|
|
import Data.Bifunctor
|
|
import Data.List
|
|
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
|
|
-- -> Picture
|
|
-- -> t RenderType
|
|
--picToAlternative _ Blank = empty
|
|
--picToAlternative j (Pictures pics) = undefined
|
|
|
|
white, black :: Color
|
|
white = (1,1,1,1)
|
|
black = (0,0,0,1)
|
|
|
|
overPos :: (Point3 -> Point3) -> RenderType -> RenderType
|
|
--{-# INLINE overPos #-}
|
|
overPos f (RenderPoly vs) = RenderPoly $ map (first f) vs
|
|
overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
|
|
overPos f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs
|
|
overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
|
|
overPos f (RenderArc vs) = RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs
|
|
overPos f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs
|
|
overPos _ _ = undefined
|
|
|
|
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
|
|
--{-# INLINE overCol #-}
|
|
overCol f (RenderPoly vs) = RenderPoly $ map (second f) vs
|
|
overCol f (RenderEllipse vs) = RenderEllipse $ map (second f) vs
|
|
overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
|
|
overCol f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs
|
|
overCol f (RenderArc vs) = RenderArc $ map (\(a,b,c) -> (a,f b,c)) vs
|
|
overCol f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (a,f b,c)) vs
|
|
overCol _ _ = undefined
|
|
|
|
-- no premature optimisation, consider changing to use texture arrays
|
|
stringToList :: String -> [(Point3,Point4,Point2)]
|
|
{-# INLINE stringToList #-}
|
|
--stringToList s = concat $ zipWith charToTuple [0,0.9*dimText ..] s
|
|
stringToList s = concatMap (uncurry charToTuple) $ zip [0,0.9*dimText ..] s
|
|
where
|
|
dimText = 100
|
|
|
|
charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
|
|
{-# INLINE charToTuple #-}
|
|
charToTuple x c =
|
|
[((x-50,-100,0), white,(offset,1))
|
|
,((x-50,100,0), white,(offset,0))
|
|
,((x+50,100,0), white,(offset+1,0))
|
|
,((x-50,-100,0), white,(offset,1))
|
|
,((x+50,-100,0), white,(offset+1,1))
|
|
,((x+50,100,0), white,(offset+1,0))
|
|
]
|
|
where
|
|
offset = fromIntegral (fromEnum c) - 32
|
|
|
|
--{- Translate a 3D vector in the x and y directions. -}
|
|
--translate3 :: Float -> Float -> Point3 -> Point3
|
|
--{-# INLINE translate3 #-}
|
|
--translate3 a b (x,y,z) = (x+a,y+b,z)
|