From 745d80f2f3e02c13ca96361434be2f42c86f677e Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 19 Jun 2023 13:35:07 +1200 Subject: [PATCH] Add simple radial gradient support, fix lint warnings. --- Mondrian.cabal | 8 ++ app/Main.hs | 12 +-- lib/Graphics/Rendering/Rect.hs | 1 + lib/Graphics/Rendering/Rect/Backgrounds.hs | 46 +++++++++++- lib/Graphics/Rendering/Rect/CSS.hs | 2 + .../Rendering/Rect/CSS/Backgrounds.hs | 75 ++++++++++--------- lib/Graphics/Rendering/Rect/CSS/Colour.hs | 36 ++++----- lib/Graphics/Rendering/Rect/Image.hs | 8 +- lib/Graphics/Rendering/Rect/Types.hs | 18 +++-- 9 files changed, 137 insertions(+), 69 deletions(-) diff --git a/Mondrian.cabal b/Mondrian.cabal index 6a07d2c..dd0c8fc 100644 --- a/Mondrian.cabal +++ b/Mondrian.cabal @@ -33,6 +33,8 @@ library hs-source-dirs: lib default-language: Haskell2010 + ghc-options: -Wall + executable Mondrian main-is: Main.hs -- other-modules: @@ -42,15 +44,21 @@ executable Mondrian hs-source-dirs: app default-language: Haskell2010 + ghc-options: -Wall + executable Convert main-is: Convert.hs build-depends: base >= 4.13 && <4.14, JuicyPixels hs-source-dirs: app default-language: Haskell2010 + ghc-options: -Wall + test-suite Mondrian-test default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: MyLibTest.hs build-depends: base >=4.13 && <4.14 + + ghc-options: -Wall diff --git a/app/Main.hs b/app/Main.hs index 103e133..d3ce6a3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,21 +10,21 @@ import Data.CSS.Syntax.Tokens (tokenize, serialize, Token(Whitespace)) import SDL hiding (trace) import Graphics.GL.Core32 import System.Environment (getArgs) -import Linear.Projection (ortho) import Data.Function (fix) import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO (..)) -import Codec.Picture (DynamicImage(..), Image(..), PixelRGBA8(..), +import Codec.Picture (DynamicImage(..), PixelRGBA8(..), readImage, generateImage) import Debug.Trace (trace) -- To warn about invalid args +parseStyle :: PropertyParser p => String -> p parseStyle syn | (ret, []) <- parseProperties' toks = apply ret - | (ret, tail) <- parseProperties' toks = - trace ("Extraneous chars: " ++ unpack (serialize tail)) $ apply ret + | (ret, rest) <- parseProperties' toks = + trace ("Extraneous chars: " ++ unpack (serialize rest)) $ apply ret where toks = tokenize $ pack syn apply ((key, val):props) @@ -36,6 +36,7 @@ parseStyle syn val' = filter (/= Whitespace) val apply [] = temp +orthoProjection :: (Fractional a1, Integral a2) => V2 a2 -> M44 a1 orthoProjection (V2 ww wh) = let (hw,hh) = (fromIntegral ww, fromIntegral wh) in ortho 0 hw hh 0 0 1 @@ -79,10 +80,11 @@ main = do liftIO $ glSwapWindow w unless (QuitEvent `elem` events) loop -loadImage "" = return $ ImageRGBA8 $ generateImage transparent 1 1 +loadImage :: Text -> IO DynamicImage loadImage path = do ret <- readImage $ unpack path return $ case ret of Right x -> x Left _ -> ImageRGBA8 $ generateImage transparent 1 1 +transparent :: p1 -> p2 -> PixelRGBA8 transparent _ _ = PixelRGBA8 0 0 0 0 diff --git a/lib/Graphics/Rendering/Rect.hs b/lib/Graphics/Rendering/Rect.hs index ba164fe..5c2ce30 100644 --- a/lib/Graphics/Rendering/Rect.hs +++ b/lib/Graphics/Rendering/Rect.hs @@ -36,6 +36,7 @@ styleResolveImages atlas self = atlasLookup' None = None atlasLookup' (Img path) = Img $ atlasLookup path atlas atlasLookup' (Linear a b) = Linear a b + atlasLookup' (Radial a) = Radial a atlasFromStyles :: MonadIO m => (Text -> IO DynamicImage) -> [RectStyle Text] -> m Atlas diff --git a/lib/Graphics/Rendering/Rect/Backgrounds.hs b/lib/Graphics/Rendering/Rect/Backgrounds.hs index f4a12ac..b6655e0 100644 --- a/lib/Graphics/Rendering/Rect/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/Backgrounds.hs @@ -11,6 +11,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Data.Maybe (fromMaybe, listToMaybe) import Control.Monad (forM) +baseFragmentShader :: B8.ByteString baseFragmentShader = B8.pack $ unlines [ "#version 330 core", "out vec4 fcolour;", @@ -18,6 +19,7 @@ baseFragmentShader = B8.pack $ unlines [ "void main() { fcolour = colour; }" ] +imageFragmentShader :: B8.ByteString imageFragmentShader = B8.pack $ unlines [ "#version 330 core", "in vec2 coord;", @@ -27,6 +29,7 @@ imageFragmentShader = B8.pack $ unlines [ "void main() { fcolour = texture(image, coord/size); }" ] +linearFragmentShader :: B8.ByteString linearFragmentShader = B8.pack $ unlines [ "#version 330 core", "in vec2 coord;", @@ -36,6 +39,7 @@ linearFragmentShader = B8.pack $ unlines [ "uniform float stopPoints[10];", "uniform int nStops;", "uniform float angle;", + "", "void main() {", " vec2 pos = coord/size;", -- Range 0..1 " pos -= 0.5; pos *= 2;", -- Range -1..1 @@ -58,6 +62,36 @@ linearFragmentShader = B8.pack $ unlines [ "}" ] +radialFragmentShader :: B8.ByteString +radialFragmentShader = B8.pack $ unlines [ + "#version 330 core", + "in vec2 coord;", + "out vec4 fcolour;", + "uniform vec2 size;", + "uniform vec4 stops[10];", + "uniform float stopPoints[10];", + "uniform int nStops;", + "", + "void main() {", + " vec2 pos = coord/size;", + " float a = distance(pos, vec2(0.5)) * 2;", + "", + " int i = 0;", + -- Workaround for buggy GPU drivers on test machine. + " if (8 < nStops - 1 && a > stopPoints[8]) i = 8;", + " else if (7 < nStops - 1 && a > stopPoints[7]) i = 7;", + " else if (6 < nStops - 1 && a > stopPoints[6]) i = 6;", + " else if (5 < nStops - 1 && a > stopPoints[5]) i = 5;", + " else if (4 < nStops - 1 && a > stopPoints[4]) i = 4;", + " else if (3 < nStops - 1 && a > stopPoints[3]) i = 3;", + " else if (2 < nStops - 1 && a > stopPoints[2]) i = 2;", + " else if (1 < nStops - 1 && a > stopPoints[1]) i = 1;", + "", + " a = smoothstep(stopPoints[i], stopPoints[i+1], a);", + " fcolour = mix(stops[i], stops[i+1], a);", + "}" + ] + renderBackgrounds :: (MonadIO m, MonadIO n) => n (Backgrounds Texture -> Rects -> M44 Float -> m ()) renderBackgrounds = do @@ -65,11 +99,13 @@ renderBackgrounds = do layer <- renderRectWith imageFragmentShader ["size"] linear <- renderRectWith linearFragmentShader ["size", "angle", "stops", "stopPoints", "nStops"] + radial <- renderRectWith radialFragmentShader + ["size", "nStops", "stops", "stopPoints"] 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 $ \((pat0, clip0), size0) -> case pat0 of + _ <- forM layers $ \((pat0, clip0), size0) -> case pat0 of None -> return () Img img0 -> layer [img0] [ u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0 @@ -78,11 +114,18 @@ renderBackgrounds = do u $ v2 $ size', u angle, cs 10 $ map fst stops, us $ ls2fs size' $ map snd $ take 10 stops, u $ length stops ] clip0 a b + Radial stops -> let size'@(_,h) = size $ clip0 a in radial [] [ + u $ v2 $ size', u $ length stops, cs 10 $ map fst stops, + us $ ls2fs (0,h/2) $ map snd $ take 10 stops + ] clip0 a b return () +headDef :: c -> [c] -> c headDef def = fromMaybe def . listToMaybe +v2 :: (a, a) -> V2 a v2 = uncurry V2 -- Easier to express this algorithm on CPU-side... +ls2fs :: (Float, Float) -> [Length] -> [Float] ls2fs (_,h) ls = resolveAutos 0 $ inner True 0 ls where -- https://drafts.csswg.org/css-images/#color-stop-fixup Step 1. @@ -94,6 +137,7 @@ ls2fs (_,h) ls = resolveAutos 0 $ inner True 0 ls inner _ _ (Scale x:ls') = Scale x:inner False x ls' inner _ _ (Absolute x:ls') = Absolute x:inner False (x/h) ls' inner _ prev (Auto:ls') = Auto:inner False prev ls' + inner _ _ [] = [] -- Step 3 resolveAutos :: Float -> [Length] -> [Float] resolveAutos _ (Scale x:ls') = x:resolveAutos x ls' diff --git a/lib/Graphics/Rendering/Rect/CSS.hs b/lib/Graphics/Rendering/Rect/CSS.hs index 5fc0d2f..80b5635 100644 --- a/lib/Graphics/Rendering/Rect/CSS.hs +++ b/lib/Graphics/Rendering/Rect/CSS.hs @@ -5,11 +5,13 @@ import Stylist (PropertyParser(..)) import Graphics.Rendering.Rect.CSS.Colour (ColourPallet(foreground)) import Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..)) import Data.Text (Text) +import Data.Colour(AlphaColour) data RectStyle img = RectStyle { colours :: ColourPallet, backgrounds :: Backgrounds img } deriving (Eq, Show, Read) +colour :: RectStyle img -> AlphaColour Float colour = foreground . colours instance PropertyParser (RectStyle Text) where diff --git a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs index a460f14..203cc12 100644 --- a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs @@ -12,8 +12,6 @@ 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 :: C, @@ -24,7 +22,8 @@ data Backgrounds img = Backgrounds { type C = AlphaColour Float -data Pattern img = None | Img img | Linear Float [(C, Length)] deriving (Eq, Show, Read) +data Pattern img = None | Img img | Linear Float [(C, Length)] + | Radial [(C, Length)] 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) @@ -48,23 +47,23 @@ instance PropertyParser (Backgrounds Text) where inner [Ident "border-box"] = Just borderBox inner [Ident "initial"] = Just borderBox -- To aid shorthand implementation. inner _ = Nothing - longhand _ self "background-image" t | val@(_:_) <- parseCSSList inner t = - Just self { image = reverse val } + longhand _ self@Backgrounds { pallet = pp } "background-image" t + | val@(_:_) <- parseCSSList inner t = Just self { image = reverse val } where 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 cs@(_:_:_) <- colourStops (Comma:toks) = Just $ Linear pi cs + | Just cs@(_:_:_)<-colourStops pp (Comma:toks) = Just $ Linear pi cs inner (Function "linear-gradient":Dimension _ x unit:toks) | Just s <- lookup unit [("deg", pi/180), ("grad", pi/200), ("rad", 1), ("turn", 2*pi)], - Just cs@(_:_:_) <- colourStops toks = Just $ Linear (f x*s) cs + Just cs@(_:_:_) <- colourStops pp toks = Just $ Linear (f x*s) cs inner (Function "linear-gradient":Ident "to":Ident a:Ident b:toks) - | Just angle <- corner a b, Just stops@(_:_:_) <- colourStops toks = + | Just angle<-corner a b, Just stops@(_:_:_)<-colourStops pp toks = Just $ Linear angle stops - | Just angle <- corner b a, Just stops@(_:_:_) <- colourStops toks = + | Just angle<-corner b a, Just stops@(_:_:_)<-colourStops pp toks = Just $ Linear angle stops where corner "top" "right" = Just $ 0.25*pi @@ -75,37 +74,24 @@ instance PropertyParser (Backgrounds Text) where inner (Function "linear-gradient":Ident "to":Ident side:toks) | Just angle <- lookup side [ ("top", 0), ("right", pi/2), ("bottom", pi), ("left", pi*1.5)], - Just cs@(_:_:_) <- colourStops toks = Just $ Linear angle cs + Just cs@(_:_:_) <- colourStops pp toks = Just $ Linear angle cs + inner (Function "radial-gradient":toks) + | Just cs@(_:_:_) <- colourStops pp (Comma:toks) = Just $ Radial cs inner _ = Nothing - colourStops [RightParen] = Just [] - colourStops (Comma:toks) - | Just (Percentage _ x:toks', c) <- parseColour (pallet self) toks, - Just ret <- colourStops toks' = Just $ (c, Scale $ p x):ret - | Just (Dimension _ x "px":toks', c) <- parseColour (pallet self) toks, - Just ret <- colourStops toks' = Just $ (c, Absolute $ f x):ret - | Just (toks', c) <- parseColour (pallet self) toks, - Just ret <- colourStops toks' = Just $ (c, Auto):ret - colourStops (Comma:Percentage _ x:toks) - | Just (toks', c) <- parseColour (pallet self) toks, - Just ret <- colourStops toks' = Just $ (c, Scale $ p x):ret - colourStops (Comma:Dimension _ x "px":toks) - | Just (toks', c) <- parseColour (pallet self) toks, - Just ret <- colourStops toks' = Just $ (c, Absolute $ f x):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. - inner [x, y] | Just a <- length x, Just b <- length y = Just $ Size a b + inner [x, y] | Just a <- l x, Just b <- l 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 + l (Ident "auto") = Just Auto + l (Dimension _ x "px") = Just $ Absolute $ f x + l (Percentage _ x) = Just $ Scale $ p x + l _ = Nothing longhand _ _ _ _ = Nothing -- The multi-layered shorthand is one source of parsing complexity. @@ -128,6 +114,25 @@ instance PropertyParser (Backgrounds Text) where shorthand self key val | Just _ <- longhand self self key val = [(key, val)] | otherwise = [] +colourStops :: ColourPallet + -> [Token] -> Maybe [(AlphaColour Float, Length)] +colourStops _ [RightParen] = Just [] +colourStops cs (Comma:toks) + | Just (Percentage _ x:toks', c) <- parseColour cs toks, + Just ret <- colourStops cs toks' = Just $ (c, Scale $ p x):ret + | Just (Dimension _ x "px":toks', c) <- parseColour cs toks, + Just ret <- colourStops cs toks' = Just $ (c, Absolute $ f x):ret + | Just (toks', c) <- parseColour cs toks, + Just ret <- colourStops cs toks' = Just $ (c, Auto):ret +colourStops cs (Comma:Percentage _ x:toks) + | Just (toks', c) <- parseColour cs toks, + Just ret <- colourStops cs toks' = Just $ (c, Scale $ p x):ret +colourStops cs (Comma:Dimension _ x "px":toks) + | Just (toks', c) <- parseColour cs toks, + Just ret <- colourStops cs toks' = Just $ (c, Absolute $ f x):ret +colourStops _ _ = Nothing + +parseCSSList :: ([Token] -> Maybe a) -> [Token] -> [a] parseCSSList cb toks | all isJust ret = catMaybes ret | otherwise = [] where ret = map cb $ concat $ splitList [Comma] $ parseOperands toks @@ -152,10 +157,10 @@ splitList sep list = h:splitList sep t -- | Split is like break, but the matching element is dropped. split :: (a -> Bool) -> [a] -> ([a], [a]) -split f s = (left,right) +split filt s = (x,y) where - (left,right')=break f s - right = if null right' then [] else tail right' + (x,y')=break filt s + y = if null y' then [] else tail y' ------ --- Dynamically-computed properties @@ -167,7 +172,7 @@ resolveSize (owidth, oheight) (width, height) Contain | width > owidth = (width*sw, height*sw) | height > oheight = (width*sh, height*sh) | height > width = (width*sw, height*sw) - | width > height = (width*sh, height*sh) + | otherwise = (width*sh, height*sh) where sh = oheight/height sw = owidth/width @@ -179,7 +184,7 @@ resolveSize (owidth, oheight) (width, height) Cover | 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) + | otherwise = (width*sh, height*sh) where sh = oheight/height sw = owidth/width diff --git a/lib/Graphics/Rendering/Rect/CSS/Colour.hs b/lib/Graphics/Rendering/Rect/CSS/Colour.hs index a54334c..d590aef 100644 --- a/lib/Graphics/Rendering/Rect/CSS/Colour.hs +++ b/lib/Graphics/Rendering/Rect/CSS/Colour.hs @@ -13,14 +13,14 @@ import Data.Scientific (toRealFloat) import qualified Data.Text as Txt import Data.Word (Word8) -import Data.Bits (toIntegralSized) -import Data.Char (isHexDigit, toLower, isUpper) +import Data.Char (isHexDigit, toLower) import Data.List (elemIndex) import Debug.Trace (trace) -- For warning messages. import Stylist (PropertyParser(..)) -hsl' h s l = uncurryRGB rgb $ hsl h s l +hsl' :: RealFrac a => a -> a -> a -> Colour a +hsl' hue s l = uncurryRGB rgb $ hsl hue s l data ColourPallet = ColourPallet { foreground :: AlphaColour Float, @@ -238,21 +238,21 @@ parseColour self@ColourPallet { foreground = colour} (Ident x:toks) | Txt.toLower x `elem` ["currentcolor", "initial"] = Just (toks, colour) | Txt.toLower x == "accentcolor" = Just (toks, accent self) -parseColour _ (Function "hsl":h':Comma: - Percentage _ s:Comma:Percentage _ l:RightParen:toks) | Just h <- d h' = - Just (toks, opaque $ hsl' h (pc s) (pc l)) -parseColour _ (Function "hsl":h':Comma:Percentage _ s:Comma:Percentage _ l: - Comma:a':RightParen:toks) | Just h <- d h', Just a <- f' a' = - Just (toks, hsl' h (pc s) (pc l) `withOpacity` a) -parseColour _ (Function "hsla":h':Comma:Percentage _ s:Comma:Percentage _ l: - Comma:a':RightParen:toks) | Just h <- d h', Just a <- f' a' = - Just (toks, hsl' h (pc s) (pc l) `withOpacity` a) -parseColour _ (Function "hsl":h':s':l':RightParen:toks) - | Just h <- d' h', Just s <- pc' s', Just l <- pc' l' = - Just (toks, opaque $ hsl' h s l) -parseColour _ (Function "hsl":h':s':l':Delim '/':a':RightParen:toks) - | Just h <- d' h', Just s <- pc' s', Just l <- pc' l', Just a <- f' a' = - Just (toks, hsl' h s l `withOpacity` a) +parseColour _ (Function "hsl":hue':Comma:Percentage _ s:Comma:Percentage _ l: + RightParen:toks) + | Just hue <- d hue' = Just (toks, opaque $ hsl' hue (pc s) (pc l)) +parseColour _ (Function "hsl":hue':Comma:Percentage _ s:Comma:Percentage _ l: + Comma:a':RightParen:toks) | Just hue <- d hue', Just a <- f' a' = + Just (toks, hsl' hue (pc s) (pc l) `withOpacity` a) +parseColour _ (Function "hsla":hue':Comma:Percentage _ s:Comma:Percentage _ l: + Comma:a':RightParen:toks) | Just hue <- d hue', Just a <- f' a' = + Just (toks, hsl' hue (pc s) (pc l) `withOpacity` a) +parseColour _ (Function "hsl":hue':s':l':RightParen:toks) + | Just hue <- d' hue', Just s <- pc' s', Just l <- pc' l' = + Just (toks, opaque $ hsl' hue s l) +parseColour _ (Function "hsl":hue':s':l':Delim '/':a':RightParen:toks) + | Just hue <- d' hue', Just s <- pc' s', Just l <- pc' l', Just a <- f' a' = + Just (toks, hsl' hue s l `withOpacity` a) parseColour _ _ = Nothing diff --git a/lib/Graphics/Rendering/Rect/Image.hs b/lib/Graphics/Rendering/Rect/Image.hs index 0782a7a..65a2071 100644 --- a/lib/Graphics/Rendering/Rect/Image.hs +++ b/lib/Graphics/Rendering/Rect/Image.hs @@ -4,15 +4,13 @@ module Graphics.Rendering.Rect.Image( import qualified Data.HashMap.Lazy as HM import Data.Text (Text) -import Codec.Picture (DynamicImage(..), Image(..), PixelRGBA8(..), PixelF, - pixelMap, generateImage) +import Codec.Picture (DynamicImage(..), Image(..), PixelF, pixelMap) import Codec.Picture.Types (promoteImage, dynamicMap, convertImage) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad (forM) import Data.Maybe (fromMaybe) -import Typograffiti.GL import Graphics.GL.Core32 import Graphics.GL.Types import Graphics.GL.Ext.EXT.Cmyka @@ -26,7 +24,7 @@ import Foreign.Marshal.Array (allocaArray, peekArray) data Atlas = Atlas { unAtlas :: HM.HashMap Text Texture } buildAtlas :: MonadIO m => (Text -> IO DynamicImage) -> [Text] -> m Atlas -buildAtlas cb [] = return $ Atlas HM.empty +buildAtlas _ [] = return $ Atlas HM.empty buildAtlas cb srcs = do -- TODO Merge textures into an actual atlas. let len = length srcs @@ -57,6 +55,7 @@ buildAtlas cb srcs = do return $ Atlas $ HM.fromList $ zip srcs textures' data Texture = Texture { unTexture :: GLuint, texSize :: (Float, Float) } +nilTexture :: Texture nilTexture = Texture 0 (0, 0) atlasLookup :: Text -> Atlas -> Texture atlasLookup key = fromMaybe nilTexture . HM.lookup key . unAtlas @@ -79,6 +78,7 @@ convertDyn (ImageYCbCr8 img) = ImageRGB8 $ convertImage img convertDyn (ImageCMYK8 img) = ImageRGB8 $ convertImage img convertDyn (ImageCMYK16 img) = ImageRGB16 $ convertImage img +glFormat :: DynamicImage -> (GLenum, GLenum) glFormat (ImageY8 _) = (GL_LUMINANCE, GL_UNSIGNED_BYTE) glFormat (ImageY16 _) = (GL_LUMINANCE, GL_UNSIGNED_SHORT) glFormat (ImageY32 _) = (GL_LUMINANCE, GL_UNSIGNED_INT) diff --git a/lib/Graphics/Rendering/Rect/Types.hs b/lib/Graphics/Rendering/Rect/Types.hs index 46c63cf..0c2f322 100644 --- a/lib/Graphics/Rendering/Rect/Types.hs +++ b/lib/Graphics/Rendering/Rect/Types.hs @@ -28,10 +28,12 @@ data Rect = Rect { left :: Float, top :: Float, right :: Float, bottom :: Float } deriving (Read, Show, Eq, Ord) +rect2geom :: Rect -> UV.Vector (V2 Float) 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 -> (Float, Float) size Rect {..} = (right - left, bottom - top) data Rects = Rects { @@ -40,6 +42,7 @@ data Rects = Rects { borderBox :: Rect, marginBox :: Rect } deriving (Read, Show, Eq, Ord) +rect :: Float -> Rect rect x = Rect x x x x type BoxSelector = Rects -> Rect @@ -51,6 +54,7 @@ instance Show BoxSelector where | a rects == rect 1 = "paddingBox" | a rects == rect 2 = "borderBox" | a rects == rect 3 = "marginBox" + | otherwise = "?" 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)] @@ -59,6 +63,7 @@ instance Read BoxSelector where readsPrec _ ('m':'a':'r':'g':'i':'n':'B':'o':'x':t) = [(marginBox, t)] readsPrec _ _ = [] +vertexShader :: ByteString vertexShader = B8.pack $ unlines [ "#version 330 core", "uniform mat4 transform;", @@ -106,15 +111,15 @@ renderRectWith fragmentShader uniformNames = do glEnable GL_BLEND glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA return $ \textures uniforms getter rects mat -> do - let rect = getter rects + let r = getter rects vao <- liftIO $ newBoundVAO pbuf <- newBuffer - bufferGeometry 0 pbuf $ rect2geom rect + bufferGeometry 0 pbuf $ rect2geom r 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 + liftIO $ updateUniform prog originID $ V2 (left r) (top r) + _ <- forM (zip uniformIDs uniforms) $ \(slot, cb) -> cb prog slot withBoundTextures (map unTexture textures) $ do glBindVertexArray vao @@ -131,5 +136,6 @@ liftGL n = do Left err -> liftIO $ die err Right x -> return x -mflip (V4 (V4 a b c d) (V4 e f g h) (V4 i j k l) (V4 m n o p)) = - V4 (V4 a e i m) (V4 b f j n) (V4 c g k o) (V4 d h l p) +mflip :: V4 (V4 a) -> V4 (V4 a) +mflip (V4 (V4 a b cc d) (V4 e f g h) (V4 i j k l) (V4 m n o p)) = + V4 (V4 a e i m) (V4 b f j n) (V4 cc g k o) (V4 d h l p) -- 2.30.2