From ee0a24c8917abf3e2ebc85033c4b7d6634012367 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Tue, 27 Jun 2023 12:14:06 +1200 Subject: [PATCH] Add support for background-position. --- lib/Graphics/Rendering/Rect/Backgrounds.hs | 13 +++-- .../Rendering/Rect/CSS/Backgrounds.hs | 58 +++++++++++-------- 2 files changed, 42 insertions(+), 29 deletions(-) diff --git a/lib/Graphics/Rendering/Rect/Backgrounds.hs b/lib/Graphics/Rendering/Rect/Backgrounds.hs index 76b2b70..2e3caaf 100644 --- a/lib/Graphics/Rendering/Rect/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/Backgrounds.hs @@ -25,9 +25,10 @@ imageFragmentShader = B8.pack $ unlines [ "#version 330 core", "in vec2 coord;", "out vec4 fcolour;", + "uniform vec2 pos;", "uniform sampler2D image;", "uniform vec2 size;", - "void main() { fcolour = texture(image, coord/size); }" + "void main() { fcolour = texture(image, coord/size - pos/size); }" ] linearFragmentShader :: B8.ByteString @@ -160,7 +161,7 @@ renderBackgrounds :: (MonadIO m, MonadIO n) => n (Backgrounds Texture -> Rects -> M44 Float -> m ()) renderBackgrounds = do base <- renderRectWith baseFragmentShader ["colour"] - layer <- renderRectWith imageFragmentShader ["size"] + layer <- renderRectWith imageFragmentShader ["size", "pos"] linear <- renderRectWith linearFragmentShader ["size", "angle", "stops", "stopPoints", "nStops"] ellipse <- renderRectWith radialFragmentShader ["size", "extent", "center", @@ -175,10 +176,12 @@ renderBackgrounds = do let layers = image self `zip` (clip self ++ repeat borderBox) `zip` (bgSize self ++ repeat (Size Auto Auto)) `zip` (origin self ++ repeat paddingBox) - _ <- forM layers $ \(((pat0, clip0), size0), origin0) -> case pat0 of + `zip` (bgPos self ++ repeat (Absolute 0, Absolute 0)) + _ <- forM layers $ \((((pat0, clip0), size0), origin0), pos0) -> case pat0 of None -> return () - Img img0 -> layer [img0] [ - u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0 + Img img0 -> let sz = resolveSize (size $ clip0 a) (texSize img0) size0 + in layer [img0] [ + u $ v2 $ sz, u $ v2 $ l2f' pos0 sz ] clip0 origin0 a b Linear angle stops -> let size' = size $ clip0 a in linear [] [ u $ v2 $ size', u angle, cs 10 $ map fst stops, diff --git a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs index 4ef4a1f..5b46d95 100644 --- a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs @@ -19,6 +19,7 @@ data Backgrounds img = Backgrounds { clip :: [Rects -> Rect], origin :: [Rects -> Rect], image :: [Pattern img], + bgPos :: [(Length, Length)], bgSize :: [Resize] } deriving (Eq, Show, Read) @@ -39,7 +40,8 @@ data Length = Absolute Float | Scale Float | Auto deriving (Eq, Show, Read) instance PropertyParser (Backgrounds Text) where temp = Backgrounds { pallet = temp, background = transparent, clip = [borderBox], - image = [None], bgSize = [Size Auto Auto], origin = [paddingBox] + image = [None], bgSize = [Size Auto Auto], origin = [paddingBox], + bgPos = [(Absolute 0, Absolute 0)] } inherit _ = temp priority _ = [] @@ -156,30 +158,10 @@ instance PropertyParser (Backgrounds Text) where 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-origin" t | val@(_:_) <- parseCSSList box t = Just self { origin = reverse val } + longhand _ self "background-position" t | val@(_:_) <- parseCSSList position t, + all (null . snd) val = Just self { bgPos = reverse $ map fst val } longhand _ self "background-size" t | val@(_:_) <- parseCSSList inner t = Just self { bgSize = reverse val } where -- TODO: Add shorthand support, after background-position. @@ -210,7 +192,8 @@ instance PropertyParser (Backgrounds Text) where -- Shouldn't happen, `inner` expands all props at least to "initial"! | otherwise = (key, val) inner toks | ret@(_:_) <- parseUnorderedShorthand self [ - "background-color", "background-clip", "background-image" + "background-color", "background-clip", "background-image", + "background-origin", "background-position" ] toks = Just ret | otherwise = Nothing shorthand self key val | Just _ <- longhand self self key val = [(key, val)] @@ -223,6 +206,29 @@ box [Ident "border-box"] = Just borderBox box [Ident "initial"] = Just borderBox -- To aid shorthand implementation. box _ = Nothing +position :: [Token] -> Maybe ((Length, Length), [Token]) +position (x:y:ts) = position' x y ts *> position' y x ts +position _ = Nothing +position' :: Token -> Token -> [Token] -> Maybe ((Length, Length), [Token]) +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 + colourStops :: ColourPallet -> [Token] -> Maybe [(AlphaColour Float, Length)] colourStops _ [RightParen] = Just [] @@ -253,6 +259,10 @@ p :: NumericValue -> Float p (NVInteger x) = fromInteger x / 100 -- Do the division while we're in base-10! p (NVNumber x) = toRealFloat (x/scientific 1 2) +p' :: NumericValue -> Length +p' = Scale . p +f' :: NumericValue -> Length +f' = Absolute . f ------ --- Utils taken from HappStack -- 2.30.2