From 7564554b3527f7e220c09c24cc9f8035d3f196b0 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sat, 8 Jul 2023 16:28:09 +1200
Subject: [PATCH] Commit border renderer, make them trapazoidal.

---
 app/Main.hs                           |  2 +-
 lib/Graphics/Rendering/Rect/Border.hs | 78 +++++++++++++++++++++++++++
 2 files changed, 79 insertions(+), 1 deletion(-)
 create mode 100644 lib/Graphics/Rendering/Rect/Border.hs

diff --git a/app/Main.hs b/app/Main.hs
index d3ce6a3..39da449 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -73,7 +73,7 @@ main = do
         liftIO $ glViewport 0 0 (fromIntegral dw) (fromIntegral dh)
 
         let rect = Rect 0 0 (fromIntegral dw) (fromIntegral dh)
-            rects = Rects (shrink1 rect 15) (shrink1 rect 10) (shrink1 rect 5) rect
+            rects = Rects (shrink1 rect 150) (shrink1 rect 100) (shrink1 rect 50) rect
 
         render style' rects $ orthoProjection sz
 
diff --git a/lib/Graphics/Rendering/Rect/Border.hs b/lib/Graphics/Rendering/Rect/Border.hs
new file mode 100644
index 0000000..53b567f
--- /dev/null
+++ b/lib/Graphics/Rendering/Rect/Border.hs
@@ -0,0 +1,78 @@
+module Graphics.Rendering.Rect.Border(renderBorder, Border(..), BorderStyle(..),
+        topColour, rightColour, bottomColour, leftColour) where
+
+import Graphics.Rendering.Rect.CSS.Border
+import Graphics.Rendering.Rect.Types
+import qualified Data.ByteString.Char8 as B8
+import Control.Monad.IO.Class (MonadIO(..))
+import Linear (M44)
+
+borderFragmentShader :: B8.ByteString
+borderFragmentShader = B8.pack $ unlines [
+    "#version 330 core",
+    "uniform float widths[4];",
+    "uniform vec4 colours[4];",
+    "uniform int styles[5];",
+    "uniform vec2 boxSize;",
+    "in vec2 coord;",
+    "out vec4 fcolour;",
+    "",
+    "const int TOP = 0;",
+    "const int RIGHT = 1;",
+    "const int BOTTOM = 2;",
+    "const int LEFT = 3;",
+    "const int NONE = 4;",
+    "",
+    "const int NOBORDER = 0;",
+    "const int SOLID = 1;",
+    "const int DASHED = 2;",
+    "const int DOTTED = 3;",
+    "const int DOUBLE = 4;",
+    "const int GROOVE = 5;",
+    "const int RIDGE = 6;",
+    "const int INSET = 7;",
+    "const int OUTSET = 8;",
+    "",
+    "bool inTrap(float x, float y, float width, int height, int left, int right) {",
+    "   float a = y/widths[height];",
+    "   return a*widths[left] <= x && x <= width - widths[right]*a;",
+    "}",
+    "",
+    "void main() {",
+    "   int side = NONE;",
+    "   if (coord.y < abs(widths[TOP]) &&",
+    "           inTrap(coord.x, coord.y, boxSize.x, TOP, LEFT, RIGHT))",
+    "       side = TOP;",
+    "   else if (coord.x < abs(widths[LEFT]) &&",
+    "           inTrap(coord.y, coord.x, boxSize.y, LEFT, TOP, BOTTOM))",
+    "       side = LEFT;",
+    "   else if (boxSize.x - coord.x < abs(widths[RIGHT]) &&",
+    "           inTrap(coord.y, boxSize.x-coord.x, boxSize.y, RIGHT,TOP,BOTTOM))",
+    "       side = RIGHT;",
+    "   else if (boxSize.y - coord.y < abs(widths[BOTTOM])) side = BOTTOM;",
+    "",
+    "   vec2 pos = coord;",
+    "   if (side == RIGHT || side == BOTTOM) pos = boxSize - coord;",
+    "   if (side == TOP || side == BOTTOM) pos = pos.xy;",
+    "",
+    "   if (styles[side] == SOLID) fcolour = colours[side];",
+    "   else fcolour = vec4(0.0);",
+    "}"
+  ]
+
+renderBorder :: (MonadIO m, MonadIO n) => n (Border -> Rects -> M44 Float -> m ())
+renderBorder = do
+    inner <- renderRectWith borderFragmentShader [
+            "widths[0]", "widths[1]", "widths[2]", "widths[3]",
+            "colours[0]", "colours[1]", "colours[2]", "colours[3]",
+            "styles[0]", "styles[1]", "styles[2]", "styles[3]", "styles[4]"]
+    return $ \self rects -> let (b, p) = (borderBox rects, paddingBox rects)
+        in inner [] [
+            u $ top p - top b, u $ right b - right p,
+            u $ bottom b - bottom p, u $ left p - left b,
+            c $ topColour self, c $ rightColour self,
+            c $ bottomColour self, c $ leftColour self,
+            u $ fromEnum $ topStyle self, u $ fromEnum $ rightStyle self,
+            u $ fromEnum $ bottomStyle self, u $ fromEnum $ leftStyle self,
+            u (0 :: Int)
+        ] borderBox borderBox rects
-- 
2.30.2