{-|
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 #-}

module Monomer.Widgets.Util.Drawing (
  drawInScissor,
  drawInTranslation,
  drawInScale,
  drawInRotation,
  drawInAlpha,
  drawTextLine,
  drawRect,
  drawRectBorder,
  drawArc,
  drawArcBorder,
  drawEllipse,
  drawEllipseBorder,
  drawArrowDown,
  drawTimesX,
  drawStyledAction,
  drawRoundedRect,
  drawRectRoundedBorder
) where

import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (^?), (^?!), (.~), non)
import Control.Monad (forM_, void, when)
import Data.ByteString (ByteString)
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 -> Bool -> Rect -> IO () -> IO ()
drawInScissor Renderer
renderer Bool
False Rect
_ IO ()
action = IO ()
action
drawInScissor Renderer
renderer Bool
True Rect
rect IO ()
action = do
  Renderer -> IO ()
saveContext Renderer
renderer
  Renderer -> Rect -> IO ()
intersectScissor Renderer
renderer Rect
rect
  IO ()
action
  Renderer -> IO ()
restoreContext Renderer
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 -> Point -> IO () -> IO ()
drawInTranslation Renderer
renderer Point
offset IO ()
action = do
  Renderer -> IO ()
saveContext Renderer
renderer
  Renderer -> Point -> IO ()
setTranslation Renderer
renderer Point
offset
  IO ()
action
  Renderer -> IO ()
restoreContext Renderer
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 -> Point -> IO () -> IO ()
drawInScale Renderer
renderer Point
scale IO ()
action = do
  Renderer -> IO ()
saveContext Renderer
renderer
  Renderer -> Point -> IO ()
setScale Renderer
renderer Point
scale
  IO ()
action
  Renderer -> IO ()
restoreContext Renderer
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 -> Double -> IO () -> IO ()
drawInRotation Renderer
renderer Double
angle IO ()
action = do
  Renderer -> IO ()
saveContext Renderer
renderer
  Renderer -> Double -> IO ()
setRotation Renderer
renderer Double
angle
  IO ()
action
  Renderer -> IO ()
restoreContext Renderer
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 -> Double -> IO () -> IO ()
drawInAlpha Renderer
renderer Double
alpha IO ()
action = do
  Renderer -> IO ()
saveContext Renderer
renderer
  Renderer -> Double -> IO ()
setGlobalAlpha Renderer
renderer Double
alpha
  IO ()
action
  Renderer -> IO ()
restoreContext Renderer
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 -> StyleState -> TextLine -> IO ()
drawTextLine Renderer
renderer StyleState
style TextLine
textLine = do
  Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
fontColor
  Renderer -> Point -> Font -> FontSize -> FontSpace -> Text -> IO ()
