From 7a7ce8ffa2aadc1747f9333e9096f6f55beb5f6f Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Mon, 5 Jun 2023 13:11:50 +1200
Subject: [PATCH] Implement background-colour rendering!

---
 Mondrian.cabal                                |  2 +-
 lib/Graphics/Rendering/Rect/Backgrounds.hs    | 17 ++--
 lib/Graphics/Rendering/Rect/CSS/Background.hs |  2 +-
 lib/Graphics/Rendering/Rect/CSS/Colour.hs     | 20 ++---
 lib/Graphics/Rendering/Rect/Types.hs          | 86 +++++++++++++++++--
 5 files changed, 99 insertions(+), 28 deletions(-)

diff --git a/Mondrian.cabal b/Mondrian.cabal
index 65c870d..8471c3e 100644
--- a/Mondrian.cabal
+++ b/Mondrian.cabal
@@ -27,7 +27,7 @@ library
   -- other-extensions:
   build-depends:       base >=4.13 && <4.14, stylist-traits >= 0.1.3.1 && < 1,
                        css-syntax, colour >= 2.3.6 && < 3, scientific, text,
-                       bytestring
+                       bytestring, typograffiti, linear, gl, vector, mtl
   hs-source-dirs:      lib
   default-language:    Haskell2010
 
diff --git a/lib/Graphics/Rendering/Rect/Backgrounds.hs b/lib/Graphics/Rendering/Rect/Backgrounds.hs
index c2cb07e..6408e8d 100644
--- a/lib/Graphics/Rendering/Rect/Backgrounds.hs
+++ b/lib/Graphics/Rendering/Rect/Backgrounds.hs
@@ -2,14 +2,10 @@ module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), renderBackgrounds) w
 
 import Graphics.Rendering.Rect.CSS.Background
 import Graphics.Rendering.Rect.Types
-import qualified Data.ByteString.Char8  as B8
+import qualified Data.ByteString.Char8 as B8
+import Linear (M44)
+import Control.Monad.IO.Class (MonadIO(..))
 
