From 4fb39760e2559c8622c33aac8f27aba8b6887edd Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 14 Jun 2023 15:48:12 +1200 Subject: [PATCH] Implement background-size! --- lib/Graphics/Rendering/Rect/Backgrounds.hs | 17 ++-- .../Rendering/Rect/CSS/Backgrounds.hs | 77 +++++++++++++++++-- lib/Graphics/Rendering/Rect/Image.hs | 15 ++-- lib/Graphics/Rendering/Rect/Types.hs | 3 +- 4 files changed, 95 insertions(+), 17 deletions(-) diff --git a/lib/Graphics/Rendering/Rect/Backgrounds.hs b/lib/Graphics/Rendering/Rect/Backgrounds.hs index 21a17ef..05eddad 100644 --- a/lib/Graphics/Rendering/Rect/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/Backgrounds.hs @@ -2,9 +2,9 @@ module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), renderBackgrounds) w import Graphics.Rendering.Rect.CSS.Backgrounds import Graphics.Rendering.Rect.Types -import Graphics.Rendering.Rect.Image (Texture) +import Graphics.Rendering.Rect.Image (Texture(texSize)) import qualified Data.ByteString.Char8 as B8 -import Linear (M44) +import Linear (M44, V2(..)) import Control.Monad.IO.Class (MonadIO(..)) import Data.Maybe (fromMaybe, listToMaybe) @@ -22,19 +22,24 @@ imageFragmentShader = B8.pack $ unlines [ "in vec2 coord;", "out vec4 fcolour;", "uniform sampler2D image;", - "void main() { fcolour = texture(image, coord/textureSize(image, 0)); }" + "uniform vec2 size;", + "void main() { fcolour = texture(image, coord/size); }" ] renderBackgrounds :: (MonadIO m, MonadIO n) => n (Backgrounds Texture -> Rects -> M44 Float -> m ()) renderBackgrounds = do base <- renderRectWith baseFragmentShader ["colour"] - layer <- renderRectWith imageFragmentShader [] + layer <- renderRectWith imageFragmentShader ["size"] return $ \self a b -> do base [] [c $ background self] (headDef borderBox $ clip self) a b let layers = image self `zip` (clip self ++ repeat borderBox) - forM layers $ \(img0, clip0) -> - layer [img0] [] clip0 a b + `zip` (bgSize self ++ repeat (Size Auto Auto)) + forM layers $ \((img0, clip0), size0) -> + layer [img0] [ + u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0 + ] clip0 a b return () headDef def = fromMaybe def . listToMaybe +v2 = uncurry V2 diff --git a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs index b72ea1c..b47b15f 100644 --- a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs @@ -1,10 +1,12 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances #-} -module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..)) where +module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..), + Resize(..), Length(..), resolveSize) where import Stylist (PropertyParser(..), parseUnorderedShorthand) -import Data.CSS.Syntax.Tokens (Token(..)) +import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..)) import Data.Maybe (isJust, catMaybes) import Data.Text (Text) +import Data.Scientific (scientific, toRealFloat) import Graphics.Rendering.Rect.CSS.Colour (ColourPallet, parseColour) import Data.Colour (AlphaColour, transparent) @@ -14,12 +16,18 @@ data Backgrounds img = Backgrounds { pallet :: ColourPallet, background :: AlphaColour Float, clip :: [Rects -> Rect], - image :: [img] + image :: [img], + bgSize :: [Resize] } 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) +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 = [""] + pallet = temp, background = transparent, clip = [borderBox], + image = [""], bgSize = [Size Auto Auto] } inherit _ = temp priority _ = [] @@ -42,6 +50,20 @@ instance PropertyParser (Backgrounds Text) where inner [Url ret] = Just ret inner [Function "url", String ret, RightParen] = Just ret inner _ = Nothing + longhand _ self "background-size" t | val@(_:_) <- parseCSSList inner t = + Just self { bgSize = reverse val } + where -- TODO: Add shorthand support, after background-position. + inner [x, y] | Just a <- length x, Just b <- length y = Just $ Size a b + inner [Ident "contain"] = Just Contain + inner [Ident "cover"] = Just Cover + inner [Ident "auto"] = Just $ Size Auto Auto + inner [Ident "initial"] = Just $ Size Auto Auto + inner _ = Nothing + -- NOTE: Leave lowering other units to CatTrap. + length (Ident "auto") = Just Auto + length (Dimension _ x "px") = Just $ Absolute $ f x + length (Percentage _ x) = Just $ Scale $ p x + length _ = Nothing longhand _ _ _ _ = Nothing -- The multi-layered shorthand is one source of parsing complexity. @@ -58,7 +80,7 @@ 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-color" + "background-color", "background-clip", "background-image" ] toks = Just ret | otherwise = Nothing shorthand self key val | Just _ <- longhand self self key val = [(key, val)] @@ -68,6 +90,14 @@ parseCSSList cb toks | all isJust ret = catMaybes ret | otherwise = [] where ret = map cb $ splitList Comma toks +f :: NumericValue -> Float +f (NVInteger x) = fromInteger x +f (NVNumber x) = toRealFloat x +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) + ------ --- Utils taken from HappStack ------ @@ -84,3 +114,40 @@ split f s = (left,right) where (left,right')=break f s right = if null right' then [] else tail right' + +------ +--- Dynamically-computed properties +------ + +resolveSize :: (Float, Float) -> (Float, Float) -> Resize -> (Float, Float) +resolveSize (owidth, oheight) (width, height) Contain + | width > owidth, height*sw > oheight, height > width = (width*sh, height*sh) + | width > owidth = (width*sw, height*sw) + | height > oheight = (width*sh, height*sh) + | height > width = (width*sw, height*sw) + | width > height = (width*sh, height*sh) + where + sh = oheight/height + sw = owidth/width +resolveSize (owidth, oheight) (width, height) Cover + | owidth > width, oheight > height*sw = (width*sh, height*sh) + | oheight > height, owidth > width*sh = (width*sw, height*sw) + | owidth > width = (width*sw, height*sw) + | oheight > height = (width*sh, height*sh) + | oheight > height*sw = (width*sh, height*sh) + | owidth > width*sh = (width*sw, height*sw) + | height > width = (width*sw, height*sw) + | width > height = (width*sh, height*sh) + where + sh = oheight/height + sw = owidth/width +resolveSize _ ret (Size Auto Auto) = ret +resolveSize _ (width, height) (Size x y) = (x', y') + where + x' | Absolute ret <- x = ret + | Scale s <- x = width*s + | Auto <- x = y' * width/height + y' | Absolute ret <- y = ret + | Scale s <- y = height*s + -- NOTE: If Auto,Auto case wasn't handled above this'd be an infinite loop. + | Auto <- y = x' * height/width diff --git a/lib/Graphics/Rendering/Rect/Image.hs b/lib/Graphics/Rendering/Rect/Image.hs index 3a7b088..41342c6 100644 --- a/lib/Graphics/Rendering/Rect/Image.hs +++ b/lib/Graphics/Rendering/Rect/Image.hs @@ -23,7 +23,7 @@ import Data.Vector.Storable (unsafeWith, unsafeCast, Vector) import Foreign.Ptr (castPtr) import Foreign.Marshal.Array (allocaArray, peekArray) -data Atlas = Atlas { unAtlas :: HM.HashMap Text GLuint } +data Atlas = Atlas { unAtlas :: HM.HashMap Text Texture } buildAtlas :: MonadIO m => (Text -> IO DynamicImage) -> [Text] -> m Atlas buildAtlas cb [] = return $ Atlas HM.empty @@ -35,7 +35,7 @@ buildAtlas cb srcs = do peekArray len ptr imgs <- liftIO $ forM srcs cb - forM (zip textures imgs) $ \(texture, dyn) -> do + sizes <- forM (zip textures imgs) $ \(texture, dyn) -> do -- NOTE: `unsafe` crashes with a divide-by-zero given a `Vector ()` let dyn' = convertDyn dyn let img = dynamicMap (unsafeCast . imageData) dyn' :: Vector Word @@ -50,11 +50,16 @@ buildAtlas cb srcs = do liftIO $ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT liftIO $ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT - return $ Atlas $ HM.fromList $ zip srcs textures + return (toEnum $ dynamicMap imageWidth dyn', + toEnum $ dynamicMap imageHeight dyn') -data Texture = Texture { unTexture :: GLuint } + let textures' = map (uncurry Texture) $ zip textures sizes + return $ Atlas $ HM.fromList $ zip srcs textures' + +data Texture = Texture { unTexture :: GLuint, texSize :: (Float, Float) } +nilTexture = Texture 0 (0, 0) atlasLookup :: Text -> Atlas -> Texture -atlasLookup key = Texture . fromMaybe 0 . HM.lookup key . unAtlas +atlasLookup key = fromMaybe nilTexture . HM.lookup key . unAtlas -- OpenGL deals in CrCb not CbCr... -- Convert pixels to some flavour of RGBA diff --git a/lib/Graphics/Rendering/Rect/Types.hs b/lib/Graphics/Rendering/Rect/Types.hs index aa8a829..8a8d4bd 100644 --- a/lib/Graphics/Rendering/Rect/Types.hs +++ b/lib/Graphics/Rendering/Rect/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards #-} -- So getters can implement typeclasses {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -module Graphics.Rendering.Rect.Types(Rect(..), Rects(..), BoxSelector, +module Graphics.Rendering.Rect.Types(Rect(..), size, Rects(..), BoxSelector, Uniform, u, c, renderRectWith, liftGL) where import Linear (M44, V2(..), V4(..)) @@ -31,6 +31,7 @@ rect2geom Rect{..} = UV.fromList [tl, tr, br, tl, br, bl] where (tl, tr) = (V2 left top, V2 right top) (bl, br) = (V2 left bottom, V2 right bottom) +size Rect {..} = (right - left, bottom - top) data Rects = Rects { contentBox :: Rect, -- 2.30.2