8 files changed, 110 insertions(+), 30 deletions(-)

M Mondrian.cabal
M app/Main.hs
M lib/Graphics/Rendering/Rect.hs
M lib/Graphics/Rendering/Rect/Backgrounds.hs
M lib/Graphics/Rendering/Rect/CSS.hs
M lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs
M lib/Graphics/Rendering/Rect/Image.hs
M lib/Graphics/Rendering/Rect/Types.hs

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

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

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

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

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

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

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

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