-baseVertexShader = B8.pack $ unlines [
-    "#version 330 core;",
-    "uniform mat4 transform;",
-    "in vec2 pos;",
-    "void main() { gl_Position = pos * transform; }"
-  ]
 baseFragmentShader = B8.pack $ unlines [
     "#version 330 core;",
     "out vec4 fcolour;",
@@ -17,5 +13,8 @@ baseFragmentShader = B8.pack $ unlines [
     "void main() { fcolour = colour; }"
   ]
 
-renderBackgrounds :: Backgrounds -> Rects -> IO ()
-renderBackgrounds _ _ = return ()
+renderBackgrounds :: (MonadIO m, MonadIO n) =>
+    n (Backgrounds -> Rects -> M44 Float -> m ())
+renderBackgrounds = do
+    base <- renderRectWith baseFragmentShader ["colour"]
+    return $ \self -> base [c $ background self] borderBox
diff --git a/lib/Graphics/Rendering/Rect/CSS/Background.hs b/lib/Graphics/Rendering/Rect/CSS/Background.hs
index cb65914..2016c6f 100644
--- a/lib/Graphics/Rendering/Rect/CSS/Background.hs
+++ b/lib/Graphics/Rendering/Rect/CSS/Background.hs
@@ -7,7 +7,7 @@ import Data.Colour (AlphaColour, transparent)
 
 data Backgrounds = Backgrounds {
     pallet :: ColourPallet,
-    background :: AlphaColour Double
+    background :: AlphaColour Float
 }
 
 instance PropertyParser Backgrounds where
diff --git a/lib/Graphics/Rendering/Rect/CSS/Colour.hs b/lib/Graphics/Rendering/Rect/CSS/Colour.hs
index b28c697..82bfeda 100644
--- a/lib/Graphics/Rendering/Rect/CSS/Colour.hs
+++ b/lib/Graphics/Rendering/Rect/CSS/Colour.hs
@@ -23,8 +23,8 @@ import Stylist (PropertyParser(..))
 hsl' h s l = uncurryRGB rgb $ hsl h s l
 
 data ColourPallet = ColourPallet {
-    foreground :: AlphaColour Double,
-    accent :: AlphaColour Double
+    foreground :: AlphaColour Float,
+    accent :: AlphaColour Float
 }
 
 instance PropertyParser ColourPallet where
@@ -43,7 +43,7 @@ instance PropertyParser ColourPallet where
     shorthand self key val | Just _ <- longhand self self key val = [(key, val)]
         | otherwise = []
 
-parseColour :: ColourPallet -> [Token] -> Maybe ([Token], AlphaColour Double)
+parseColour :: ColourPallet -> [Token] -> Maybe ([Token], AlphaColour Float)
 parseColour _ (Function "rgb":Percentage _ r:Comma:
         Percentage _ g:Comma:Percentage _ b:RightParen:toks) =
     Just (toks, opaque $ sRGB (pc r) (pc g) (pc b))
@@ -256,7 +256,7 @@ parseColour _ (Function "hsl":h':s':l':Delim '/':a':RightParen:toks)
 
 parseColour _ _ = Nothing
 
-sRGBhex :: Char -> Char -> Char -> Char -> Char -> Char -> Colour Double
+sRGBhex :: Char -> Char -> Char -> Char -> Char -> Char -> Colour Float
 sRGBhex r0 r1 g0 g1 b0 b1 = sRGB24 (h r0 r1) (h g0 g1) (h b0 b1)
 
 h :: Char -> Char -> Word8
@@ -266,20 +266,20 @@ h a b
     | otherwise = trace (a:b:" Invalid hexcode!") 0 -- Should already be checked!
   where
     digits = "0123456789abcdef"
-h' :: Char -> Char -> Double
+h' :: Char -> Char -> Float
 h' a b = fromIntegral (h a b) / 255
 
-pc :: NumericValue -> Double
+pc :: NumericValue -> Float
 pc x = f x / 100
-pc' :: Token -> Maybe Double
+pc' :: Token -> Maybe Float
 pc' (Ident "none") = Just 0
 pc' (Percentage _ x) = Just $ pc x
 pc' _ = Nothing
 
-f :: NumericValue -> Double
+f :: NumericValue -> Float
 f (NVInteger x) = fromIntegral x
 f (NVNumber x) = toRealFloat x
-f' :: Token -> Maybe Double
+f' :: Token -> Maybe Float
 f' (Ident "none") = Just 0
 f' (Percentage _ x) = Just $ pc x
 f' (Number _ x) = Just $ f x
@@ -293,7 +293,7 @@ w' (Number _ (NVInteger x)) | x >= 0 && x <= 255 = Just $ fromIntegral $ w x
 w' (Percentage _ x) = Just $ toEnum $ fromEnum (pc x * 255)
 w' _ = Nothing
 
-d', d :: Token -> Maybe Double
+d', d :: Token -> Maybe Float
 d (Dimension _ x "deg") = Just $ f x
 d (Dimension _ x "grad") = Just $ f x / 400 * 360
 d (Dimension _ x "rad") = Just $ f x / pi * 180
diff --git a/lib/Graphics/Rendering/Rect/Types.hs b/lib/Graphics/Rendering/Rect/Types.hs
index c44b856..7a0218b 100644
--- a/lib/Graphics/Rendering/Rect/Types.hs
+++ b/lib/Graphics/Rendering/Rect/Types.hs
@@ -1,13 +1,85 @@
-module Graphics.Rendering.Rect.Types where
+{-# LANGUAGE RecordWildCards #-}
+module Graphics.Rendering.Rect.Types(Rect(..), Rects(..),
+        Uniform, u, c, renderRectWith, liftGL) where
+
+import Linear (M44, V2(..), V4(..))
+import qualified Data.ByteString.Char8 as B8
+import Data.ByteString (ByteString)
+import qualified Data.Vector.Unboxed as UV
+
+import Typograffiti.GL
+import Graphics.GL.Core32
+import Graphics.GL.Types
+
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad (forM)
+import System.Exit (die)
+
+import Data.Colour (AlphaColour, over, alphaChannel)
+import Data.Colour.SRGB (RGB(..), toSRGB)
+import Data.Colour.Names (white)
 
 data Rect = Rect {
-    left :: Double, top :: Double,
-    right :: Double, bottom :: Double
+    left :: Float, top :: Float,
+    right :: Float, bottom :: Float
 } deriving (Read, Show, Eq, Ord)
+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)
 
 data Rects = Rects {
-    content :: Rect,
-    padding :: Rect,
-    border :: Rect,
-    margin :: Rect
+    contentBox :: Rect,
+    paddingBox :: Rect,
+    borderBox :: Rect,
+    marginBox :: Rect
 } deriving (Read, Show, Eq, Ord)
+
+vertexShader = B8.pack $ unlines [
+    "#version 330 core;",
+    "uniform mat4 transform;",
+    "in vec2 pos;",
+    "void main() { gl_Position = pos * transform; }"
+  ]
+
+type Uniform m = GLuint -> GLint -> m ()
+u :: (MonadIO m, UniformValue a) => a -> Uniform m
+u val prog slot = liftIO $ updateUniform prog slot val
+
+c :: MonadIO m => AlphaColour Float -> Uniform m
+c rgba = u $ V4 r g b a
+  where
+    a = alphaChannel rgba
+    -- Workaround for missing APIs in "colour" hackage.
+    RGB r g b = toSRGB $ over rgba white
+
+renderRectWith :: (MonadIO m, MonadIO n) => ByteString -> [String] ->
+        n ([Uniform m] -> (a -> Rect) -> a -> M44 Float -> m ())
+renderRectWith fragmentShader uniformNames = do
+    vs <- liftGL $ compileOGLShader vertexShader GL_VERTEX_SHADER
+    fs <- liftGL $ compileOGLShader fragmentShader GL_FRAGMENT_SHADER
+    prog <- liftGL $ compileOGLProgram [("pos", 0)] [vs, fs]
+    uniformIDs <- forM uniformNames $ getUniformLocation prog
+    matID <- getUniformLocation prog "transform"
+    glUseProgram prog
+    glEnable GL_BLEND
+    glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
+    return $ \uniforms getter rects mat -> do
+        vao <- liftIO $ newBoundVAO
+        pbuf <- newBuffer
+        bufferGeometry 0 pbuf $ rect2geom $ getter rects
+
+        glUseProgram prog
+        liftIO $ updateUniform prog matID mat
+        forM (zip uniformIDs uniforms) $ \(slot, cb) -> cb prog slot
+
+        glBindVertexArray vao
+        drawVAO prog vao GL_TRIANGLES 6 -- 2 triangles
+        glBindVertexArray 0
+
+liftGL :: MonadIO m => IO (Either String a) -> m a
+liftGL n = do
+    ret <- liftIO n
+    case ret of
+        Left err -> liftIO $ die err
+        Right x -> return x
-- 
2.30.2