4 files changed, 95 insertions(+), 17 deletions(-)

M lib/Graphics/Rendering/Rect/Backgrounds.hs
M lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs
M lib/Graphics/Rendering/Rect/Image.hs
M lib/Graphics/Rendering/Rect/Types.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

@@ 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

@@ 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

@@ 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,