{-# OPTIONS_GHC -Wno-duplicate-exports #-}

-- | Cairo drawing backend.
module Draw (
    -- * SVG and PNG file handling
      render
    , CoordinateSystem(..)
    , coordinateSystem
    , haddockRender

    -- * Drawing presets
    , moveToVec
    , lineToVec
    , Sketch(..)
    , Arrow(..)
    , ArrowSpec(..)
    , Circle(..)
    , Cross(..)
    , PolyBezier(..)
    , arcSketch
    , arcSketchNegative

    -- * Colors
    , Colour, Color
    , AlphaColour, AlphaColor
    , CairoColor(..)
    , module Draw.Color

    -- ** Discrete color schemes
    -- $discreteColorSchemes
    , module Draw.Color.Schemes.Discrete

    -- ** Continuous color schemes
    -- $continuousColorSchemes
    , module Draw.Color.Schemes.Continuous

    -- * Temporary Cairo modifications
    , withOperator
    , cairoScope
    , grouped

    -- * Orientation helpers
    , cartesianCoordinateSystem
    , CartesianParams(..)
    , radialCoordinateSystem
    , PolarParams(..)

    -- * Transformations
    , fromCairoMatrix
    , toCairoMatrix

    -- * Text
    , module Draw.Text

    -- * Convenience
    , for_
    , module Data.Foldable
    , module Data.Default.Class
) where



import           Control.Monad
import qualified Data.ByteString.Lazy            as BSL
import           Data.Default.Class
import           Data.Foldable
import           Data.Int
import           Data.List
import           Graphics.Rendering.Cairo        as C hiding (x, y)
import           Graphics.Rendering.Cairo.Matrix (Matrix (..))
import           System.Directory
import           System.FilePath
import           Text.Printf

import Data.Crc32
import Draw.Color
import Draw.Color.Schemes.Continuous
import Draw.Color.Schemes.Discrete
import Draw.NormalizeSvg
import Draw.Text
import Geometry                      as G



withSurface
    :: OutputFormat      -- ^ Output format
    -> FilePath          -- ^ Output file name
    -> Int               -- ^ Canvas width
    -> Int               -- ^ Canvas height
    -> (Surface -> IO a) -- ^ Drawing action, see 'C.renderWith'
    -> IO a
withSurface :: forall a.
OutputFormat -> String -> Int -> Int -> (Surface -> IO a) -> IO a
withSurface OutputFormat
PNG String
file Int
w Int
h Surface -> IO a
action = Format -> Int -> Int -> (Surface -> IO a) -> IO a
forall a. Format -> Int -> Int -> (Surface -> IO a) -> IO a
withImageSurface Format
FormatARGB32 Int
w Int
h ((Surface -> IO a) -> IO a) -> (Surface -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Surface
surface -> do
    a
result <- Surface -> IO a
action Surface
surface
    Surface -> String -> IO ()
surfaceWriteToPNG Surface
surface String
file
    a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
withSurface OutputFormat
SVG String
file Int
w Int
h Surface -> IO a
draw = String -> Double -> Double -> (Surface -> IO a) -> IO a
forall a. String -> Double -> Double -> (Surface -> IO a) -> IO a
withSVGSurface String
file (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h) ((Surface -> IO a) -> IO a) -> (Surface -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Surface
surface -> do
    Surface -> SvgUnit -> IO ()
forall (m :: * -> *). MonadIO m => Surface -> SvgUnit -> m ()
svgSurfaceSetDocumentUnit Surface
surface SvgUnit
SvgUnitPx
    Surface -> IO a
draw Surface
surface

data OutputFormat = PNG | SVG

-- | Auto-detects the 'OutputFormat' based on the file extension.
fromExtension :: String -> OutputFormat
fromExtension :: String -> OutputFormat
fromExtension String
filePath
    | String
".png" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
filePath = OutputFormat
PNG
    | String
".svg" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
filePath = OutputFormat
SVG
    | Bool
otherwise = String -> OutputFormat
forall a. HasCallStack => String -> a
error (String
"Unknown file extension: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
filePath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", expecting .png or .svg")

-- | Renders the drawing as PNG or SVG, depending on the file extension.
render
    :: FilePath
    -> Int -- ^ Height (px)
    -> Int -- ^ Width (px)
    -> Render ()
    -> IO ()
render :: String -> Int -> Int -> Render () -> IO ()
render String
filepath Int
w Int
h Render ()
actions = do
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
filepath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/")
    OutputFormat -> String -> Int -> Int -> (Surface -> IO ()) -> IO ()
forall a.
OutputFormat -> String -> Int -> Int -> (Surface -> IO a) -> IO a
withSurface (String -> OutputFormat
fromExtension String
filepath) String
filepath Int
w Int
h (\Surface
surface -> Surface -> Render () -> IO ()
forall (m :: * -> *) a. MonadIO m => Surface -> Render a -> m a
renderWith Surface
surface Render ()
actions)

-- | Argument to 'coordinateSystem' to pick zero location and axis direction.
data CoordinateSystem
    = CairoStandard_ZeroTopLeft_XRight_YDown

        -- ^ __Left-handed coordinate system.__ Standard Cairo/computer graphics
        -- coordinates. Zero is on the top left, and the Y axis points downwards.
        -- Even though this is common in computer graphics, working geometrically
        -- with a left-handed coordinate system can be a bit awkward and
        -- surprising.
        --
        -- <<docs/haddock/Draw/coordinate_system_cairo_standard.svg>>
        --
        -- === __(image code)__
        -- >>> :{
        -- haddockRender "Draw/coordinate_system_cairo_standard.svg" 200 160 $ \_ -> do
        --     coordinateSystem CairoStandard_ZeroTopLeft_XRight_YDown
        --     cairoScope $ do
        --         sketch (Arrow (angledLine (Vec2 10 10) (deg 0) 180) def)
        --         sketch (Arrow (angledLine (Vec2 10 10) (deg 90) 140) def)
        --         stroke
        --     cairoScope $ do
        --         C.translate 10 10
        --         setColor (mma 1)
        --         let radius = 40
        --         arc 0 0 radius 0 (pi/2)
        --         sketch (Arrow (lineReverse (angledLine (Vec2 0 radius) (deg (-7)) 10))
        --                       def {_arrowDrawBody=False})
        --         stroke
        -- :}
        -- Generated file: size 2KB, crc32: 0x22a87e3e

    | MathStandard_ZeroBottomLeft_XRight_YUp Double
        -- ^ __Right-handed coordinate system.__ Standard math coordinates, with
        -- zero on the bottom left. Needs the image’s height as arguments for
        -- technical reasons.
        --
        -- <<docs/haddock/Draw/coordinate_system_math_standard.svg>>
        --
        -- === __(image code)__
        -- >>> :{
        -- haddockRender "Draw/coordinate_system_math_standard.svg" 200 160 $ \_ -> do
        --     coordinateSystem (MathStandard_ZeroBottomLeft_XRight_YUp 160)
        --     cairoScope $ do
        --         sketch (Arrow (angledLine (Vec2 10 10) (deg 0) 180) def)
        --         sketch (Arrow (angledLine (Vec2 10 10) (deg 90) 140) def)
        --         stroke
        --     cairoScope $ do
        --         C.translate 10 10
        --         setColor (mma 1)
        --         let radius = 40
        --         arc 0 0 radius 0 (pi/2)
        --         sketch (Arrow (lineReverse (angledLine (Vec2 0 radius) (deg (-7)) 10))
        --                       def {_arrowDrawBody=False})
        --         stroke
        -- :}
        -- Generated file: size 3KB, crc32: 0xd33a20ee

    | MathStandard_ZeroCenter_XRight_YUp Double Double
        -- ^ __Right-handed coordinate system.__ Standard math coordinates, with
        -- zero in the center. Needs the image’s width and height as arguments for
        -- technical reasons.
        --
        -- <<docs/haddock/Draw/coordinate_system_math_standard_centered.svg>>
        --
        -- === __(image code)__
        -- >>> :{
        -- haddockRender "Draw/coordinate_system_math_standard_centered.svg" 200 160 $ \(Vec2 w h) -> do
        --     coordinateSystem (MathStandard_ZeroCenter_XRight_YUp w h)
        --     cairoScope $ do
        --         sketch (Arrow (centerLine (Line (Vec2 0 0) (Vec2 (w-20) 0))) def)
        --         sketch (Arrow (centerLine (Line (Vec2 0 0) (Vec2 0 (h-20)))) def)
        --         stroke
        --     cairoScope $ do
        --         setColor (mma 1)
        --         let radius = 40
        --         arc 0 0 radius 0 (pi/2)
        --         sketch (Arrow (lineReverse (angledLine (Vec2 0 radius) (deg (-5)) 10))
        --                       def {_arrowDrawBody=False})
        --         stroke
        -- :}
        -- Generated file: size 3KB, crc32: 0xe6e10f11

    deriving (CoordinateSystem -> CoordinateSystem -> Bool
(CoordinateSystem -> CoordinateSystem -> Bool)
-> (CoordinateSystem -> CoordinateSystem -> Bool)
-> Eq CoordinateSystem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CoordinateSystem -> CoordinateSystem -> Bool
== :: CoordinateSystem -> CoordinateSystem -> Bool
$c/= :: CoordinateSystem -> CoordinateSystem -> Bool
/= :: CoordinateSystem -> CoordinateSystem -> Bool
Eq, Eq CoordinateSystem
Eq CoordinateSystem
-> (CoordinateSystem -> CoordinateSystem -> Ordering)
-> (CoordinateSystem -> CoordinateSystem -> Bool)
-> (CoordinateSystem -> CoordinateSystem -> Bool)
-> (CoordinateSystem -> CoordinateSystem -> Bool)
-> (CoordinateSystem -> CoordinateSystem -> Bool)
-> (CoordinateSystem -> CoordinateSystem -> CoordinateSystem)
-> (CoordinateSystem -> CoordinateSystem -> CoordinateSystem)
-> Ord CoordinateSystem
CoordinateSystem -> CoordinateSystem -> Bool
CoordinateSystem -> CoordinateSystem -> Ordering
CoordinateSystem -> CoordinateSystem -> CoordinateSystem
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CoordinateSystem -> CoordinateSystem -> Ordering
compare :: CoordinateSystem -> CoordinateSystem -> Ordering
$c< :: CoordinateSystem -> CoordinateSystem -> Bool
< :: CoordinateSystem -> CoordinateSystem -> Bool
$c<= :: CoordinateSystem -> CoordinateSystem -> Bool
<= :: CoordinateSystem -> CoordinateSystem -> Bool
$c> :: CoordinateSystem -> CoordinateSystem -> Bool
> :: CoordinateSystem -> CoordinateSystem -> Bool
$c>= :: CoordinateSystem -> CoordinateSystem -> Bool
>= :: CoordinateSystem -> CoordinateSystem -> Bool
$cmax :: CoordinateSystem -> CoordinateSystem -> CoordinateSystem
max :: CoordinateSystem -> CoordinateSystem -> CoordinateSystem
$cmin :: CoordinateSystem -> CoordinateSystem -> CoordinateSystem
min :: CoordinateSystem -> CoordinateSystem -> CoordinateSystem
Ord, Int -> CoordinateSystem -> String -> String
[CoordinateSystem] -> String -> String
CoordinateSystem -> String
(Int -> CoordinateSystem -> String -> String)
-> (CoordinateSystem -> String)
-> ([CoordinateSystem] -> String -> String)
-> Show CoordinateSystem
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> CoordinateSystem -> String -> String
showsPrec :: Int -> CoordinateSystem -> String -> String
$cshow :: CoordinateSystem -> String
show :: CoordinateSystem -> String
$cshowList :: [CoordinateSystem] -> String -> String
showList :: [CoordinateSystem] -> String -> String
Show)

instance Default CoordinateSystem where
    def :: CoordinateSystem
def = CoordinateSystem
CairoStandard_ZeroTopLeft_XRight_YDown

-- | Choose a coordinate system.
coordinateSystem :: CoordinateSystem -> Render ()
coordinateSystem :: CoordinateSystem -> Render ()
coordinateSystem CoordinateSystem
cosy = do
    Render ()
C.identityMatrix
    case CoordinateSystem
cosy of
        CoordinateSystem
CairoStandard_ZeroTopLeft_XRight_YDown -> () -> Render ()
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        MathStandard_ZeroBottomLeft_XRight_YUp Double
height -> do
            Double -> Double -> Render ()
C.translate Double
0 Double
height
            Double -> Double -> Render ()
C.scale Double
1 (-Double
1)
        MathStandard_ZeroCenter_XRight_YUp Double
width Double
height -> do
            Double -> Double -> Render ()
C.translate Double
0 Double
height
            Double -> Double -> Render ()
C.scale Double
1 (-Double
1)
            Double -> Double -> Render ()
C.translate (Double
widthDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (Double
heightDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)

-- | Render pictures for Haddock with doctests. Nomenclature: the 'FilePath' for
-- /Foo.Bar.Baz/ is /Foo\/Bar\/Baz\/pic_name.svg/.
--
-- Prints status information about the generated file so that doctests fail when
-- the file contents change. Inspect the new output and update the output if the
-- result is OK.
haddockRender
    :: FilePath
    -> Int -- ^ Image width (px)
    -> Int -- ^ Image height (px)
    -> (Vec2 -> Render ())
        -- ^ The width/height of the image is passed as 'Double'-based 'Vec2's to the
        -- rendering function for convenience. This makes it easier to write images
        -- that scale with changes in the width/height parameters.
    -> IO ()
haddockRender :: String -> Int -> Int -> (Vec2 -> Render ()) -> IO ()
haddockRender String
filename Int
w Int
h Vec2 -> Render ()
actions = do
    let filepath :: String
filepath = String
"docs/haddock/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filename
    String -> Int -> Int -> Render () -> IO ()
render String
filepath Int
w Int
h (Render () -> IO ()) -> Render () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        CoordinateSystem -> Render ()
coordinateSystem (Double -> CoordinateSystem
MathStandard_ZeroBottomLeft_XRight_YUp (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h))
        Int -> Int -> Render ()
haddockGrid Int
w Int
h

        do -- Set defaults
            Double -> Render ()
C.setLineWidth Double
1.5
            Color Double -> Render ()
forall color. CairoColor color => color -> Render ()
setColor (Int -> Color Double
mma Int
0)
            [Double] -> Double -> Render ()
C.setDash [] Double
0
            Double -> Render ()
C.setTolerance Double
0.1 -- 0.1 is Cairo’s default
            Antialias -> Render ()
C.setAntialias Antialias
C.AntialiasDefault
            LineCap -> Render ()
C.setLineCap LineCap
C.LineCapRound
            LineJoin -> Render ()
C.setLineJoin LineJoin
C.LineJoinRound
            FillRule -> Render ()
C.setFillRule FillRule
C.FillRuleWinding

        -- We return the matrix so we can paint the 'haddockAxes' correctly below
        Matrix
matrix <- Render Matrix -> Render Matrix
forall a. Render a -> Render a
cairoScope (Render Matrix -> Render Matrix) -> Render Matrix -> Render Matrix
forall a b. (a -> b) -> a -> b
$ do
            Vec2 -> Render ()
actions (Double -> Double -> Vec2
Vec2 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h))
            Render Matrix
getMatrix

        Render () -> Render ()
forall a. Render a -> Render a
cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
            Matrix -> Render ()
setMatrix Matrix
matrix
            Vec2 -> Double -> Render ()
haddockAxes (Double -> Double -> Vec2
Vec2 Double
5 Double
5) Double
15

    String -> IO ()
normalizeSvgFile String
filepath
    String -> IO ()
haddockPrintInfo String
filepath

haddockGrid :: Int -> Int -> Render ()
haddockGrid :: Int -> Int -> Render ()
haddockGrid Int
w Int
h = Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
grouped (Double -> Render ()
paintWithAlpha Double
0.1) (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
    let i :: Int -> Double
i = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral
        xLine :: Int -> Render ()
xLine Int
y = Line -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Vec2 -> Vec2 -> Line
Line (Double -> Double -> Vec2
Vec2 Double
0 (Int -> Double
i Int
y)) (Double -> Double -> Vec2
Vec2 (Int -> Double
i Int
w) (Int -> Double
i Int
y)))
        yLine :: Int -> Render ()
yLine Int
x = Line -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Vec2 -> Vec2 -> Line
Line (Double -> Double -> Vec2
Vec2 (Int -> Double
i Int
x) Double
0) (Double -> Double -> Vec2
Vec2 (Int -> Double
i Int
x) (Int -> Double
i Int
h)))
    [Double] -> Double -> Render ()
setDash [Double
5,Double
5] Double
2.5
    [Int] -> (Int -> Render ()) -> Render ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0, Int
10 .. Int
h] Int -> Render ()
xLine
    [Int] -> (Int -> Render ()) -> Render ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0, Int
10 .. Int
w] Int -> Render ()
yLine
    Double -> Render ()
