Drawing.hs

{-|
Module      : Monomer.Widgets.Util.Drawing
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Utility drawing functions. Built on top the lower level primitives provided by
"Monomer.Graphics.Types.Renderer".
-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}

module Monomer.Widgets.Util.Drawing (
  drawInScissor,
  drawInTranslation,
  drawInScale,
  drawInRotation,
  drawInAlpha,
  drawTextLine,
  drawLine,
  drawRect,
  drawRectBorder,
  drawRectBoxGradient,
  drawTriangle,
  drawTriangleBorder,
  drawArc,
  drawArcBorder,
  drawEllipse,
  drawEllipseBorder,
  drawArrowUp,
  drawArrowDown,
  drawTimesX,
  drawStyledAction,
  drawStyledAction_,
  drawRoundedRect,
  drawRoundedRectBorder
) where

import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (^?), (^?!), (.~), non)
import Control.Monad (forM_, void, when)
import Data.Default
import Data.Maybe
import Data.Text (Text)

import Monomer.Core
import Monomer.Graphics.Types

import qualified Monomer.Common.Lens as L
import qualified Monomer.Core.Lens as L
import qualified Monomer.Graphics.Lens as L

-- | Performs the provided drawing operations with an active scissor, and then
-- | disables it.
drawInScissor
  :: Renderer  -- ^ The renderer.
  -> Bool      -- ^ Whether to apply the scissor (useful to selectively apply).
  -> Rect      -- ^ Scissor rect, where drawing will be visible.
  -> IO ()     -- ^ Drawing operations.
  -> IO ()     -- ^ The resulting action.
drawInScissor renderer False _ action = action
drawInScissor renderer True rect action = do
  saveContext renderer
  intersectScissor renderer rect
  action
  restoreContext renderer

-- | Performs the provided drawing operations displaced by the given offset.
drawInTranslation
  :: Renderer  -- ^ The renderer.
  -> Point     -- ^ The offset to apply.
  -> IO ()     -- ^ Drawing operations.
  -> IO ()     -- ^ The resulting action.
drawInTranslation renderer offset action = do
  saveContext renderer
  setTranslation renderer offset
  action
  restoreContext renderer

-- | Performs the provided drawing operations with the given resize scale.
drawInScale
  :: Renderer  -- ^ The renderer.
  -> Point     -- ^ The horizontal and vertical scale factor to apply.
  -> IO ()     -- ^ Drawing operations.
  -> IO ()     -- ^ The resulting action.
drawInScale renderer scale action = do
  saveContext renderer
  setScale renderer scale
  action
  restoreContext renderer

-- | Performs the provided drawing operations with the given rotation angle.
drawInRotation
  :: Renderer  -- ^ The renderer.
  -> Double    -- ^ The angle in degrees.
  -> IO ()     -- ^ Drawing operations.
  -> IO ()     -- ^ The resulting action.
drawInRotation renderer angle action = do
  saveContext renderer
  setRotation renderer angle
  action
  restoreContext renderer

-- | Performs the provided drawing operations with a global alpha applied.
drawInAlpha
  :: Renderer  -- ^ The renderer.
  -> Double    -- ^ The global alpha to apply.
  -> IO ()     -- ^ Drawing operations.
  -> IO ()     -- ^ The resulting action.
drawInAlpha renderer alpha action = do
  saveContext renderer
  setGlobalAlpha renderer alpha
  action
  restoreContext renderer

-- | Draws a TextLine with the provided style. Font and size must be the same
-- | as when the TextLine was created, but color and decorations can change.
drawTextLine
  :: Renderer    -- ^ The renderer.
  -> StyleState  -- ^ The style to apply.
  -> TextLine    -- ^ The TextLine with the text to render.
  -> IO ()       -- ^ The resulting action.
