module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), Pattern(..),
    RadialShape(..), Resize(..), Length(..), Extent(..),
    resolveSize, renderBackgrounds) where

import Graphics.Rendering.Rect.CSS.Backgrounds
import Graphics.Rendering.Rect.Types
import Graphics.Rendering.Rect.Image (Texture(texSize))
import qualified Data.ByteString.Char8 as B8
import Linear (M44, V2(..))

import Control.Monad.IO.Class (MonadIO(..))
import Data.Maybe (fromMaybe, listToMaybe)
import Control.Monad (forM)

baseFragmentShader :: B8.ByteString
baseFragmentShader = B8.pack $ unlines [
    "#version 330 core",
    "out vec4 fcolour;",
    "uniform vec4 colour;",
    "void main() { fcolour = colour; }"
  ]

imageFragmentShader :: B8.ByteString
imageFragmentShader = B8.pack $ unlines [
    "#version 330 core",
    "in vec2 coord;",
    "out vec4 fcolour;",
    "uniform sampler2D image;",
    "uniform vec2 size;",
    "void main() { fcolour = texture(image, coord/size); }"
  ]

linearFragmentShader :: B8.ByteString
linearFragmentShader = B8.pack $ unlines [
    "#version 330 core",
    "in vec2 coord;",
    "out vec4 fcolour;",
    "uniform vec2 size;",
    "uniform vec4 stops[10];",
    "uniform float stopPoints[10];",
    "uniform int nStops;",
    "uniform float angle;",
    "",
    "void main() {",
    "   vec2 pos = coord/size;", -- Range 0..1
    "   pos -= 0.5; pos *= 2;", -- Range -1..1
    "   float a = pos.x*sin(angle) + pos.y*-cos(angle);", -- Range -1..1
    "   a /= 2; a += 0.5;", -- Range 0..1
    "",
    "   int i = 0;",
    -- Workaround for buggy GPU drivers on test machine.
    "   if (1 < nStops - 1 && a > stopPoints[1]) i = 1;",
    "   if (2 < nStops - 1 && a > stopPoints[2]) i = 2;",
    "   if (3 < nStops - 1 && a > stopPoints[3]) i = 3;",
    "   if (4 < nStops - 1 && a > stopPoints[4]) i = 4;",
    "   if (5 < nStops - 1 && a > stopPoints[5]) i = 5;",
    "   if (6 < nStops - 1 && a > stopPoints[6]) i = 6;",
    "   if (7 < nStops - 1 && a > stopPoints[7]) i = 7;",
    "   if (8 < nStops - 1 && a > stopPoints[8]) i = 8;",
    "",
    "   a = smoothstep(stopPoints[i], stopPoints[i+1], a);",
    "   fcolour = mix(stops[i], stops[i+1], a);",
    "}"
  ]

radialFragmentShader :: B8.ByteString
radialFragmentShader = B8.pack $ unlines [
    "#version 330 core",
    "in vec2 coord;",
    "out vec4 fcolour;",
    "uniform vec2 size;",
    "uniform vec2 extent;",
    "uniform vec2 center;",
    "uniform vec4 stops[10];",
    "uniform float stopPoints[10];",
    "uniform int nStops;",
    "",
    "void main() {",
    "   float a = distance(coord/extent, center/size) * 2;",
    "",
    "   int i = 0;",
    -- Workaround for buggy GPU drivers on test machine.
    "   if (1 < nStops - 1 && a > stopPoints[1]) i = 1;",
    "   if (2 < nStops - 1 && a > stopPoints[2]) i = 2;",
    "   if (3 < nStops - 1 && a > stopPoints[3]) i = 3;",
    "   if (4 < nStops - 1 && a > stopPoints[4]) i = 4;",
    "   if (5 < nStops - 1 && a > stopPoints[5]) i = 5;",
    "   if (6 < nStops - 1 && a > stopPoints[6]) i = 6;",
    "   if (7 < nStops - 1 && a > stopPoints[7]) i = 7;",
    "   if (8 < nStops - 1 && a > stopPoints[8]) i = 8;",
    "",
    "   a = smoothstep(stopPoints[i], stopPoints[i+1], a);",
    "   fcolour = mix(stops[i], stops[i+1], a);",
    "}"
  ]
