From bd6dd38bb87e2ad65b9824eca974b3c190d08590 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 16 Jun 2023 17:19:45 +1200 Subject: [PATCH] Allow configuring where colour stops occur. --- lib/Graphics/Rendering/Rect/Backgrounds.hs | 50 +++++++++++++++++-- .../Rendering/Rect/CSS/Backgrounds.hs | 14 +++++- lib/Graphics/Rendering/Rect/Types.hs | 9 ++-- 3 files changed, 63 insertions(+), 10 deletions(-) diff --git a/lib/Graphics/Rendering/Rect/Backgrounds.hs b/lib/Graphics/Rendering/Rect/Backgrounds.hs index 6095528..f4a12ac 100644 --- a/lib/Graphics/Rendering/Rect/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/Backgrounds.hs @@ -33,6 +33,7 @@ linearFragmentShader = B8.pack $ unlines [ "out vec4 fcolour;", "uniform vec2 size;", "uniform vec4 stops[10];", + "uniform float stopPoints[10];", "uniform int nStops;", "uniform float angle;", "void main() {", @@ -40,8 +41,20 @@ linearFragmentShader = B8.pack $ unlines [ " 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 - " a *= float(min(nStops, 10) - 1);", -- Range 0..(nStops-1) - " fcolour = mix(stops[int(floor(a))], stops[int(ceil(a))], fract(a));", + "", + " 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);", "}" ] @@ -50,7 +63,8 @@ renderBackgrounds :: (MonadIO m, MonadIO n) => renderBackgrounds = do base <- renderRectWith baseFragmentShader ["colour"] layer <- renderRectWith imageFragmentShader ["size"] - linear <- renderRectWith linearFragmentShader ["size","stops","nStops","angle"] + linear <- renderRectWith linearFragmentShader ["size", "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) @@ -60,10 +74,36 @@ renderBackgrounds = do Img img0 -> layer [img0] [ u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0 ] clip0 a b - Linear angle stops -> linear [] [ - u $ v2 $ size $ clip0 a, cs 10 stops, u $ length stops, u angle + 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 return () headDef def = fromMaybe def . listToMaybe v2 = uncurry V2 +-- Easier to express this algorithm on CPU-side... +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' + -- 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) diff --git a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs index 0c01c82..a460f14 100644 --- a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs @@ -24,7 +24,7 @@ data Backgrounds img = Backgrounds { type C = AlphaColour Float -data Pattern img = None | Img img | Linear Float [C] deriving (Eq, Show, Read) +data Pattern img = None | Img img | Linear Float [(C, Length)] deriving (Eq, Show, Read) -- We need to resolve images before we can compute the actual lengths! data Resize = Cover | Contain | Size Length Length deriving (Eq, Show, Read) @@ -79,8 +79,18 @@ instance PropertyParser (Backgrounds Text) where inner _ = Nothing colourStops [RightParen] = Just [] colourStops (Comma:toks) + | Just (Percentage _ x:toks', c) <- parseColour (pallet self) toks, + Just ret <- colourStops toks' = Just $ (c, Scale $ p x):ret + | Just (Dimension _ x "px":toks', c) <- parseColour (pallet self) toks, + Just ret <- colourStops toks' = Just $ (c, Absolute $ f x):ret | Just (toks', c) <- parseColour (pallet self) toks, - Just ret <- colourStops toks' = Just $ c:ret + Just ret <- colourStops toks' = Just $ (c, Auto):ret + colourStops (Comma:Percentage _ x:toks) + | Just (toks', c) <- parseColour (pallet self) toks, + Just ret <- colourStops toks' = Just $ (c, Scale $ p x):ret + colourStops (Comma:Dimension _ x "px":toks) + | Just (toks', c) <- parseColour (pallet self) toks, + Just ret <- colourStops toks' = Just $ (c, Absolute $ f x):ret colourStops _ = Nothing longhand _ self "background-size" t | val@(_:_) <- parseCSSList inner t = Just self { bgSize = reverse val } diff --git a/lib/Graphics/Rendering/Rect/Types.hs b/lib/Graphics/Rendering/Rect/Types.hs index ecbb610..46c63cf 100644 --- a/lib/Graphics/Rendering/Rect/Types.hs +++ b/lib/Graphics/Rendering/Rect/Types.hs @@ -2,7 +2,7 @@ -- So getters can implement typeclasses {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Graphics.Rendering.Rect.Types(Rect(..), size, Rects(..), BoxSelector, - Uniform, u, c, cs, renderRectWith, liftGL) where + Uniform, u, us, c, cs, renderRectWith, liftGL) where import Linear (M44, V2(..), V4(..)) import qualified Data.ByteString.Char8 as B8 @@ -74,6 +74,10 @@ vertexShader = B8.pack $ unlines [ type Uniform m = GLuint -> GLint -> m () u :: (MonadIO m, UniformValue a) => a -> Uniform m u val prog slot = liftIO $ updateUniform prog slot val +us :: MonadIO m => [Float] -> Uniform m +us vals prog slot = do + liftIO $ withArrayLen vals $ \len -> glUniform1fv slot (toEnum len) + clearUniformUpdateError prog slot vals c :: MonadIO m => AlphaColour Float -> Uniform m c rgba = u $ c' rgba @@ -86,8 +90,7 @@ c' rgba = V4 r g b a cs :: MonadIO m => Int -> [AlphaColour Float] -> Uniform m cs mlen rgba prog slot = do let val = map c' $ take mlen rgba - liftIO $ withArrayLen val $ \len -> - glUniform4fv slot (toEnum len) . castPtr + liftIO $ withArrayLen val $ \len -> glUniform4fv slot (toEnum len) . castPtr clearUniformUpdateError prog slot val renderRectWith :: (MonadIO m, MonadIO n) => ByteString -> [String] -> -- 2.30.2