renderText Renderer
renderer Point
txtOrigin Font
_tlFont FontSize
_tlFontSize FontSpace
_tlFontSpaceH Text
_tlText

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
underline (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Renderer -> Point -> Point -> Double -> Maybe Color -> IO ()
drawLine Renderer
renderer (Double -> Double -> Point
Point Double
tx Double
uy) (Double -> Double -> Point
Point Double
tr Double
uy) Double
lw (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
fontColor)

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
overline (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Renderer -> Point -> Point -> Double -> Maybe Color -> IO ()
drawLine Renderer
renderer (Double -> Double -> Point
Point Double
tx Double
oy) (Double -> Double -> Point
Point Double
tr Double
oy) Double
lw (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
fontColor)

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
throughline (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Renderer -> Point -> Point -> Double -> Maybe Color -> IO ()
drawLine Renderer
renderer (Double -> Double -> Point
Point Double
tx Double
hy) (Double -> Double -> Point
Point Double
tr Double
hy) Double
lw (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
fontColor)
  where
    TextLine{Text
Seq GlyphPos
Rect
Size
TextMetrics
FontSpace
FontSize
Font
_tlGlyphs :: TextLine -> Seq GlyphPos
_tlRect :: TextLine -> Rect
_tlSize :: TextLine -> Size
_tlText :: TextLine -> Text
_tlMetrics :: TextLine -> TextMetrics
_tlFontSpaceV :: TextLine -> FontSpace
_tlFontSpaceH :: TextLine -> FontSpace
_tlFontSize :: TextLine -> FontSize
_tlFont :: TextLine -> Font
_tlGlyphs :: Seq GlyphPos
_tlRect :: Rect
_tlSize :: Size
_tlMetrics :: TextMetrics
_tlFontSpaceV :: FontSpace
_tlText :: Text
_tlFontSpaceH :: FontSpace
_tlFontSize :: FontSize
_tlFont :: Font
..} = TextLine
textLine
    TextMetrics Double
asc Double
desc Double
_ Double
_ = TextMetrics
_tlMetrics
    Rect Double
tx Double
ty Double
tw Double
th = Rect
_tlRect
    tr :: Double
tr = Double
tx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
tw

    fontColor :: Color
fontColor = StyleState -> Color
styleFontColor StyleState
style
    alignV :: AlignTV
alignV = StyleState -> AlignTV
styleTextAlignV StyleState
style

    underline :: Bool
underline = StyleState
style StyleState -> Getting (Endo Bool) StyleState Bool -> Bool
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! (Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
-> StyleState -> Const (Endo Bool) StyleState
forall s a. HasText s a => Lens' s a
L.text ((Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
 -> StyleState -> Const (Endo Bool) StyleState)
-> ((Bool -> Const (Endo Bool) Bool)
    -> Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
-> Getting (Endo Bool) StyleState Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextStyle -> Iso' (Maybe TextStyle) TextStyle
forall a. Eq a => a -> Iso' (Maybe a) a
non TextStyle
forall a. Default a => a
def ((TextStyle -> Const (Endo Bool) TextStyle)
 -> Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
-> ((Bool -> Const (Endo Bool) Bool)
    -> TextStyle -> Const (Endo Bool) TextStyle)
-> (Bool -> Const (Endo Bool) Bool)
-> Maybe TextStyle
-> Const (Endo Bool) (Maybe TextStyle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Const (Endo Bool) (Maybe Bool))
-> TextStyle -> Const (Endo Bool) TextStyle
forall s a. HasUnderline s a => Lens' s a
L.underline ((Maybe Bool -> Const (Endo Bool) (Maybe Bool))
 -> TextStyle -> Const (Endo Bool) TextStyle)
-> ((Bool -> Const (Endo Bool) Bool)
    -> Maybe Bool -> Const (Endo Bool) (Maybe Bool))
-> (Bool -> Const (Endo Bool) Bool)
-> TextStyle
-> Const (Endo Bool) TextStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Iso' (Maybe Bool) Bool
forall a. Eq a => a -> Iso' (Maybe a) a
non Bool
False
    overline :: Bool
overline = StyleState
style StyleState -> Getting (Endo Bool) StyleState Bool -> Bool
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! (Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
-> StyleState -> Const (Endo Bool) StyleState
forall s a. HasText s a => Lens' s a
L.text ((Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
 -> StyleState -> Const (Endo Bool) StyleState)
-> ((Bool -> Const (Endo Bool) Bool)
    -> Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
-> Getting (Endo Bool) StyleState Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextStyle -> Iso' (Maybe TextStyle) TextStyle
forall a. Eq a => a -> Iso' (Maybe a) a
non TextStyle
forall a. Default a => a
def ((TextStyle -> Const (Endo Bool) TextStyle)
 -> Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
-> ((Bool -> Const (Endo Bool) Bool)
    -> TextStyle -> Const (Endo Bool) TextStyle)
-> (Bool -> Const (Endo Bool) Bool)
-> Maybe TextStyle
-> Const (Endo Bool) (Maybe TextStyle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Const (Endo Bool) (Maybe Bool))
-> TextStyle -> Const (Endo Bool) TextStyle
forall s a. HasOverline s a => Lens' s a
L.overline ((Maybe Bool -> Const (Endo Bool) (Maybe Bool))
 -> TextStyle -> Const (Endo Bool) TextStyle)
-> ((Bool -> Const (Endo Bool) Bool)
    -> Maybe Bool -> Const (Endo Bool) (Maybe Bool))
-> (Bool -> Const (Endo Bool) Bool)
-> TextStyle
-> Const (Endo Bool) TextStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Iso' (Maybe Bool) Bool
forall a. Eq a => a -> Iso' (Maybe a) a
non Bool
False
    throughline :: Bool
throughline = StyleState
style StyleState -> Getting (Endo Bool) StyleState Bool -> Bool
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! (Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
-> StyleState -> Const (Endo Bool) StyleState
forall s a. HasText s a => Lens' s a
L.text ((Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
 -> StyleState -> Const (Endo Bool) StyleState)
-> ((Bool -> Const (Endo Bool) Bool)
    -> Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
-> Getting (Endo Bool) StyleState Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextStyle -> Iso' (Maybe TextStyle) TextStyle
forall a. Eq a => a -> Iso' (Maybe a) a
non TextStyle
forall a. Default a => a
def ((TextStyle -> Const (Endo Bool) TextStyle)
 -> Maybe TextStyle -> Const (Endo Bool) (Maybe TextStyle))
-> ((Bool -> Const (Endo Bool) Bool)
    -> TextStyle -> Const (Endo Bool) TextStyle)
-> (Bool -> Const (Endo Bool) Bool)
-> Maybe TextStyle
-> Const (Endo Bool) (Maybe TextStyle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Const (Endo Bool) (Maybe Bool))
-> TextStyle -> Const (Endo Bool) TextStyle
forall s a. HasThroughline s a => Lens' s a
L.throughline ((Maybe Bool -> Const (Endo Bool) (Maybe Bool))
 -> TextStyle -> Const (Endo Bool) TextStyle)
-> ((Bool -> Const (Endo Bool) Bool)
    -> Maybe Bool -> Const (Endo Bool) (Maybe Bool))
-> (Bool -> Const (Endo Bool) Bool)
-> TextStyle
-> Const (Endo Bool) TextStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Iso' (Maybe Bool) Bool
forall a. Eq a => a -> Iso' (Maybe a) a
non Bool
False

    offset :: Double
offset
      | AlignTV
alignV AlignTV -> AlignTV -> Bool
forall a. Eq a => a -> a -> Bool
== AlignTV
ATBaseline = Double
0
      | Bool
otherwise = Double
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 :: Double
lw = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1.5 (FontSize -> Double
unFontSize FontSize
_tlFontSize Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
20)
    by :: Double
by = Double
ty Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
th Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offset
    uy :: Double
uy = Double
by Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
lw
    oy :: Double
oy = Double
ty
    hy :: Double
hy = Double
by Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
asc Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.35
    txtOrigin :: Point
txtOrigin = Double -> Double -> Point
Point Double
tx Double
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 :: Renderer -> Point -> Point -> Double -> Maybe Color -> IO ()
drawLine Renderer
_ Point
_ Point
_ Double
_ Maybe Color
Nothing = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
drawLine Renderer
renderer Point
p1 Point
p2 Double
width (Just Color
color) = do
  Renderer -> IO ()
beginPath Renderer
renderer
  Renderer -> Color -> IO ()
setStrokeColor Renderer
renderer Color
color
  Renderer -> Double -> IO ()
setStrokeWidth Renderer
renderer Double
width
  Renderer -> Point -> Point -> IO ()
renderLine Renderer
renderer Point
p1 Point
p2
  Renderer -> IO ()
stroke Renderer
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 :: Renderer -> Rect -> Maybe Color -> Maybe Radius -> IO ()
drawRect Renderer
_ Rect
_ Maybe Color
Nothing Maybe Radius
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
drawRect Renderer
renderer Rect
rect (Just Color
color) Maybe Radius
Nothing = do
  Renderer -> IO ()
beginPath Renderer
renderer
  Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
color
  Renderer -> Rect -> IO ()
renderRect Renderer
renderer Rect
rect
  Renderer -> IO ()
fill Renderer
renderer
drawRect Renderer
renderer Rect
rect (Just Color
color) (Just Radius
radius) = do
  Renderer -> IO ()
beginPath Renderer
renderer
  Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
color
  Renderer -> Rect -> Radius -> IO ()
drawRoundedRect Renderer
renderer Rect
rect Radius
radius
  Renderer -> IO ()
fill Renderer
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 -> Maybe Radius -> IO ()
drawRectBorder Renderer
renderer Rect
rect Border
border Maybe Radius
Nothing =
  Renderer -> Rect -> Border -> IO ()
drawRectSimpleBorder Renderer
renderer Rect
rect Border
border
drawRectBorder Renderer
renderer Rect
rect Border
border (Just Radius
radius) =
  Renderer -> Rect -> Border -> Radius -> IO ()
drawRectRoundedBorder Renderer
renderer Rect
rect Border
border Radius
radius

-- | 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 -> Double -> Double -> Winding -> Maybe Color -> IO ()
drawArc Renderer
renderer Rect
rect Double
start Double
end Winding
winding Maybe Color
Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawArc Renderer
renderer Rect
rect Double
start Double
end Winding
winding (Just Color
color) = do
  Renderer -> IO ()
beginPath Renderer
renderer
  Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
color
  Renderer -> Point -> Double -> Double -> Double -> Winding -> IO ()
renderArc Renderer
renderer Point
center Double
radius Double
start Double
end Winding
winding
  Renderer -> IO ()
fill Renderer
renderer
  where
    Rect Double
rx Double
ry Double
rw Double
rh = Rect
rect
    radius :: Double
radius = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Double
rw Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) (Double
rh Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
    center :: Point
center = Double -> Double -> Point
Point (Double
rx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
rw Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) (Double
ry Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
rh Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
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
-> Double
-> Double
-> Winding
-> Maybe Color
-> Double
-> IO ()
drawArcBorder Renderer
renderer Rect
rect Double
start Double
end Winding
winding Maybe Color
Nothing Double
width = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawArcBorder Renderer
renderer Rect
rect Double
start Double
end Winding
winding (Just Color
color) Double
width = do
  Renderer -> IO ()
beginPath Renderer
renderer
  Renderer -> Color -> IO ()
setStrokeColor Renderer
renderer Color
color
  Renderer -> Double -> IO ()
setStrokeWidth Renderer
renderer Double
width
  Renderer -> Point -> Double -> Double -> Double -> Winding -> IO ()
renderArc Renderer
renderer Point
center Double
radius Double
start Double
end Winding
winding
  Renderer -> IO ()
stroke Renderer
renderer
  where
    Rect Double
rx Double
ry Double
rw Double
rh = Rect
rect
    radius :: Double
radius = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min ((Double
rw Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
width) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) ((Double
rh Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
width) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
    center :: Point
center = Double -> Double -> Point
Point (Double
rx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
rw Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) (Double
ry Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
rh Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
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 -> Maybe Color -> IO ()
drawEllipse Renderer
renderer Rect
rect Maybe Color
Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawEllipse Renderer
renderer Rect
rect (Just Color
color) = do
  Renderer -> IO ()
beginPath Renderer
renderer
  Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
color
  Renderer -> Rect -> IO ()
renderEllipse Renderer
renderer Rect
rect
  Renderer -> IO ()
fill Renderer
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 -> Maybe Color -> Double -> IO ()
drawEllipseBorder Renderer
renderer Rect
rect Maybe Color
Nothing Double
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawEllipseBorder Renderer
renderer Rect
rect (Just Color
color) Double
width =
  Maybe Rect -> (Rect -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Rect
contentRect ((Rect -> IO ()) -> IO ()) -> (Rect -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Rect
finalRect -> do
    Renderer -> IO ()
beginPath Renderer
renderer
    Renderer -> Color -> IO ()
setStrokeColor Renderer
renderer Color
color
    Renderer -> Double -> IO ()
setStrokeWidth Renderer
renderer Double
width
    Renderer -> Rect -> IO ()
renderEllipse Renderer
renderer Rect
finalRect
    Renderer -> IO ()
stroke Renderer
renderer
  where
    contentRect :: Maybe Rect
contentRect = Rect -> Double -> Double -> Double -> Double -> Maybe Rect
subtractFromRect Rect
rect Double
w Double
w Double
w Double
w
    w :: Double
w = Double
width Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2

-- | 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 -> Maybe Color -> IO ()
drawArrowDown Renderer
renderer Rect
rect Maybe Color
Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawArrowDown Renderer
renderer Rect
rect (Just Color
color) = do
  Renderer -> IO ()
beginPath Renderer
renderer
  Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
color
  Renderer -> Point -> IO ()
moveTo Renderer
renderer Point
p1
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
p2
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
p3
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
p1
  Renderer -> IO ()
fill Renderer
renderer
  where
    Rect Double
x Double
y Double
w Double
h = Rect
rect
    p1 :: Point
p1 = Double -> Double -> Point
Point Double
x Double
y
    p2 :: Point
p2 = Double -> Double -> Point
Point (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w) Double
y
    p3 :: Point
p3 = Double -> Double -> Point
Point (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
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 -> Double -> Maybe Color -> IO ()
drawTimesX Renderer
renderer Rect
rect Double
lw Maybe Color
Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawTimesX Renderer
renderer Rect
rect Double
lw (Just Color
fgColor) = do
  Renderer -> IO ()
beginPath Renderer
renderer
  Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
fgColor
  Renderer -> Point -> IO ()
moveTo Renderer
renderer (Double -> Double -> Point
Point (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hw) Double
y)
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point Double
cx (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
hw))
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point (Double
mx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
hw) Double
y)
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point Double
mx (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hw))
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hw) Double
cy)
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point Double
mx (Double
my Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
hw))
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point (Double
mx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
hw) Double
my)
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point Double
cx (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hw))
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hw) Double
my)
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point Double
x (Double
my Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
hw))
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
hw) Double
cy)
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point Double
x (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hw))
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer (Double -> Double -> Point
Point (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hw) Double
y)
  Renderer -> IO ()
fill Renderer
renderer
  where
    Rect Double
x Double
y Double
w Double
h = Rect
rect
    hw :: Double
hw = Double
lw Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    cx :: Double
cx = Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    cy :: Double
cy = Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    mx :: Double
mx = Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w
    my :: Double
my = Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
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 -> StyleState -> (Rect -> IO ()) -> IO ()
drawStyledAction Renderer
renderer Rect
rect StyleState
style Rect -> IO ()
action = do
  Renderer -> Rect -> Maybe Color -> Maybe Radius -> IO ()
drawRect Renderer
renderer Rect
rect Maybe Color
_sstBgColor Maybe Radius
_sstRadius

  Maybe Rect -> (Rect -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Rect
contentRect Rect -> IO ()
action

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Border -> Bool
forall a. Maybe a -> Bool
isJust Maybe Border
_sstBorder) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Renderer -> Rect -> Border -> Maybe Radius -> IO ()
drawRectBorder Renderer
renderer Rect
rect (Maybe Border -> Border
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Border
_sstBorder) Maybe Radius
_sstRadius
  where
    StyleState{Maybe Color
Maybe TextStyle
Maybe Radius
Maybe Border
Maybe Padding
Maybe CursorIcon
Maybe SizeReq
_sstCursorIcon :: StyleState -> Maybe CursorIcon
_sstText :: StyleState -> Maybe TextStyle
_sstHlColor :: StyleState -> Maybe Color
_sstSndColor :: StyleState -> Maybe Color
_sstFgColor :: StyleState -> Maybe Color
_sstBgColor :: StyleState -> Maybe Color
_sstRadius :: StyleState -> Maybe Radius
_sstBorder :: StyleState -> Maybe Border
_sstPadding :: StyleState -> Maybe Padding
_sstSizeReqH :: StyleState -> Maybe SizeReq
_sstSizeReqW :: StyleState -> Maybe SizeReq
_sstCursorIcon :: Maybe CursorIcon
_sstText :: Maybe TextStyle
_sstHlColor :: Maybe Color
_sstSndColor :: Maybe Color
_sstFgColor :: Maybe Color
_sstPadding :: Maybe Padding
_sstSizeReqH :: Maybe SizeReq
_sstSizeReqW :: Maybe SizeReq
_sstBorder :: Maybe Border
_sstRadius :: Maybe Radius
_sstBgColor :: Maybe Color
..} = StyleState
style
    contentRect :: Maybe Rect
contentRect = StyleState -> Rect -> Maybe Rect
removeOuterBounds StyleState
style Rect
rect

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

drawRectSimpleBorder :: Renderer -> Rect -> Border -> IO ()
drawRectSimpleBorder :: Renderer -> Rect -> Border -> IO ()
drawRectSimpleBorder Renderer
renderer (Rect Double
x Double
y Double
w Double
h) Border{Maybe BorderSide
_brdBottom :: Border -> Maybe BorderSide
_brdTop :: Border -> Maybe BorderSide
_brdRight :: Border -> Maybe BorderSide
_brdLeft :: Border -> Maybe BorderSide
_brdBottom :: Maybe BorderSide
_brdTop :: Maybe BorderSide
_brdRight :: Maybe BorderSide
_brdLeft :: Maybe BorderSide
..} =
  let
    ptl :: Point
ptl = Double -> Double -> Point
Point Double
x Double
y
    ptr :: Point
ptr = Double -> Double -> Point
Point (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w) Double
y
    pbr :: Point
pbr = Double -> Double -> Point
Point (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w) (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
h)
    pbl :: Point
pbl = Double -> Double -> Point
Point Double
x (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
h)

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

    Renderer
-> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO ()
drawQuad Renderer
renderer Point
otl Point
otr Point
itr Point
itl Maybe BorderSide
borderT
    Renderer
-> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO ()
drawQuad Renderer
renderer Point
ort Point
orb Point
ibr Point
itr Maybe BorderSide
borderR
    Renderer
-> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO ()
drawQuad Renderer
renderer Point
obr Point
obl Point
ibl Point
ibr Maybe BorderSide
borderB
    Renderer
-> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO ()
drawQuad Renderer
renderer Point
olb Point
olt Point
itl Point
ibl Maybe BorderSide
borderL

drawRectCorner
  :: Renderer
  -> RectCorner
  -> Point
  -> Maybe BorderSide
  -> Maybe BorderSide
  -> IO (Point, Point, Point)
drawRectCorner :: Renderer
-> RectCorner
-> Point
-> Maybe BorderSide
-> Maybe BorderSide
-> IO (Point, Point, Point)
drawRectCorner Renderer
_ RectCorner
_ Point
ocorner Maybe BorderSide
Nothing Maybe BorderSide
Nothing = (Point, Point, Point) -> IO (Point, Point, Point)
forall (m :: * -> *) a. Monad m => a -> m a
return (Point, Point, Point)
points where
  points :: (Point, Point, Point)
points = (Point
ocorner, Point
ocorner, Point
ocorner)
drawRectCorner Renderer
renderer RectCorner
cor Point
ocorner Maybe BorderSide
ms1 Maybe BorderSide
ms2 = do
  Renderer -> IO ()
beginPath Renderer
renderer

  if Color
color1 Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
color2
    then Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
color1
    else Renderer -> Point -> Point -> Color -> Color -> IO ()
setFillLinearGradient Renderer
renderer Point
g1 Point
g2 Color
color1 Color
color2

  Renderer -> Point -> IO ()
moveTo Renderer
renderer Point
o1
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
icorner
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
o2
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
ocorner
  Renderer -> IO ()
closePath Renderer
renderer

  Renderer -> IO ()
fill Renderer
renderer
  (Point, Point, Point) -> IO (Point, Point, Point)
forall (m :: * -> *) a. Monad m => a -> m a
return (Point
o1, Point
o2, Point
icorner)
  where
    Point Double
cx Double
cy = Point
ocorner
    s1 :: BorderSide
s1 = BorderSide -> Maybe BorderSide -> BorderSide
forall a. a -> Maybe a -> a
fromMaybe BorderSide
forall a. Default a => a
def Maybe BorderSide
ms1
    s2 :: BorderSide
s2 = BorderSide -> Maybe BorderSide -> BorderSide
forall a. a -> Maybe a -> a
fromMaybe BorderSide
forall a. Default a => a
def Maybe BorderSide
ms2
    w1 :: Double
w1 = BorderSide -> Double
_bsWidth BorderSide
s1
    w2 :: Double
w2 = BorderSide -> Double
_bsWidth BorderSide
s2

    color1 :: Color
color1 = BorderSide -> Color
_bsColor (Maybe BorderSide -> BorderSide
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe BorderSide
ms1 Maybe BorderSide -> Maybe BorderSide -> Maybe BorderSide
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe BorderSide
ms2))
    color2 :: Color
color2 = BorderSide -> Color
_bsColor (Maybe BorderSide -> BorderSide
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe BorderSide
ms2 Maybe BorderSide -> Maybe BorderSide -> Maybe BorderSide
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe BorderSide
ms1))

    (Point
o1, Point
o2) = case RectCorner
cor of
      RectCorner
CornerTL -> (Double -> Double -> Point
Point Double
cx (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w2), Double -> Double -> Point
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w1) Double
cy)
      RectCorner
CornerTR -> (Double -> Double -> Point
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w2) Double
cy, Double -> Double -> Point
Point Double
cx (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w1))
      RectCorner
CornerBR -> (Double -> Double -> Point
Point Double
cx (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w2), Double -> Double -> Point
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w1) Double
cy)
      RectCorner
CornerBL -> (Double -> Double -> Point
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w2) Double
cy, Double -> Double -> Point
Point Double
cx (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w1))
    icorner :: Point
