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

Tweak single bind pass

Browse Source
This commit is contained in:
jgk
2021-07-26 12:51:01 +02:00
parent 59be6eb216
commit d27c5e7ff4
2 changed files with 40 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Picture.hs
+39 -13
View File
@@ -148,23 +148,27 @@ extrapolate (ox,oy) (ax,ay) (bx,by) (x,y) =
color :: RGBA -> Picture -> Picture
{-# INLINE color #-}
color c = map $ second $ overCol (const c)
--color c = map $ second $ overCol (const c)
color c = map $ overCol' (const c)
translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z)
translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-}
translate x y = map $ second $ overPos (translate3 x y)
--{-# INLINE translate #-}
--translate x y = map $ second $ overPos (translate3 x y)
translate x y = map $ overPos' (translate3 x y)
setDepth :: Float -> Picture -> Picture
{-# INLINE setDepth #-}
setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
--{-# INLINE setDepth #-}
--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
setDepth d = map $ overPos' (\(x,y,_) -> (x,y,d))
addDepth :: Float -> Picture -> Picture
{-# INLINE addDepth #-}
addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
--{-# INLINE addDepth #-}
--addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
addDepth d = map $ overPos' (\(x,y,z) -> (x,y,z+d))
setLayer :: Int -> Picture -> Picture
{-# INLINE setLayer #-}
@@ -175,12 +179,14 @@ scale3 :: Float -> Float -> Point3 -> Point3
scale3 a b (x,y,z) = (x*a,y*b,z)
scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-}
scale x y = map . second . overPos $ scale3 x y
--{-# INLINE scale #-}
--scale x y = map . second . overPos $ scale3 x y
scale x y = map $ overPos' $ scale3 x y
rotate :: Float -> Picture -> Picture
{-# INLINE rotate #-}
rotate a = map . second . overPos $ rotate3 a
--{-# INLINE rotate #-}
--rotate a = map . second . overPos $ rotate3 a
rotate a = map $ overPos' $ rotate3 a
pictures :: [Picture] -> Picture
{-# INLINE pictures #-}
@@ -336,15 +342,35 @@ bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
greyN :: Float -> Color
greyN x = (x,x,x,1)
overPos' :: (Point3 -> Point3) -> (Int,RenderType) -> (Int,RenderType)
--{-# INLINE overPos' #-}
overPos' f (i,RenderPoly vs) = (i, RenderPoly $ map (first f) vs )
overPos' f (i,RenderText vs) = (i, RenderText $ map (\(a,b,c) -> (f a,b,c)) vs )
overPos' f (i,RenderBezQ vs) = (i, RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs )
overPos' f (i,RenderEllipse vs) = (i, RenderEllipse $ map (first f) vs )
overPos' f (i,RenderArc vs) = (i, RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs )
overPos' f (i,RenderPolyZ vs) = (i, RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs )
overPos' _ rt = rt
overPos :: (Point3 -> Point3) -> RenderType -> RenderType
--{-# INLINE overPos #-}
{-# 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
overPos _ rt = rt
overCol' :: (Point4 -> Point4) -> (Int,RenderType) -> (Int,RenderType)
--{-# INLINE overCol #-}
overCol' f (i,(RenderPoly vs) ) = (i,RenderPoly $ map (second f) vs )
overCol' f (i,(RenderEllipse vs)) = (i,RenderEllipse $ map (second f) vs )
overCol' f (i,(RenderText vs) ) = (i,RenderText $ map (\(a,b,c) -> (a,f b,c)) vs )
overCol' f (i,(RenderBezQ vs) ) = (i,RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs )
overCol' f (i,(RenderArc vs) ) = (i,RenderArc $ map (\(a,b,c) -> (a,f b,c)) vs )
overCol' f (i,(RenderPolyZ vs) ) = (i,RenderPolyZ $ map (\(a,b,c) -> (a,f b,c)) vs )
overCol' _ _ = undefined
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
--{-# INLINE overCol #-}