setLineWidth Double
0.7
    Render ()
stroke

haddockAxes :: Vec2 -> Double -> Render ()
haddockAxes :: Vec2 -> Double -> Render ()
haddockAxes Vec2
start Double
len = Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
grouped (Double -> Render ()
paintWithAlpha Double
0.5) (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
    Double
yDirection <- do
        -- >0 ==> y down on screen
        -- <0 ==> y up on screen
        Matrix Double
_xx Double
_yx Double
_xy Double
yy Double
_x0 Double
_y0 <- Render Matrix
C.getMatrix
        Double -> Render Double
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
yy
    Double -> Render ()
C.setLineWidth Double
0.5
    Colour Integer -> Render ()
forall color. CairoColor color => color -> Render ()
setColor Colour Integer
forall a. Num a => Colour a
black
    [Arrow] -> Render ()
forall a. Sketch a => a -> Render ()
sketch [Arrow]
arrows
    [Line] -> Render ()
forall a. Sketch a => a -> Render ()
sketch [Line]
xSymbol
    [Line] -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Double -> [Line]
forall {p}. (Ord p, Num p) => p -> [Line]
ySymbol Double
yDirection)
    Render ()
stroke
  where
    arrows :: [Arrow]
arrows =
        let arrowSpec :: ArrowSpec
arrowSpec = ArrowSpec
forall a. Default a => a
def { _arrowheadSize :: Double
_arrowheadSize = Double
3 }
            xLine :: Line
xLine = Vec2 -> Vec2 -> Line
Line Vec2
forall v. VectorSpace v => v
zero (Double -> Double -> Vec2
Vec2 Double
len Double
0)
            yLine :: Line
yLine = Vec2 -> Vec2 -> Line
Line Vec2
forall v. VectorSpace v => v
zero (Double -> Double -> Vec2
Vec2 Double
0 Double
len)
        in [Line -> ArrowSpec -> Arrow
Arrow (Transformation -> Line -> Line
forall geo. Transform geo => Transformation -> geo -> geo
G.transform (Vec2 -> Transformation
G.translate Vec2
start) Line
line) ArrowSpec
arrowSpec | Line
line <- [Line
xLine, Line
yLine]]
    xSymbol :: [Line]
xSymbol =
        let angle :: Angle
angle = Double -> Angle
deg Double
55
            lx :: Double
lx = Double
2.6
            x' :: [Line]