icorner = case RectCorner
cor of
      RectCorner
CornerTL -> Double -> Double -> Point
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w1) (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w2)
      RectCorner
CornerTR -> Double -> Double -> Point
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w2) (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w1)
      RectCorner
CornerBR -> Double -> Double -> Point
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w1) (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w2)
      RectCorner
CornerBL -> Double -> Double -> Point
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w2) (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w1)
    (Point
g1, Point
g2) = Point -> Point -> (Point, Point)
cornerGradientPoints Point
ocorner Point
icorner

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

    rtl :: Rect
rtl = Double -> Double -> Double -> Double -> Rect
Rect Double
xl Double
yt Double
hw Double
hh
    rtr :: Rect
rtr = Double -> Double -> Double -> Double -> Rect
Rect (Double
xl Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hw) Double
yt Double
hw Double
hh
    rbr :: Rect
rbr = Double -> Double -> Double -> Double -> Rect
Rect (Double
xl Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hw) (Double
yt Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hh) Double
hw Double
hh
    rbl :: Rect
rbl = Double -> Double -> Double -> Double -> Rect
Rect Double
xl (Double
yt Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hh) Double
hw Double
hh

    validTL :: Double
validTL = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
midw (Maybe RadiusCorner -> Double
radW Maybe RadiusCorner
radTL)
    validTR :: Double