drawTextLine renderer style textLine = do
  setFillColor renderer fontColor
  renderText renderer txtOrigin _tlFont _tlFontSize _tlFontSpaceH _tlText

  when underline $ do
    drawLine renderer (Point tx uy) (Point tr uy) lw (Just fontColor)

  when overline $ do
    drawLine renderer (Point tx oy) (Point tr oy) lw (Just fontColor)

  when throughline $ do
    drawLine renderer (Point tx hy) (Point tr hy) lw (Just fontColor)
  where
    TextLine{..} = textLine
    TextMetrics asc desc _ _ = _tlMetrics
    Rect tx ty tw th = _tlRect
    tr = tx + tw

    fontColor = styleFontColor style
    alignV = styleTextAlignV style

    underline = style ^?! L.text . non def . L.underline . non False
    overline = style ^?! L.text . non def . L.overline . non False
    throughline = style ^?! L.text . non def . L.throughline . non False

    offset
      | alignV == ATBaseline = 0
      | otherwise = desc
    {-
    There's not a scientific reason for choosing 1/20 as the scale, it just
    looked reasonably good as the line width on a set of different fonts.
    -}
    lw = max 1.5 (unFontSize _tlFontSize / 20)
    by = ty + th + offset
    uy = by + 1.5 * lw
    oy = ty
    hy = by - asc * 0.35
    txtOrigin = Point tx by

-- | Draws a line with the given width and color.
drawLine
  :: Renderer     -- ^ The renderer.
  -> Point        -- ^ The start point.
  -> Point        -- ^ The end point.
  -> Double       -- ^ The line width.
  -> Maybe Color  -- ^ The color. If Nothing, the line will not be drawn.
  -> IO ()        -- ^ The resulting action.
drawLine _ _ _ _ Nothing = pure ()
drawLine renderer p1 p2 width (Just color) = do
  beginPath renderer
  setStrokeColor renderer color
  setStrokeWidth renderer width
  renderLine renderer p1 p2
  stroke renderer

-- | Draws a filled rect with the given color and radius.
drawRect
  :: Renderer      -- ^ The renderer.
  -> Rect          -- ^ The rectangle to be drawn.
  -> Maybe Color   -- ^ The color. If Nothing, the rect will not be drawn.
  -> Maybe Radius  -- ^ The optional radius config.
  -> IO ()         -- ^ The resulting action.
drawRect _ _ Nothing _ = pure ()
drawRect renderer rect (Just color) Nothing = do
  beginPath renderer
  setFillColor renderer color
  renderRect renderer rect
  fill renderer
drawRect renderer rect (Just color) (Just radius) = do
  beginPath renderer
  setFillColor renderer color
  drawRoundedRect renderer rect radius
  fill renderer

-- | Draws a rect's border, with an optional radius.
drawRectBorder
  :: Renderer      -- ^ The renderer.
  -> Rect          -- ^ The rectangle to be drawn.
  -> Border        -- ^ The border config.
  -> Maybe Radius  -- ^ The optional radius config.
  -> IO ()         -- ^ The resulting action.
drawRectBorder renderer rect border Nothing =
  drawRectSimpleBorder renderer rect border
drawRectBorder renderer rect border (Just radius) =
  drawRoundedRectBorder renderer rect border radius

-- | Draws a box gradient rect with the given radius, inner and outer colors.
drawRectBoxGradient
  :: Renderer      -- ^ The renderer.
  -> Rect          -- ^ The rectangle to be drawn.
  -> Double        -- ^ The radius width.
  -> Double        -- ^ The feather size.
  -> Color         -- ^ The inner color.
  -> Color         -- ^ The outer color.
  -> IO ()         -- ^ The resulting action.
drawRectBoxGradient renderer rect rad feather inner outer = do
  beginPath renderer
  renderRoundedRect renderer rect rad rad rad rad
  setFillBoxGradient renderer rect rad feather inner outer
  fill renderer
  where
    Rect rx ry rw rh = rect

{-|
Draws a filled triangle with the given color.

The points should be provided in clockwise order.
-}
drawTriangle
  :: Renderer     -- ^ The renderer.
  -> Point        -- ^ The first point.
  -> Point        -- ^ The second point.
  -> Point        -- ^ The third point.
  -> Maybe Color  -- ^ The color. If Nothing, the triangle will not be drawn.
  -> IO ()        -- ^ The resulting action.