x' = [ Line -> Line
centerLine (Vec2 -> Angle -> Double -> Line
angledLine Vec2
forall v. VectorSpace v => v
zero Angle
angle Double
lx)
                 , Line -> Line
centerLine (Vec2 -> Angle -> Double -> Line
angledLine Vec2
forall v. VectorSpace v => v
zero (Double -> Angle
deg Double
180 Angle -> Angle -> Angle
forall v. VectorSpace v => v -> v -> v
-. Angle
angle) Double
lx)
                 ]
        in Transformation -> [Line] -> [Line]
forall geo. Transform geo => Transformation -> geo -> geo
G.transform (Vec2 -> Transformation
G.translate (Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 (Double
lenDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
5) Double
0) Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Double -> Transformation
G.scale Double
2) [Line]
x'

    -- When the y axis is flipped, we need to flip the y symbol as well. (We don’t
    -- need this for the x symbol because it’s symmetric.)
    ySymbol :: p -> [Line]
ySymbol p
yDirection =
        let angle :: Angle
angle = Double -> Angle
deg Double
55
            ly :: Double
ly = Double
3
            y' :: [Line]
y' = [ Line -> Line
centerLine (Vec2 -> Angle -> Double -> Line
angledLine Vec2
forall v. VectorSpace v => v
zero Angle
angle Double
ly)
                 , Vec2 -> Angle -> Double -> Line
angledLine Vec2
forall v. VectorSpace v => v
zero (Double -> Angle
deg Double
180 Angle -> Angle -> Angle
forall v. VectorSpace v => v -> v -> v
-. Angle
angle) (Double
lyDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)
                 ]
            directionFlip :: Transformation
directionFlip | p
yDirection p -> p -> Bool
forall a. Ord a => a -> a -> Bool
< p
0 = Transformation
forall a. Monoid a => a
mempty
                          | Bool
otherwise      = Transformation
mirrorYCoords
        in Transformation -> [Line] -> [Line]
forall geo. Transform geo => Transformation -> geo -> geo
G.transform (Vec2 -> Transformation
G.translate (Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 Double
0 (Double
lenDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
5)) Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Double -> Transformation
G.scale Double
2 Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation
directionFlip) [Line]
y'

haddockPrintInfo :: FilePath -> IO ()
haddockPrintInfo :: String -> IO ()
haddockPrintInfo String
filepath = do
    ByteString
contents <- String -> IO ByteString
BSL.readFile String
filepath
    String -> String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"Generated file: size %s, crc32: %s" (Int64 -> String
humanFilesize (ByteString -> Int64
BSL.length ByteString
contents)) (Crc32 -> String
forall a. Show a => a -> String
show (ByteString -> Crc32
crc32 ByteString
contents))

humanFilesize :: Int64 -> String
humanFilesize :: Int64 -> String
humanFilesize = [String] -> Int64 -> String
forall {t}.
(PrintfArg t, Show t, Integral t) =>
[String] -> t -> String
go [String]
suffixes
  where
    go :: [String] -> t -> String
go [] t
size = String -> t -> String
forall r. PrintfType r => String -> r
printf String
"Oh wow this file is %d byte large I ran out of suffixes" t
size
    go (String
suffix:[String]
rest) t
size
        | t
size t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
1000 = t -> String
forall a. Show a => a -> String
show t
size String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix
        | Bool
otherwise = [String] -> t -> String
go [String]
rest (t
size t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
1000)
    suffixes :: [String]
suffixes = [String
"B", String
"KB", String
"MB", String
"GB", String
"TB", String
"PB"] -- That should suffice.

-- | 'Vec2'-friendly version of Cairo’s 'moveTo'.
moveToVec :: Vec2 -> Render ()
moveToVec :: Vec2 -> Render ()
moveToVec (Vec2 Double
x Double
y) = Double -> Double -> Render ()
moveTo Double
x Double
y

-- | 'Vec2'-friendly version of Cairo’s 'lineTo'.
lineToVec :: Vec2 -> Render ()
lineToVec :: Vec2 -> Render ()
lineToVec (Vec2 Double
x Double
y) = Double -> Double -> Render ()
lineTo Double
x Double
y

-- |
-- <<docs/haddock/Draw/instance_Sketch_Bezier.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/instance_Sketch_Bezier.svg" 150 100 $ \_ -> do
--     C.setLineWidth 2
--     sketch (Bezier (Vec2 10 10) (Vec2 50 200) (Vec2 100 (-50)) (Vec2 140 90))
--     stroke
-- :}
-- Generated file: size 2KB, crc32: 0xe17dab02
instance Sketch Bezier where
    sketch :: Bezier -> Render ()
sketch (Bezier Vec2
start (Vec2 Double
x1 Double
y1) (Vec2 Double
x2 Double
y2) (Vec2 Double
x3 Double
y3)) = do
        Vec2 -> Render ()
moveToVec Vec2
start
        Double
-> Double -> Double -> Double -> Double -> Double -> Render ()
curveTo Double
x1 Double
y1 Double
x2 Double
y2 Double
x3 Double
y3

newtype PolyBezier f = PolyBezier (f Bezier)

-- | Sketch a continuous curve consisting of multiple Bezier segments. The end of
-- each segment is assumed to be the start of the next one.
instance Sequential f => Sketch (PolyBezier f) where
    sketch :: PolyBezier f -> Render ()
sketch (PolyBezier f Bezier
xs) = [Bezier] -> Render ()
go (f Bezier -> [Bezier]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f Bezier
xs)
      where
        go :: [Bezier] -> Render ()
go [] = () -> Render ()
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        go ps :: [Bezier]
ps@(Bezier Vec2
start Vec2
_ Vec2
_ Vec2
_ : [Bezier]
_) = do
            Vec2 -> Render ()
moveToVec Vec2
start
            [Bezier] -> (Bezier -> Render ()) -> Render ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Bezier]
ps ((Bezier -> Render ()) -> Render ())
-> (Bezier -> Render ()) -> Render ()
forall a b. (a -> b) -> a -> b
$ \(Bezier Vec2
_ (Vec2 Double
x1 Double
y1) (Vec2 Double
x2 Double
y2) (Vec2 Double
x3 Double
y3)) -> Double
-> Double -> Double -> Double -> Double -> Double -> Render ()
curveTo Double
x1 Double
y1 Double
x2 Double
y2 Double
x3 Double
y3

data ArrowSpec = ArrowSpec
    { ArrowSpec -> Double
_arrowheadRelPos    :: !Double -- ^ Relative position of the arrow head, from 0 (start) to 1 (end). 0.5 paints the arrow in the center. ('def'ault: 1)
    , ArrowSpec -> Double
_arrowheadSize      :: !Double -- ^ Length of each of the sides of the arrow head. ('def'ault: 10)
    , ArrowSpec -> Bool
_arrowDrawBody      :: !Bool   -- ^ Draw the arrow’s main body line ('True'), or just the tip ('False')? ('def'ault: 'True')
    , ArrowSpec -> Angle
_arrowheadAngle     :: !Angle  -- ^ How pointy should the arrow be? 10° is very pointy, 80° very blunt. ('def'ault: @'rad' 0.5@)
    , ArrowSpec -> Bool
_arrowheadDrawRight :: !Bool   -- ^ Draw the left part of the arrow head? ('def'ault: 'True')
    , ArrowSpec -> Bool
_arrowheadDrawLeft  :: !Bool   -- ^ Draw the right part of the arrow head? ('def'ault: 'True')
    } deriving (ArrowSpec -> ArrowSpec -> Bool
(ArrowSpec -> ArrowSpec -> Bool)
-> (ArrowSpec -> ArrowSpec -> Bool) -> Eq ArrowSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArrowSpec -> ArrowSpec -> Bool
== :: ArrowSpec -> ArrowSpec -> Bool
$c/= :: ArrowSpec -> ArrowSpec -> Bool
/= :: ArrowSpec -> ArrowSpec -> Bool
Eq, Int -> ArrowSpec -> String -> String
[ArrowSpec] -> String -> String
ArrowSpec -> String
(Int -> ArrowSpec -> String -> String)
-> (ArrowSpec -> String)
-> ([ArrowSpec] -> String -> String)
-> Show ArrowSpec
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ArrowSpec -> String -> String
showsPrec :: Int -> ArrowSpec -> String -> String
$cshow :: ArrowSpec -> String
show :: ArrowSpec -> String
$cshowList :: [ArrowSpec] -> String -> String
showList :: [ArrowSpec] -> String -> String
Show)

instance Default ArrowSpec where
    def :: ArrowSpec
def = ArrowSpec
        { _arrowheadRelPos :: Double
_arrowheadRelPos    = Double
1
        , _arrowheadSize :: Double
_arrowheadSize      = Double
10
        , _arrowDrawBody :: Bool
_arrowDrawBody      = Bool
True
        , _arrowheadAngle :: Angle
_arrowheadAngle     = Double -> Angle
rad Double
0.5
        , _arrowheadDrawRight :: Bool
_arrowheadDrawRight = Bool
True
        , _arrowheadDrawLeft :: Bool
_arrowheadDrawLeft  = Bool
True
        }

-- | For 'sketch'ing arrows.
data Arrow = Arrow !Line !ArrowSpec
    deriving (Arrow -> Arrow -> Bool
(Arrow -> Arrow -> Bool) -> (Arrow -> Arrow -> Bool) -> Eq Arrow
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Arrow -> Arrow -> Bool
== :: Arrow -> Arrow -> Bool
$c/= :: Arrow -> Arrow -> Bool
/= :: Arrow -> Arrow -> Bool
Eq, Int -> Arrow -> String -> String
[Arrow] -> String -> String
Arrow -> String
(Int -> Arrow -> String -> String)
-> (Arrow -> String) -> ([Arrow] -> String -> String) -> Show Arrow
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Arrow -> String -> String
showsPrec :: Int -> Arrow -> String -> String
$cshow :: Arrow -> String
show :: Arrow -> String
$cshowList :: [Arrow] -> String -> String
showList :: [Arrow] -> String -> String
Show)