validTR = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
midw (Maybe RadiusCorner -> Double
radW Maybe RadiusCorner
radTR)
    validBR :: Double
validBR = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
midw (Maybe RadiusCorner -> Double
radW Maybe RadiusCorner
radBR)
    validBL :: Double
validBL = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
midw (Maybe RadiusCorner -> Double
radW Maybe RadiusCorner
radBL)

    xt1 :: Double
xt1 = Double
xl Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
validTL
    xt2 :: Double
xt2 = Double
xr Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
validTR

    xb1 :: Double
xb1 = Double
xl Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
validBL
    xb2 :: Double
xb2 = Double
xr Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
validBR

    yl1 :: Double
yl1 = Double
yt Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
validTL
    yl2 :: Double
yl2 = Double
yb Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
validBL

    yr1 :: Double
yr1 = Double
yt Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
validTR
    yr2 :: Double
yr2 = Double
yb Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
validBR
  in do
    (Point
lt1, Point
lt2, Point
tl1, Point
tl2) <- Renderer
-> RectCorner
-> Rect
-> Point
-> Maybe RadiusCorner
-> Maybe BorderSide
-> Maybe BorderSide
-> IO (Point, Point, Point, Point)
drawRoundedCorner Renderer
renderer RectCorner
CornerTL Rect
rtl (Double -> Double -> Point
p2 Double
xt1 Double
yl1) Maybe RadiusCorner
radTL Maybe BorderSide
borL Maybe BorderSide
borT
    (Point
tr1, Point
tr2, Point
rt1, Point
rt2) <- Renderer
-> RectCorner
-> Rect
-> Point
-> Maybe RadiusCorner
-> Maybe BorderSide
-> Maybe BorderSide
-> IO (Point, Point, Point, Point)
drawRoundedCorner Renderer
renderer RectCorner
CornerTR Rect
rtr (Double -> Double -> Point
p2 Double
xt2 Double
yr1) Maybe RadiusCorner
radTR Maybe BorderSide
borT Maybe BorderSide
borR
    (Point
rb1, Point
rb2, Point
br1, Point
br2) <- Renderer
-> RectCorner
-> Rect
-> Point
-> Maybe RadiusCorner
-> Maybe BorderSide
-> Maybe BorderSide
-> IO (Point, Point, Point, Point)
drawRoundedCorner Renderer
renderer RectCorner
CornerBR Rect
rbr (Double -> Double -> Point
p2 Double
xb2 Double
yr2) Maybe RadiusCorner
radBR Maybe BorderSide
borR Maybe BorderSide
borB
    (Point
bl1, Point
bl2, Point
lb1, Point
lb2) <- Renderer
-> RectCorner
-> Rect
-> Point
-> Maybe RadiusCorner
-> Maybe BorderSide
-> Maybe BorderSide
-> IO (Point, Point, Point, Point)
drawRoundedCorner Renderer
renderer RectCorner
CornerBL Rect
rbl (Double -> Double -> Point
p2 Double
xb1 Double
yl2) Maybe RadiusCorner
radBL Maybe BorderSide
borB Maybe BorderSide
borL

    Renderer
-> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO ()
drawQuad Renderer
renderer Point
lb1 Point
lt1 Point
lt2 Point
lb2 Maybe BorderSide
borL
    Renderer
-> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO ()
drawQuad Renderer
renderer Point
tl1 Point
tr1 Point
tr2 Point
tl2 Maybe BorderSide
borT
    Renderer
-> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO ()
drawQuad Renderer
renderer Point
rt1 Point
rb1 Point
rb2 Point
rt2 Maybe BorderSide
borR
    Renderer
-> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO ()
drawQuad Renderer
renderer Point
br1 Point
bl1 Point
bl2 Point
br2 Maybe BorderSide
borB

drawRoundedCorner
  :: Renderer
  -> RectCorner
  -> Rect
  -> Point
  -> Maybe RadiusCorner
  -> Maybe BorderSide
  -> Maybe BorderSide
  -> IO (Point, Point, Point, Point)
drawRoundedCorner :: Renderer
-> RectCorner
-> Rect
-> Point
-> Maybe RadiusCorner
-> Maybe BorderSide
-> Maybe BorderSide
-> IO (Point, Point, Point, Point)
drawRoundedCorner Renderer
_ RectCorner
_ Rect
_ Point
center Maybe RadiusCorner
_ Maybe BorderSide
Nothing Maybe BorderSide
Nothing = (Point, Point, Point, Point) -> IO (Point, Point, Point, Point)
forall (m :: * -> *) a. Monad m => a -> m a
return (Point, Point, Point, Point)
points where
  points :: (Point, Point, Point, Point)
