From 94547420f10f0af679958e805b2abbf68d0e6ee2 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 9 Jun 2023 16:58:17 +1200 Subject: [PATCH] Build texturing infrastructure & implement background-color! --- Mondrian.cabal | 2 +- app/Main.hs | 20 ++++++++-- lib/Graphics/Rendering/Rect.hs | 20 +++++++++- lib/Graphics/Rendering/Rect/Backgrounds.hs | 21 +++++++++- lib/Graphics/Rendering/Rect/CSS.hs | 11 +++--- .../Rendering/Rect/CSS/Backgrounds.hs | 16 ++++---- lib/Graphics/Rendering/Rect/Image.hs | 11 ++++-- lib/Graphics/Rendering/Rect/Types.hs | 39 ++++++++++++++++--- 8 files changed, 110 insertions(+), 30 deletions(-) diff --git a/Mondrian.cabal b/Mondrian.cabal index 6da41a2..561f537 100644 --- a/Mondrian.cabal +++ b/Mondrian.cabal @@ -38,7 +38,7 @@ executable Mondrian -- other-modules: -- other-extensions: build-depends: base >=4.13 && <4.14, Mondrian, sdl2 >= 2.5.4, gl, linear, - stylist-traits, text, css-syntax + stylist-traits, text, css-syntax, JuicyPixels hs-source-dirs: app default-language: Haskell2010 diff --git a/app/Main.hs b/app/Main.hs index fd9b739..c421455 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,7 +4,7 @@ module Main where import Graphics.Rendering.Rect import Stylist.Parse (parseProperties') import Stylist (PropertyParser(..)) -import Data.Text (pack, unpack) +import Data.Text (Text, pack, unpack) import Data.CSS.Syntax.Tokens (tokenize, serialize) import SDL hiding (trace) @@ -16,6 +16,9 @@ import Data.Function (fix) import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO (..)) +import Codec.Picture (DynamicImage(..), Image(..), PixelRGBA8(..), + readImage, generateImage) + import Debug.Trace (trace) -- To warn about invalid args parseStyle syn @@ -39,7 +42,7 @@ main :: IO () main = do SDL.initializeAll args <- getArgs - let style :: RectStyle + let style :: RectStyle Text style = case args of [] -> trace "Using blank styles, should see blank screen!" temp [arg] -> parseStyle arg @@ -54,6 +57,9 @@ main = do w <- createWindow "Mondrian" wcfg _ <- glCreateContext w + atlas <- atlasFromStyles loadImage [style] + let style' = styleResolveImages atlas style + render <- renderRects fix $ \loop -> do events <- fmap eventPayload <$> pollEvents @@ -66,7 +72,15 @@ main = do let rect = Rect 0 0 (fromIntegral dw) (fromIntegral dh) rects = Rects (shrink1 rect 15) (shrink1 rect 10) (shrink1 rect 5) rect - render style rects $ orthoProjection sz + render style' rects $ orthoProjection sz liftIO $ glSwapWindow w unless (QuitEvent `elem` events) loop + +loadImage "" = return $ ImageRGBA8 $ generateImage transparent 1 1 +loadImage path = do + ret <- readImage $ unpack path + return $ case ret of + Right x -> x + Left _ -> ImageRGBA8 $ generateImage transparent 1 1 +transparent _ _ = PixelRGBA8 0 0 0 0 diff --git a/lib/Graphics/Rendering/Rect.hs b/lib/Graphics/Rendering/Rect.hs index e8be21f..dd93550 100644 --- a/lib/Graphics/Rendering/Rect.hs +++ b/lib/Graphics/Rendering/Rect.hs @@ -1,13 +1,19 @@ module Graphics.Rendering.Rect(Rect(..), Rects(..), shrink, shrink1, renderRects, - RectStyle(..), colour, Backgrounds(..)) where + RectStyle(..), colour, Backgrounds(..), + Atlas, buildAtlas, atlasFromStyles, Texture, styleResolveImages) where import Graphics.Rendering.Rect.CSS import Graphics.Rendering.Rect.Backgrounds import Graphics.Rendering.Rect.Types +import Graphics.Rendering.Rect.Image import Linear (M44) import Control.Monad.IO.Class (MonadIO) +import Codec.Picture (DynamicImage) +import Data.Text (Text) +import Data.List (nub) + shrink :: Rect -> Float -> Float -> Float -> Float -> Rect shrink self dLeft dTop dRight dBottom = Rect (left self + dLeft) (top self + dTop) @@ -16,8 +22,18 @@ shrink1 :: Rect -> Float -> Rect shrink1 self d = shrink self d d d d renderRects :: (MonadIO m, MonadIO n) => - n (RectStyle -> Rects -> M44 Float -> m ()) + n (RectStyle Texture -> Rects -> M44 Float -> m ()) renderRects = do bg <- renderBackgrounds return $ \style rects mat -> do bg (backgrounds style) rects mat + +styleResolveImages :: Atlas -> RectStyle Text -> RectStyle Texture +styleResolveImages atlas self = + let textures = map (flip atlasLookup atlas) $ image $ backgrounds self + in self { backgrounds = (backgrounds self) { image = textures } } + +atlasFromStyles :: MonadIO m => + (Text -> IO DynamicImage) -> [RectStyle Text] -> m Atlas +atlasFromStyles cb styles = + buildAtlas cb $ nub $ concat $ map (image . backgrounds) styles diff --git a/lib/Graphics/Rendering/Rect/Backgrounds.hs b/lib/Graphics/Rendering/Rect/Backgrounds.hs index 9e7a1f7..9a29731 100644 --- a/lib/Graphics/Rendering/Rect/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/Backgrounds.hs @@ -2,10 +2,13 @@ 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 qualified Data.ByteString.Char8 as B8 import Linear (M44) + import Control.Monad.IO.Class (MonadIO(..)) import Data.Maybe (fromMaybe, listToMaybe) +import Control.Monad (forM) baseFragmentShader = B8.pack $ unlines [ "#version 330 core", @@ -14,10 +17,24 @@ baseFragmentShader = B8.pack $ unlines [ "void main() { fcolour = colour; }" ] +imageFragmentShader = B8.pack $ unlines [ + "#version 330 core", + "in vec2 coord;", + "out vec4 fcolour;", + "uniform sampler2D image;", + "void main() { fcolour = texture(image, coord); }" + ] + renderBackgrounds :: (MonadIO m, MonadIO n) => - n (Backgrounds -> Rects -> M44 Float -> m ()) + n (Backgrounds Texture -> Rects -> M44 Float -> m ()) renderBackgrounds = do base <- renderRectWith baseFragmentShader ["colour"] - return $ \slf -> base [] [c $ background slf] $ headDef borderBox $ clip slf + layer <- renderRectWith imageFragmentShader [] + 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 + return () headDef def = fromMaybe def . listToMaybe diff --git a/lib/Graphics/Rendering/Rect/CSS.hs b/lib/Graphics/Rendering/Rect/CSS.hs index ffee393..5fc0d2f 100644 --- a/lib/Graphics/Rendering/Rect/CSS.hs +++ b/lib/Graphics/Rendering/Rect/CSS.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-} module Graphics.Rendering.Rect.CSS(RectStyle(..), colour) where import Stylist (PropertyParser(..)) import Graphics.Rendering.Rect.CSS.Colour (ColourPallet(foreground)) import Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..)) +import Data.Text (Text) -data RectStyle = RectStyle { +data RectStyle img = RectStyle { colours :: ColourPallet, - backgrounds :: Backgrounds -} + backgrounds :: Backgrounds img +} deriving (Eq, Show, Read) colour = foreground . colours -instance PropertyParser RectStyle where +instance PropertyParser (RectStyle Text) where temp = RectStyle { colours = temp, backgrounds = temp } inherit RectStyle {..} = RectStyle { colours = inherit colours, backgrounds = temp diff --git a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs index a8bda23..f503c84 100644 --- a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..)) where import Stylist (PropertyParser(..), parseUnorderedShorthand) @@ -10,14 +10,14 @@ import Graphics.Rendering.Rect.CSS.Colour (ColourPallet, parseColour) import Data.Colour (AlphaColour, transparent) import Graphics.Rendering.Rect.Types (Rects(..), Rect(..)) -data Backgrounds = Backgrounds { +data Backgrounds img = Backgrounds { pallet :: ColourPallet, background :: AlphaColour Float, clip :: [Rects -> Rect], - image :: [Text] -} + image :: [img] +} deriving (Eq, Show, Read) -instance PropertyParser Backgrounds where +instance PropertyParser (Backgrounds Text) where temp = Backgrounds { pallet = temp, background = transparent, clip = [borderBox], image = [""] } @@ -27,7 +27,7 @@ instance PropertyParser Backgrounds where 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 = - Just self { clip = val } + Just self { clip = reverse val } where inner [Ident "content-box"] = Just contentBox inner [Ident "padding-box"] = Just paddingBox @@ -35,7 +35,7 @@ instance PropertyParser Backgrounds where inner [Ident "initial"] = Just borderBox -- To aid shorthand implementation. inner _ = Nothing longhand _ self "background-image" t | val@(_:_) <- parseCSSList inner t = - Just self { image = val } + Just self { image = reverse val } where inner [Ident "none"] = Just "" inner [Ident "initial"] = Just "" @@ -53,7 +53,7 @@ instance PropertyParser Backgrounds where | otherwise = [] -- Only allow background-color in bottommost layer. catProp _ ret@("background-color", _) = ret catProp bases (key, val) - | Just base <- key `lookup` bases = (key, val ++ Comma:base) + | Just base <- key `lookup` bases = (key, base ++ Comma:val) -- Shouldn't happen, `inner` expands all props at least to "initial"! | otherwise = (key, val) inner toks | ret@(_:_) <- parseUnorderedShorthand self [ diff --git a/lib/Graphics/Rendering/Rect/Image.hs b/lib/Graphics/Rendering/Rect/Image.hs index dd48ec0..c56bc56 100644 --- a/lib/Graphics/Rendering/Rect/Image.hs +++ b/lib/Graphics/Rendering/Rect/Image.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Graphics.Rendering.Rect.Image( Atlas, buildAtlas, Texture(..), atlasLookup) where @@ -17,13 +18,14 @@ import Graphics.GL.Ext.EXT.Cmyka import Graphics.GL.Ext.SGIX.Ycrcb import Graphics.GL.Compatibility32 -import Data.Vector.Storable (unsafeWith, unsafeCast) +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 } buildAtlas :: MonadIO m => (Text -> IO DynamicImage) -> [Text] -> m Atlas +buildAtlas cb [] = return $ Atlas HM.empty buildAtlas cb srcs = do -- TODO Merge textures into an actual atlas. let len = length srcs @@ -33,14 +35,15 @@ buildAtlas cb srcs = do imgs <- liftIO $ forM srcs cb forM (zip textures imgs) $ \(texture, dyn) -> do - let img = dynamicMap (unsafeCast . imageData) dyn + -- NOTE: `unsafe` crashes with a divide-by-zero given a `Vector ()` + let img = dynamicMap (unsafeCast . imageData) dyn :: Vector Word let (format, word) = glFormat dyn liftIO $ glBindTexture GL_TEXTURE_2D texture - liftIO $ unsafeWith img $ + liftIO $ unsafeWith img $ -- FIXME: Crashes glTexImage2D GL_TEXTURE_2D 0 GL_RGBA (toEnum $ dynamicMap imageWidth dyn) (toEnum $ dynamicMap imageHeight dyn) - 0 format word + 0 format word . castPtr return $ Atlas $ HM.fromList $ zip srcs textures diff --git a/lib/Graphics/Rendering/Rect/Types.hs b/lib/Graphics/Rendering/Rect/Types.hs index 5945fd8..a666026 100644 --- a/lib/Graphics/Rendering/Rect/Types.hs +++ b/lib/Graphics/Rendering/Rect/Types.hs @@ -1,5 +1,7 @@ {-# LANGUAGE RecordWildCards #-} -module Graphics.Rendering.Rect.Types(Rect(..), Rects(..), +-- So getters can implement typeclasses +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +module Graphics.Rendering.Rect.Types(Rect(..), Rects(..), BoxSelector, Uniform, u, c, renderRectWith, liftGL) where import Linear (M44, V2(..), V4(..)) @@ -19,7 +21,7 @@ import System.Exit (die) import Data.Colour (AlphaColour, over, alphaChannel) import Data.Colour.SRGB (RGB(..), toSRGB) import Data.Colour.Names (black) -import Graphics.Rendering.Rect.Image (Texture) +import Graphics.Rendering.Rect.Image (Texture(..)) data Rect = Rect { left :: Float, top :: Float, @@ -36,12 +38,35 @@ data Rects = Rects { borderBox :: Rect, marginBox :: Rect } deriving (Read, Show, Eq, Ord) +rect x = Rect x x x x + +type BoxSelector = Rects -> Rect +instance Eq BoxSelector where + a == b = a rects == b rects + where rects = Rects (rect 0) (rect 1) (rect 2) (rect 3) +instance Show BoxSelector where + show a | a rects == rect 0 = "contentBox" + | a rects == rect 1 = "paddingBox" + | a rects == rect 2 = "borderBox" + | a rects == rect 3 = "marginBox" + where rects = Rects (rect 0) (rect 1) (rect 2) (rect 3) +instance Read BoxSelector where + readsPrec _ ('c':'o':'n':'t':'e':'n':'t':'B':'o':'x':t) = [(contentBox, t)] + readsPrec _ ('p':'a':'d':'d':'i':'n':'g':'B':'o':'x':t) = [(paddingBox, t)] + readsPrec _ ('b':'o':'r':'d':'e':'r':'B':'o':'x':t) = [(borderBox, t)] + readsPrec _ ('m':'a':'r':'g':'i':'n':'B':'o':'x':t) = [(marginBox, t)] + readsPrec _ _ = [] vertexShader = B8.pack $ unlines [ "#version 330 core", "uniform mat4 transform;", + "uniform vec2 origin;", "in vec2 pos;", - "void main() { gl_Position = vec4(pos, 0, 1) * transform; }" + "out vec2 coord;", + "void main() {", + " gl_Position = vec4(pos, 0, 1) * transform;", + " coord = pos - origin;", + "}" ] type Uniform m = GLuint -> GLint -> m () @@ -63,17 +88,21 @@ renderRectWith fragmentShader uniformNames = do prog <- liftGL $ compileOGLProgram [("pos", 0)] [vs, fs] uniformIDs <- forM uniformNames $ getUniformLocation prog matID <- getUniformLocation prog "transform" + originID <- getUniformLocation prog "origin" glUseProgram prog glEnable GL_BLEND glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA - return $ \_ uniforms getter rects mat -> do + return $ \textures uniforms getter rects mat -> do + let rect = getter rects vao <- liftIO $ newBoundVAO pbuf <- newBuffer - bufferGeometry 0 pbuf $ rect2geom $ getter rects + bufferGeometry 0 pbuf $ rect2geom rect glUseProgram prog liftIO $ updateUniform prog matID $ mflip mat + liftIO $ updateUniform prog originID $ V2 (left rect) (top rect) forM (zip uniformIDs uniforms) $ \(slot, cb) -> cb prog slot + forM textures $ \(Texture texture) -> glBindTexture GL_TEXTURE_2D texture glBindVertexArray vao drawVAO prog vao GL_TRIANGLES 6 -- 2 triangles -- 2.30.2