circleFragmentShader :: B8.ByteString
circleFragmentShader = B8.pack $ unlines [
    "#version 330 core",
    "in vec2 coord;",
    "out vec4 fcolour;",
    "uniform vec2 center;",
    "uniform float radius;",
    "uniform vec4 stops[10];",
    "uniform float stopPoints[10];",
    "uniform int nStops;",
    "",
    "void main() {",
    "   float a = distance(coord, center)/radius;",
    "",
    "   int i = 0;",
    -- Workaround for buggy GPU drivers on test machine.
    "   if (1 < nStops - 1 && a > stopPoints[1]) i = 1;",
    "   if (2 < nStops - 1 && a > stopPoints[2]) i = 2;",
    "   if (3 < nStops - 1 && a > stopPoints[3]) i = 3;",
    "   if (4 < nStops - 1 && a > stopPoints[4]) i = 4;",
    "   if (5 < nStops - 1 && a > stopPoints[5]) i = 5;",
    "   if (6 < nStops - 1 && a > stopPoints[6]) i = 6;",
    "   if (7 < nStops - 1 && a > stopPoints[7]) i = 7;",
    "   if (8 < nStops - 1 && a > stopPoints[8]) i = 8;",
    "",
    "   a = smoothstep(stopPoints[i], stopPoints[i+1], a);",
    "   fcolour = mix(stops[i], stops[i+1], a);",
    "}"
  ]

conicFragmentShader :: B8.ByteString
conicFragmentShader = B8.pack $ unlines [
    "#version 330 core",
    "in vec2 coord;",
    "out vec4 fcolour;",
    "uniform vec2 center;",
    "uniform float angle;",
    "uniform vec4 stops[10];",
    "uniform float stopPoints[10];",
    "uniform int nStops;",
    "",
    "void main() {",
    "   vec2 v = coord - center;",
    "   float a = atan(v.x, -v.y) - angle;",
    "   float turn = 2*radians(180);",
    "   a = fract(a/turn);",
    "",
    "   int i = 0;",
    -- Workaround for buggy GPU drivers on test machine.
    "   if (1 < nStops - 1 && a > stopPoints[1]) i = 1;",
    "   if (2 < nStops - 1 && a > stopPoints[2]) i = 2;",
    "   if (3 < nStops - 1 && a > stopPoints[3]) i = 3;",
    "   if (4 < nStops - 1 && a > stopPoints[4]) i = 4;",
    "   if (5 < nStops - 1 && a > stopPoints[5]) i = 5;",
    "   if (6 < nStops - 1 && a > stopPoints[6]) i = 6;",
    "   if (7 < nStops - 1 && a > stopPoints[7]) i = 7;",
    "   if (8 < nStops - 1 && a > stopPoints[8]) i = 8;",
    "",
    "   a = smoothstep(stopPoints[i], stopPoints[i+1], a);",
    "   fcolour = mix(stops[i], stops[i+1], a);",
    "}"
  ]

renderBackgrounds :: (MonadIO m, MonadIO n) =>
    n (Backgrounds Texture -> Rects -> M44 Float -> m ())
renderBackgrounds = do
    base <- renderRectWith baseFragmentShader ["colour"]
    layer <- renderRectWith imageFragmentShader ["size"]
    linear <- renderRectWith linearFragmentShader ["size", "angle",
            "stops", "stopPoints", "nStops"]
    ellipse <- renderRectWith radialFragmentShader ["size", "extent", "center",
            "stops", "stopPoints", "nStops"]
    circle <- renderRectWith circleFragmentShader ["center", "radius",
            "stops", "stopPoints", "nStops"]
    conic <- renderRectWith conicFragmentShader ["center", "angle",
            "stops", "stopPoints", "nStops"]
    return $ \self a b -> do
        base [] [c $ background self] (headDef borderBox $ clip self) a b
        let layers = image self `zip` (clip self ++ repeat borderBox)
                `zip` (bgSize self ++ repeat (Size Auto Auto))
        _ <- forM layers $ \((pat0, clip0), size0) -> case pat0 of
            None -> return ()
            Img img0 -> layer [img0] [
                    u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0
                ] clip0 a b
            Linear angle stops -> let size' = size $ clip0 a in linear [] [
                    u $ v2 $ size', u angle, cs 10 $ map fst stops,
                    us $ ls2fs size' $ map snd $ take 10 stops, u $ length stops
                ] clip0 a b
            -- FIXME: Incorporate resolveEllipseExtent without messing up center
            Radial Ellipse ext org stops -> let sz@(_,h) = size $ clip0 a in
                let (org', ext') = resolveEllipseExtent sz org ext in ellipse [] [
                    u $ v2 sz, u $ v2 ext', u $ v2 org', cs 10 $ map fst stops,
                    us $ ls2fs (0,h/2) $ map snd $ take 10 stops, u $ length stops
                ] clip0 a b
            Radial Circle ext org stops -> let sz@(w,h) = size $ clip0 a
                in let (org', r) = resolveCircleExtent sz org ext in circle [] [
                    u $ v2 org', u r, cs 10 $ map fst stops,
                    us $ ls2fs (0,min w h/2) $ map snd $ take 10 stops,
                    u $ length stops
                ] clip0 a b
            Conical angle org stops -> let sz = size $ clip0 a in conic [] [
                    u $ v2 $ l2f' org sz, u angle, cs 10 $ map fst stops,
                    us $ ls2fs (0,2*pi) $ map snd $ take 10 stops, u $ length stops
                ] clip0 a b
        return ()