points = (Point
center, Point
center, Point
center, Point
center)
drawRoundedCorner Renderer
renderer RectCorner
cor Rect
bounds Point
ocenter Maybe RadiusCorner
mrcor Maybe BorderSide
ms1 Maybe BorderSide
ms2 = do
  Renderer -> IO ()
beginPath Renderer
renderer

  if Color
color1 Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
color2
    then Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
color1
    else Renderer -> Point -> Point -> Color -> Color -> IO ()
setFillLinearGradient Renderer
renderer Point
g1 Point
g2 Color
color1 Color
color2

  if Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round Double
orad Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
    then Renderer -> RectCorner -> Point -> Double -> Double -> IO ()
drawRectArc Renderer
renderer RectCorner
cor Point
icenter Double
w1 Double
w2
    else Renderer -> Point -> Double -> Double -> Double -> Winding -> IO ()
renderArc Renderer
renderer Point
ocenter Double
orad Double
deg (Double
deg Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
90) Winding
CCW

  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
o1

  if Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round Double
orad Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round Double
irad Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0
    then do
      Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
i1
      Renderer -> Point -> Double -> Double -> Double -> Winding -> IO ()
renderArc Renderer
renderer Point
icenter Double
irad (Double
deg Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
90) Double
deg Winding
CW
      Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
i2
    else do
      Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
