module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), Pattern(..), RadialShape(..), Resize(..), Length(..), 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 (8 < nStops - 1 && a > stopPoints[8]) i = 8;", " else if (7 < nStops - 1 && a > stopPoints[7]) i = 7;", " else if (6 < nStops - 1 && a > stopPoints[6]) i = 6;", " else if (5 < nStops - 1 && a > stopPoints[5]) i = 5;", " else if (4 < nStops - 1 && a > stopPoints[4]) i = 4;", " else if (3 < nStops - 1 && a > stopPoints[3]) i = 3;", " else if (2 < nStops - 1 && a > stopPoints[2]) i = 2;", " else if (1 < nStops - 1 && a > stopPoints[1]) i = 1;", "", " 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 center;", "uniform vec4 stops[10];", "uniform float stopPoints[10];", "uniform int nStops;", "", "void main() {", " float a = distance(coord/size, center/size) * 2;", "", " int i = 0;", -- Workaround for buggy GPU drivers on test machine. " if (8 < nStops - 1 && a > stopPoints[8]) i = 8;", " else if (7 < nStops - 1 && a > stopPoints[7]) i = 7;", " else if (6 < nStops - 1 && a > stopPoints[6]) i = 6;", " else if (5 < nStops - 1 && a > stopPoints[5]) i = 5;", " else if (4 < nStops - 1 && a > stopPoints[4]) i = 4;", " else if (3 < nStops - 1 && a > stopPoints[3]) i = 3;", " else if (2 < nStops - 1 && a > stopPoints[2]) i = 2;", " else if (1 < nStops - 1 && a > stopPoints[1]) i = 1;", "", " 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 (8 < nStops - 1 && a > stopPoints[8]) i = 8;", " else if (7 < nStops - 1 && a > stopPoints[7]) i = 7;", " else if (6 < nStops - 1 && a > stopPoints[6]) i = 6;", " else if (5 < nStops - 1 && a > stopPoints[5]) i = 5;", " else if (4 < nStops - 1 && a > stopPoints[4]) i = 4;", " else if (3 < nStops - 1 && a > stopPoints[3]) i = 3;", " else if (2 < nStops - 1 && a > stopPoints[2]) i = 2;", " else if (1 < nStops - 1 && a > stopPoints[1]) i = 1;", "", " 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", "center", "stops", "stopPoints", "nStops"] circle <- renderRectWith circleFragmentShader ["center", "radius", "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 Radial Ellipse stops -> let sz@(w,h) = size $ clip0 a in ellipse [] [ u $ v2 sz, u $ v2 (w/2, h/2), cs 10 $ map fst stops, us $ ls2fs (0,h/2) $ map snd $ take 10 stops, u $ length stops ] clip0 a b Radial Circle stops -> let (w,h) = size $ clip0 a in circle [] [ u $ v2 (w/2, h/2), u (min w h/2), cs 10 $ map fst stops, us $ ls2fs (0,min w h/2) $ 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)