-- |
-- <<docs/haddock/Draw/instance_Sketch_Arrow.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/instance_Sketch_Arrow.svg" 150 100 $ \_ -> do
--     C.setLineWidth 2
--     sketch (Arrow (Line (Vec2 10 10) (Vec2 140 90)) def)
--     stroke
-- :}
-- Generated file: size 2KB, crc32: 0x2c724862
instance Sketch Arrow where
    sketch :: Arrow -> Render ()
sketch (Arrow Line
line ArrowSpec{Bool
Double
Angle
_arrowheadSize :: ArrowSpec -> Double
_arrowheadRelPos :: ArrowSpec -> Double
_arrowDrawBody :: ArrowSpec -> Bool
_arrowheadAngle :: ArrowSpec -> Angle
_arrowheadDrawRight :: ArrowSpec -> Bool
_arrowheadDrawLeft :: ArrowSpec -> Bool
_arrowheadRelPos :: Double
_arrowheadSize :: Double
_arrowDrawBody :: Bool
_arrowheadAngle :: Angle
_arrowheadDrawRight :: Bool
_arrowheadDrawLeft :: Bool
..}) = do
        Bool -> Render () -> Render ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_arrowDrawBody (Line -> Render ()
forall a. Sketch a => a -> Render ()
sketch Line
line)

        let Line Vec2
start Vec2
end = Line
line

            arrowTip :: Vec2
arrowTip = Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. (Double
_arrowheadRelPos Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. (Vec2
end Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
start))

        let arrowheadHalf :: (Angle -> Angle -> Angle) -> Line
arrowheadHalf Angle -> Angle -> Angle
(+-) = Vec2 -> Angle -> Double -> Line
angledLine Vec2
arrowTip (Line -> Angle
angleOfLine Line
line Angle -> Angle -> Angle
forall v. VectorSpace v => v -> v -> v
+. Double -> Angle
rad Double
forall a. Floating a => a
pi Angle -> Angle -> Angle
+- Angle
_arrowheadAngle) Double
_arrowheadSize
            Line Vec2
_ Vec2
arrowLeftEnd  = (Angle -> Angle -> Angle) -> Line
arrowheadHalf Angle -> Angle -> Angle
forall v. VectorSpace v => v -> v -> v
(+.)
            Line Vec2
_ Vec2
arrowRightEnd = (Angle -> Angle -> Angle) -> Line
arrowheadHalf Angle -> Angle -> Angle
forall v. VectorSpace v => v -> v -> v
(-.)
        case (Bool
_arrowheadDrawRight, Bool
_arrowheadDrawLeft) of
            (Bool
True, Bool
True) -> do
                Vec2 -> Render ()
moveToVec Vec2
arrowLeftEnd
                Vec2 -> Render ()
lineToVec Vec2
arrowTip
                Vec2 -> Render ()
lineToVec Vec2
arrowRightEnd
            (Bool
False, Bool
True) -> do
                Vec2 -> Render ()
moveToVec Vec2
arrowLeftEnd
                Vec2 -> Render ()
lineToVec Vec2
arrowTip
            (Bool
True, Bool
False) -> do
                Vec2 -> Render ()
moveToVec Vec2
arrowRightEnd
                Vec2 -> Render ()
lineToVec Vec2
arrowTip
            (Bool
False, Bool
False) -> () -> Render ()
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Sketch a shape that can then be made visible by drawing functions such as 'stroke' or 'fill'.
class Sketch a where
    sketch :: a -> Render ()

instance (Sketch a, Sketch b) => Sketch (Either a b) where
    sketch :: Either a b -> Render ()
sketch (Left a
l) = a -> Render ()
forall a. Sketch a => a -> Render ()
sketch a
l
    sketch (Right b
r) = b -> Render ()
forall a. Sketch a => a -> Render ()
sketch b
r

instance (Sketch a, Sketch b) => Sketch (a,b) where
    sketch :: (a, b) -> Render ()
sketch (a
a,b
b) = a -> Render ()
forall a. Sketch a => a -> Render ()
sketch a
a Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Render ()
forall a. Sketch a => a -> Render ()
sketch b
b

instance (Sketch a, Sketch b, Sketch c) => Sketch (a,b,c) where
    sketch :: (a, b, c) -> Render ()
sketch (a
a,b
b,c
c) = a -> Render ()
forall a. Sketch a => a -> Render ()
sketch a
a Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Render ()
forall a. Sketch a => a -> Render ()
sketch b
b Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> Render ()
forall a. Sketch a => a -> Render ()
sketch c
c

instance (Sketch a, Sketch b, Sketch c, Sketch d) => Sketch (a,b,c,d) where
    sketch :: (a, b, c, d) -> Render ()
sketch (a
a,b
b,c
c,d
d) = a -> Render ()
forall a. Sketch a => a -> Render ()
sketch a
a Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Render ()
forall a. Sketch a => a -> Render ()
sketch b
b Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> Render ()
forall a. Sketch a => a -> Render ()
sketch c
c Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> d -> Render ()
forall a. Sketch a => a -> Render ()
sketch d
d

instance (Sketch a, Sketch b, Sketch c, Sketch d, Sketch e) => Sketch (a,b,c,d,e) where
    sketch :: (a, b, c, d, e) -> Render ()
sketch (a
a,b
b,c
c,d
d,e
e) = a -> Render ()
forall a. Sketch a => a -> Render ()
sketch a
a Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Render ()
forall a. Sketch a => a -> Render ()
sketch b
b Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> Render ()
forall a. Sketch a => a -> Render ()
sketch c
c Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> d -> Render ()
forall a. Sketch a => a -> Render ()
sketch d
d Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> e -> Render ()
forall a. Sketch a => a -> Render ()
sketch e
e

instance Sketch a => Sketch [a] where
    sketch :: [a] -> Render ()
sketch [a]
xs = [a] -> (a -> Render ()) -> Render ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [a]
xs a -> Render ()
forall a. Sketch a => a -> Render ()
sketch

instance Sketch a => Sketch (Maybe a) where
    sketch :: Maybe a -> Render ()
sketch Maybe a
xs = Maybe a -> (a -> Render ()) -> Render ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe a
xs a -> Render ()
forall a. Sketch a => a -> Render ()
sketch

-- |
-- <<docs/haddock/Draw/instance_Sketch_Line.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/instance_Sketch_Line.svg" 150 100 $ \_ -> do
--     C.setLineWidth 2
--     sketch (Line (Vec2 10 10) (Vec2 140 90))
--     stroke
-- :}
-- Generated file: size 2KB, crc32: 0x9287e4a8
instance Sketch Line where
    sketch :: Line -> Render ()
sketch (Line Vec2
start Vec2
end) = do
        Vec2 -> Render ()
moveToVec Vec2
start
        Vec2 -> Render ()
lineToVec Vec2
end

-- | Polyline, i.e. a sequence of lines given by their joints.
--
-- <<docs/haddock/Draw/instance_Sketch_Sequential_Vec2.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/instance_Sketch_Sequential_Vec2.svg" 150 100 $ \_ -> do
--     C.setLineWidth 2
--     sketch (Polyline [Vec2 10 10, Vec2 90 90, Vec2 120 10, Vec2 140 50])
--     stroke
-- :}
-- Generated file: size 2KB, crc32: 0x5d5a0158
instance Sketch Polyline where
    sketch :: Polyline -> Render ()
sketch (Polyline [Vec2]
xs) = [Vec2] -> Render ()
go [Vec2]
xs
      where
        go :: [Vec2] -> Render ()
go [] = () -> Render ()
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        go (Vec2 Double
x0 Double
y0 : [Vec2]
vecs) = do
            Double -> Double -> Render ()
moveTo Double
x0 Double
y0
            [Vec2] -> (Vec2 -> Render ()) -> Render ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Vec2]
vecs (\(Vec2 Double
x Double
y) -> Double -> Double -> Render ()
lineTo Double
x Double
y)

-- |
-- <<docs/haddock/Draw/instance_Sketch_Polygon.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/instance_Sketch_Polygon.svg" 100 100 $ \_ -> do
--     C.setLineWidth 2
--     sketch (Polygon [Vec2 20 10, Vec2 10 80, Vec2 45 45, Vec2 60 90, Vec2 90 30])
--     stroke
-- :}
-- Generated file: size 2KB, crc32: 0x7f620554
instance Sketch Polygon where
    sketch :: Polygon -> Render ()
sketch (Polygon []) = () -> Render ()
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    sketch (Polygon [Vec2]
xs) = Polyline -> Render ()
forall a. Sketch a => a -> Render ()
sketch ([Vec2] -> Polyline
Polyline [Vec2]
xs) Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render ()
closePath

-- |
-- <<docs/haddock/Draw/instance_Sketch_Circle.svg>>
--
-- === __(image code)__
--
-- >>> :{
-- haddockRender "Draw/instance_Sketch_Circle.svg" 200 200 $ \_ -> do
--     sketch (Circle (Vec2 100 100) 90)
--     stroke
-- :}
-- Generated file: size 2KB, crc32: 0x565193fd
instance Sketch Circle where
    sketch :: Circle -> Render ()
sketch (Circle (Vec2 Double
x Double
y) Double
r) = Double -> Double -> Double -> Double -> Double -> Render ()
arc Double
x Double
y Double
r Double
0 (Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
forall a. Floating a => a
pi)