icenter

  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
o2

  Renderer -> IO ()
closePath Renderer
renderer
  Renderer -> IO ()
fill Renderer
renderer

  (Point, Point, Point, Point) -> IO (Point, Point, Point, Point)
forall (m :: * -> *) a. Monad m => a -> m a
return (Point, Point, Point, Point)
bordersCorners
  where
    Point Double
ocx Double
ocy = Point
ocenter
    Point Double
icx Double
icy = Point
icenter
    rcor :: RadiusCorner
rcor = RadiusCorner -> Maybe RadiusCorner -> RadiusCorner
forall a. a -> Maybe a -> a
fromMaybe RadiusCorner
forall a. Default a => a
def Maybe RadiusCorner
mrcor
    s1 :: BorderSide
s1 = BorderSide -> Maybe BorderSide -> BorderSide
forall a. a -> Maybe a -> a
fromMaybe BorderSide
forall a. Default a => a
def Maybe BorderSide
ms1
    s2 :: BorderSide
s2 = BorderSide -> Maybe BorderSide -> BorderSide
forall a. a -> Maybe a -> a
fromMaybe BorderSide
forall a. Default a => a
def Maybe BorderSide
ms2
    w1 :: Double
w1 = BorderSide -> Double
_bsWidth BorderSide
s1
    w2 :: Double
w2 = BorderSide -> Double
_bsWidth BorderSide
s2
    color1 :: Color
color1 = BorderSide -> Color
_bsColor (Maybe BorderSide -> BorderSide
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe BorderSide
ms1 Maybe BorderSide -> Maybe BorderSide -> Maybe BorderSide
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe BorderSide
ms2))
    color2 :: Color
color2 = BorderSide -> Color
_bsColor (Maybe BorderSide -> BorderSide
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe BorderSide
ms2 Maybe BorderSide -> Maybe BorderSide -> Maybe BorderSide
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe BorderSide
ms1))
    minW :: Double
minW = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
w1 Double
w2

    orad :: Double
orad = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (RadiusCorner -> Double
_rcrWidth RadiusCorner
rcor)
    irad :: Double
irad = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
minW)
    omax1 :: Double
omax1 = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
orad Double
w1
    omax2 :: Double
omax2 = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
orad Double
w2

    cxmin :: Double
cxmin = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
ocx Double
icx
    cxmax :: Double
cxmax = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
ocx Double
icx
    cymin :: Double
cymin = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
ocy Double
icy
    cymax :: Double
cymax = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
ocy Double
icy

    restrict :: (Point, Point) -> (Point, Point)
restrict (Point
p1, Point
p2) = (Rect -> Point -> Point
rectBoundedPoint Rect
bounds Point
p1, Rect -> Point -> Point
rectBoundedPoint Rect
bounds Point
p2)
    (Double
deg, Point
icenter) = case RectCorner
cor of
      RectCorner
CornerTL -> (Double
270, Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
irad) (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
irad))
      RectCorner
CornerTR -> (  Double
0, Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
irad) (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
irad))
      RectCorner
CornerBR -> ( Double
90, Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
irad) (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
irad))
      RectCorner
CornerBL -> (Double
180, Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
irad) (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
irad))
    (Point
o1, Point
o2) = (Point, Point) -> (Point, Point)
restrict ((Point, Point) -> (Point, Point))
-> (Point, Point) -> (Point, Point)
forall a b. (a -> b) -> a -> b
$ case RectCorner
cor of
      RectCorner
CornerTL -> (Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
omax1) Double
cymax, Double -> Double -> Point
Point Double
cxmax (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
omax2))
      RectCorner
CornerTR -> (Double -> Double -> Point
Point Double
cxmin (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
omax2), Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
omax1) Double
cymax)
      RectCorner
CornerBR -> (Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
omax1) Double
cymin, Double -> Double -> Point
Point Double
cxmin (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
omax2))
      RectCorner
