From f68b8be9ce773c8abfae958b1163f69bd47484f5 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Mon, 1 Mar 2021 12:36:57 +0100
Subject: [PATCH] Try to fuse functions over pictures (overPos and overCol)

---
 src/Picture.hs        | 12 +++++++-----
 src/Picture/Data.hs   |  2 +-
 src/Picture/Render.hs |  8 ++++++++
 3 files changed, 16 insertions(+), 6 deletions(-)

diff --git a/src/Picture.hs b/src/Picture.hs
index 9335e8fc6..567d66eea 100644
--- a/src/Picture.hs
+++ b/src/Picture.hs
@@ -88,7 +88,7 @@ polygonCol = PolygonCol 0
 
 color :: RGBA -> Picture -> Picture
 {-# INLINE color #-}
-color c pic = Color c pic
+color c pic = OverPic id id (const c) pic
 
 translate3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE translate3 #-}
@@ -96,11 +96,11 @@ translate3 a b (x,y,z) = (x+a,y+b,z)
 
 translate :: Float -> Float -> Picture -> Picture
 {-# INLINE translate #-}
-translate x y pic = Translate x y pic
+translate x y pic = OverPic (translate3 x y) id id pic
 
 setDepth :: Float -> Picture -> Picture
 {-# INLINE setDepth #-}
-setDepth d pic = SetDepth d pic
+setDepth d pic = OverPic (\(x,y,_) -> (x,y,-d)) id id pic
 
 setLayer :: Int -> Picture -> Picture
 setLayer _ Blank = Blank
@@ -115,6 +115,7 @@ setLayer i (Rotate x p) = Rotate x $ setLayer i p
 setLayer i (SetDepth x p) = SetDepth x $ setLayer i p
 setLayer i (Color x p) = Color x $ setLayer i p
 setLayer i (Pictures p) = Pictures $ map (setLayer i) p
+setLayer i (OverPic f f' f'' pic) = OverPic f f' f'' (setLayer i pic)
 
 
 scale3 :: Float -> Float -> Point3 -> Point3
@@ -123,15 +124,16 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
 
 scale :: Float -> Float -> Picture -> Picture
 {-# INLINE scale #-}
-scale x y pic = Scale x y pic
+scale x y pic = OverPic (scale3 x y) ((*) x) id pic
 
 rotate3 :: Float -> Point3 -> Point3
 {-# INLINE rotate3 #-}
 rotate3 a (x,y,z) = (x',y',z)
     where (x',y') = rotateV a (x,y)
 
-rotate = Rotate
+rotate :: Float -> Picture -> Picture
 {-# INLINE rotate #-}
+rotate a pic = OverPic (rotate3 a) id id pic
 
 --rotateRad a = Rotate a
 --{-# INLINE rotateRad #-}
diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs
index dbe3682c2..fa087f85f 100644
--- a/src/Picture/Data.hs
+++ b/src/Picture/Data.hs
@@ -66,7 +66,7 @@ data Picture
     | SetDepth Float Picture
     | Color RGBA Picture
     | Pictures [Picture]
-    | OverPos (Point3 -> Point3) (Float -> Float) Picture
+    | OverPic (Point3 -> Point3) (Float -> Float) (Point4 -> Point4) Picture
 
 
 blank :: Picture
diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs
index 042fe6629..66e6f6b1a 100644
--- a/src/Picture/Render.hs
+++ b/src/Picture/Render.hs
@@ -77,6 +77,11 @@ overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
 overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c)
 overCol _ RenderBlank = RenderBlank
 
+overSca :: (Float -> Float) -> RenderType -> RenderType
+{-# INLINE overSca #-}
+overSca f (RenderText vs) = RenderText $ map (scaleT (f 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) vs
@@ -231,6 +236,9 @@ picToLTree j (Rotate a pic) = fmap (rotateRen a) $ picToLTree j pic
 picToLTree j (SetDepth a pic) = fmap (setDepthRen a) $ picToLTree j pic
 picToLTree j (Color c pic) = fmap (colorRen c) $ picToLTree j pic
 picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
+picToLTree j (OverPic f f' f'' (OverPic g g' g'' pic)) = picToLTree j $ OverPic (f . g) (f' . g') (f'' . g'') pic
+picToLTree j (OverPic f f' f'' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f' f'') ps)
+picToLTree j (OverPic f f' f'' pic) = fmap (overPos f . overSca f' . overCol f'') $ picToLTree j pic
 
 doubleLine :: [Point2] -> [Point2]
 doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)