Border.hs

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 == LEFT || side == RIGHT) pos = pos.yx;",
    "",
    "   int segment = int(floor(pos.x/widths[side]/2));",
    "   float width = widths[side];",
    "   vec2 dotCenter = vec2(segment*width*2 + width, width/2);",
    "   int stroke3 = int(floor(3*pos.y/widths[side]));",
    "   int stroke = int(floor(2*pos.y/widths[side]));",
    "   bool topleft = side == TOP || side == LEFT;",
    "   if (!topleft) stroke = abs(1 - stroke);",
    "   if (styles[side] == SOLID) fcolour = colours[side];",
    "   else if (styles[side] == DASHED)",
    "       fcolour = segment % 2 == 0 ? colours[side] : vec4(0);",
    "   else if (styles[side] == DOTTED)",
    "       fcolour = distance(pos, dotCenter) < widths[side]/2 ?",
    "               colours[side] : vec4(0);",
    "   else if (styles[side] == DOUBLE && stroke3 != 1) fcolour = colours[side];",
    "   else if (styles[side] == GROOVE)",
    "       fcolour = colours[side] + vec4(stroke == 0 ? -0.1 : +0.1);",
    "   else if (styles[side] == RIDGE)",
    "       fcolour = colours[side] + vec4(stroke == 0 ? +0.1 : -0.1);",
    "   else if (styles[side] == INSET)",
    "       fcolour = colours[side] + vec4(topleft ? -0.2 : +0.2);",
    "   else if (styles[side] == OUTSET)",
    "       fcolour = colours[side] + vec4(topleft ? +0.2 : -0.2);",
    "   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