{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_GHC -Wall #-}
-- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP

-- | Very simple image algebra, as in Pan

module ConCat.Graphics.Image where

import Control.Applicative (liftA2)
-- import GHC.Float.RealFracMethods (int2Double,floorDoubleInt)

import Data.NumInstances ()

import ConCat.Misc ((:*),delay,R,Unop,Binop,sqr,magSqr)
import ConCat.Graphics.Color (Color,ToColor(..))

type R2 = R :* R

{--------------------------------------------------------------------
    Spatial transformations
--------------------------------------------------------------------}

type Angle = R -- in radians

type Transform = Unop R2

rotateP :: Angle -> Transform
rotateP :: R -> Transform
rotateP R
theta = \ (R
x,R
y) -> (R
x R -> R -> R
forall a. Num a => a -> a -> a
* R
c R -> R -> R
forall a. Num a => a -> a -> a
- R
y R -> R -> R
forall a. Num a => a -> a -> a
* R
s, R
y R -> R -> R
forall a. Num a => a -> a -> a
* R
c R -> R -> R
forall a. Num a => a -> a -> a
+ R
x R -> R -> R
forall a. Num a => a -> a -> a
* R
s)
 where c :: R
c = R -> R
forall a. Floating a => a -> a
cos R
theta
       s :: R
s = R -> R
forall a. Floating a => a -> a
sin R
theta

translateP, scaleP :: R2 -> Transform
translateP :: R2 -> Transform
translateP = R2 -> Transform
forall a. Num a => a -> a -> a
(+)
scaleP :: R2 -> Transform
scaleP     = R2 -> Transform
forall a. Num a => a -> a -> a
(*)

-- translateP (dx,dy) = \ (x,y) -> (x + dx, y + dy)
-- scaleP     (sx,sy) = \ (x,y) -> (sx * x, sy * y)

uniform :: (R2 -> a) -> (R -> a)
uniform :: forall a. (R2 -> a) -> R -> a
uniform R2 -> a
f R
z = R2 -> a
f (R
z,R
z)

uscaleP :: R -> Transform
uscaleP :: R -> Transform
uscaleP = (R2 -> Transform) -> R -> Transform
forall a. (R2 -> a) -> R -> a
uniform R2 -> Transform
scaleP

{--------------------------------------------------------------------
    Images
--------------------------------------------------------------------}

type Image c = R2 -> c

type ImageC = Image Color
type Region = Image Bool

type Filter c = Unop (Image c)

toImageC :: ToColor c => (p -> c) -> (p -> Color)
toImageC :: forall c p. ToColor c => (p -> c) -> p -> Color
toImageC = (c -> Color
forall a. ToColor a => a -> Color
toColor (c -> Color) -> (p -> c) -> p -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

toPImageC :: ToColor c => (a -> p -> c) -> (a -> p -> Color)
toPImageC :: forall c a p. ToColor c => (a -> p -> c) -> a -> p -> Color
toPImageC = ((p -> c) -> p -> Color
forall c p. ToColor c => (p -> c) -> p -> Color
toImageC ((p -> c) -> p -> Color) -> (a -> p -> c) -> a -> p -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

translate :: R2 -> Filter c
translate :: forall c. R2 -> Filter c
translate R2
v Image c
im = Image c
im Image c -> Transform -> Image c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R2 -> Transform
forall a. Num a => a -> a -> a
subtract R2
v

scale :: R2 -> Filter c
scale :: forall c. R2 -> Filter c
scale R2
v Image c
im = Image c
im Image c -> Transform -> Image c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (R2 -> Transform
forall a. Fractional a => a -> a -> a
/ R2
v)
-- scale v = (. scaleP (recip v))

uscale :: R -> Filter c
uscale :: forall c. R -> Filter c
uscale = (R2 -> Filter c) -> R -> Filter c
forall a. (R2 -> a) -> R -> a
uniform R2 -> Filter c
forall c. R2 -> Filter c
scale

rotate :: R -> Filter c
rotate :: forall c. R -> Filter c
rotate R
theta = ((R2 -> c) -> Transform -> R2 -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R -> Transform
rotateP (-R
theta))

complementR                     :: Applicative f => Unop  (f Bool)
intersectR, unionR, xorR, diffR :: Applicative f => Binop (f Bool)

complementR :: forall (f :: * -> *). Applicative f => Unop (f Bool)
complementR = (Bool -> Bool) -> f Bool -> f Bool
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not
intersectR :: forall (f :: * -> *). Applicative f => Binop (f Bool)
intersectR  = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&)
unionR :: forall (f :: * -> *). Applicative f => Binop (f Bool)
unionR      = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||)
xorR :: forall (f :: * -> *). Applicative f => Binop (f Bool)
xorR        = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(/=)

f Bool
r diffR :: forall (f :: * -> *). Applicative f => Binop (f Bool)
`diffR` f Bool
r' = f Bool
r Binop (f Bool)
forall (f :: * -> *). Applicative f => Binop (f Bool)
`intersectR` Unop (f Bool)
forall (f :: * -> *). Applicative f => Unop (f Bool)
complementR f Bool
r'

nothing :: a -> Bool
nothing :: forall a. a -> Bool
nothing = Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
False

everything :: a -> Bool
everything :: forall a. a -> Bool
everything = Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True

-- | Half plane
xPos :: Region
xPos :: Region
xPos (R
x,R
_y) =  R
x R -> R -> Bool
forall a. Ord a => a -> a -> Bool
> R
0

-- | Opposite quadrants
xyPos :: Region
xyPos :: Region
xyPos (R
x,R
y) =  R
xR -> R -> R
forall a. Num a => a -> a -> a
*R
y R -> R -> Bool
forall a. Ord a => a -> a -> Bool
> R
0

-- | unit disk
udisk :: Region
udisk :: Region
udisk R2
p = R2 -> R
forall a. Num a => (a :* a) -> a
magSqr R2
p R -> R -> Bool
forall a. Ord a => a -> a -> Bool
<= R
1

-- | disk
disk :: R -> Region
-- disk r = uscale r udisk
disk :: R -> Region
disk R
r = (R2 -> Region -> Region) -> R -> Region -> Region
forall a. (R2 -> a) -> R -> a
uniform R2 -> Region -> Region
forall c. R2 -> Filter c
scale R
r Region
udisk

-- Alternative definition
disk' :: R -> Region
disk' :: R -> Region
disk' R
r R2
p = R2 -> R
forall a. Num a => (a :* a) -> a
magSqr R2
p R -> R -> Bool
forall a. Ord a => a -> a -> Bool
<= R -> R
forall a. Num a => a -> a
sqr R
r

-- | Annulus, given outer & inner radii
annulus :: R -> R -> Region
annulus :: R -> R -> Region
annulus R
o R
i = R -> Region
disk R
o Binop Region
forall (f :: * -> *). Applicative f => Binop (f Bool)
`diffR` R -> Region
disk R
i
{-# INLINE annulus #-}

-- | Checker-board
checker :: Region
checker :: Region
checker (R
x,R
y) = R -> Bool
forall {a}. RealFrac a => a -> Bool
test R
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== R -> Bool
forall {a}. RealFrac a => a -> Bool
test R
y
  where test :: a -> Bool
test a
w = a -> a
forall a. RealFrac a => a -> a
frac a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0.5
{-# INLINE checker #-}
  
frac :: RealFrac a => a -> a
frac :: forall a. RealFrac a => a -> a
frac a
x = a
x a -> a -> a
forall a. Num a => a -> a -> a
- Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((a -> Int) -> a -> Int
forall a. a -> a
delay a -> Int
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor a
x :: Int)
{-# INLINE frac #-}

woobly :: Region
woobly :: Region
woobly p :: R2
p@(R
x,R
y) = R2 -> R
forall a. Num a => (a :* a) -> a
magSqr R2
p R -> R -> Bool
forall a. Ord a => a -> a -> Bool
< R
0.75 R -> R -> R
forall a. Num a => a -> a -> a
+ R
0.25 R -> R -> R
forall a. Num a => a -> a -> a
* R -> R
forall a. Floating a => a -> a
sin (R
5 R -> R -> R
forall a. Num a => a -> a -> a
* R -> R -> R
forall a. RealFloat a => a -> a -> a
atan2 R
y R
x)