124 lines
4.9 KiB
Haskell
124 lines
4.9 KiB
Haskell
module Picture.Tree
|
|
( picToLTree
|
|
)
|
|
where
|
|
import Picture.Data
|
|
import Geometry
|
|
|
|
import Data.Bifunctor
|
|
import Data.List
|
|
|
|
-- todo: refactor out the layer check somehow
|
|
-- consider generalising to alternative rather than using LTree
|
|
picToLTree :: Maybe Int -> Picture -> LTree RenderType
|
|
{-# INLINE picToLTree #-}
|
|
picToLTree mx (Polygon i ps)
|
|
= filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
|
picToLTree mx (PolygonCol i vs)
|
|
= filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
|
where (ps,cs) = unzip vs
|
|
picToLTree mx (BezierQuad i vs)
|
|
= filtB mx i $ 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 [( (-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 $ ((0,0,0),black,(startA,endA,rad,wdth))
|
|
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
|
|
where (ps,cs) = unzip vs
|
|
picToLTree mx (Text i s)
|
|
= filtB mx i $ LLeaf $ RenderText $ stringToList s
|
|
picToLTree j Blank = LBranches []
|
|
picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
|
|
picToLTree j (OverPic f f' r f'' (OverPic g g' s g'' pic))
|
|
= picToLTree j $ OverPic (f . g) (f' . g') (r + s) (f'' . g'') pic
|
|
picToLTree j (OverPic f f' r f'' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f' r f'') ps)
|
|
picToLTree j (OverPic f f' r f'' pic) = fmap (overPos f . overSca f' . overRot r . 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
|
|
|
|
filtB :: Maybe Int -> Int -> LTree RenderType -> LTree RenderType
|
|
{-# INLINE filtB #-}
|
|
filtB mx i t | Just i == mx || Nothing == mx = t
|
|
| otherwise = LBranches []
|
|
|
|
doubleLine :: [a] -> [a]
|
|
{-# INLINE doubleLine #-}
|
|
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
|
|
doubleLine _ = []
|
|
|
|
white = (1,1,1,1)
|
|
black = (0,0,0,1)
|
|
|
|
polyToTris :: [s] -> [s]
|
|
{-# INLINE polyToTris #-}
|
|
polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
|
|
polyToTris _ = []
|
|
|
|
scaleT :: (Float,Float) -> (Point3,Point4,Point3) -> (Point3,Point4,Point3)
|
|
{-# INLINE scaleT #-}
|
|
scaleT (x,y) (a,b,(o,s,t)) = (a,b,(o,s*x,t*y))
|
|
|
|
overPos :: (Point3 -> Point3) -> RenderType -> RenderType
|
|
{-# INLINE overPos #-}
|
|
overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
|
|
overPos f (RenderLine vs) = RenderLine $ 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 (a,b,c)) = RenderArc (f a,b,c)
|
|
|
|
overRot :: Float -> RenderType -> RenderType
|
|
{-# INLINE overRot #-}
|
|
overRot ang (RenderArc (a,b,(r,s,t,v))) = RenderArc (a,b,(r+ang,s+ang,t,v))
|
|
overRot _ ren = ren
|
|
|
|
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
|
|
{-# INLINE overCol #-}
|
|
overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs
|
|
overCol f (RenderLine vs) = RenderLine $ 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 (a,b,c)) = RenderArc (a,f b,c)
|
|
|
|
overSca :: (Point2 -> Point2) -> RenderType -> RenderType
|
|
{-# INLINE overSca #-}
|
|
overSca f (RenderText vs) = RenderText $ map (scaleT (f (1,1))) vs
|
|
overSca f p = p
|
|
|
|
stringToList :: String -> [(Point3,Point4,Point3)]
|
|
{-# INLINE stringToList #-}
|
|
stringToList s = zipWith (\x (a,b,c) -> (translate3 x 0 a,b,c))
|
|
[0,0.9*dimText..]
|
|
$ map charToTuple s
|
|
--where dimText = 100
|
|
dimText :: Float
|
|
dimText = 100
|
|
|
|
charToTuple :: Char -> (Point3,Point4,Point3)
|
|
{-# INLINE charToTuple #-}
|
|
charToTuple c = ((0,0,0),white,(offset,dimText,2*dimText))
|
|
where offset = fromIntegral (fromEnum c) - 32
|
|
|
|
translate3 :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE translate3 #-}
|
|
translate3 a b (x,y,z) = (x+a,y+b,z)
|
|
scale3 :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE scale3 #-}
|
|
scale3 a b (x,y,z) = (x*a,y*b,z)
|
|
rotate3 :: Float -> Point3 -> Point3
|
|
{-# INLINE rotate3 #-}
|
|
rotate3 a (x,y,z) = (x',y',z)
|
|
where (x',y') = rotateV a (x,y)
|
|
|