-- based on Conal Elliott's Functional Reactive Animation
-- http://conal.net/papers/icfp97/

module Fran where

import FunctionalImage

vstrip :: Region
vstrip (x, y) = abs x <  1/2

checker :: Region
checker (x, y) = even (floor x + floor y)

altRings :: Region
altRings p = even $ floor $ distO p

distO (x, y) = sqrt (x*x + y*y)

type PolarPoint = (Double, Double)

fromPolar :: PolarPoint -> Point
fromPolar (rho, theta) = (rho * cos theta, rho * sin theta)

toPolar :: Point -> PolarPoint
toPolar (x, y) = (distO (x, y), atan2 y x)

polarChecker :: Int -> Region
polarChecker n = checker . sc . toPolar
  where sc (rho, theta) = (rho, theta * fromIntegral n / pi)

wavDist :: ImageM
wavDist p = (1 + cos (pi * distO p)) / 2

lerpC :: Frac -> Colour -> Colour -> Colour
lerpC w (b1,g1,r1,a1) (b2,g2,r2,a2) = (h b1 b2, h g1 g2, h r1 r2, h a1 a2)
  where h x1 x2 = w * x1 + (1-w)  * x2

overC :: Colour -> Colour -> Colour
(b1,g1,r1,a1) `overC` (b2,g2,r2,a2) = (h b1 b2, h g1 g2, h r1 r2, h a1 a2)
  where h x1 x2 = x1 + (1-a1)  * x2

over :: ImageC -> ImageC -> ImageC
(top `over` bot) p = top p `overC` bot p

lift1 h f1 p = h (f1 p)
lift2 h f1 f2 p = h (f1 p) (f2 p)
lift3 h f1 f2 f3 p = h (f1 p) (f2 p) (f3 p)

cond :: Region -> Image a -> Image a -> Image a
cond = lift3 (\ a b c -> if a then b else c)

lerpI :: ImageM -> ImageC -> ImageC -> ImageC
lerpI = lift3 lerpC

-- const a p = a
empty, whiteI, blackI, redI, greenI, blueI, cyanI, magentaI, yellowI :: ImageC
empty    = const invisible
whiteI   = const white
blackI   = const black
redI     = const red
greenI   = const green
blueI    = const blue
cyanI    = const cyan
magentaI = const magenta
yellowI  = const yellow 

ybRings = lerpI wavDist blueI yellowI

bwIm :: Region -> ImageC
bwIm reg = cond reg blackI whiteI

byIm :: Region -> ImageC
byIm reg = cond reg blueI yellowI

type Transform = Point -> Point
type Vector = (Double, Double)  -- Double?

translateP :: Vector -> Transform
translateP (dx,dy) (x,y) = (x+dx,y+dy)

scaleP :: Vector -> Transform
scaleP (sx,sy) (x,y) = (sx*x,sy*y) 

uscaleP :: Double -> Transform
uscaleP s = scaleP (s,s)

rotateP :: Double -> Transform
rotateP t (x,y) = let c = cos t; s = sin t in
                  (x*c-y*s, y*c+x*s)
udisk :: Region
udisk p = distO p < 1

type Filter a = Image a -> Image a

translate, scale :: Vector -> Filter a
uscale, rotate   :: Double -> Filter a

translate (dx,dy) im = im . translateP (-dx,-dy)
scale (sx,sy)     im = im . scaleP (1/sx,1/sy)
uscale s          im = im . uscaleP (1/s)
rotate t          im = im . rotateP (-t)

swirlP :: Double -> Transform
swirlP r p = rotateP (distO p * 2 * pi / r) p

swirl :: Double -> Filter a
swirl r im = im . swirlP (-r)

type FilterC = Filter Colour

type Time = Double
type Anim a = Time -> Image a

xPos :: Region
xPos (x,y) = x > 0

yPos :: Region
yPos (x,y) = y > 0

universeR, emptyR :: Region
universeR = const True
emptyR    = const False

compR :: Region -> Region
compR = lift1 not

capR, cupR, xorR, setminusR :: Region -> Region -> Region

capR = lift2 (&&)
cupR = lift2 (||)
xorR = lift2 (/=)
r `setminusR` r' = r `capR` compR r'

annulus :: Frac -> Region
annulus inner = udisk `setminusR` uscale inner udisk

radReg :: Double -> Region
radReg n = test . toPolar
  where test (_,t) = even (floor (t * n / pi))

wedgeAnnulus :: Double -> Double -> Region
wedgeAnnulus inner n = annulus inner `capR` radReg n

shiftXor :: Double -> Filter Bool
shiftXor r reg = reg' r `xorR` reg' (-r)
   where reg' d = translate (d,0) reg

xorgon :: Int -> Double -> Region -> Region
xorgon n r reg = xorRs (map rf [0 .. n-1])
    where
        rf i = translate (fromPolar (r, a)) reg
            where
                a = fromIntegral i * 2  * 3.14 / fromIntegral n

xorRs :: [Region] -> Region
xorRs = foldr xorR emptyR
   
crop :: Region -> FilterC
crop reg im = cond reg im empty

-- swirlP r = polarXf (\ (rh, t) -> (rh, t + rh * 2 * pi / r))

polarXf :: Transform -> Transform
polarXf xf = fromPolar . xf. toPolar

radInvertP :: Transform
radInvertP = polarXf (\ (r, t) -> (1/r, t))

radInvert :: Image a -> Image a
radInvert im = im . radInvertP

rippleRadP :: Double -> Double -> Transform
rippleRadP n s = polarXf $ \ (r,t) -> (r * (1 + s * sin (n*t)), t)

rippleRad :: Double -> Double -> Image a -> Image a
rippleRad n s im = im . rippleRadP n (-s)

cropRad :: Double -> FilterC
cropRad r = crop (uscale r udisk)

circleLimit :: Double -> FilterC
circleLimit radius im = cropRad radius (im . polarXf xf)
   where  xf (r,t) = (radius*r/(radius-r),t)

{-
image2list :: (Double, Double) -> (Double, Double) -> Image t -> [t]
image2list (xmax, ymax) (width, height) img =
  let xstep = 2*xmax/width; ystep = 2*ymax/height
  in [img (-xmax+(i+0.5)*xstep, -ymax+(j+0.5)*ystep)
       | j <- [0..height-1], i <- [0..width-1] ]
-}

{-
-- image = lerpI wavDist greenI yellowI
-- image = cond (swirl 1 vstrip) greenI yellowI
-- image = cond (shiftXor 2.6 altRings) greenI yellowI
-- image = cond (xorgon 8 (7/4) altRings) greenI yellowI -- ??
-- image = rippleRad 8 0.3 ybRings
-- image = circleLimit 10 (bwIm checker)
-}