From 1adb7b35a44df9d6e6c3b21672d3577ffba8b3f6 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 15 Jun 2023 14:10:53 +1200 Subject: [PATCH] Add basic support for linear gradients! --- app/Main.hs | 10 +++--- lib/Graphics/Rendering/Rect.hs | 10 ++++-- lib/Graphics/Rendering/Rect/Backgrounds.hs | 26 +++++++++++--- .../Rendering/Rect/CSS/Backgrounds.hs | 34 +++++++++++++------ 4 files changed, 58 insertions(+), 22 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c421455..103e133 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,7 +5,7 @@ import Graphics.Rendering.Rect import Stylist.Parse (parseProperties') import Stylist (PropertyParser(..)) import Data.Text (Text, pack, unpack) -import Data.CSS.Syntax.Tokens (tokenize, serialize) +import Data.CSS.Syntax.Tokens (tokenize, serialize, Token(Whitespace)) import SDL hiding (trace) import Graphics.GL.Core32 @@ -28,10 +28,12 @@ parseStyle syn where toks = tokenize $ pack syn apply ((key, val):props) - | Just self' <- longhand self self key val = self' - | props'@(_:_) <- shorthand self key val = apply (props' ++ props) + | Just self' <- longhand self self key val' = self' + | props'@(_:_) <- shorthand self key val' = apply (props' ++ props) | otherwise = trace ("Unsupported property " ++ unpack key) self - where self = apply props + where + self = apply props + val' = filter (/= Whitespace) val apply [] = temp orthoProjection (V2 ww wh) = diff --git a/lib/Graphics/Rendering/Rect.hs b/lib/Graphics/Rendering/Rect.hs index dd93550..ba164fe 100644 --- a/lib/Graphics/Rendering/Rect.hs +++ b/lib/Graphics/Rendering/Rect.hs @@ -1,5 +1,5 @@ module Graphics.Rendering.Rect(Rect(..), Rects(..), shrink, shrink1, renderRects, - RectStyle(..), colour, Backgrounds(..), + RectStyle(..), colour, Backgrounds(..), Pattern(..), Resize(..), Length(..), Atlas, buildAtlas, atlasFromStyles, Texture, styleResolveImages) where import Graphics.Rendering.Rect.CSS @@ -30,10 +30,14 @@ renderRects = do styleResolveImages :: Atlas -> RectStyle Text -> RectStyle Texture styleResolveImages atlas self = - let textures = map (flip atlasLookup atlas) $ image $ backgrounds self + let textures = map atlasLookup' $ image $ backgrounds self in self { backgrounds = (backgrounds self) { image = textures } } + where + atlasLookup' None = None + atlasLookup' (Img path) = Img $ atlasLookup path atlas + atlasLookup' (Linear a b) = Linear a b atlasFromStyles :: MonadIO m => (Text -> IO DynamicImage) -> [RectStyle Text] -> m Atlas atlasFromStyles cb styles = - buildAtlas cb $ nub $ concat $ map (image . backgrounds) styles + buildAtlas cb $ nub [path | s <- styles, Img path <- image $ backgrounds s] diff --git a/lib/Graphics/Rendering/Rect/Backgrounds.hs b/lib/Graphics/Rendering/Rect/Backgrounds.hs index 05eddad..07af903 100644 --- a/lib/Graphics/Rendering/Rect/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/Backgrounds.hs @@ -1,4 +1,5 @@ -module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), renderBackgrounds) where +module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), Pattern(..), + Resize(..), Length(..), resolveSize, renderBackgrounds) where import Graphics.Rendering.Rect.CSS.Backgrounds import Graphics.Rendering.Rect.Types @@ -26,19 +27,34 @@ imageFragmentShader = B8.pack $ unlines [ "void main() { fcolour = texture(image, coord/size); }" ] +linearFragmentShader = B8.pack $ unlines [ + "#version 330 core", + "in vec2 coord;", + "out vec4 fcolour;", + "uniform vec2 size;", + "uniform vec4 start;", + "uniform vec4 end;", + "void main() { fcolour = mix(start, end, coord.y/size.y); }" + ] + renderBackgrounds :: (MonadIO m, MonadIO n) => n (Backgrounds Texture -> Rects -> M44 Float -> m ()) renderBackgrounds = do base <- renderRectWith baseFragmentShader ["colour"] layer <- renderRectWith imageFragmentShader ["size"] + linear <- renderRectWith linearFragmentShader ["size", "start", "end"] return $ \self a b -> do base [] [c $ background self] (headDef borderBox $ clip self) a b let layers = image self `zip` (clip self ++ repeat borderBox) `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 + forM layers $ \((pat0, clip0), size0) -> case pat0 of + None -> return () + Img img0 -> layer [img0] [ + u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0 + ] clip0 a b + Linear start end -> linear [] [ + u $ v2 $ size $ clip0 a, c start, c end + ] clip0 a b return () headDef def = fromMaybe def . listToMaybe diff --git a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs index b47b15f..9668206 100644 --- a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances #-} -module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..), +module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..), Pattern(..), Resize(..), Length(..), resolveSize) where -import Stylist (PropertyParser(..), parseUnorderedShorthand) +import Stylist (PropertyParser(..), parseUnorderedShorthand, parseOperands) import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..)) import Data.Maybe (isJust, catMaybes) import Data.Text (Text) @@ -12,14 +12,20 @@ import Graphics.Rendering.Rect.CSS.Colour (ColourPallet, parseColour) import Data.Colour (AlphaColour, transparent) import Graphics.Rendering.Rect.Types (Rects(..), Rect(..)) +import Debug.Trace (traceShow) + data Backgrounds img = Backgrounds { pallet :: ColourPallet, - background :: AlphaColour Float, + background :: C, clip :: [Rects -> Rect], - image :: [img], + image :: [Pattern img], bgSize :: [Resize] } deriving (Eq, Show, Read) +type C = AlphaColour Float + +data Pattern img = None | Img img | Linear C C 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) @@ -27,7 +33,7 @@ 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 = [""], bgSize = [Size Auto Auto] + image = [None], bgSize = [Size Auto Auto] } inherit _ = temp priority _ = [] @@ -45,11 +51,19 @@ instance PropertyParser (Backgrounds Text) where longhand _ self "background-image" t | val@(_:_) <- parseCSSList inner t = Just self { image = reverse val } where - inner [Ident "none"] = Just "" - inner [Ident "initial"] = Just "" - inner [Url ret] = Just ret - inner [Function "url", String ret, RightParen] = Just ret + inner [Ident "none"] = Just None + inner [Ident "initial"] = Just None + inner [Url ret] = Just $ Img ret + inner [Function "url", String ret, RightParen] = Just $ Img ret + inner (Function "linear-gradient":toks) + | Just [s, e] <- colourStops (Comma:toks) = Just $ Linear s e + | otherwise = traceShow toks Nothing inner _ = Nothing + colourStops [RightParen] = Just [] + colourStops (Comma:toks) + | Just (toks', c) <- parseColour (pallet self) toks, + Just ret <- colourStops toks' = Just $ c:ret + colourStops _ = Nothing longhand _ self "background-size" t | val@(_:_) <- parseCSSList inner t = Just self { bgSize = reverse val } where -- TODO: Add shorthand support, after background-position. @@ -88,7 +102,7 @@ instance PropertyParser (Backgrounds Text) where parseCSSList cb toks | all isJust ret = catMaybes ret | otherwise = [] - where ret = map cb $ splitList Comma toks + where ret = map cb $ concat $ splitList [Comma] $ parseOperands toks f :: NumericValue -> Float f (NVInteger x) = fromInteger x -- 2.30.2