%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\begin{code}
{-# LANGUAGE TypeSynonymInstances #-}
\end{code}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\begin{code}
module Graphics.HDemo.TexGen
    ( TextureTree(..), ChannelTree(..), ChannelOp(..), TextureMod(..)
    , generateTexture ) 
    where
\end{code}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\begin{code}
import Data.Array.Diff( DiffUArray, array, indices, elems, (!), bounds, assocs )
import Data.Word( Word8, Word16 )
import System.Random( randomRs, mkStdGen )
import Data.List( transpose, isPrefixOf )
import Graphics.HDemo.Utils( quads, word16ToFraction )
import Graphics.HDemo.MathUtils( clamp, catmullRomVal )
import Graphics.HDemo.Texture( Texture(..), ColorLayer, colorLayer )
\end{code}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\begin{code}
clampc :: Double -> Word8
clampc = round . clamp 0 255
\end{code}

\begin{code}
comp :: (Double -> Double -> Double) -> ColorLayer -> ColorLayer -> ColorLayer
comp f cl1 cl2 = array (bounds cl1) $ zip (indices cl1) 
                $ zipWith g (elems cl1) (elems cl2)
    where g a b = clampc $ f (fromIntegral a) (fromIntegral b)
\end{code}

\begin{code}
mixf :: (Double -> Double -> Double) -> Double 
     -> ColorLayer -> ColorLayer -> ColorLayer
mixf f p = comp (\a b -> (p * a) `f` ((1 - p) * b))
\end{code}

\begin{code}
type Filter = DiffUArray (Int, Int) Int
\end{code}

\begin{code}
applyFilter :: Filter -> ColorLayer -> ColorLayer
applyFilter f cl = array (bounds cl) $ zip (indices cl) 
                   $ map (filterFun f cl) (indices cl)
\end{code}

\begin{code}
filterFun :: Filter -> ColorLayer -> (Int, Int) -> Word8
filterFun f cl p = clampc $ 128 + ((sum $ map (getFilterColor cl p) (assocs f)) / 8)
--    where l = fromIntegral $ length (elems f)
\end{code}

\begin{code}
getFilterColor :: ColorLayer -> (Int,Int) -> ((Int,Int),Int) -> Double
getFilterColor cl (x,y) (((ix,iy)),w) = fromIntegral $ v * w
    where v = fromIntegral $ getColor cl (x+ix) (y+iy)
\end{code}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\begin{code}
getColor :: ColorLayer -> Int -> Int -> Word8
getColor layer x y 
         | x < 0 || y < 0 || x >= w || y >= h = 0
         | otherwise = layer ! (x,y)
    where (_,(maxw,maxh)) = bounds layer
          w = maxw + 1
          h = maxh + 1
\end{code}

\begin{code}
getInterpolatedColor :: ColorLayer -> Double -> Double -> Word8
getInterpolatedColor lay px py = round $ p0 + p1 + p2 + p3
    where x = floor px
          y = floor py
          fx = px - fromIntegral x
          fy = py - fromIntegral y
          p0 = fx * fy * fromIntegral (getColor lay x y)
          p1 = (1-fx) * fy * fromIntegral (getColor lay (x+1) y)
          p2 = fx * (1-fy) * fromIntegral (getColor lay  x (y+1))
          p3 = (1-fx) * (1-fy) * fromIntegral (getColor lay (x+1) (y+1))
\end{code}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\begin{code}
funLayer :: (Int -> Int -> Word8) -> Int -> Int -> ColorLayer
funLayer f w h = colorLayer w h [((i,j),f j i) | i<-[0..(w-1)],j<-[0..(h-1)]]
\end{code}

\begin{code}
color :: Word8 -> Int -> Int -> ColorLayer
color = funLayer . const . const
\end{code}

\begin{code}
sinePlasmaVal :: Double -> Double -> Int -> Int -> Word8
sinePlasmaVal fx fy x y = round $ 127 
                          + 63.5 * sin( fromIntegral x * fx ) 
                          + 63.5 * sin( fromIntegral y * fy )
\end{code}

\begin{code}
sinePlasma :: Word16 -> Word16 -> Int -> Int -> ColorLayer
sinePlasma nx ny w h = funLayer (sinePlasmaVal fx fy) w h
    where 
      fx = (fromIntegral nx * 2 * pi) / fromIntegral w
      fy = (fromIntegral ny * 2 * pi) / fromIntegral h
\end{code}

\begin{code}
distanceMapVal :: Double -> Double -> Double -> Int -> Int -> Word8
distanceMapVal r cx cy x y 
    | d >= r = 0
    | otherwise = round $ 255 - 255*(d / r)
    where d = sqrt((fx - cx)*(fx - cx) + (fy - cy)*(fy - cy))
          fx = fromIntegral x
          fy = fromIntegral y
\end{code}

\begin{code}
distanceMap :: Double -> Double -> Double -> Int -> Int -> ColorLayer
distanceMap r cx cy = funLayer (distanceMapVal r cx cy)
\end{code}

\begin{code}
randomColor :: Int -> Int -> Int -> ColorLayer
randomColor r w h = colorLayer w h $ zip  [(i,j)|i<-[0..w-1],j<-[0..h-1]] vals
    where vals = map clampc (randomRs (0,255) (mkStdGen r) :: [Double])
\end{code}

\begin{code}
catmullRomSpan :: Int -> (Double,Double,Double,Double) -> [Double]
catmullRomSpan n (x,y,z,w) = [catmullRomVal x y z w (fromIntegral i/l) 
                              | i <- [0..(n-1)]]
    where l = fromIntegral (n-1)
\end{code}

\begin{code}
catmullRomRow :: Int -> [Double] -> [Double]
catmullRomRow n xs = concatMap (catmullRomSpan n) $ quads (head xs : xs)
\end{code}

\begin{code}
catmullRom :: Int -> Int -> Int -> Int -> ColorLayer
catmullRom r n w h = colorLayer w h $ zip [(i,j)|i<-[0..w-1],j<-[0..h-1]] $ map clampc vals
    where columnNumbers = catmullRomRow n' . randomRs (0,255) $ mkStdGen r
          columns = take wn $ columns' columnNumbers
          columns' xs = take h xs : columns' (drop h xs)
          wn = (floor::Double->Int) ((fromIntegral w / fromIntegral n') + 1) + 1
          vals = concatMap (take w . catmullRomRow n') $ transpose columns
          n' = clamp 2 w n
\end{code}

\begin{code}
fractalPlasma :: Int -> Int -> Int -> Int -> ColorLayer
fractalPlasma r n w h = foldl1 (comp (+)) $ map (cr r w h) $ take n [1..7]

cr :: Int -> Int -> Int -> Int -> ColorLayer
cr r w h n = mixf (+) (plasmaFactor n)
                 (catmullRom r (round $ 256.0 * plasmaFactor n) w h) 
                 (color 0 w h)

plasmaFactor :: Int -> Double
plasmaFactor n = 1.0 / (2^n)
\end{code}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\begin{code}
sineDistortVal :: Double -> Double -> ColorLayer -> (Int, Int) -> ((Int,Int),Word8)
sineDistortVal fx fy layer (x,y) = ((x,y), val)
    where val = getInterpolatedColor layer px py
          px = x' + 10 * sin (x' * fx)
          py = y' + 10 * sin (y' * fy)
          x' = fromIntegral x
          y' = fromIntegral y
\end{code}

\begin{code}
sineDistort :: Word16 -> Word16 -> Int -> Int -> ColorLayer -> ColorLayer
sineDistort nx ny w h layer = array (bounds layer) 
                              $ map (sineDistortVal fx fy layer)
                              $ indices layer
    where
      fx = (fromIntegral nx * 2 * pi) / fromIntegral w
      fy = (fromIntegral ny * 2 * pi) / fromIntegral h
\end{code}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\begin{code}
data TextureTree = TexTree { weight :: !Word16
                           , heigth :: !Word16
                           , texMods :: [TextureMod]
                           , ctRed :: ChannelTree 
                           , ctGreen :: ChannelTree
                           , ctBlue :: ChannelTree }
\end{code}

\begin{code}
data ChannelTree = COLOR !Word8
                 | RANDCOL !Word16
                 | SINEPLASMA !Word16 !Word16
                 | FRACPLASMA !Word16 !Int
                 | DISTANCE !Word16 !Int !Int
                 | CATROM !Word16 !Word16
                 | SINEDIST !Word16 !Word16 !ChannelTree
                 | MIXF !ChannelOp !Word16 !ChannelTree !ChannelTree
                 | COMP !ChannelOp !ChannelTree !ChannelTree
                 | FILTER !ChannelTree
                   deriving( Show, Read )
\end{code}

\begin{code}
data TextureMod = HSV !Int
                  deriving(Show,Read)
\end{code}

\begin{code}
data ChannelOp = ADDL | MULL | SUBL | DIVL 
               | SCREENL | DARKL | LIGHTL | ABSL | SHADEL
                 deriving( Eq, Enum )
\end{code}

\begin{code}
instance Show ChannelOp where
    show ADDL = "Add"
    show MULL = "Mul"
    show SUBL = "Sub"
    show DIVL = "Div"
    show SCREENL = "Screen"
    show DARKL = "Darken"
    show LIGHTL = "Lighten"
    show ABSL = "Abs"
    show SHADEL = "Shade"
\end{code}

\begin{code}
instance Read ChannelOp where
    readsPrec _ s = [(snd.head $ filter fst final, "")]
        where checks = zipWith ($) (repeat isPrefixOf) names 
              boolList = map ($s) checks
              final = zip boolList [ADDL ..]
              names = map show [ADDL ..]
\end{code}

\begin{code}
opComp :: ChannelOp -> (Double -> Double -> Double)
opComp ADDL = (+)
opComp MULL = \a b -> (a*b) / 255
opComp SUBL = (-)
opComp DIVL = \a b -> min 255 (b / ((a + 1) /256))
opComp SCREENL = \a b -> 255 - (1 / 255) * (255 - a) * (255 - b)
opComp DARKL = min
opComp LIGHTL = max
opComp ABSL = \a b -> abs (a - b)
opComp SHADEL = \a b -> if a < 128 
                          then b*(a/128) 
                          else ((255*(a-128)) + (b*(256-a)))/128
\end{code}

\begin{code}
generateTexture :: TextureTree -> Texture
generateTexture tex = Tex 
                      (generateColorLayer (ctRed tex) w h)
                      (generateColorLayer (ctGreen tex) w h)
                      (generateColorLayer (ctBlue tex) w h)
    where w = fromIntegral $ weight tex
          h = fromIntegral $ heigth tex
\end{code}

\begin{code}
generateColorLayer :: ChannelTree -> Int -> Int -> ColorLayer
generateColorLayer (COLOR c) w h = color c w h
generateColorLayer (RANDCOL r) w h = 
    randomColor (fromIntegral r) w h
generateColorLayer (SINEPLASMA vx vy) w h = sinePlasma vx vy w h
generateColorLayer (FRACPLASMA r n) w h = 
    fractalPlasma (fromIntegral r) n w h
generateColorLayer (DISTANCE d cx cy) w h = 
    distanceMap (fromIntegral d) (fromIntegral cx) (fromIntegral cy) w h
generateColorLayer (CATROM r n) w h = 
    catmullRom (fromIntegral r) (fromIntegral n) w h
generateColorLayer (SINEDIST nx ny layer) w h = 
    sineDistort nx ny w h (generateColorLayer layer w h)
generateColorLayer (MIXF ch p la lb) w h = 
    mixf (opComp ch) fp (generateColorLayer la w h) (generateColorLayer lb w h)
        where fp = word16ToFraction p
generateColorLayer (COMP ch la lb) w h = 
    comp (opComp ch) (generateColorLayer la w h) (generateColorLayer lb w h)
generateColorLayer (FILTER layer) w h =
    applyFilter embossFilter (generateColorLayer layer w h)
\end{code}

\begin{code}
embossFilter :: Filter
embossFilter = array ((-1,-1),(1,1)) 
               [ ((i,j),j) | i <- [-1..1], j <- [-1..1] ]
\end{code}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%