-- |
-- <<docs/haddock/Draw/instance_Sketch_Ellipse.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/instance_Sketch_Ellipse.svg" 150 100 $ \_ -> do
--     C.setLineWidth 2
--     sketch (G.transform (G.translate (Vec2 75 50) <> G.rotate (deg 20) <> G.scale' 1.4 0.9)
--                         (toEllipse (Circle zero 45)))
--     stroke
-- :}
-- Generated file: size 2KB, crc32: 0x25bae2ef
--
instance Sketch Ellipse where
    sketch :: Ellipse -> Render ()
sketch (Ellipse Transformation
t) = Render () -> Render ()
forall a. Render a -> Render a
cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
        Matrix -> Render ()
C.transform (Transformation -> Matrix
toCairoMatrix Transformation
t)
        Circle -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Vec2 -> Double -> Circle
Circle Vec2
forall v. VectorSpace v => v
zero Double
1)

-- | 'sketch' a cross like ×. Sometimes useful to decorate a line with for e.g.
-- strikethrough effects, or to contrast the o in tic tac toe.
--
-- When drawn with the same radius, it combines to ⨂ with a 'Circle'.
data Cross = Cross
    { Cross -> Vec2
_crossCenter :: !Vec2
    , Cross -> Double
_crossRadius :: !Double
    } deriving (Cross -> Cross -> Bool
(Cross -> Cross -> Bool) -> (Cross -> Cross -> Bool) -> Eq Cross
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cross -> Cross -> Bool
== :: Cross -> Cross -> Bool
$c/= :: Cross -> Cross -> Bool
/= :: Cross -> Cross -> Bool
Eq, Eq Cross
Eq Cross
-> (Cross -> Cross -> Ordering)
-> (Cross -> Cross -> Bool)
-> (Cross -> Cross -> Bool)
-> (Cross -> Cross -> Bool)
-> (Cross -> Cross -> Bool)
-> (Cross -> Cross -> Cross)
-> (Cross -> Cross -> Cross)
-> Ord Cross
Cross -> Cross -> Bool
Cross -> Cross -> Ordering
Cross -> Cross -> Cross
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Cross -> Cross -> Ordering
compare :: Cross -> Cross -> Ordering
$c< :: Cross -> Cross -> Bool
< :: Cross -> Cross -> Bool
$c<= :: Cross -> Cross -> Bool
<= :: Cross -> Cross -> Bool
$c> :: Cross -> Cross -> Bool
> :: Cross -> Cross -> Bool
$c>= :: Cross -> Cross -> Bool
>= :: Cross -> Cross -> Bool
$cmax :: Cross -> Cross -> Cross
max :: Cross -> Cross -> Cross
$cmin :: Cross -> Cross -> Cross
min :: Cross -> Cross -> Cross
Ord, Int -> Cross -> String -> String
[Cross] -> String -> String
Cross -> String
(Int -> Cross -> String -> String)
-> (Cross -> String) -> ([Cross] -> String -> String) -> Show Cross
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Cross -> String -> String
showsPrec :: Int -> Cross -> String -> String
$cshow :: Cross -> String
show :: Cross -> String
$cshowList :: [Cross] -> String -> String
showList :: [Cross] -> String -> String
Show)

-- |
-- <<docs/haddock/Draw/instance_Sketch_Cross.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/instance_Sketch_Cross.svg" 90 40 $ \_ -> do
--     C.setLineWidth 2
--     sketch (Cross  (Vec2 20 20) 15) >> stroke
--     sketch (Cross  (Vec2 60 20) 15) >> stroke
--     sketch (Circle (Vec2 60 20) 15) >> stroke
-- :}
-- Generated file: size 2KB, crc32: 0xe2cb8567
instance Sketch Cross where
    sketch :: Cross -> Render ()
sketch (Cross Vec2
center Double
r) = do
        let lowerRight :: Vec2
lowerRight = Transformation -> Vec2 -> Vec2
forall geo. Transform geo => Transformation -> geo -> geo
G.transform (Vec2 -> Angle -> Transformation
rotateAround Vec2
center (Double -> Angle
deg Double
45)) (Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 Double
r Double
0)
            line1 :: Line
line1 = Vec2 -> Angle -> Double -> Line
angledLine Vec2
lowerRight (Double -> Angle
deg (Double
45Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
180)) (Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
r)
            line2 :: Line
line2 = Transformation -> Line -> Line
forall geo. Transform geo => Transformation -> geo -> geo
G.transform (Vec2 -> Angle -> Transformation
rotateAround Vec2
center (Double -> Angle
deg Double
90)) Line
line1
        Line -> Render ()
forall a. Sketch a => a -> Render ()
sketch Line
line1
        Line -> Render ()
forall a. Sketch a => a -> Render ()
sketch Line
line2

-- | Draw a \(100\times 100\) square with its corner at 'zero' and transformed with
-- the 'Transformation', sometimes useful for debugging.
--
-- <<docs/haddock/Draw/instance_Sketch_Transformation.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/instance_Sketch_Transformation.svg" 300 200 $ \_ -> do
--     C.setLineWidth 2
--     setColor (mma 0) >> sketch (G.translate (Vec2 20 20)) >> stroke
--     setColor (mma 1) >> sketch (G.translate (Vec2 110 50) <> G.rotate (deg 30)) >> stroke
--     setColor (mma 2) >> sketch (G.shear 0.5 0.2 <> G.translate (Vec2 140 0)) >> stroke
-- :}
-- Generated file: size 4KB, crc32: 0x1f4ae5da
instance Sketch Transformation where
    sketch :: Transformation -> Render ()
sketch Transformation
t = do
        let grid :: [Line]
grid = [Vec2 -> Vec2 -> Line
Line (Double -> Double -> Vec2
Vec2 Double
0 Double
y) (Double -> Double -> Vec2
Vec2 Double
100 Double
y) | Double
y <- (Integer -> Double) -> [Integer] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Integer
0,Integer
20..Integer
100]]
                [Line] -> [Line] -> [Line]
forall a. [a] -> [a] -> [a]
++ [Vec2 -> Vec2 -> Line
Line (Double -> Double -> Vec2
Vec2 Double
x Double
0) (Double -> Double -> Vec2
Vec2 Double
x Double
100) | Double
x <- (Integer -> Double) -> [Integer] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Integer
0,Integer
20..Integer
100]]
        [Line] -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Transformation -> [Line] -> [Line]
forall geo. Transform geo => Transformation -> geo -> geo
G.transform Transformation
t [Line]
grid)

-- | Sketch part of a circle.
arcSketch
    :: Vec2   -- ^ Center
    -> Double -- ^ Radius
    -> Angle  -- ^ Starting angle (absolute)
    -> Angle  -- ^ Ending angle (absolute)
    -> Render ()
arcSketch :: Vec2 -> Double -> Angle -> Angle -> Render ()
arcSketch (Vec2 Double
x Double
y) Double
r Angle
angleStart Angle
angleEnd
  = Double -> Double -> Double -> Double -> Double -> Render ()
arc Double
x Double
y Double
r (Angle -> Double
getRad Angle
angleStart) (Angle -> Double
getRad Angle
angleEnd)

-- | Sketch part of a circle.
arcSketchNegative
    :: Vec2   -- ^ Center
    -> Double -- ^ Radius
    -> Angle  -- ^ Starting angle (absolute)
    -> Angle  -- ^ Ending angle (absolute)
    -> Render ()
arcSketchNegative :: Vec2 -> Double -> Angle -> Angle -> Render ()
arcSketchNegative (Vec2 Double
x Double
y) Double
r Angle
angleStart Angle
angleEnd
  = Double -> Double -> Double -> Double -> Double -> Render ()
arcNegative Double
x Double
y Double
r (Angle -> Double
getRad Angle
angleStart) (Angle -> Double
getRad Angle
angleEnd)

-- | Sketches a rectangle with a diagonal cross through it. Useful for debugging.
--
-- <<docs/haddock/Draw/instance_Sketch_BoundingBox.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/instance_Sketch_BoundingBox.svg" 100 100 $ \_ -> do
--     let geometry = [Circle (Vec2 30 30) 25, Circle (Vec2 60 60) 35]
--     for_ geometry $ \x -> cairoScope (sketch x >> setColor (mma 1) >> setDash [4,6] 0 >> stroke)
--     sketch (boundingBox geometry)
--     stroke
-- :}
-- Generated file: size 3KB, crc32: 0xfed2c044
instance Sketch BoundingBox where
    sketch :: BoundingBox -> Render ()
sketch (BoundingBox (Vec2 Double
xlo Double
ylo) (Vec2 Double
xhi Double
yhi)) = do
        let w :: Double
w = Double
xhi Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
xlo
            h :: Double
h = Double
yhi Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ylo
        Double -> Double -> Double -> Double -> Render ()
rectangle Double
xlo Double
ylo Double
w Double
h
        Double -> Double -> Render ()
moveTo Double
xlo Double
ylo
        Double -> Double -> Render ()
lineTo Double
xhi Double
yhi
        Double -> Double -> Render ()
moveTo Double
xhi Double
ylo
        Double -> Double -> Render ()
lineTo Double
xlo Double
yhi