drawTriangle _ _ _ _ Nothing = return ()
drawTriangle renderer p1 p2 p3 (Just color) = do
  beginPath renderer
  setFillColor renderer color
  moveTo renderer p1
  renderLineTo renderer p2
  renderLineTo renderer p3
  closePath renderer
  fill renderer

-- | Draws a triangle's border with the given color and width.
drawTriangleBorder
  :: Renderer     -- ^ The renderer.
  -> Point        -- ^ The first point.
  -> Point        -- ^ The second point.
  -> Point        -- ^ The third point.
  -> Double       -- ^ The border width.
  -> Maybe Color  -- ^ The color. If Nothing, the triangle will not be drawn.
  -> IO ()        -- ^ The resulting action.
drawTriangleBorder _ _ _ _ _ Nothing = return ()
drawTriangleBorder renderer p1 p2 p3 width (Just color) =
  when (width > 0) $ do
    beginPath renderer
    setStrokeColor renderer color
    setStrokeWidth renderer width
    moveTo renderer p1
    renderLineTo renderer p2
    renderLineTo renderer p3
    closePath renderer
    stroke renderer

-- | Draws a filled arc, delimited by a rect and within the given angles.
drawArc
  :: Renderer      -- ^ The renderer.
  -> Rect          -- ^ The rect delimiting the arc area.
  -> Double        -- ^ The start angle in degrees.
  -> Double        -- ^ The end angle in degrees.
  -> Winding       -- ^ The direction in which the arc is drawn.
  -> Maybe Color   -- ^ The color. If Nothing, the arc will not be drawn.
  -> IO ()         -- ^ The resulting action.
drawArc renderer rect start end winding Nothing = return ()
drawArc renderer rect start end winding (Just color) = do
  beginPath renderer
  setFillColor renderer color
  renderArc renderer center radius start end winding
  fill renderer
  where
    Rect rx ry rw rh = rect
    radius = min (rw / 2) (rh / 2)
    center = Point (rx + rw / 2) (ry + rh / 2)

-- | Draws an arc's border, delimited by a rect and within the given angles.
drawArcBorder
  :: Renderer      -- ^ The renderer.
  -> Rect          -- ^ The rect delimiting the arc area.
  -> Double        -- ^ The start angle in degrees.
  -> Double        -- ^ The end angle in degrees.
  -> Winding       -- ^ The direction in which the arc is drawn.
  -> Maybe Color   -- ^ The color. If Nothing, the arc will not be drawn.
  -> Double        -- ^ The arc width.
  -> IO ()         -- ^ The resulting action.
drawArcBorder renderer rect start end winding Nothing width = return ()
drawArcBorder renderer rect start end winding (Just color) width =
  when (width > 0) $ do
    beginPath renderer
    setStrokeColor renderer color
    setStrokeWidth renderer width
    renderArc renderer center radius start end winding
    stroke renderer
  where
    Rect rx ry rw rh = rect
    radius = min ((rw - width) / 2) ((rh - width) / 2)
    center = Point (rx + rw / 2) (ry + rh / 2)

-- | Draws a filled ellipse, delimited by a rect.
drawEllipse
  :: Renderer      -- ^ The renderer.
  -> Rect          -- ^ The rect delimiting the ellipse.
  -> Maybe Color   -- ^ The color. If Nothing, the ellipse will not be drawn.
  -> IO ()         -- ^ The resulting action.
drawEllipse renderer rect Nothing = return ()
drawEllipse renderer rect (Just color) = do
  beginPath renderer
  setFillColor renderer color
  renderEllipse renderer rect
  fill renderer

-- | Draws an ellipse's border, delimited by a rect.
drawEllipseBorder
  :: Renderer      -- ^ The renderer.
  -> Rect          -- ^ The rect delimiting the ellipse.
  -> Maybe Color   -- ^ The color. If Nothing, the ellipse will not be drawn.
  -> Double        -- ^ The border width.
  -> IO ()         -- ^ The resulting action.
