justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Try to fuse functions over pictures (overPos and overCol)

Browse Source
This commit is contained in:
justin
2021-03-01 12:36:57 +01:00
parent bb05bcaaf1
commit f68b8be9ce
3 changed files with 16 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Picture.hs
+7 -5
View File
@@ -88,7 +88,7 @@ polygonCol = PolygonCol 0
color :: RGBA -> Picture -> Picture color :: RGBA -> Picture -> Picture
{-# INLINE color #-} {-# INLINE color #-}
color c pic = Color c pic color c pic = OverPic id id (const c) pic
translate3 :: Float -> Float -> Point3 -> Point3 translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-} {-# INLINE translate3 #-}
@@ -96,11 +96,11 @@ translate3 a b (x,y,z) = (x+a,y+b,z)
translate :: Float -> Float -> Picture -> Picture translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-} {-# 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 setDepth :: Float -> Picture -> Picture
{-# INLINE setDepth #-} {-# 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 :: Int -> Picture -> Picture
setLayer _ Blank = Blank 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 (SetDepth x p) = SetDepth x $ setLayer i p
setLayer i (Color x p) = Color 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 (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 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 scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-} {-# 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 rotate3 :: Float -> Point3 -> Point3
{-# INLINE rotate3 #-} {-# INLINE rotate3 #-}
rotate3 a (x,y,z) = (x',y',z) rotate3 a (x,y,z) = (x',y',z)
where (x',y') = rotateV a (x,y) where (x',y') = rotateV a (x,y)
rotate = Rotate rotate :: Float -> Picture -> Picture
{-# INLINE rotate #-} {-# INLINE rotate #-}
rotate a pic = OverPic (rotate3 a) id id pic
--rotateRad a = Rotate a --rotateRad a = Rotate a
--{-# INLINE rotateRad #-} --{-# INLINE rotateRad #-}
src/Picture/Data.hs
+1 -1
View File
@@ -66,7 +66,7 @@ data Picture
| SetDepth Float Picture | SetDepth Float Picture
| Color RGBA Picture | Color RGBA Picture
| Pictures [Picture] | Pictures [Picture]
| OverPos (Point3 -> Point3) (Float -> Float) Picture | OverPic (Point3 -> Point3) (Float -> Float) (Point4 -> Point4) Picture
blank :: Picture blank :: Picture
src/Picture/Render.hs
+8
View File
@@ -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 f (RenderArc (a,b,c)) = RenderArc (a,f b,c)
overCol _ RenderBlank = RenderBlank 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 scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
{-# INLINE scaleRen #-} {-# INLINE scaleRen #-}
scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT x) vs 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 (SetDepth a pic) = fmap (setDepthRen a) $ picToLTree j pic
picToLTree j (Color c pic) = fmap (colorRen c) $ 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 (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 :: [Point2] -> [Point2]
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs) doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)