From cf3ffa1413e29bb9662a14946c90328de5e0370d Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 26 Jun 2023 13:58:35 +1200 Subject: [PATCH] Implement background-origin! --- lib/Graphics/Rendering/Rect/Backgrounds.hs | 16 ++++++++------- .../Rendering/Rect/CSS/Backgrounds.hs | 20 +++++++++++-------- lib/Graphics/Rendering/Rect/Types.hs | 9 +++++---- 3 files changed, 26 insertions(+), 19 deletions(-) diff --git a/lib/Graphics/Rendering/Rect/Backgrounds.hs b/lib/Graphics/Rendering/Rect/Backgrounds.hs index f33df0e..76b2b70 100644 --- a/lib/Graphics/Rendering/Rect/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/Backgrounds.hs @@ -170,34 +170,36 @@ renderBackgrounds = do conic <- renderRectWith conicFragmentShader ["center", "angle", "stops", "stopPoints", "nStops"] return $ \self a b -> do - base [] [c $ background self] (headDef borderBox $ clip self) a b + base [] [c $ background self] (headDef borderBox $ clip self) + (headDef paddingBox $ origin self) a b let layers = image self `zip` (clip self ++ repeat borderBox) `zip` (bgSize self ++ repeat (Size Auto Auto)) - _ <- forM layers $ \((pat0, clip0), size0) -> case pat0 of + `zip` (origin self ++ repeat paddingBox) + _ <- forM layers $ \(((pat0, clip0), size0), origin0) -> case pat0 of None -> return () Img img0 -> layer [img0] [ u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0 - ] clip0 a b + ] clip0 origin0 a b 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 + ] clip0 origin0 a b -- 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 + ] clip0 origin0 a b 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 + ] clip0 origin0 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 + ] clip0 origin0 a b return () headDef :: c -> [c] -> c diff --git a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs index 4bd571a..4ef4a1f 100644 --- a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs @@ -17,6 +17,7 @@ data Backgrounds img = Backgrounds { pallet :: ColourPallet, background :: C, clip :: [Rects -> Rect], + origin :: [Rects -> Rect], image :: [Pattern img], bgSize :: [Resize] } deriving (Eq, Show, Read) @@ -38,21 +39,15 @@ 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] + image = [None], bgSize = [Size Auto Auto], origin = [paddingBox] } inherit _ = temp priority _ = [] longhand _ self@Backgrounds{ pallet = c } "background-color" toks | Just ([], val) <- parseColour c toks = Just self { background = val } - longhand _ self "background-clip" t | val@(_:_) <- parseCSSList inner t = + longhand _ self "background-clip" t | val@(_:_) <- parseCSSList box t = Just self { clip = reverse val } - where - inner [Ident "content-box"] = Just contentBox - inner [Ident "padding-box"] = Just paddingBox - inner [Ident "border-box"] = Just borderBox - inner [Ident "initial"] = Just borderBox -- To aid shorthand implementation. - inner _ = Nothing longhand _ self@Backgrounds { pallet = pp } "background-image" t | val@(_:_) <- parseCSSList inner t = Just self { image = reverse val } where @@ -183,6 +178,8 @@ instance PropertyParser (Backgrounds Text) where 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-size" t | val@(_:_) <- parseCSSList inner t = Just self { bgSize = reverse val } where -- TODO: Add shorthand support, after background-position. @@ -219,6 +216,13 @@ instance PropertyParser (Backgrounds Text) where shorthand self key val | Just _ <- longhand self self key val = [(key, val)] | otherwise = [] +box :: [Token] -> Maybe (Rects -> Rect) +box [Ident "content-box"] = Just contentBox +box [Ident "padding-box"] = Just paddingBox +box [Ident "border-box"] = Just borderBox +box [Ident "initial"] = Just borderBox -- To aid shorthand implementation. +box _ = Nothing + colourStops :: ColourPallet -> [Token] -> Maybe [(AlphaColour Float, Length)] colourStops _ [RightParen] = Just [] diff --git a/lib/Graphics/Rendering/Rect/Types.hs b/lib/Graphics/Rendering/Rect/Types.hs index 8c9810c..aa7c024 100644 --- a/lib/Graphics/Rendering/Rect/Types.hs +++ b/lib/Graphics/Rendering/Rect/Types.hs @@ -97,7 +97,8 @@ cs mlen rgba prog slot = do clearUniformUpdateError prog slot val renderRectWith :: (MonadIO m, MonadIO n) => ByteString -> [String] -> - n ([Texture] -> [Uniform m] -> (a -> Rect) -> a -> M44 Float -> m ()) + n ([Texture] -> [Uniform m] -> (a -> Rect) -> (a -> Rect) -> a + -> M44 Float -> m ()) renderRectWith fragmentShader uniformNames = do vs <- liftGL $ compileOGLShader vertexShader GL_VERTEX_SHADER fs <- liftGL $ compileOGLShader fragmentShader GL_FRAGMENT_SHADER @@ -108,14 +109,14 @@ renderRectWith fragmentShader uniformNames = do glUseProgram prog glEnable GL_BLEND glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA - return $ \textures uniforms getter rects mat -> do - let r = getter rects + return $ \textures uniforms clip' origin' rects mat -> do vao <- liftIO $ newBoundVAO pbuf <- newBuffer - bufferGeometry 0 pbuf $ rect2geom r + bufferGeometry 0 pbuf $ rect2geom $ clip' rects glUseProgram prog liftIO $ updateUniform prog matID $ mflip mat + let r = origin' rects liftIO $ updateUniform prog originID $ V2 (left r) (top r) _ <- forM (zip uniformIDs uniforms) $ \(slot, cb) -> cb prog slot -- 2.30.2