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)