Refactor picture rendering code

2021-03-10 22:45:43 +01:00
parent a2fa713bde
commit e2c35b21bc
4 changed files with 153 additions and 289 deletions
@@ -0,0 +1,140 @@
+module Picture.Tree
+    ( picToLTree
+    )
+    where
+import Picture.Data
+import Geometry
+
+import Data.Bifunctor
+import Data.List
+
+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 (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 _ = []
+
+tripFirst :: (a -> a') -> (a,b,c) -> (a',b,c)
+{-# INLINE tripFirst #-}
+tripFirst f (x,y,z) = (f x,y,z)
+
+tripSecond :: (b -> b') -> (a,b,c) -> (a,b',c)
+{-# INLINE tripSecond #-}
+tripSecond f (x,y,z) = (x,f y,z)
+
+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 (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 (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
+
+scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
+{-# INLINE scaleRen #-}
+scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT (x,y)) vs
+scaleRen x y rt = overPos (scale3 x y) rt
+{-# INLINE translateRen #-}
+translateRen x y = overPos $ translate3 x y
+rotateRen,setDepthRen :: Float -> RenderType -> RenderType
+{-# INLINE rotateRen #-}
+rotateRen a (RenderArc (p,c,(as,ae,r,w))) = overPos (rotate3 a) $ RenderArc (p,c,(f as,f ae,r,w))
+    --where f b = normalizeAngle $ a + b
+    where f b = a + b
+rotateRen a pic = overPos (rotate3 a) pic
+{-# INLINE setDepthRen #-}
+setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
+{-# INLINE colorRen #-}
+colorRen :: RGBA -> RenderType -> RenderType
+colorRen c = overCol $ const c
+
+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)
+