drawEllipseBorder renderer rect Nothing _ = return ()
drawEllipseBorder renderer rect (Just color) width =
  when (width > 0) $
    forM_ contentRect $ \finalRect -> do
      beginPath renderer
      setStrokeColor renderer color
      setStrokeWidth renderer width
      renderEllipse renderer finalRect
      stroke renderer
  where
    contentRect = subtractFromRect rect w w w w
    w = width / 2

-- | Draws a triangular arrow pointing up, delimited by the given rect.
drawArrowUp
  :: Renderer      -- ^ The renderer.
  -> Rect          -- ^ The rect delimiting the arrow.
  -> Maybe Color   -- ^ The color. If Nothing, the arrow will not be drawn.
  -> IO ()         -- ^ The resulting action.
drawArrowUp renderer rect Nothing = return ()
drawArrowUp renderer rect (Just color) = do
  beginPath renderer
  setFillColor renderer color
  moveTo renderer p1
  renderLineTo renderer p2
  renderLineTo renderer p3
  renderLineTo renderer p1
  fill renderer
  where
    Rect x y w h = rect
    p1 = Point (x + w / 2) y
    p2 = Point (x + w) (y + h)
    p3 = Point x (y + h)

-- | Draws a triangular arrow pointing down, delimited by the given rect.
drawArrowDown
  :: Renderer      -- ^ The renderer.
  -> Rect          -- ^ The rect delimiting the arrow.
  -> Maybe Color   -- ^ The color. If Nothing, the arrow will not be drawn.
  -> IO ()         -- ^ The resulting action.
drawArrowDown renderer rect Nothing = return ()
drawArrowDown renderer rect (Just color) = do
  beginPath renderer
  setFillColor renderer color
  moveTo renderer p1
  renderLineTo renderer p2
  renderLineTo renderer p3
  renderLineTo renderer p1
  fill renderer
  where
    Rect x y w h = rect
    p1 = Point x y
    p2 = Point (x + w) y
    p3 = Point (x + w / 2) (y + h)

-- | Draws an X, delimited by the given rect.
drawTimesX
  :: Renderer      -- ^ The renderer.
  -> Rect          -- ^ The rect delimiting the arrow.
  -> Double        -- ^ The width of the lines.
  -> Maybe Color   -- ^ The color. If Nothing, the X will not be drawn.
  -> IO ()         -- ^ The resulting action.
drawTimesX renderer rect lw Nothing = return ()
drawTimesX renderer rect lw (Just fgColor) = do
  beginPath renderer
  setFillColor renderer fgColor
  moveTo renderer (Point (x + hw) y)
  renderLineTo renderer (Point cx (cy - hw))
  renderLineTo renderer (Point (mx - hw) y)
  renderLineTo renderer (Point mx (y + hw))
  renderLineTo renderer (Point (cx + hw) cy)
  renderLineTo renderer (Point mx (my - hw))
  renderLineTo renderer (Point (mx - hw) my)
  renderLineTo renderer (Point cx (cy + hw))
  renderLineTo renderer (Point (x + hw) my)
  renderLineTo renderer (Point x (my - hw))
  renderLineTo renderer (Point (cx - hw) cy)
  renderLineTo renderer (Point x (y + hw))
  renderLineTo renderer (Point (x + hw) y)
  fill renderer
  where
    Rect x y w h = rect
    hw = lw / 2
    cx = x + w / 2
    cy = y + h / 2
    mx = x + w
    my = y + h

{-|
Runs a set of rendering operations after drawing the style's background, and
before drawing the style's border.
-}
drawStyledAction
  :: Renderer         -- ^ The renderer.
  -> Rect             -- ^ The rect where background and border will be drawn.
  -> StyleState       -- ^ The style defining background and border.
  -> (Rect -> IO ())  -- ^ The drawing actions. They receive the content area.
  -> IO ()            -- ^ The resulting action.
drawStyledAction renderer rect style action =
  drawStyledAction_ renderer True rect style action

{-|
Runs a set of rendering operations after conditionally drawing the style's
background, and before drawing the style's border.
-}
drawStyledAction_
  :: Renderer         -- ^ The renderer.
  -> Bool             -- ^ Whether background and border should be drawn.
  -> Rect             -- ^ The rect where background and border will be drawn.
  -> StyleState       -- ^ The style defining background and border.
  -> (Rect -> IO ())  -- ^ The drawing actions. They receive the content area.
  -> IO ()            -- ^ The resulting action.
