3 files changed, 63 insertions(+), 10 deletions(-)

M lib/Graphics/Rendering/Rect/Backgrounds.hs
M lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs
M lib/Graphics/Rendering/Rect/Types.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)

@@ 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 }

@@ 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] ->