module Shady.Image
(
Point, pointToR2, r2ToPoint
, FilterG, Filter, samplerIm, scale2, uscale2, translate2, rotate2
, bilerp, bilerpC
, ImageG, Image
, PRegion, Region
, universeR, emptyR, eqF, neqF, intersectR, unionR, xorR, diffR, complementR
, udisk, disk, annulus, checker
, crop
, transformG, translate2Im, scale2Im, uscale2Im, rotate2Im
, swirl
, utile, tile
) where
import Control.Applicative (Applicative(..),liftA2)
import Shady.Complex
import Data.VectorSpace
import Data.Boolean
import Shady.Misc
import Shady.Language.Exp
import Shady.Color
import Shady.ITransform
type Point = ComplexE R
pointToR2 :: Point -> R2E
pointToR2 (x :+ y) = vec2 x y
r2ToPoint :: R2E -> Point
r2ToPoint xy = getX xy :+ getY xy
type ImageG s a = Complex s -> a
type Image a = ImageG FloatE a
type FilterG p a = Unop (p -> a)
type Filter a = FilterG Point a
samplerIm :: Sampler2 :=> Image Color
samplerIm s = r4ToColor . texture s . pointToR2
translate2X :: AdditiveGroup a => a -> ITransform a
scale2X :: Fractional s => Complex s -> ITransform (Complex s)
uscale2X :: Fractional s => s -> ITransform (Complex s)
rotate2X :: Floating s => s -> ITransform (Complex s)
translate2X = andInverse (^+^) negateV
scale2X = andInverse (onRI2 (*)) (onRI recip)
rotate2X = andInverse rotate2C negate
uscale2X = scale2X . \ a -> a :+ a
rotate2C :: Floating s => s -> Unop (Complex s)
rotate2C theta = (cis theta *)
translate2, scale2 :: (Floating s, ITrans (Complex s) a) => Complex s -> Unop a
uscale2,rotate2 :: (Floating s, ITrans (Complex s) a) => s -> Unop a
translate2 = (*:) . translate2X
scale2 = (*:) . scale2X
rotate2 = (*:) . rotate2X
uscale2 = (*:) . uscale2X
bilerp :: VectorSpace w =>
w -> w -> w -> w -> (Scalar w, Scalar w) -> w
bilerp ll lr ul ur (dx,dy) =
lerp (lerp ll lr dx) (lerp ul ur dx) dy
bilerpC :: (VectorSpace w, Scalar w ~ s) =>
w -> w -> w -> w -> ImageG s w
bilerpC ll lr ul ur (dx :+ dy) = bilerp ll lr ul ur (dx,dy)
type PRegion p = p -> BoolE
type Region = Image BoolE
universeR, emptyR :: Applicative f => f BoolE
universeR = pure true
emptyR = pure false
eqF, neqF :: (IsNat n, IsScalar a, Eq a, Applicative f) =>
f (VecE n a) -> f (VecE n a) -> f BoolE
eqF = liftA2 (==^)
neqF = liftA2 (/=^)
intersectR, unionR, xorR, diffR :: Applicative f => Binop (f BoolE)
complementR :: Applicative f => Unop (f BoolE)
intersectR = liftA2 (&&*)
unionR = liftA2 (||*)
complementR = fmap notE
xorR = neqF
diffR r r' = r `intersectR` complementR r'
udisk :: (InnerSpace p, Scalar p ~ FloatE) => PRegion p
udisk p = magnitudeSq p <=* 1
disk :: (InnerSpace p, Scalar p ~ FloatE) => FloatE -> PRegion p
disk s = udisk . (^/ s)
annulus :: (InnerSpace p, Scalar p ~ FloatE) => FloatE -> FloatE -> PRegion p
annulus o i = disk o `diffR` disk i
checker :: Region
checker (x :+ y) = getX c ==* getY c
where c = frac (x <+> y) >* 0.5
transformG' :: (c -> Unop p) -> (p -> c) -> Unop (p -> a)
transformG' f imc ima p = ima (f (imc p) p)
transformG :: (c -> ITransform p) -> (p -> c) -> Unop (p -> a)
transformG f = transformG' (itBackward . f)
translate2Im :: AdditiveGroup p => Unop p -> Unop (p -> a)
translate2Im = transformG translate2X
scale2Im :: Fractional s => Unop (Complex s) -> Unop (ImageG s a)
scale2Im = transformG scale2X
uscale2Im :: Fractional s => ImageG s s -> Unop (ImageG s a)
uscale2Im = transformG uscale2X
rotate2Im :: Floating s => ImageG s s -> Unop (ImageG s a)
rotate2Im = transformG rotate2X
swirl :: Floating s => s -> Unop (ImageG s a)
swirl s = rotate2Im ((2*pi*s*) . magnitude)
utile' :: Frac p => Unop (p -> a)
utile' = (. frac)
utile :: (Frac p, ITrans (Complex s) p, ITrans (Complex s) a, Floating s) =>
Unop (p -> a)
utile = translate2 (negate (0.5 :+ 0.5)) utile'
tile :: (Floating s, Frac s, ITrans (Complex s) a) =>
Complex s -> Unop (ImageG s a)
tile s = scale2 s utile
instance ITrans Point Color where (*:) = const id