data CartesianParams = CartesianParams
    { CartesianParams -> Int
_cartesianMinX    :: !Int
    , CartesianParams -> Int
_cartesianMaxX    :: !Int
    , CartesianParams -> Int
_cartesianMinY    :: !Int
    , CartesianParams -> Int
_cartesianMaxY    :: !Int
    , CartesianParams -> Double
_cartesianAlpha   :: !Double
    , CartesianParams -> Bool
_renderAxisLabels :: !Bool -- ^ Render numbers to the hundreds intersections?
    , CartesianParams -> Bool
_renderTens       :: !Bool -- ^ Render the tens (as crosses)?
    , CartesianParams -> Bool
_renderHundreds   :: !Bool -- ^ Render the hundreds lines more visible?
    } deriving (CartesianParams -> CartesianParams -> Bool
(CartesianParams -> CartesianParams -> Bool)
-> (CartesianParams -> CartesianParams -> Bool)
-> Eq CartesianParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CartesianParams -> CartesianParams -> Bool
== :: CartesianParams -> CartesianParams -> Bool
$c/= :: CartesianParams -> CartesianParams -> Bool
/= :: CartesianParams -> CartesianParams -> Bool
Eq, Eq CartesianParams
Eq CartesianParams
-> (CartesianParams -> CartesianParams -> Ordering)
-> (CartesianParams -> CartesianParams -> Bool)
-> (CartesianParams -> CartesianParams -> Bool)
-> (CartesianParams -> CartesianParams -> Bool)
-> (CartesianParams -> CartesianParams -> Bool)
-> (CartesianParams -> CartesianParams -> CartesianParams)
-> (CartesianParams -> CartesianParams -> CartesianParams)
-> Ord CartesianParams
CartesianParams -> CartesianParams -> Bool
CartesianParams -> CartesianParams -> Ordering
CartesianParams -> CartesianParams -> CartesianParams
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CartesianParams -> CartesianParams -> Ordering
compare :: CartesianParams -> CartesianParams -> Ordering
$c< :: CartesianParams -> CartesianParams -> Bool
< :: CartesianParams -> CartesianParams -> Bool
$c<= :: CartesianParams -> CartesianParams -> Bool
<= :: CartesianParams -> CartesianParams -> Bool
$c> :: CartesianParams -> CartesianParams -> Bool
> :: CartesianParams -> CartesianParams -> Bool
$c>= :: CartesianParams -> CartesianParams -> Bool
>= :: CartesianParams -> CartesianParams -> Bool
$cmax :: CartesianParams -> CartesianParams -> CartesianParams
max :: CartesianParams -> CartesianParams -> CartesianParams
$cmin :: CartesianParams -> CartesianParams -> CartesianParams
min :: CartesianParams -> CartesianParams -> CartesianParams
Ord, Int -> CartesianParams -> String -> String
[CartesianParams] -> String -> String
CartesianParams -> String
(Int -> CartesianParams -> String -> String)
-> (CartesianParams -> String)
-> ([CartesianParams] -> String -> String)
-> Show CartesianParams
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> CartesianParams -> String -> String
showsPrec :: Int -> CartesianParams -> String -> String
$cshow :: CartesianParams -> String
show :: CartesianParams -> String
$cshowList :: [CartesianParams] -> String -> String
showList :: [CartesianParams] -> String -> String
Show)

instance Default CartesianParams where
    def :: CartesianParams
def = CartesianParams
        { _cartesianMinX :: Int
_cartesianMinX    = -Int
1000
        , _cartesianMaxX :: Int
_cartesianMaxX    =  Int
1000
        , _cartesianMinY :: Int
_cartesianMinY    = -Int
1000
        , _cartesianMaxY :: Int
_cartesianMaxY    =  Int
1000
        , _cartesianAlpha :: Double
_cartesianAlpha   =  Double
1
        , _renderAxisLabels :: Bool
_renderAxisLabels =  Bool
True
        , _renderTens :: Bool
_renderTens       =  Bool
True
        , _renderHundreds :: Bool
_renderHundreds   =  Bool
True
        }

-- | Draw a caresian coordinate system in range (x,x') (y,y'). Very useful for
-- prototyping.
--
-- === __(image code)__
--
-- <<docs/haddock/Draw/cartesianCoordinateSystem.svg>>
-- >>> :{
-- haddockRender "Draw/cartesianCoordinateSystem.svg" 320 220 $ \_ -> cartesianCoordinateSystem def
-- :}
-- Generated file: size 21KB, crc32: 0xf43aac0c
cartesianCoordinateSystem :: CartesianParams -> Render ()
cartesianCoordinateSystem :: CartesianParams -> Render ()
cartesianCoordinateSystem params :: CartesianParams
params@CartesianParams{Bool
Double
Int
_cartesianMinX :: CartesianParams -> Int
_cartesianMaxX :: CartesianParams -> Int
_cartesianMinY :: CartesianParams -> Int
_cartesianMaxY :: CartesianParams -> Int
_cartesianAlpha :: CartesianParams -> Double
_renderAxisLabels :: CartesianParams -> Bool
_renderTens :: CartesianParams -> Bool
_renderHundreds :: CartesianParams -> Bool
_cartesianMinX :: Int
_cartesianMaxX :: Int
_cartesianMinY :: Int
_cartesianMaxY :: Int
_cartesianAlpha :: Double
_renderAxisLabels :: Bool
_renderTens :: Bool
_renderHundreds :: Bool
..}  = Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
grouped (Double -> Render ()
paintWithAlpha Double
_cartesianAlpha) (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
    let vec2 :: a -> a -> Vec2
vec2 a
x a
y = Double -> Double -> Vec2
Vec2 (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x) (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y)
    Double -> Render ()
setLineWidth Double
1

    let CartesianParams{_cartesianMinX :: CartesianParams -> Int
_cartesianMinX=Int
minX, _cartesianMaxX :: CartesianParams -> Int
_cartesianMaxX=Int
maxX, _cartesianMinY :: CartesianParams -> Int
_cartesianMinY=Int
minY, _cartesianMaxY :: CartesianParams -> Int
_cartesianMaxY=Int
maxY} = CartesianParams
params

    Bool -> Render () -> Render ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_renderHundreds (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ Render () -> Render ()
forall a. Render a -> Render a
cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
        AlphaColor Double -> Render ()
forall color. CairoColor color => color -> Render ()
setColor (Double -> Double -> Double -> Double -> AlphaColor Double
hsva Double
0 Double
0 Double
0 Double
0.5)
        [Render ()] -> Render ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Line -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Vec2 -> Vec2 -> Line
Line (Int -> Int -> Vec2
forall {a} {a}. (Integral a, Integral a) => a -> a -> Vec2
vec2 Int
x Int
minY) (Int -> Int -> Vec2
forall {a} {a}. (Integral a, Integral a) => a -> a -> Vec2
vec2 Int
x Int
maxY))
                | Int
x <- [Int
minX, Int
minXInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
100 .. Int
maxX] ]
        [Render ()] -> Render ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Line -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Vec2 -> Vec2 -> Line
Line (Int -> Int -> Vec2
forall {a} {a}. (Integral a, Integral a) => a -> a -> Vec2
vec2 Int
minX Int
y) (Int -> Int -> Vec2
forall {a} {a}. (Integral a, Integral a) => a -> a -> Vec2
vec2 Int
maxX Int
y))
                | Int
y <- [Int
minY, Int
minYInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
100 .. Int
maxY] ]
        Render ()
stroke

    Bool -> Render () -> Render ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_renderTens (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ Render () -> Render ()
forall a. Render a -> Render a
cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
        AlphaColor Double -> Render ()
forall color. CairoColor color => color -> Render ()
setColor (Double -> Double -> Double -> Double -> AlphaColor Double
hsva Double
0 Double
0 Double
0 Double
0.2)
        [Double] -> Double -> Render ()
setDash [Double
4,Double
6] Double
2
        let skipHundreds :: a -> Bool
skipHundreds a
i = Bool -> Bool
not Bool
_renderHundreds Bool -> Bool -> Bool
|| a -> a -> a
forall a. Integral a => a -> a -> a
mod a
i a
100 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0
        [Render ()] -> Render ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Line -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Vec2 -> Vec2 -> Line
Line (Int -> Int -> Vec2
forall {a} {a}. (Integral a, Integral a) => a -> a -> Vec2
vec2 Int
x Int
minY) (Int -> Int -> Vec2
forall {a} {a}. (Integral a, Integral a) => a -> a -> Vec2
vec2 Int
x Int
maxY))
                  | Int
x <- [Int
minX, Int
minXInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
10 .. Int
maxX]
                  , Int -> Bool
forall {a}. Integral a => a -> Bool
skipHundreds Int
x ]
        [Render ()] -> Render ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Line -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Vec2 -> Vec2 -> Line
Line (Int -> Int -> Vec2
forall {a} {a}. (Integral a, Integral a) => a -> a -> Vec2
vec2 Int
minX Int
y) (Int -> Int -> Vec2
forall {a} {a}. (Integral a, Integral a) => a -> a -> Vec2
vec2 Int
maxX Int
y))
                  | Int
y <- [Int
minY, Int
minYInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
10 .. Int
maxY]
                  , Int -> Bool
forall {a}. Integral a => a -> Bool
skipHundreds Int
y]
        Render ()
stroke

    Bool -> Render () -> Render ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_renderAxisLabels (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ Render () -> Render ()
forall a. Render a -> Render a
cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
        let centeredText :: Int -> Int -> String -> Render ()
            centeredText :: Int -> Int -> String -> Render ()
centeredText Int
x Int
y String
str = do
                Double -> Double -> Render ()
moveTo (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)
                HAlign -> VAlign -> String -> Render ()
forall string.
CairoString string =>
HAlign -> VAlign -> string -> Render ()
showTextAligned HAlign
HCenter VAlign
VTop String
str
        Double -> Render ()
setFontSize Double
8
        Color Double -> Render ()
forall color. CairoColor color => color -> Render ()
setColor (Int -> Color Double
mma Int
0)
        [Render ()] -> Render ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Int -> Int -> String -> Render ()
centeredText Int
x Int
y (Int -> String
forall a. Show a => a -> String
show Int
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
y)
                | Int
x <- [Int
minX, Int
minXInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
100 .. Int
maxX]
                , Int
y <- [Int
minY, Int
minYInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
100 .. Int
maxY] ]