drawStyledAction_ renderer drawDecorations rect style action = do
  when drawDecorations $
    drawRect renderer rect _sstBgColor _sstRadius

  forM_ contentRect action

  when (drawDecorations && isJust _sstBorder) $
    drawRectBorder renderer rect (fromJust _sstBorder) _sstRadius
  where
    StyleState{..} = style
    contentRect = removeOuterBounds style rect

-- | Draws a rounded rect with the provided radius config.
drawRoundedRect :: Renderer -> Rect -> Radius -> IO ()
drawRoundedRect renderer rect radius =
  let
    Rect _ _ w h = rect
    Radius{..} = fixRadius rect radius
    midw = min w h / 2
    validTL = min midw (radW _radTopLeft)
    validTR = min midw (radW _radTopRight)
    validBR = min midw (radW _radBottomRight)
    validBL = min midw (radW _radBottomLeft)
  in do
    renderRoundedRect renderer rect validTL validTR validBR validBL

drawRectSimpleBorder :: Renderer -> Rect -> Border -> IO ()
drawRectSimpleBorder renderer (Rect x y w h) Border{..} =
  let
    ptl = Point x y
    ptr = Point (x + w) y
    pbr = Point (x + w) (y + h)
    pbl = Point x (y + h)

    borderL = _brdLeft
    borderR = _brdRight
    borderT = _brdTop
    borderB = _brdBottom
  in do
    (olt, otl, itl) <- drawRectCorner renderer CornerTL ptl borderL borderT
    (otr, ort, itr) <- drawRectCorner renderer CornerTR ptr borderT borderR
    (orb, obr, ibr) <- drawRectCorner renderer CornerBR pbr borderR borderB
    (obl, olb, ibl) <- drawRectCorner renderer CornerBL pbl borderB borderL

    drawQuad renderer otl otr itr itl borderT
    drawQuad renderer ort orb ibr itr borderR
    drawQuad renderer obr obl ibl ibr borderB
    drawQuad renderer olb olt itl ibl borderL

drawRectCorner
  :: Renderer
  -> RectCorner
  -> Point
  -> Maybe BorderSide
  -> Maybe BorderSide
  -> IO (Point, Point, Point)
drawRectCorner _ _ ocorner Nothing Nothing = return points where
  points = (ocorner, ocorner, ocorner)
drawRectCorner renderer cor ocorner ms1 ms2 = do
  when (w1 > 0 && w2 > 0) $ do
    beginPath renderer

    if color1 == color2
      then setFillColor renderer color1
      else setFillLinearGradient renderer g1 g2 color1 color2

    moveTo renderer o1
    renderLineTo renderer icorner
    renderLineTo renderer o2
    renderLineTo renderer ocorner
    closePath renderer

    fill renderer

  return (o1, o2, icorner)
  where
    Point cx cy = ocorner
    s1 = fromMaybe def ms1
    s2 = fromMaybe def ms2
    w1 = _bsWidth s1
    w2 = _bsWidth s2

    color1 = _bsColor (fromJust (ms1 <|> ms2))
    color2 = _bsColor (fromJust (ms2 <|> ms1))

    (o1, o2) = case cor of
      CornerTL -> (Point cx (cy + w2), Point (cx + w1) cy)
      CornerTR -> (Point (cx - w2) cy, Point cx (cy + w1))
      CornerBR -> (Point cx (cy - w2), Point (cx - w1) cy)
      CornerBL -> (Point (cx + w2) cy, Point cx (cy - w1))
    icorner = case cor of
      CornerTL -> Point (cx + w1) (cy + w2)
      CornerTR -> Point (cx - w2) (cy + w1)
      CornerBR -> Point (cx - w1) (cy - w2)
      CornerBL -> Point (cx + w2) (cy - w1)
    (g1, g2) = cornerGradientPoints ocorner icorner