headDef :: c -> [c] -> c
headDef def = fromMaybe def . listToMaybe
v2 :: (a, a) -> V2 a
v2 = uncurry V2
-- Easier to express this algorithm on CPU-side...
ls2fs :: (Float, Float) -> [Length] -> [Float]
ls2fs (_,h) ls = resolveAutos 0 $ inner True 0 ls
  where
    -- https://drafts.csswg.org/css-images/#color-stop-fixup Step 1.
    inner True _ (Auto:ls') = Scale 0:inner False 0 ls'
    inner _ _ [Auto] = [Scale 1]
    -- Step 2
    inner _ prev (Scale x:ls') | x < prev = Scale prev:inner False prev ls'
    inner _ prev (Absolute x:ls') | x/h < prev = Scale prev:inner False prev ls'
    inner _ _ (Scale x:ls') = Scale x:inner False x ls'
    inner _ _ (Absolute x:ls') = Absolute x:inner False (x/h) ls'
    inner _ prev (Auto:ls') = Auto:inner False prev ls'
    inner _ _ [] = []
    -- Step 3
    resolveAutos :: Float -> [Length] -> [Float]
    resolveAutos _ (Scale x:ls') = x:resolveAutos x ls'
    resolveAutos _ (Absolute x:ls') = (x/h):resolveAutos (x/h) ls'
    resolveAutos _ [] = []
    resolveAutos prev ls0 = [prev + succ i*grad | i <- [0..n - 1]] ++ fs
      where
        (autos, ls') = span (==Auto) ls0
        n = toEnum $ length autos
        fs = resolveAutos 0 ls' -- Doesn't matter if prev's in another branch...
        next | (x:_) <- fs = x
            | otherwise = 1 -- Step 1 should've taken care of this...
        grad = (next - prev)/(n + 1)

l2f :: Length -> Float -> Float
l2f Auto x = x/2
l2f (Scale x) y = x*y
l2f (Absolute x) _ = x
l2f' :: (Length, Length) -> (Float, Float) -> (Float, Float)
l2f' (x,y) (w,h) = (l2f x w, l2f y h)

resolveEllipseExtent :: (Float, Float) -> (Length, Length) -> Extent ->
    ((Float, Float), (Float, Float))
resolveEllipseExtent sz@(x',y') pos ext = ((x, y), inner ext)
  where
    (x,y) = l2f' pos sz
    horiz = [x, x' - x]
    vert = [y, y' - y]
    inner (Extent s t) = (l2f s x, l2f t y)
    -- FIXME: How to calculate closest/farthest-corner?
    -- Spec just says keep this aspect ratio.
    inner ClosestCorner = (minimum horiz * 2, minimum vert * 2)
    inner ClosestSide = (minimum horiz * 2, minimum vert * 2)
    inner FarthestCorner = (maximum horiz * 2, maximum vert * 2)
    inner FarthestSide = (maximum horiz * 2, maximum vert * 2)
resolveCircleExtent :: (Float, Float) -> (Length, Length) -> Extent ->
    ((Float, Float), Float)
resolveCircleExtent sz@(x',y') pos ext = ((x, y), inner ext)
  where
    (x,y) = l2f' pos sz
    sides = [x, x' - x, y, y' - y]
    corners = [hypot x y, hypot x $ y'-y, hypot y $ x'-x, hypot (x'-x) (y'-y)]
    hypot a b = sqrt $ a*a + b*b
    inner (Extent a _) = l2f a y -- Should be absolute...
    inner ClosestCorner = minimum corners
    inner ClosestSide = minimum sides
    inner FarthestCorner = maximum corners
    inner FarthestSide = maximum sides