3 files changed, 59 insertions(+), 13 deletions(-)

M lib/Graphics/Rendering/Rect.hs
M lib/Graphics/Rendering/Rect/Backgrounds.hs
M lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs

@@ 1,5 1,6 @@
 module Graphics.Rendering.Rect(Rect(..), Rects(..), shrink, shrink1, renderRects,
-    RectStyle(..), colour, Backgrounds(..), Pattern(..), Resize(..), Length(..),
+    RectStyle(..), colour,
+    Backgrounds(..), Pattern(..), Resize(..), Length(..), RadialShape(..),
     Atlas, buildAtlas, atlasFromStyles, Texture, styleResolveImages) where
 
 import Graphics.Rendering.Rect.CSS


@@ 36,7 37,7 @@ styleResolveImages atlas self =
     atlasLookup' None = None
     atlasLookup' (Img path) = Img $ atlasLookup path atlas
     atlasLookup' (Linear a b) = Linear a b
-    atlasLookup' (Radial a) = Radial a
+    atlasLookup' (Radial a b) = Radial a b
 
 atlasFromStyles :: MonadIO m =>
         (Text -> IO DynamicImage) -> [RectStyle Text] -> m Atlas

@@ 1,5 1,5 @@
 module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), Pattern(..),
-    Resize(..), Length(..), resolveSize, renderBackgrounds) where
+    RadialShape(..), Resize(..), Length(..), resolveSize, renderBackgrounds) where
 
 import Graphics.Rendering.Rect.CSS.Backgrounds
 import Graphics.Rendering.Rect.Types


@@ 68,13 68,42 @@ radialFragmentShader = B8.pack $ unlines [
     "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() {",
-    "   vec2 pos = coord/size;",
-    "   float a = distance(pos, vec2(0.5)) * 2;",
+    "   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.


@@ 99,8 128,10 @@ renderBackgrounds = do
     layer <- renderRectWith imageFragmentShader ["size"]
     linear <- renderRectWith linearFragmentShader ["size", "angle",
             "stops", "stopPoints", "nStops"]
-    radial <- renderRectWith radialFragmentShader
-            ["size", "nStops", "stops", "stopPoints"]
+    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)


@@ 114,9 145,14 @@ renderBackgrounds = do
                     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 stops -> let size'@(_,h) = size $ clip0 a in radial [] [
-                    u $ v2 $ size', u $ length stops, cs 10 $ map fst stops,
-                    us $ ls2fs (0,h/2) $ map snd $ take 10 stops
+            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 ()
 

@@ 1,5 1,6 @@
 {-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
-module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..), Pattern(..),
+module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..),
+    Pattern(..), RadialShape(..),
     Resize(..), Length(..), resolveSize) where
 
 import Stylist (PropertyParser(..), parseUnorderedShorthand, parseOperands)


@@ 23,7 24,8 @@ data Backgrounds img = Backgrounds {
 type C = AlphaColour Float
 
 data Pattern img = None | Img img | Linear Float [(C, Length)]
-    | Radial [(C, Length)] deriving (Eq, Show, Read)
+    | Radial RadialShape [(C, Length)] deriving (Eq, Show, Read)
+data RadialShape = Circle | Ellipse 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)


@@ 76,7 78,14 @@ instance PropertyParser (Backgrounds Text) where
                 ("top", 0), ("right", pi/2), ("bottom", pi), ("left", pi*1.5)],
                 Just cs@(_:_:_) <- colourStops pp toks = Just $ Linear angle cs
         inner (Function "radial-gradient":toks)
-            | Just cs@(_:_:_) <- colourStops pp (Comma:toks) = Just $ Radial cs
+            | Just cs@(_:_:_) <- colourStops pp (Comma:toks) =
+                Just $ Radial Ellipse cs
+            | Just (shp, ts) <- radArgs toks, Just cs@(_:_:_) <- colourStops pp ts
+                = Just $ Radial shp cs
+          where
+            radArgs (Ident "circle":ts) = Just (Circle, ts)
+            radArgs (Ident "ellipse":ts) = Just (Ellipse, ts)
+            radArgs _ = Nothing
         inner _ = Nothing
     longhand _ self "background-size" t | val@(_:_) <- parseCSSList inner t =
         Just self { bgSize = reverse val }