-- | Draws the border of a rounded rect. Borders' widths may not match.
drawRoundedRectBorder :: Renderer -> Rect -> Border -> Radius -> IO ()
drawRoundedRectBorder renderer rect border radius =
  let
    Rect xl yt w h = rect
    Border borL borR borT borB = border
    Radius radTL radTR radBL radBR = fixRadius rect radius
    xr = xl + w
    yb = yt + h
    hw = w / 2
    hh = h / 2
    midw = min w h / 2

    rtl = Rect xl yt hw hh
    rtr = Rect (xl + hw) yt hw hh
    rbr = Rect (xl + hw) (yt + hh) hw hh
    rbl = Rect xl (yt + hh) hw hh

    validTL = min midw (radW radTL)
    validTR = min midw (radW radTR)
    validBR = min midw (radW radBR)
    validBL = min midw (radW radBL)

    xt1 = xl + validTL
    xt2 = xr - validTR

    xb1 = xl + validBL
    xb2 = xr - validBR

    yl1 = yt + validTL
    yl2 = yb - validBL

    yr1 = yt + validTR
    yr2 = yb - validBR
  in do
    (lt1, lt2, tl1, tl2) <- drawRoundedCorner renderer CornerTL rtl (p2 xt1 yl1) radTL borL borT
    (tr1, tr2, rt1, rt2) <- drawRoundedCorner renderer CornerTR rtr (p2 xt2 yr1) radTR borT borR
    (rb1, rb2, br1, br2) <- drawRoundedCorner renderer CornerBR rbr (p2 xb2 yr2) radBR borR borB
    (bl1, bl2, lb1, lb2) <- drawRoundedCorner renderer CornerBL rbl (p2 xb1 yl2) radBL borB borL

    drawQuad renderer lb1 lt1 lt2 lb2 borL
    drawQuad renderer tl1 tr1 tr2 tl2 borT
    drawQuad renderer rt1 rb1 rb2 rt2 borR
    drawQuad renderer br1 bl1 bl2 br2 borB

drawRoundedCorner
  :: Renderer
  -> RectCorner
  -> Rect
  -> Point
  -> Maybe RadiusCorner
  -> Maybe BorderSide
  -> Maybe BorderSide
  -> IO (Point, Point, Point, Point)
drawRoundedCorner _ _ _ center _ Nothing Nothing = return points where
  points = (center, center, center, center)
drawRoundedCorner renderer cor bounds ocenter mrcor ms1 ms2 = do
  when (w1 > 0 || w2 > 0) $ do
    beginPath renderer

    if color1 == color2
      then setFillColor renderer color1
      else setFillLinearGradient renderer g1 g2 color1 color2

    if round orad == 0
      then drawRectArc renderer cor icenter w1 w2
      else renderArc renderer ocenter orad deg (deg - 90) CCW

    renderLineTo renderer o1

    if round orad > 0 && round irad > 0
      then do
        renderLineTo renderer i1
        renderArc renderer icenter irad (deg - 90) deg CW
        renderLineTo renderer i2
      else do
        renderLineTo renderer icenter

    renderLineTo renderer o2

    closePath renderer
    fill renderer

  return bordersCorners
  where
    Point ocx ocy = ocenter
    Point icx icy = icenter
    rcor = fromMaybe def mrcor
    s1 = fromMaybe def ms1
    s2 = fromMaybe def ms2
    w1 = _bsWidth s1
    w2 = _bsWidth s2
    color1 = _bsColor (fromJust (ms1 <|> ms2))
    color2 = _bsColor (fromJust (ms2 <|> ms1))
    minW = min w1 w2

    orad = max 0 (_rcrWidth rcor)
    irad = max 0 (orad - minW)
    omax1 = max orad w1
    omax2 = max orad w2

    cxmin = min ocx icx
    cxmax = max ocx icx
    cymin = min ocy icy
    cymax = max ocy icy

    restrict (p1, p2) = (rectBoundedPoint bounds p1, rectBoundedPoint bounds p2)
    (deg, icenter) = case cor of
      CornerTL -> (270, Point (ocx - orad + w1 + irad) (ocy - orad + w2 + irad))
      CornerTR -> (  0, Point (ocx + orad - w2 - irad) (ocy - orad + w1 + irad))
      CornerBR -> ( 90, Point (ocx + orad - w1 - irad) (ocy + orad - w2 - irad))
      CornerBL -> (180, Point (ocx - orad + w2 + irad) (ocy + orad - w1 - irad))
    (o1, o2) = restrict $ case cor of
      CornerTL -> (Point (ocx - omax1) cymax, Point cxmax (ocy - omax2))
      CornerTR -> (Point cxmin (ocy - omax2), Point (ocx + omax1) cymax)
      CornerBR -> (Point (ocx + omax1) cymin, Point cxmin (ocy + omax2))
      CornerBL -> (Point cxmax (ocy + omax2), Point (ocx - omax1) cymin)
    (i1, i2) = restrict $ case cor of
      CornerTL -> (Point (ocx - orad + w1) cymax, Point cxmax (ocy - orad + w2))
      CornerTR -> (Point cxmin (ocy - orad + w1), Point (ocx + orad - w2) cymax)
      CornerBR -> (Point (ocx + orad - w1) cymin, Point cxmin (ocy + orad - w2))
      CornerBL -> (Point cxmax (ocy + orad - w1), Point (ocx - orad + w2) cymin)
    bordersCorners
      | round orad == 0 = (o1, icenter, o2, icenter)
      | otherwise = (o1, i1, o2, i2)
    ocorner = Point (o1 ^. L.x) (o2 ^. L.y)
    icorner = Point (o2 ^. L.x) (o1 ^. L.y)
    (g1, g2)
      | cor `elem` [CornerTL, CornerBR] = cornerGradientPoints ocorner icorner
      | otherwise = cornerGradientPoints icorner ocorner

