@@ 1,5 1,6 @@
module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), Pattern(..),
- RadialShape(..), Resize(..), Length(..), resolveSize, renderBackgrounds) where
+ RadialShape(..), Resize(..), Length(..), Extent(..),
+ resolveSize, renderBackgrounds) where
import Graphics.Rendering.Rect.CSS.Backgrounds
import Graphics.Rendering.Rect.Types
@@ 68,13 69,14 @@ radialFragmentShader = B8.pack $ unlines [
"in vec2 coord;",
"out vec4 fcolour;",
"uniform vec2 size;",
+ "uniform vec2 extent;",
"uniform vec2 center;",
"uniform vec4 stops[10];",
"uniform float stopPoints[10];",
"uniform int nStops;",
"",
"void main() {",
- " float a = distance(coord/size, center/size) * 2;",
+ " float a = distance(coord/extent, center/size) * 2;",
"",
" int i = 0;",
-- Workaround for buggy GPU drivers on test machine.
@@ 121,6 123,39 @@ circleFragmentShader = B8.pack $ unlines [
"}"
]
+conicFragmentShader :: B8.ByteString
+conicFragmentShader = B8.pack $ unlines [
+ "#version 330 core",
+ "in vec2 coord;",
+ "out vec4 fcolour;",
+ "uniform vec2 center;",
+ "uniform float angle;",
+ "uniform vec4 stops[10];",
+ "uniform float stopPoints[10];",
+ "uniform int nStops;",
+ "",
+ "void main() {",
+ " vec2 v = coord - center;",
+ " float a = atan(v.x, -v.y) - angle;",
+ " float turn = 2*radians(180);",
+ " a = fract(a/turn);",
+ "",
+ " int i = 0;",
+ -- Workaround for buggy GPU drivers on test machine.
+ " if (1 < nStops - 1 && a > stopPoints[1]) i = 1;",
+ " if (2 < nStops - 1 && a > stopPoints[2]) i = 2;",
+ " if (3 < nStops - 1 && a > stopPoints[3]) i = 3;",
+ " if (4 < nStops - 1 && a > stopPoints[4]) i = 4;",
+ " if (5 < nStops - 1 && a > stopPoints[5]) i = 5;",
+ " if (6 < nStops - 1 && a > stopPoints[6]) i = 6;",
+ " if (7 < nStops - 1 && a > stopPoints[7]) i = 7;",
+ " if (8 < nStops - 1 && a > stopPoints[8]) i = 8;",
+ "",
+ " 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
@@ 128,10 163,12 @@ renderBackgrounds = do
layer <- renderRectWith imageFragmentShader ["size"]
linear <- renderRectWith linearFragmentShader ["size", "angle",
"stops", "stopPoints", "nStops"]
- ellipse <- renderRectWith radialFragmentShader ["size", "center",
+ ellipse <- renderRectWith radialFragmentShader ["size", "extent", "center",
"stops", "stopPoints", "nStops"]
circle <- renderRectWith circleFragmentShader ["center", "radius",
"stops", "stopPoints", "nStops"]
+ conic <- renderRectWith conicFragmentShader ["center", "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)
@@ 145,17 182,22 @@ 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 Ellipse _ org stops ->
- let sz@(_,h) = size $ clip0 a in ellipse [] [
- u $ v2 sz, u $ v2 $ l2f' org sz, cs 10 $ map fst stops,
+ -- FIXME: Incorporate resolveEllipseExtent without messing up center
+ Radial Ellipse ext org stops -> let sz@(_,h) = size $ clip0 a in
+ let (org', ext') = resolveEllipseExtent sz org ext in ellipse [] [
+ u $ v2 sz, u $ v2 ext', u $ v2 org', cs 10 $ map fst stops,
us $ ls2fs (0,h/2) $ map snd $ take 10 stops, u $ length stops
] clip0 a b
- Radial Circle _ org stops ->
- let sz@(w,h) = size $ clip0 a in circle [] [
- u $ v2 $ l2f' org sz, u (min w h/2), cs 10 $ map fst stops,
+ Radial Circle ext org stops -> let sz@(w,h) = size $ clip0 a
+ in let (org', r) = resolveCircleExtent sz org ext in circle [] [
+ u $ v2 org', u r, cs 10 $ map fst stops,
us $ ls2fs (0,min w h/2) $ map snd $ take 10 stops,
u $ length stops
] clip0 a b
+ Conical angle org stops -> let sz = size $ clip0 a in conic [] [
+ u $ v2 $ l2f' org sz, u angle, cs 10 $ map fst stops,
+ us $ ls2fs (0,2*pi) $ map snd $ take 10 stops, u $ length stops
+ ] clip0 a b
return ()
headDef :: c -> [c] -> c
@@ 195,4 237,32 @@ l2f Auto x = x/2
l2f (Scale x) y = x*y
l2f (Absolute x) _ = x
l2f' :: (Length, Length) -> (Float, Float) -> (Float, Float)
-l2f' (w,h) (x,y) = (l2f w x, l2f h y)
+l2f' (x,y) (w,h) = (l2f x w, l2f y h)
+
+resolveEllipseExtent :: (Float, Float) -> (Length, Length) -> Extent ->
+ ((Float, Float), (Float, Float))
+resolveEllipseExtent sz@(x',y') pos ext = ((x, y), inner ext)
+ where
+ (x,y) = l2f' pos sz
+ horiz = [x, x' - x]
+ vert = [y, y' - y]
+ inner (Extent s t) = (l2f s x, l2f t y)
+ -- FIXME: How to calculate closest/farthest-corner?
+ -- Spec just says keep this aspect ratio.
+ inner ClosestCorner = (minimum horiz * 2, minimum vert * 2)
+ inner ClosestSide = (minimum horiz * 2, minimum vert * 2)
+ inner FarthestCorner = (maximum horiz * 2, maximum vert * 2)
+ inner FarthestSide = (maximum horiz * 2, maximum vert * 2)
+resolveCircleExtent :: (Float, Float) -> (Length, Length) -> Extent ->
+ ((Float, Float), Float)
+resolveCircleExtent sz@(x',y') pos ext = ((x, y), inner ext)
+ where
+ (x,y) = l2f' pos sz
+ sides = [x, x' - x, y, y' - y]
+ corners = [hypot x y, hypot x $ y'-y, hypot y $ x'-x, hypot (x'-x) (y'-y)]
+ hypot a b = sqrt $ a*a + b*b
+ inner (Extent a _) = l2f a y -- Should be absolute...
+ inner ClosestCorner = minimum corners
+ inner ClosestSide = minimum sides
+ inner FarthestCorner = maximum corners
+ inner FarthestSide = maximum sides
@@ 1,6 1,6 @@
{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..),
- Pattern(..), RadialShape(..),
+ Pattern(..), RadialShape(..), Extent(..),
Resize(..), Length(..), resolveSize) where
import Stylist (PropertyParser(..), parseUnorderedShorthand, parseOperands)
@@ 25,6 25,7 @@ type C = AlphaColour Float
data Pattern img = None | Img img | Linear Float [(C, Length)]
| Radial RadialShape Extent (Length, Length) [(C, Length)]
+ | Conical Float (Length, Length) [(C, Length)]
deriving (Eq, Show, Read)
data RadialShape = Circle | Ellipse deriving (Eq, Show, Read)
data Extent = Extent Length Length | ClosestCorner
@@ 62,8 63,7 @@ instance PropertyParser (Backgrounds Text) where
inner (Function "linear-gradient":toks)
| Just cs@(_:_:_)<-colourStops pp (Comma:toks) = Just $ Linear pi cs
inner (Function "linear-gradient":Dimension _ x unit:toks)
- | Just s <- lookup unit [("deg", pi/180), ("grad", pi/200),
- ("rad", 1), ("turn", 2*pi)],
+ | Just s <- lookup unit angularUnits,
Just cs@(_:_:_) <- colourStops pp toks = Just $ Linear (f x*s) cs
inner (Function "linear-gradient":Ident "to":Ident a:Ident b:toks)
| Just angle<-corner a b, Just stops@(_:_:_)<-colourStops pp toks =
@@ 86,7 86,6 @@ instance PropertyParser (Backgrounds Text) where
| (shp, org, ext, ts) <- radArgs toks,
Just cs@(_:_:_) <- colourStops pp ts = Just $ Radial shp ext org cs
where
- center = (Scale 0.5, Scale 0.5)
radArgs (Ident s:Ident "at":ts) | Just shape <- radShape s,
Just (org, ts') <- position ts =
(shape, org, FarthestCorner, ts')
@@ 142,29 141,48 @@ instance PropertyParser (Backgrounds Text) where
ellipseExt _ = Nothing
circleExt (Dimension _ x "px":ts) = Just (f' x `Extent` f' x, ts)
circleExt ts = radExt ts
- p' = Scale . p
- f' = Absolute . f
- position (x:y:ts) = position' x y ts *> position' y x ts
- position _ = Nothing
- position' x y ts = case ((case x of
- Ident "left" -> Scale 0
- Ident "center" -> Scale 0.5
- Ident "right" -> Scale 1
- Percentage _ a -> p' a
- Dimension _ a "px" -> f' a
- _ -> Auto,
- case y of
- Ident "top" -> Scale 0
- Ident "center" -> Scale 0.5
- Ident "right" -> Scale 1
- Percentage _ a -> p' a
- Dimension _ a "px" -> f' a
- _ -> Auto),
- ts) of
- ((Auto, _), _) -> Nothing
- ((_, Auto), _) -> Nothing
- ret -> Just ret
+ -- NOTE: Not implementing colourspaces yet...
+ inner (Function "conic-gradient":Ident "from":Dimension _ x unit:
+ Ident "at":ts)
+ | Just (org, ts') <- position ts, Just s <- lookup unit angularUnits,
+ Just stops@(_:_:_) <- colourStops pp ts' =
+ Just $ Conical (f x*s) org stops
+ inner (Function "conic-gradient":Ident "from":Dimension _ x unit:ts)
+ | Just s <- lookup unit angularUnits,
+ Just stops@(_:_:_) <- colourStops pp ts =
+ Just $ Conical (f x*s) center stops
+ inner (Function "conic-gradient":Ident "at":ts)
+ | Just (org, ts') <- position ts,
+ Just cs@(_:_:_) <- colourStops pp ts' = Just $ Conical 0 org cs
+ inner (Function "conic-gradient":ts)
+ | Just stops@(_:_:_) <- colourStops pp (Comma:ts) =
+ Just $ Conical 0 center stops
inner _ = Nothing
+
+ angularUnits = [("deg",pi/180),("grad",pi/200),("rad",1),("turn",2*pi)]
+ center = (Scale 0.5, Scale 0.5)
+ position (x:y:ts) = position' x y ts *> position' y x ts
+ position _ = Nothing
+ position' x y ts = case ((case x of
+ Ident "left" -> Scale 0
+ Ident "center" -> Scale 0.5
+ Ident "right" -> Scale 1
+ Percentage _ a -> p' a
+ Dimension _ a "px" -> f' a
+ _ -> Auto,
+ case y of
+ Ident "top" -> Scale 0
+ Ident "center" -> Scale 0.5
+ Ident "right" -> Scale 1
+ Percentage _ a -> p' a
+ Dimension _ a "px" -> f' a
+ _ -> Auto),
+ ts) of
+ ((Auto, _), _) -> Nothing
+ ((_, Auto), _) -> Nothing
+ ret -> Just ret
+ p' = Scale . p
+ f' = Absolute . f
longhand _ self "background-size" t | val@(_:_) <- parseCSSList inner t =
Just self { bgSize = reverse val }
where -- TODO: Add shorthand support, after background-position.