data PolarParams = PolarParams
    { PolarParams -> Vec2
_polarCenter    :: !Vec2
    , PolarParams -> Double
_polarMaxRadius :: !Double
    , PolarParams -> Double
_polarAlpha     :: !Double
    } deriving (PolarParams -> PolarParams -> Bool
(PolarParams -> PolarParams -> Bool)
-> (PolarParams -> PolarParams -> Bool) -> Eq PolarParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PolarParams -> PolarParams -> Bool
== :: PolarParams -> PolarParams -> Bool
$c/= :: PolarParams -> PolarParams -> Bool
/= :: PolarParams -> PolarParams -> Bool
Eq, Eq PolarParams
Eq PolarParams
-> (PolarParams -> PolarParams -> Ordering)
-> (PolarParams -> PolarParams -> Bool)
-> (PolarParams -> PolarParams -> Bool)
-> (PolarParams -> PolarParams -> Bool)
-> (PolarParams -> PolarParams -> Bool)
-> (PolarParams -> PolarParams -> PolarParams)
-> (PolarParams -> PolarParams -> PolarParams)
-> Ord PolarParams
PolarParams -> PolarParams -> Bool
PolarParams -> PolarParams -> Ordering
PolarParams -> PolarParams -> PolarParams
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PolarParams -> PolarParams -> Ordering
compare :: PolarParams -> PolarParams -> Ordering
$c< :: PolarParams -> PolarParams -> Bool
< :: PolarParams -> PolarParams -> Bool
$c<= :: PolarParams -> PolarParams -> Bool
<= :: PolarParams -> PolarParams -> Bool
$c> :: PolarParams -> PolarParams -> Bool
> :: PolarParams -> PolarParams -> Bool
$c>= :: PolarParams -> PolarParams -> Bool
>= :: PolarParams -> PolarParams -> Bool
$cmax :: PolarParams -> PolarParams -> PolarParams
max :: PolarParams -> PolarParams -> PolarParams
$cmin :: PolarParams -> PolarParams -> PolarParams
min :: PolarParams -> PolarParams -> PolarParams
Ord, Int -> PolarParams -> String -> String
[PolarParams] -> String -> String
PolarParams -> String
(Int -> PolarParams -> String -> String)
-> (PolarParams -> String)
-> ([PolarParams] -> String -> String)
-> Show PolarParams
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> PolarParams -> String -> String
showsPrec :: Int -> PolarParams -> String -> String
$cshow :: PolarParams -> String
show :: PolarParams -> String
$cshowList :: [PolarParams] -> String -> String
showList :: [PolarParams] -> String -> String
Show)

instance Default PolarParams where
    def :: PolarParams
def = PolarParams
        { _polarCenter :: Vec2
_polarCenter    = Vec2
forall v. VectorSpace v => v
zero
        , _polarMaxRadius :: Double
_polarMaxRadius = Double
1000
        , _polarAlpha :: Double
_polarAlpha     = Double
1
        }

-- | Like 'cartesianCoordinateSystem', but with polar coordinates.
--
-- <<docs/haddock/Draw/radialCoordinateSystem.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/radialCoordinateSystem.svg" 250 250 $ \_ -> do
--     C.translate 50 50
--     radialCoordinateSystem def
-- :}
-- Generated file: size 26KB, crc32: 0x9b68b36
radialCoordinateSystem :: PolarParams -> Render ()
radialCoordinateSystem :: PolarParams -> Render ()
radialCoordinateSystem PolarParams{_polarCenter :: PolarParams -> Vec2
_polarCenter=Vec2
center, _polarMaxRadius :: PolarParams -> Double
_polarMaxRadius=Double
maxR} = Render () -> Render ()
forall a. Render a -> Render a
cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
    Double -> Render ()
setLineWidth Double
1
    Color Double -> Render ()
forall color. CairoColor color => color -> Render ()
setColor (Double -> Double -> Double -> Color Double
hsv Double
0 Double
0 Double
0)
    [Render ()] -> Render ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Circle -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Vec2 -> Double -> Circle
Circle Vec2
center (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r)) Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render ()
stroke
              | Int
r <- [Int
100, Int
200 .. Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
maxR :: Int] ]
    [Render ()] -> Render ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Line -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Vec2 -> Angle -> Double -> Line
angledLine Vec2
center (Double -> Angle
deg (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
angle)) Double
maxR) Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render ()
stroke
              | Int
angle <- [Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
init [Int
0, Int
45 .. Int
360 :: Int] ]

    AlphaColor Double -> Render ()
forall color. CairoColor color => color -> Render ()
setColor (Double -> Double -> Double -> Double -> AlphaColor Double
hsva Double
0 Double
0 Double
0 Double
0.5)
    [Render ()] -> Render ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Circle -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Vec2 -> Double -> Circle
Circle Vec2
center (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r)) Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render ()
stroke
              | Int
r <- [Int
25, Int
50 .. Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
maxR :: Int]
              , Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
r Int
100 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 ]
    [Render ()] -> Render ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Line -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Vec2 -> Angle -> Double -> Line
angledLine Vec2
center (Double -> Angle
deg (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
angle)) Double
maxR) Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render ()
stroke
              | Int
angle <- [Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
init [Int
0, Int
15 .. Int
360 :: Int]
              , Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
angle Int
45 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 ]

-- | Temporarily draw using a different composition operator, such as
-- 'OperatorClear' to delete part of an image.
withOperator :: Operator -> Render a -> Render a
withOperator :: forall a. Operator -> Render a -> Render a
withOperator Operator
op Render a
actions = do
    Operator
formerOp <- Render Operator
getOperator
    Operator -> Render ()
setOperator Operator
op
    a
result <- Render a
actions
    Operator -> Render ()
setOperator Operator
formerOp
    a -> Render a
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