drawRectArc :: Renderer -> RectCorner -> Point -> Double -> Double -> IO ()
drawRectArc renderer corner c1 pw1 pw2 = do
  moveTo renderer (addPoint c1 p1)
  renderLineTo renderer (addPoint c1 p2)
  renderLineTo renderer (addPoint c1 p3)
  where
    nw1 = -pw1
    nw2 = -pw2
    (p1, p2, p3) = case corner of
      CornerTL -> (Point 0 nw2, Point nw1 nw2, Point nw1 0)
      CornerTR -> (Point pw2 0, Point pw2 nw1, Point 0 nw1)
      CornerBR -> (Point 0 pw2, Point pw1 pw2, Point pw1 0)
      CornerBL -> (Point nw2 0, Point nw2 pw1, Point 0 pw1)

drawQuad :: Renderer -> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO ()
drawQuad renderer p1 p2 p3 p4 Nothing = pure ()
drawQuad renderer p1 p2 p3 p4 (Just BorderSide{..}) =
  when (_bsWidth > 0) $ do
    beginPath renderer
    setFillColor renderer _bsColor
    moveTo renderer p1
    renderLineTo renderer p2
    renderLineTo renderer p3
    renderLineTo renderer p4
    closePath renderer
    fill renderer

cornerGradientPoints :: Point -> Point -> (Point, Point)
cornerGradientPoints outer inner = (g1, g2) where
  Point ox oy = outer
  Point ix iy = inner
  Point mx my = midPoint outer inner
  (vx, vy) = (ix - ox, iy - oy)
  (nx, ny) = (vy, -vx)
  factor = 0.01
  g1 = Point (mx - factor * nx) (my - factor * ny)
  g2 = Point (mx + factor * nx) (my + factor * ny)

p2 :: Double -> Double -> Point
p2 x y = Point x y

radW :: Maybe RadiusCorner -> Double
radW r = _rcrWidth (fromMaybe def r)

fixRadius :: Rect -> Radius -> Radius
fixRadius (Rect _ _ w h) (Radius tl tr bl br) = newRadius where
  fixC (RadiusCorner cwidth)
    | cwidth < min w h / 2= RadiusCorner cwidth
    | otherwise = RadiusCorner (min w h / 2)
  newRadius = Radius (fixC <$> tl) (fixC <$> tr) (fixC <$> bl) (fixC <$> br)