CornerBL -> (Double -> Double -> Point
Point Double
cxmax (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
omax2), Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
omax1) Double
cymin)
    (Point
i1, Point
i2) = (Point, Point) -> (Point, Point)
restrict ((Point, Point) -> (Point, Point))
-> (Point, Point) -> (Point, Point)
forall a b. (a -> b) -> a -> b
$ case RectCorner
cor of
      RectCorner
CornerTL -> (Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w1) Double
cymax, Double -> Double -> Point
Point Double
cxmax (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w2))
      RectCorner
CornerTR -> (Double -> Double -> Point
Point Double
cxmin (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w1), Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w2) Double
cymax)
      RectCorner
CornerBR -> (Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w1) Double
cymin, Double -> Double -> Point
Point Double
cxmin (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w2))
      RectCorner
CornerBL -> (Double -> Double -> Point
Point Double
cxmax (Double
ocy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w1), Double -> Double -> Point
Point (Double
ocx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
orad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w2) Double
cymin)
    bordersCorners :: (Point, Point, Point, Point)
bordersCorners
      | Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round Double
orad Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = (Point
o1, Point
icenter, Point
o2, Point
icenter)
      | Bool
otherwise = (Point
o1, Point
i1, Point
o2, Point
i2)
    ocorner :: Point
ocorner = Double -> Double -> Point
Point (Point
o1 Point -> Getting Double Point Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Point Double
forall s a. HasX s a => Lens' s a
L.x) (Point
o2 Point -> Getting Double Point Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Point Double
forall s a. HasY s a => Lens' s a
L.y)
    icorner :: Point
icorner = Double -> Double -> Point
Point (Point
o2 Point -> Getting Double Point Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Point Double
forall s a. HasX s a => Lens' s a
L.x) (Point
o1 Point -> Getting Double Point Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Point Double
forall s a. HasY s a => Lens' s a
L.y)
    (Point
g1, Point
g2)
      | RectCorner
cor RectCorner -> [RectCorner] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RectCorner
CornerTL, RectCorner
CornerBR] = Point -> Point -> (Point, Point)
cornerGradientPoints Point
ocorner Point
icorner
      | Bool
otherwise = Point -> Point -> (Point, Point)
cornerGradientPoints Point
icorner Point
ocorner

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

drawQuad :: Renderer -> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO ()
drawQuad :: Renderer
-> Point -> Point -> Point -> Point -> Maybe BorderSide -> IO ()
drawQuad Renderer
renderer Point
p1 Point
p2 Point
p3 Point
p4 Maybe BorderSide
Nothing = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
drawQuad Renderer
renderer Point
p1 Point
p2 Point
p3 Point
p4 (Just BorderSide{Double
Color
_bsColor :: Color
_bsWidth :: Double
_bsColor :: BorderSide -> Color
_bsWidth :: BorderSide -> Double
..}) = do
  Renderer -> IO ()
beginPath Renderer
renderer
  Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
_bsColor
  Renderer -> Point -> IO ()
moveTo Renderer
renderer Point
p1
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
p2
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
p3
  Renderer -> Point -> IO ()
renderLineTo Renderer
renderer Point
p4
  Renderer -> IO ()
closePath Renderer
renderer
  Renderer -> IO ()
fill Renderer
renderer

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

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

radW :: Maybe RadiusCorner -> Double
radW :: Maybe RadiusCorner -> Double
radW Maybe RadiusCorner
r = RadiusCorner -> Double
_rcrWidth (RadiusCorner -> Maybe RadiusCorner -> RadiusCorner
forall a. a -> Maybe a -> a
fromMaybe RadiusCorner
forall a. Default a => a
def Maybe RadiusCorner
r)

fixRadius :: Rect -> Radius -> Radius
fixRadius :: Rect -> Radius -> Radius
fixRadius (Rect Double
_ Double
_ Double
w Double
h) (Radius Maybe RadiusCorner
tl Maybe RadiusCorner
tr Maybe RadiusCorner
bl Maybe RadiusCorner
br) = Radius
newRadius where
  fixC :: RadiusCorner -> RadiusCorner
fixC (RadiusCorner Double
cwidth)
    | Double
cwidth Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
w Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2= Double -> RadiusCorner
RadiusCorner Double
cwidth
    | Bool
otherwise = Double -> RadiusCorner
RadiusCorner (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
w Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
  newRadius :: Radius
newRadius = Maybe RadiusCorner
-> Maybe RadiusCorner
-> Maybe RadiusCorner
-> Maybe RadiusCorner
-> Radius
Radius (RadiusCorner -> RadiusCorner
fixC (RadiusCorner -> RadiusCorner)
-> Maybe RadiusCorner -> Maybe RadiusCorner
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RadiusCorner
tl) (RadiusCorner -> RadiusCorner
fixC (RadiusCorner -> RadiusCorner)
-> Maybe RadiusCorner -> Maybe RadiusCorner
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RadiusCorner
tr) (RadiusCorner -> RadiusCorner
fixC (RadiusCorner -> RadiusCorner)
-> Maybe RadiusCorner -> Maybe RadiusCorner
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RadiusCorner
bl) (RadiusCorner -> RadiusCorner
fixC (RadiusCorner -> RadiusCorner)
-> Maybe RadiusCorner -> Maybe RadiusCorner
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RadiusCorner
br)