-- | Open a new Cairo scope to allow local parameter changes. When the scope
-- closes, the parameters are reset. Cairo documentation hides what actually is in
-- the parameter state remarkably well; the state thus includes
-- [(source)](https://github.com\/freedesktop\/cairo\/blob\/2ec0a874031fdb2f3d7a4eaf1d63740a0e25b268\/src\/cairo-gstate-private.h#L41):
--
--   * Drawing operator ('withOperator')
--   * Tolerance ('setTolerance')
--   * Antialiasing ('setAntialias')
--   * Line style ('setLineWidth', 'setLineCap', 'setLineJoin', 'setMiterLimit', 'setDash')
--   * Fill rule ('setFillRule')
--   * Font face, scaling, options
--   * Clipping ('clip')
--   * Pattern (includes colors\/'setColor', gradients\/'withLinearPattern' etc.)
--   * Tranformation matrix ('C.translate' etc.)
--
-- For example, we can paint the first block with a wide style, the second one
-- dashed, and afterwards fall back to the implicit defaults:
--
-- >>> :{
-- haddockRender "Draw/cairoScope.svg" 200 40 $ \_ -> do
--     let line = Line (Vec2 10 0) (Vec2 190 0)
--     cairoScope $ do
--         C.translate 0 30
--         setLineWidth 3
--         setColor (mma 1)
--         sketch line
--         stroke
--     cairoScope $ do
--         C.translate 0 20
--         setDash [5,3] 0
--         setColor (mma 2)
--         sketch line
--         stroke
--     C.translate 0 10
--     sketch line
--     stroke
-- :}
-- Generated file: size 2KB, crc32: 0x2d7bee90
--
-- <<docs/haddock/Draw/cairoScope.svg>>
cairoScope :: Render a -> Render a
cairoScope :: forall a. Render a -> Render a
cairoScope Render a
actions = Render ()
save Render () -> Render a -> Render a
forall after a. Render after -> Render a -> Render a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Render a
actions Render a -> Render () -> Render a
forall a b. Render a -> Render b -> Render a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Render ()
restore

-- | Render something as a group, as in encapsulate it in 'pushGroup' and
-- 'popGroupToSource'. This function semantically includes a call 'cairoScope'.
--
-- 'grouped' is commonly used to avoid a less transparent area when overlapping two
-- transparent areas.
--
-- The naive way has the intersection of the two circles darker,
--
-- @
-- do
--     'setSourceRGBA' 0 0 0 0.5
--     'sketch' ('Circle' ('Vec2' 0 0) 10)
--     'fill'
--     'sketch' ('Circle' ('Vec2' 7 0) 10)
--     'fill'
-- @
--
-- On the other hand this will have the combination of the entire combined shape
-- drawn with 0.5 alpha:
--
-- @
-- 'grouped' ('paintWithAlpha' 0.5) $ do
--     'setSourceRGBA' 0 0 0 1
--     'sketch' ('Circle' ('Vec2' 0 0) 10)
--     'fill'
--     'sketch' ('Circle' ('Vec2' 7 0) 10)
--     'fill'
-- @
grouped :: Render after -> Render a -> Render a
grouped :: forall after a. Render after -> Render a -> Render a
grouped Render after
afterwards Render a
actions = Render a -> Render a
forall a. Render a -> Render a
cairoScope (Render a -> Render a) -> Render a -> Render a
forall a b. (a -> b) -> a -> b
$ Render ()
pushGroup Render () -> Render a -> Render a
forall after a. Render after -> Render a -> Render a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Render a
actions Render a -> Render () -> Render a
forall a b. Render a -> Render b -> Render a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Render ()
popGroupToSource Render a -> Render after -> Render a
forall a b. Render a -> Render b -> Render a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Render after
afterwards

-- | Translate between Cairo and our matrix representation for transformations.
--
-- Cairo does its transformation in inverse: we transform the geometry, Cairo
-- transforms the canvas. 'fromCairoMatrix' and 'toCairoMatrix' translate between
-- the worlds, so that conceptually both of these yield the same output:
--
-- @
-- trafo :: 'Transformation'
--
-- 'sketch' ('transform' trafo geometry)
-- --
-- 'C.transform' ('fromCairoMatrix' trafo) '>>' 'sketch' geometry
-- @
--
-- __Note__ that Cairo’s 'C.transform' does more than just moving around lines: it
-- also scales other properties such as line width, so the pictures described above
-- might have some differences.
--
-- Useful Cairo functions for working with this are
--
-- @
-- 'C.transform' :: 'C.Matrix' -> 'C.Render' ()
-- 'C.setMatrix' :: 'C.Matrix' -> 'C.Render' ()
-- 'C.getMatrix' :: 'C.Render' 'C.Matrix'
-- @
fromCairoMatrix :: Matrix -> Transformation
fromCairoMatrix :: Matrix -> Transformation
fromCairoMatrix (Matrix Double
ca Double
cb Double
cc Double
cd Double
ce Double
cf) =
    -- According to the Haskell Cairo docs:
    --
    -- > Matrix a b c d e f:
    -- >   / x' \  =  / a c \  / x \  + / e \
    -- >   \ y' /     \ b d /  \ y /    \ f /
    --
    -- Our matrix representation is (copied from the 'Transformation' doc
    -- block in "Geometry.Core"):
    --
    -- > transformation a b c
    -- >                d e f
    -- >
    -- >   / x' \  =  / a b \  / x \  + / c \
    -- >   \ y' /     \ d e /  \ y /    \ f /
    let a :: Double
a = Double
ca
        b :: Double
b = Double
cc
        c :: Double
c = Double
ce
        d :: Double
d = Double
cb
        e :: Double
e = Double
cd
        f :: Double
f = Double
cf
    in Mat2 -> Vec2 -> Transformation
Transformation (Double -> Double -> Double -> Double -> Mat2
Mat2 Double
a Double
b Double
d Double
e) (Double -> Double -> Vec2
Vec2 Double
c Double
f)

-- | See  'fromCairoMatrix'’ documentation, of which 'toCairoMatrix' is the inverse.
toCairoMatrix :: Transformation -> C.Matrix
toCairoMatrix :: Transformation -> Matrix
toCairoMatrix Transformation
trafo =
    let Transformation (Mat2 Double
a Double
b Double
d Double
e) (Vec2 Double
c Double
f) = Transformation
trafo
        ca :: Double
ca = Double
a
        cc :: Double
cc = Double
b
        ce :: Double
ce = Double
c
        cb :: Double
cb = Double
d
        cd :: Double
cd = Double
e
        cf :: Double
cf = Double
f
    in Double -> Double -> Double -> Double -> Double -> Double -> Matrix
Matrix Double
ca Double
cb Double
cc Double
cd Double
ce Double
cf

-- $discreteColorSchemes
--
-- Discrete color schemes, taken from:
--
--  * Mathematica: https://www.wolfram.com/mathematica/
--  * Color Brewer 2: https://colorbrewer2.org/
--
-- +-----------------+--------------------------------------------------------------+---------+
-- | Name            |                                                              | Domain  |
-- +=================+==============================================================+=========+
-- | 'mma'           | <<docs/colors/schemes/discrete/mathematica/ColorData97.svg>> | [0..∞)  |
-- +-----------------+--------------------------------------------------------------+---------+
-- | 'accent'        | <<docs/colors/schemes/discrete/colorbrewer2/accent.svg>>     | [0..7]  |
-- +-----------------+--------------------------------------------------------------+---------+
-- | 'dark2'         | <<docs/colors/schemes/discrete/colorbrewer2/dark2.svg>>      | [0..7]  |
-- +-----------------+--------------------------------------------------------------+---------+
-- | 'paired'        | <<docs/colors/schemes/discrete/colorbrewer2/paired.svg>>     | [0..11] |
-- +-----------------+--------------------------------------------------------------+---------+
-- | 'pastel1'       | <<docs/colors/schemes/discrete/colorbrewer2/pastel1.svg>>    | [0..8]  |
-- +-----------------+--------------------------------------------------------------+---------+
-- | 'pastel2'       | <<docs/colors/schemes/discrete/colorbrewer2/pastel2.svg>>    | [0..7]  |
-- +-----------------+--------------------------------------------------------------+---------+
-- | 'set1'          | <<docs/colors/schemes/discrete/colorbrewer2/set1.svg>>       | [0..8]  |
-- +-----------------+--------------------------------------------------------------+---------+
-- | 'set2'          | <<docs/colors/schemes/discrete/colorbrewer2/set2.svg>>       | [0..7]  |
-- +-----------------+--------------------------------------------------------------+---------+
-- | 'set3'          | <<docs/colors/schemes/discrete/colorbrewer2/set3.svg>>       | [0..11] |
-- +-----------------+--------------------------------------------------------------+---------+

-- $continuousColorSchemes
--
-- Continuous color schemes, taken from:
--
--  * Color Brewer 2: https://colorbrewer2.org/
--  * Matplotlib: https://matplotlib.org/
--  * Seaborn: https://seaborn.pydata.org/
--
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | Name              |                                                                   | Domain | Type     |
-- +===================+===================================================================+========+==========+
-- | 'haskell'         | <<docs/colors/schemes/continuous/haskell/logo.png>>               | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'magma'           | <<docs/colors/schemes/continuous/matplotlib/magma.png>>           | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'inferno'         | <<docs/colors/schemes/continuous/matplotlib/inferno.png>>         | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'plasma'          | <<docs/colors/schemes/continuous/matplotlib/plasma.png>>          | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'viridis'         | <<docs/colors/schemes/continuous/matplotlib/viridis.png>>         | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'cividis'         | <<docs/colors/schemes/continuous/matplotlib/cividis.png>>         | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'turbo'           | <<docs/colors/schemes/continuous/matplotlib/turbo.png>>           | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'twilight'        | <<docs/colors/schemes/continuous/matplotlib/twilight.png>>        | [0..1] | Cyclic   |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'rocket'          | <<docs/colors/schemes/continuous/seaborn/rocket.png>>             | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'mako'            | <<docs/colors/schemes/continuous/seaborn/mako.png>>               | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'flare'           | <<docs/colors/schemes/continuous/seaborn/flare.png>>              | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'crest'           | <<docs/colors/schemes/continuous/seaborn/crest.png>>              | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'vlag'            | <<docs/colors/schemes/continuous/seaborn/vlag.png>>               | [0..1] | Divisive |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'icefire'         | <<docs/colors/schemes/continuous/seaborn/icefire.png>>            | [0..1] | Divisive |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'orRd'            | <<docs/colors/schemes/continuous/colorbrewer2/orRd.png>>          | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'puBu'            | <<docs/colors/schemes/continuous/colorbrewer2/puBu.png>>          | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'buPu'            | <<docs/colors/schemes/continuous/colorbrewer2/buPu.png>>          | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'oranges'         | <<docs/colors/schemes/continuous/colorbrewer2/oranges.png>>       | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'buGn'            | <<docs/colors/schemes/continuous/colorbrewer2/buGn.png>>          | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'ylOrBr'          | <<docs/colors/schemes/continuous/colorbrewer2/ylOrBr.png>>        | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'ylGn'            | <<docs/colors/schemes/continuous/colorbrewer2/ylGn.png>>          | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'reds'            | <<docs/colors/schemes/continuous/colorbrewer2/reds.png>>          | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'rdPu'            | <<docs/colors/schemes/continuous/colorbrewer2/rdPu.png>>          | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'greens'          | <<docs/colors/schemes/continuous/colorbrewer2/greens.png>>        | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'ylGnBu'          | <<docs/colors/schemes/continuous/colorbrewer2/ylGnBu.png>>        | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'purples'         | <<docs/colors/schemes/continuous/colorbrewer2/purples.png>>       | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'gnBu'            | <<docs/colors/schemes/continuous/colorbrewer2/gnBu.png>>          | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'greys'           | <<docs/colors/schemes/continuous/colorbrewer2/greys.png>>         | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'ylOrRd'          | <<docs/colors/schemes/continuous/colorbrewer2/ylOrRd.png>>        | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'puRd'            | <<docs/colors/schemes/continuous/colorbrewer2/puRd.png>>          | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'blues'           | <<docs/colors/schemes/continuous/colorbrewer2/blues.png>>         | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'puBuGn'          | <<docs/colors/schemes/continuous/colorbrewer2/puBuGn.png>>        | [0..1] | Monotone |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'spectral'        | <<docs/colors/schemes/continuous/colorbrewer2/spectral.png>>      | [0..1] | Divisive |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'rdYlGn'          | <<docs/colors/schemes/continuous/colorbrewer2/rdYlGn.png>>        | [0..1] | Divisive |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'rdBu'            | <<docs/colors/schemes/continuous/colorbrewer2/rdBu.png>>          | [0..1] | Divisive |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'piYG'            | <<docs/colors/schemes/continuous/colorbrewer2/piYG.png>>          | [0..1] | Divisive |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'pRGn'            | <<docs/colors/schemes/continuous/colorbrewer2/pRGn.png>>          | [0..1] | Divisive |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'rdYlBu'          | <<docs/colors/schemes/continuous/colorbrewer2/rdYlBu.png>>        | [0..1] | Divisive |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'brBG'            | <<docs/colors/schemes/continuous/colorbrewer2/brBG.png>>          | [0..1] | Divisive |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'rdGy'            | <<docs/colors/schemes/continuous/colorbrewer2/rdGy.png>>          | [0..1] | Divisive |
-- +-------------------+-------------------------------------------------------------------+--------+----------+
-- | 'puOr'            | <<docs/colors/schemes/continuous/colorbrewer2/puOr.png>>          | [0..1] | Divisive |
-- +-------------------+-------------------------------------------------------------------+--------+----------+