{-# LANGUAGE BangPatterns #-}

-- | SVG documents for icons: a parser for the static subset icon sets use and
-- an anti-aliased rasterizer.
--
-- Supported: @svg@ (with @viewBox@, @width@, @height@), @g@, @path@, @rect@,
-- @circle@, @ellipse@, @line@, @polyline@ and @polygon@; the presentation
-- attributes @fill@, @stroke@, @stroke-width@, @stroke-linecap@,
-- @stroke-linejoin@, @stroke-miterlimit@, @fill-rule@, @opacity@,
-- @fill-opacity@ and @stroke-opacity@, also inside @style@; @transform@; and
-- colours as names, @#rgb@, @#rrggbb@, @rgb()@ and @currentColor@. Gradients,
-- patterns, text, masks, clipping, filters and @use@ are ignored.
module NanoUI.Svg
  ( Svg
  , svgSize
  , svgKey
  , svgMonochrome
  , parseSvg
  , rasterizeSvg
  ) where

import Control.Monad (forM_, unless, when)
import Control.Monad.ST (ST, runST)
import Foreign.Storable (pokeByteOff)
import Data.Bits (xor)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Internal qualified as BSI
import Data.Char (isAlpha, isDigit, isSpace, toLower)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.Read qualified as TR
import Text.XML.Hexml qualified as Hexml
import Data.Primitive.PrimArray (MutablePrimArray, PrimArray, copyMutablePrimArray, indexPrimArray, newPrimArray, readPrimArray, setPrimArray, sizeofPrimArray, unsafeFreezePrimArray, writePrimArray)
import Data.Primitive.SmallArray (SmallArray, indexSmallArray, sizeofSmallArray, smallArrayFromList)
import Data.Word (Word8)
import NanoUI.Types (Color (..), clamp01, colorA, colorB, colorG, colorR, colorRGBA)

-- | A parsed SVG document.
data Svg = Svg
  { Svg -> Box
svgViewBox :: !Box
  , Svg -> (Float, Float)
svgSize :: !(Float, Float)
  -- ^ The document's own width and height, from its @width@ and @height@ or
  -- else its @viewBox@.
  , Svg -> SmallArray Shape
svgShapes :: !(SmallArray Shape)
  , Svg -> Int
svgKey :: !Int
  -- ^ A hash of the source, for caching rasters.
  , Svg -> Bool
svgMonochrome :: !Bool
  -- ^ Every paint is @currentColor@ or unspecified, so the drawing is one
  -- colour and can be tinted.
  }

-- | Documents are equal when their sources hash the same.
instance Eq Svg where
  Svg
a == :: Svg -> Svg -> Bool
== Svg
b = Svg -> Int
svgKey Svg
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Svg -> Int
svgKey Svg
b

instance Show Svg where
  show :: Svg -> String
show Svg
doc = String
"<svg " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Float, Float) -> String
forall a. Show a => a -> String
show (Svg -> (Float, Float)
svgSize Svg
doc) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
">"

data Box = Box !Float !Float !Float !Float

data Paint = PaintNone | PaintCurrent | PaintColor !Color
  deriving (Paint -> Paint -> Bool
(Paint -> Paint -> Bool) -> (Paint -> Paint -> Bool) -> Eq Paint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Paint -> Paint -> Bool
== :: Paint -> Paint -> Bool
$c/= :: Paint -> Paint -> Bool
/= :: Paint -> Paint -> Bool
Eq)

data FillRule = NonZero | EvenOdd
  deriving (FillRule -> FillRule -> Bool
(FillRule -> FillRule -> Bool)
-> (FillRule -> FillRule -> Bool) -> Eq FillRule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FillRule -> FillRule -> Bool
== :: FillRule -> FillRule -> Bool
$c/= :: FillRule -> FillRule -> Bool
/= :: FillRule -> FillRule -> Bool
Eq)

data LineCap = CapButt | CapRound | CapSquare
  deriving (LineCap -> LineCap -> Bool
(LineCap -> LineCap -> Bool)
-> (LineCap -> LineCap -> Bool) -> Eq LineCap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LineCap -> LineCap -> Bool
== :: LineCap -> LineCap -> Bool
$c/= :: LineCap -> LineCap -> Bool
/= :: LineCap -> LineCap -> Bool
Eq)

data LineJoin = JoinMiter | JoinRound | JoinBevel
  deriving (LineJoin -> LineJoin -> Bool
(LineJoin -> LineJoin -> Bool)
-> (LineJoin -> LineJoin -> Bool) -> Eq LineJoin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LineJoin -> LineJoin -> Bool
== :: LineJoin -> LineJoin -> Bool
$c/= :: LineJoin -> LineJoin -> Bool
/= :: LineJoin -> LineJoin -> Bool
Eq)

-- | Presentation state inherited from ancestors.
data PaintStyle = PaintStyle
  { PaintStyle -> Maybe Paint
psFill :: !(Maybe Paint)
  , PaintStyle -> Maybe Paint
psStroke :: !(Maybe Paint)
  , PaintStyle -> Float
psStrokeWidth :: !Float
  , PaintStyle -> LineCap
psCap :: !LineCap
  , PaintStyle -> LineJoin
psJoin :: !LineJoin
  , PaintStyle -> Float
psMiterLimit :: !Float
  , PaintStyle -> FillRule
psRule :: !FillRule
  , PaintStyle -> Float
psOpacity :: !Float
  , PaintStyle -> Float
psFillOpacity :: !Float
  , PaintStyle -> Float
psStrokeOpacity :: !Float
  }

-- | Segments, the transform to user space, and the paint.
data Shape = Shape !(SmallArray Segment) !Matrix !PaintStyle

shapeStyle :: Shape -> PaintStyle
shapeStyle :: Shape -> PaintStyle
shapeStyle (Shape SmallArray Segment
_ Matrix
_ PaintStyle
style) = PaintStyle
style

data Segment
  = MoveTo !P
  | LineTo !P
  | CubicTo !P !P !P
  | QuadTo !P !P
  | ArcTo !Float !Float !Float !Bool !Bool !P
  | ClosePath

data P = P {-# UNPACK #-} !Float {-# UNPACK #-} !Float

-- | @a c e / b d f@, mapping @(x, y)@ to @(a x + c y + e, b x + d y + f)@.
data Matrix = Matrix !Float !Float !Float !Float !Float !Float

identity :: Matrix
identity :: Matrix
identity = Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix Float
1 Float
0 Float
0 Float
1 Float
0 Float
0

mul :: Matrix -> Matrix -> Matrix
mul :: Matrix -> Matrix -> Matrix
mul (Matrix Float
a Float
b Float
c Float
d Float
e Float
f) (Matrix Float
a' Float
b' Float
c' Float
d' Float
e' Float
f') =
  Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix
    (Float
a Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
a' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
c Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
b')
    (Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
a' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
d Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
b')
    (Float
a Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
c' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
c Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
d')
    (Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
c' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
d Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
d')
    (Float
a Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
e' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
c Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
f' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
e)
    (Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
e' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
d Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
f' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
f)

apply :: Matrix -> P -> P
apply :: Matrix -> P -> P
apply (Matrix Float
a Float
b Float
c Float
d Float
e Float
f) (P Float
x Float
y) = Float -> Float -> P
P (Float
a Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
c Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
e) (Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
d Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
f)

--------------------------------------------------------------------------------
-- XML
--------------------------------------------------------------------------------

data Element = Element !Text ![(Text, Text)] ![Element]

-- | The elements of a document, by hexml. Text, comments and processing
-- instructions are not elements; a DOCTYPE, which hexml rejects, is blanked
-- out first.
parseElements :: Text -> Either String [Element]
parseElements :: Text -> Either String [Element]
parseElements Text
src =
  case ByteString -> Either ByteString Node
Hexml.parse (ByteString -> ByteString
withoutDoctype (Text -> ByteString
TE.encodeUtf8 Text
src)) of
    Left ByteString
err -> String -> Either String [Element]
forall a b. a -> Either a b
Left (Text -> String
T.unpack (ByteString -> Text
TE.decodeUtf8Lenient ByteString
err))
    Right Node
doc -> [Element] -> Either String [Element]
forall a b. b -> Either a b
Right ((Node -> Element) -> [Node] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Element
element (Node -> [Node]
Hexml.children Node
doc))
  where
    element :: Node -> Element
element Node
node =
      Text -> [(Text, Text)] -> [Element] -> Element
Element
        (Text -> Text
localName (ByteString -> Text
TE.decodeUtf8Lenient (Node -> ByteString
Hexml.name Node
node)))
        [ (Text -> Text
localName (ByteString -> Text
TE.decodeUtf8Lenient (Attribute -> ByteString
Hexml.attributeName Attribute
a)), Text -> Text
decodeEntities (ByteString -> Text
TE.decodeUtf8Lenient (Attribute -> ByteString
Hexml.attributeValue Attribute
a)))
        | Attribute
a <- Node -> [Attribute]
Hexml.attributes Node
node
        ]
        ((Node -> Element) -> [Node] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Element
element (Node -> [Node]
Hexml.children Node
node))
    localName :: Text -> Text
localName Text
n = (Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') Text
n

-- | The document with its DOCTYPE, internal subset included, replaced by
-- spaces, so positions in parse errors still match the source.
withoutDoctype :: ByteString -> ByteString
withoutDoctype :: ByteString -> ByteString
withoutDoctype ByteString
bytes =
  case ByteString -> ByteString -> (ByteString, ByteString)
BS.breakSubstring ByteString
"<!DOCTYPE" ByteString
bytes of
    (ByteString
_, ByteString
rest) | ByteString -> Bool
BS.null ByteString
rest -> ByteString
bytes
    (ByteString
before, ByteString
rest) ->
      let close :: Int -> Int -> Int
close !Int
depth !Int
k
            | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= ByteString -> Int
BS.length ByteString
rest = Int
k
            | Bool
otherwise = case HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
rest Int
k of
                Word8
91 -> Int -> Int -> Int
close (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 :: Int) (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                Word8
93 -> Int -> Int -> Int
close (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                Word8
62 | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 -> Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                Word8
_ -> Int -> Int -> Int
close Int
depth (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          end :: Int
end = Int -> Int -> Int
close Int
0 Int
0
       in ByteString
before ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Word8 -> ByteString
BS.replicate Int
end Word8
32 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
BS.drop Int
end ByteString
rest

decodeEntities :: Text -> Text
decodeEntities :: Text -> Text
decodeEntities =
  HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"&amp;" Text
"&" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"&lt;" Text
"<" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"&gt;" Text
">" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"&quot;" Text
"\"" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"&apos;" Text
"'"

--------------------------------------------------------------------------------
-- Document
--------------------------------------------------------------------------------

-- | Parse an SVG document.
parseSvg :: Text -> Either String Svg
parseSvg :: Text -> Either String Svg
parseSvg Text
src = do
  els <- Text -> Either String [Element]
parseElements Text
src
  root <- case [e | e@(Element n _ _) <- els, n == "svg"] of
    Element
r : [Element]
_ -> Element -> Either String Element
forall a b. b -> Either a b
Right Element
r
    [] -> String -> Either String Element
forall a b. a -> Either a b
Left String
"no svg element"
  let Element _ attrs _ = root
      attr Text
k = Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Text)]
attrs
      box = case Text -> Maybe Text
attr Text
"viewBox" Maybe Text
-> (Text -> Maybe (Float, Float, Float, Float))
-> Maybe (Float, Float, Float, Float)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe (Float, Float, Float, Float)
numbers4 of
        Just (Float
x, Float
y, Float
w, Float
h) | Float
w Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Float
h Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 -> Float -> Float -> Float -> Float -> Box
Box Float
x Float
y Float
w Float
h
        Maybe (Float, Float, Float, Float)
_ -> Float -> Float -> Float -> Float -> Box
Box Float
0 Float
0 (Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe Float
24 (Text -> Maybe Text
attr Text
"width" Maybe Text -> (Text -> Maybe Float) -> Maybe Float
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Float
length1)) (Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe Float
24 (Text -> Maybe Text
attr Text
"height" Maybe Text -> (Text -> Maybe Float) -> Maybe Float
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Float
length1))
      Box _ _ bw bh = box
      width = Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe Float
bw (Text -> Maybe Text
attr Text
"width" Maybe Text -> (Text -> Maybe Float) -> Maybe Float
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Float
length1)
      height = Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe Float
bh (Text -> Maybe Text
attr Text
"height" Maybe Text -> (Text -> Maybe Float) -> Maybe Float
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Float
length1)
      shapes = Matrix -> PaintStyle -> Element -> [Shape]
collect Matrix
identity PaintStyle
defaultStyle Element
root
      -- Unspecified paints and currentColor follow the tint; an explicit
      -- colour anywhere makes the drawing multicoloured.
      monochromePaint Maybe Paint
p = case Maybe Paint
p of
        Just (PaintColor Color
_) -> Bool
False
        Maybe Paint
_ -> Bool
True
  pure
    Svg
      { svgViewBox = box
      , svgSize = (width, height)
      , svgShapes = smallArrayFromList shapes
      , svgKey = T.foldl' (\Int
h Char
c -> (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16777619) Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) 2166136261 src
      , svgMonochrome = all (\Shape
sh -> Maybe Paint -> Bool
monochromePaint (PaintStyle -> Maybe Paint
psFill (Shape -> PaintStyle
shapeStyle Shape
sh)) Bool -> Bool -> Bool
&& Maybe Paint -> Bool
monochromePaint (PaintStyle -> Maybe Paint
psStroke (Shape -> PaintStyle
shapeStyle Shape
sh))) shapes
      }
  where
    numbers4 :: Text -> Maybe (Float, Float, Float, Float)
numbers4 Text
t = case Text -> [Float]
numberList Text
t of
      [Float
a, Float
b, Float
c, Float
d] -> (Float, Float, Float, Float) -> Maybe (Float, Float, Float, Float)
forall a. a -> Maybe a
Just (Float
a, Float
b, Float
c, Float
d)
      [Float]
_ -> Maybe (Float, Float, Float, Float)
forall a. Maybe a
Nothing

defaultStyle :: PaintStyle
defaultStyle :: PaintStyle
defaultStyle =
  PaintStyle
    { psFill :: Maybe Paint
psFill = Maybe Paint
forall a. Maybe a
Nothing
    , psStroke :: Maybe Paint
psStroke = Paint -> Maybe Paint
forall a. a -> Maybe a
Just Paint
PaintNone
    , psStrokeWidth :: Float
psStrokeWidth = Float
1
    , psCap :: LineCap
psCap = LineCap
CapButt
    , psJoin :: LineJoin
psJoin = LineJoin
JoinMiter
    , psMiterLimit :: Float
psMiterLimit = Float
4
    , psRule :: FillRule
psRule = FillRule
NonZero
    , psOpacity :: Float
psOpacity = Float
1
    , psFillOpacity :: Float
psFillOpacity = Float
1
    , psStrokeOpacity :: Float
psStrokeOpacity = Float
1
    }

-- | Shapes in document order, each with its full transform and style.
collect :: Matrix -> PaintStyle -> Element -> [Shape]
collect :: Matrix -> PaintStyle -> Element -> [Shape]
collect Matrix
m0 PaintStyle
style0 (Element Text
name [(Text, Text)]
attrs [Element]
children) =
  let props :: [(Text, Text)]
props = [(Text, Text)]
attrs [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ Text -> [(Text, Text)]
styleProperties (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"style" [(Text, Text)]
attrs))
      m :: Matrix
m = Matrix -> (Text -> Matrix) -> Maybe Text -> Matrix
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Matrix
m0 (Matrix -> Matrix -> Matrix
mul Matrix
m0 (Matrix -> Matrix) -> (Text -> Matrix) -> Text -> Matrix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Matrix
parseTransform) (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"transform" [(Text, Text)]
attrs)
      -- Opacity multiplies down the tree; the other properties replace.
      style :: PaintStyle
style = ([(Text, Text)] -> PaintStyle -> PaintStyle
applyProperties [(Text, Text)]
props PaintStyle
style0) {psOpacity = psOpacity style0 * maybe 1 clamp01 (lookup "opacity" props >>= number1)}
      shape :: [Segment] -> [Shape]
shape [Segment]
segs = [SmallArray Segment -> Matrix -> PaintStyle -> Shape
Shape ([Segment] -> SmallArray Segment
forall a. [a] -> SmallArray a
smallArrayFromList [Segment]
segs) Matrix
m PaintStyle
style]
      num :: Text -> Float
num Text
k = Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe Float
0 (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Text)]
attrs Maybe Text -> (Text -> Maybe Float) -> Maybe Float
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Float
length1)
   in case Text
name of
        Text
"svg" -> (Element -> [Shape]) -> [Element] -> [Shape]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Matrix -> PaintStyle -> Element -> [Shape]
collect Matrix
m PaintStyle
style) [Element]
children
        Text
"g" -> (Element -> [Shape]) -> [Element] -> [Shape]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Matrix -> PaintStyle -> Element -> [Shape]
collect Matrix
m PaintStyle
style) [Element]
children
        Text
"a" -> (Element -> [Shape]) -> [Element] -> [Shape]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Matrix -> PaintStyle -> Element -> [Shape]
collect Matrix
m PaintStyle
style) [Element]
children
        Text
"path" -> [Segment] -> [Shape]
shape (Text -> [Segment]
parsePath (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"d" [(Text, Text)]
attrs)))
        Text
"rect" -> [Segment] -> [Shape]
shape (Float
-> Float
-> Float
-> Float
-> Maybe Float
-> Maybe Float
-> [Segment]
rectSegments (Text -> Float
num Text
"x") (Text -> Float
num Text
"y") (Text -> Float
num Text
"width") (Text -> Float
num Text
"height") (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"rx" [(Text, Text)]
attrs Maybe Text -> (Text -> Maybe Float) -> Maybe Float
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Float
length1) (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"ry" [(Text, Text)]
attrs Maybe Text -> (Text -> Maybe Float) -> Maybe Float
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Float
length1))
        Text
"circle" -> [Segment] -> [Shape]
shape (Float -> Float -> Float -> Float -> [Segment]
ellipseSegments (Text -> Float
num Text
"cx") (Text -> Float
num Text
"cy") (Text -> Float
num Text
"r") (Text -> Float
num Text
"r"))
        Text
"ellipse" -> [Segment] -> [Shape]
shape (Float -> Float -> Float -> Float -> [Segment]
ellipseSegments (Text -> Float
num Text
"cx") (Text -> Float
num Text
"cy") (Text -> Float
num Text
"rx") (Text -> Float
num Text
"ry"))
        Text
"line" -> [Segment] -> [Shape]
shape [P -> Segment
MoveTo (Float -> Float -> P
P (Text -> Float
num Text
"x1") (Text -> Float
num Text
"y1")), P -> Segment
LineTo (Float -> Float -> P
P (Text -> Float
num Text
"x2") (Text -> Float
num Text
"y2"))]
        Text
"polyline" -> [Segment] -> [Shape]
shape (Bool -> Text -> [Segment]
polySegments Bool
False (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"points" [(Text, Text)]
attrs)))
        Text
"polygon" -> [Segment] -> [Shape]
shape (Bool -> Text -> [Segment]
polySegments Bool
True (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"points" [(Text, Text)]
attrs)))
        Text
_ -> []

styleProperties :: Text -> [(Text, Text)]
styleProperties :: Text -> [(Text, Text)]
styleProperties =
  (Text -> Maybe (Text, Text)) -> [Text] -> [(Text, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
    ( \Text
decl -> case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
":" Text
decl of
        (Text
k, Text
v) | Bool -> Bool
not (Text -> Bool
T.null Text
v) -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text -> Text
T.strip Text
k, Text -> Text
T.strip (Int -> Text -> Text
T.drop Int
1 Text
v))
        (Text, Text)
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing
    )
    ([Text] -> [(Text, Text)])
-> (Text -> [Text]) -> Text -> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
";"

applyProperties :: [(Text, Text)] -> PaintStyle -> PaintStyle
applyProperties :: [(Text, Text)] -> PaintStyle -> PaintStyle
applyProperties [(Text, Text)]
props PaintStyle
s0 = (PaintStyle -> (Text, Text) -> PaintStyle)
-> PaintStyle -> [(Text, Text)] -> PaintStyle
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl PaintStyle -> (Text, Text) -> PaintStyle
forall {a}.
(Eq a, IsString a) =>
PaintStyle -> (a, Text) -> PaintStyle
step PaintStyle
s0 [(Text, Text)]
props
  where
    step :: PaintStyle -> (a, Text) -> PaintStyle
step PaintStyle
s (a
k, Text
v) = case a
k of
      a
"fill" -> PaintStyle
s {psFill = Just (parsePaint v)}
      a
"stroke" -> PaintStyle
s {psStroke = Just (parsePaint v)}
      a
"stroke-width" -> PaintStyle -> (Float -> PaintStyle) -> Maybe Float -> PaintStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PaintStyle
s (\Float
w -> PaintStyle
s {psStrokeWidth = max 0 w}) (Text -> Maybe Float
length1 Text
v)
      a
"stroke-linecap" -> case Text
v of
        Text
"round" -> PaintStyle
s {psCap = CapRound}
        Text
"square" -> PaintStyle
s {psCap = CapSquare}
        Text
_ -> PaintStyle
s {psCap = CapButt}
      a
"stroke-linejoin" -> case Text
v of
        Text
"round" -> PaintStyle
s {psJoin = JoinRound}
        Text
"bevel" -> PaintStyle
s {psJoin = JoinBevel}
        Text
_ -> PaintStyle
s {psJoin = JoinMiter}
      a
"stroke-miterlimit" -> PaintStyle -> (Float -> PaintStyle) -> Maybe Float -> PaintStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PaintStyle
s (\Float
l -> PaintStyle
s {psMiterLimit = max 1 l}) (Text -> Maybe Float
number1 Text
v)
      a
"fill-rule" -> PaintStyle
s {psRule = if v == "evenodd" then EvenOdd else NonZero}
      a
"fill-opacity" -> PaintStyle -> (Float -> PaintStyle) -> Maybe Float -> PaintStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PaintStyle
s (\Float
o -> PaintStyle
s {psFillOpacity = clamp01 o}) (Text -> Maybe Float
number1 Text
v)
      a
"stroke-opacity" -> PaintStyle -> (Float -> PaintStyle) -> Maybe Float -> PaintStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PaintStyle
s (\Float
o -> PaintStyle
s {psStrokeOpacity = clamp01 o}) (Text -> Maybe Float
number1 Text
v)
      a
_ -> PaintStyle
s


parsePaint :: Text -> Paint
parsePaint :: Text -> Paint
parsePaint Text
raw
  | Text
v Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"none" Bool -> Bool -> Bool
|| Text
v Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"transparent" = Paint
PaintNone
  | Text
v Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"currentcolor" = Paint
PaintCurrent
  | Just Text
hex <- Text -> Text -> Maybe Text
T.stripPrefix Text
"#" Text
v = Paint -> (Color -> Paint) -> Maybe Color -> Paint
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Paint
PaintNone Color -> Paint
PaintColor (Text -> Maybe Color
hexColor Text
hex)
  | Just Text
args <- Text -> Text -> Maybe Text
T.stripPrefix Text
"rgb(" Text
v = case Text -> [Float]
numberList ((Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')') Text
args) of
      [Float
r, Float
g, Float
b] -> Color -> Paint
PaintColor (Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA (Float -> Word8
forall {a} {b}. (RealFrac a, Num b) => a -> b
channel Float
r) (Float -> Word8
forall {a} {b}. (RealFrac a, Num b) => a -> b
channel Float
g) (Float -> Word8
forall {a} {b}. (RealFrac a, Num b) => a -> b
channel Float
b) Word8
255)
      [Float]
_ -> Paint
PaintNone
  | Bool
otherwise = Paint -> (Color -> Paint) -> Maybe Color -> Paint
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Color -> Paint
PaintColor (Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
0 Word8
255)) Color -> Paint
PaintColor (Text -> [(Text, Color)] -> Maybe Color
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
v [(Text, Color)]
namedColors)
  where
    v :: Text
v = Text -> Text
T.toLower (Text -> Text
T.strip Text
raw)
    channel :: a -> b
channel a
x = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
255 (a -> Int
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round a
x :: Int)))
    hexColor :: Text -> Maybe Color
hexColor Text
h = case Text -> String
T.unpack Text
h of
      [Char
r, Char
g, Char
b] -> Maybe Word8 -> Maybe Word8 -> Maybe Word8 -> Maybe Color
rgb (Char -> Char -> Maybe Word8
forall {b}. Num b => Char -> Char -> Maybe b
hex2 Char
r Char
r) (Char -> Char -> Maybe Word8
forall {b}. Num b => Char -> Char -> Maybe b
hex2 Char
g Char
g) (Char -> Char -> Maybe Word8
forall {b}. Num b => Char -> Char -> Maybe b
hex2 Char
b Char
b)
      [Char
r1, Char
r2, Char
g1, Char
g2, Char
b1, Char
b2] -> Maybe Word8 -> Maybe Word8 -> Maybe Word8 -> Maybe Color
rgb (Char -> Char -> Maybe Word8
forall {b}. Num b => Char -> Char -> Maybe b
hex2 Char
r1 Char
r2) (Char -> Char -> Maybe Word8
forall {b}. Num b => Char -> Char -> Maybe b
hex2 Char
g1 Char
g2) (Char -> Char -> Maybe Word8
forall {b}. Num b => Char -> Char -> Maybe b
hex2 Char
b1 Char
b2)
      String
_ -> Maybe Color
forall a. Maybe a
Nothing
    rgb :: Maybe Word8 -> Maybe Word8 -> Maybe Word8 -> Maybe Color
rgb (Just Word8
r) (Just Word8
g) (Just Word8
b) = Color -> Maybe Color
forall a. a -> Maybe a
Just (Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
r Word8
g Word8
b Word8
255)
    rgb Maybe Word8
_ Maybe Word8
_ Maybe Word8
_ = Maybe Color
forall a. Maybe a
Nothing
    hex2 :: Char -> Char -> Maybe b
hex2 Char
a Char
b = (\Int
x Int
y -> Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y)) (Int -> Int -> b) -> Maybe Int -> Maybe (Int -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Maybe Int
hexDigit Char
a Maybe (Int -> b) -> Maybe Int -> Maybe b
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Maybe Int
hexDigit Char
b
    hexDigit :: Char -> Maybe Int
hexDigit Char
c
      | Char -> Bool
isDigit Char
c = Int -> Maybe Int
forall a. a -> Maybe a
Just (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'0')
      | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10)
      | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing

namedColors :: [(Text, Color)]
namedColors :: [(Text, Color)]
namedColors =
  [ (Text
"black", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
0 Word8
255)
  , (Text
"white", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
255 Word8
255 Word8
255 Word8
255)
  , (Text
"red", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
255 Word8
0 Word8
0 Word8
255)
  , (Text
"green", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
128 Word8
0 Word8
255)
  , (Text
"lime", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
255 Word8
0 Word8
255)
  , (Text
"blue", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
255 Word8
255)
  , (Text
"yellow", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
255 Word8
255 Word8
0 Word8
255)
  , (Text
"orange", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
255 Word8
165 Word8
0 Word8
255)
  , (Text
"purple", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
128 Word8
0 Word8
128 Word8
255)
  , (Text
"gray", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
128 Word8
128 Word8
128 Word8
255)
  , (Text
"grey", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
128 Word8
128 Word8
128 Word8
255)
  , (Text
"silver", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
192 Word8
192 Word8
192 Word8
255)
  , (Text
"navy", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
128 Word8
255)
  , (Text
"teal", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
128 Word8
128 Word8
255)
  , (Text
"maroon", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
128 Word8
0 Word8
0 Word8
255)
  , (Text
"olive", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
128 Word8
128 Word8
0 Word8
255)
  , (Text
"aqua", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
255 Word8
255 Word8
255)
  , (Text
"cyan", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
255 Word8
255 Word8
255)
  , (Text
"fuchsia", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
255 Word8
0 Word8
255 Word8
255)
  , (Text
"magenta", Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
255 Word8
0 Word8
255 Word8
255)
  ]

--------------------------------------------------------------------------------
-- Numbers, transforms and path data
--------------------------------------------------------------------------------

-- | Numbers separated by spaces or commas, stopping at the first thing that
-- is not a number.
numberList :: Text -> [Float]
numberList :: Text -> [Float]
numberList Text
t0 = Text -> [Float]
go (Text -> Text
skipSep Text
t0)
  where
    go :: Text -> [Float]
go Text
t = case Text -> Maybe (Float, Text)
readNumber Text
t of
      Just (Float
x, Text
rest) -> Float
x Float -> [Float] -> [Float]
forall a. a -> [a] -> [a]
: Text -> [Float]
go (Text -> Text
skipSep Text
rest)
      Maybe (Float, Text)
Nothing -> []

skipSep :: Text -> Text
skipSep :: Text -> Text
skipSep = (Char -> Bool) -> Text -> Text
T.dropWhile (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',')

-- | A number at the start of the text, allowing @.5@, @-.5e-3@ and a
-- following number that starts with a sign or a second decimal point.
readNumber :: Text -> Maybe (Float, Text)
readNumber :: Text -> Maybe (Float, Text)
readNumber Text
t =
  let (Text
sign, Text
t1) = case Text -> Maybe (Char, Text)
T.uncons Text
t of
        Just (Char
c, Text
r) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' -> (Char -> Text
T.singleton Char
c, Text
r)
        Maybe (Char, Text)
_ -> (Text
T.empty, Text
t)
      intPart :: Text
intPart = (Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isDigit Text
t1
      afterInt :: Text
afterInt = Int -> Text -> Text
T.drop (Text -> Int
T.length Text
intPart) Text
t1
      (Text
fracPart, Text
afterFrac) = case Text -> Maybe (Char, Text)
T.uncons Text
afterInt of
        Just (Char
'.', Text
r) -> let ds :: Text
ds = (Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isDigit Text
r in (Char -> Text -> Text
T.cons Char
'.' Text
ds, Int -> Text -> Text
T.drop (Text -> Int
T.length Text
ds) Text
r)
        Maybe (Char, Text)
_ -> (Text
T.empty, Text
afterInt)
      (Text
expPart, Text
rest) = case Text -> Maybe (Char, Text)
T.uncons Text
afterFrac of
        Just (Char
e, Text
r)
          | Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'e' Bool -> Bool -> Bool
|| Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'E' ->
              let (Text
esign, Text
r1) = case Text -> Maybe (Char, Text)
T.uncons Text
r of
                    Just (Char
c, Text
r') | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' -> (Char -> Text
T.singleton Char
c, Text
r')
                    Maybe (Char, Text)
_ -> (Text
T.empty, Text
r)
                  eds :: Text
eds = (Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isDigit Text
r1
               in if Text -> Bool
T.null Text
eds then (Text
T.empty, Text
afterFrac) else ([Text] -> Text
T.concat [Text
"e", Text
esign, Text
eds], Int -> Text -> Text
T.drop (Text -> Int
T.length Text
eds) Text
r1)
        Maybe (Char, Text)
_ -> (Text
T.empty, Text
afterFrac)
      mantissa :: Text
mantissa = Text
intPart Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fracPart
   in if Text -> Bool
T.null ((Char -> Bool) -> Text -> Text
T.filter Char -> Bool
isDigit Text
mantissa)
        then Maybe (Float, Text)
forall a. Maybe a
Nothing
        else case Reader Double -> Reader Double
forall a. Num a => Reader a -> Reader a
TR.signed Reader Double
forall a. Fractional a => Reader a
TR.rational ([Text] -> Text
T.concat [Text
sign, if Text -> Bool
T.null Text
intPart then Text
"0" else Text
"", Text
mantissa, Text
expPart]) of
          Right (Double
x, Text
_) -> (Float, Text) -> Maybe (Float, Text)
forall a. a -> Maybe a
Just (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
x :: Double), Text
rest)
          Left String
_ -> Maybe (Float, Text)
forall a. Maybe a
Nothing

number1 :: Text -> Maybe Float
number1 :: Text -> Maybe Float
number1 Text
t = (Float, Text) -> Float
forall a b. (a, b) -> a
fst ((Float, Text) -> Float) -> Maybe (Float, Text) -> Maybe Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (Float, Text)
readNumber (Text -> Text
T.strip Text
t)

-- | A length in user units: a number with an optional @px@. Percentages and
-- other units are not lengths here.
length1 :: Text -> Maybe Float
length1 :: Text -> Maybe Float
length1 Text
t = case Text -> Maybe (Float, Text)
readNumber (Text -> Text
T.strip Text
t) of
  Just (Float
x, Text
rest) | Text -> Bool
T.null Text
rest Bool -> Bool -> Bool
|| Text
rest Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"px" -> Float -> Maybe Float
forall a. a -> Maybe a
Just Float
x
  Maybe (Float, Text)
_ -> Maybe Float
forall a. Maybe a
Nothing

parseTransform :: Text -> Matrix
parseTransform :: Text -> Matrix
parseTransform Text
t0 = Matrix -> Text -> Matrix
go Matrix
identity (Text -> Text
T.stripStart Text
t0)
  where
    go :: Matrix -> Text -> Matrix
go Matrix
m Text
t
      | Text -> Bool
T.null Text
t = Matrix
m
      | Bool
otherwise =
          let (Text
name, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isAlpha Text
t
              (Text
args, Text
rest') = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
")" (Int -> Text -> Text
T.drop Int
1 ((Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(') Text
rest))
              next :: Text
next = (Char -> Bool) -> Text -> Text
T.dropWhile (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') (Int -> Text -> Text
T.drop Int
1 Text
rest')
              m' :: Matrix
m' = case (Text
name, Text -> [Float]
numberList Text
args) of
                (Text
"matrix", [Float
a, Float
b, Float
c, Float
d, Float
e, Float
f]) -> Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix Float
a Float
b Float
c Float
d Float
e Float
f
                (Text
"translate", [Float
x]) -> Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix Float
1 Float
0 Float
0 Float
1 Float
x Float
0
                (Text
"translate", [Float
x, Float
y]) -> Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix Float
1 Float
0 Float
0 Float
1 Float
x Float
y
                (Text
"scale", [Float
s]) -> Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix Float
s Float
0 Float
0 Float
s Float
0 Float
0
                (Text
"scale", [Float
sx, Float
sy]) -> Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix Float
sx Float
0 Float
0 Float
sy Float
0 Float
0
                (Text
"rotate", [Float
a]) -> Float -> Matrix
rotation Float
a
                (Text
"rotate", [Float
a, Float
cx, Float
cy]) -> Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix Float
1 Float
0 Float
0 Float
1 Float
cx Float
cy Matrix -> Matrix -> Matrix
`mul` Float -> Matrix
rotation Float
a Matrix -> Matrix -> Matrix
`mul` Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix Float
1 Float
0 Float
0 Float
1 (-Float
cx) (-Float
cy)
                (Text
"skewX", [Float
a]) -> Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix Float
1 Float
0 (Float -> Float
forall a. Floating a => a -> a
tan (Float
a Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
180)) Float
1 Float
0 Float
0
                (Text
"skewY", [Float
a]) -> Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix Float
1 (Float -> Float
forall a. Floating a => a -> a
tan (Float
a Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
180)) Float
0 Float
1 Float
0 Float
0
                (Text, [Float])
_ -> Matrix
identity
           in if Text -> Bool
T.null Text
name then Matrix
m else Matrix -> Text -> Matrix
go (Matrix
m Matrix -> Matrix -> Matrix
`mul` Matrix
m') Text
next
    rotation :: Float -> Matrix
rotation Float
a =
      let r :: Float
r = Float
a Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
180
       in Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix (Float -> Float
forall a. Floating a => a -> a
cos Float
r) (Float -> Float
forall a. Floating a => a -> a
sin Float
r) (Float -> Float
forall a. Num a => a -> a
negate (Float -> Float
forall a. Floating a => a -> a
sin Float
r)) (Float -> Float
forall a. Floating a => a -> a
cos Float
r) Float
0 Float
0

-- | Path data as absolute segments. Parsing stops at the first error, keeping
-- what came before, as renderers do.
parsePath :: Text -> [Segment]
parsePath :: Text -> [Segment]
parsePath = Char -> P -> P -> Maybe P -> Text -> [Segment]
go Char
'M' (Float -> Float -> P
P Float
0 Float
0) (Float -> Float -> P
P Float
0 Float
0) Maybe P
forall a. Maybe a
Nothing (Text -> [Segment]) -> (Text -> Text) -> Text -> [Segment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
skipSep
  where
    -- cmd: the current (repeatable) command; cur: the current point; start:
    -- the subpath start; ctrl: the last control point, for S and T.
    go :: Char -> P -> P -> Maybe P -> Text -> [Segment]
go Char
cmd P
cur P
start Maybe P
ctrl Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
      Maybe (Char, Text)
Nothing -> []
      Just (Char
c, Text
rest)
        | Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'e' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'E' ->
            if Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'z'
              then Segment
ClosePath Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: Char -> P -> P -> Maybe P -> Text -> [Segment]
go (if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'z' then Char
'm' else Char
'M') P
start P
start Maybe P
forall a. Maybe a
Nothing (Text -> Text
skipSep Text
rest)
              else Char -> P -> P -> Maybe P -> Text -> [Segment]
run Char
c P
cur P
start Maybe P
ctrl (Text -> Text
skipSep Text
rest)
        | Bool
otherwise -> Char -> P -> P -> Maybe P -> Text -> [Segment]
run Char
cmd P
cur P
start Maybe P
ctrl Text
t
    run :: Char -> P -> P -> Maybe P -> Text -> [Segment]
run Char
cmd cur :: P
cur@(P Float
cx Float
cy) P
start Maybe P
ctrl Text
t =
      let rel :: Bool
rel = Char
cmd Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a'
          pt :: P -> P
pt (P Float
x Float
y) = if Bool
rel then Float -> Float -> P
P (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
x) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
y) else Float -> Float -> P
P Float
x Float
y
          nums :: Int -> Maybe ([Float], Text)
nums Int
n = Int -> Text -> Maybe ([Float], Text)
takeNumbers Int
n Text
t
       in case Char -> Char
toLower Char
cmd of
            Char
'm' -> case Int -> Maybe ([Float], Text)
nums Int
2 of
              Just ([Float
x, Float
y], Text
r) ->
                let p :: P
p = P -> P
pt (Float -> Float -> P
P Float
x Float
y)
                 in P -> Segment
MoveTo P
p Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: Char -> P -> P -> Maybe P -> Text -> [Segment]
go (if Bool
rel then Char
'l' else Char
'L') P
p P
p Maybe P
forall a. Maybe a
Nothing (Text -> Text
skipSep Text
r)
              Maybe ([Float], Text)
_ -> []
            Char
'l' -> case Int -> Maybe ([Float], Text)
nums Int
2 of
              Just ([Float
x, Float
y], Text
r) -> let p :: P
p = P -> P
pt (Float -> Float -> P
P Float
x Float
y) in P -> Segment
LineTo P
p Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: Char -> P -> P -> Maybe P -> Text -> [Segment]
go Char
cmd P
p P
start Maybe P
forall a. Maybe a
Nothing (Text -> Text
skipSep Text
r)
              Maybe ([Float], Text)
_ -> []
            Char
'h' -> case Int -> Maybe ([Float], Text)
nums Int
1 of
              Just ([Float
x], Text
r) -> let p :: P
p = Float -> Float -> P
P (if Bool
rel then Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
x else Float
x) Float
cy in P -> Segment
LineTo P
p Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: Char -> P -> P -> Maybe P -> Text -> [Segment]
go Char
cmd P
p P
start Maybe P
forall a. Maybe a
Nothing (Text -> Text
skipSep Text
r)
              Maybe ([Float], Text)
_ -> []
            Char
'v' -> case Int -> Maybe ([Float], Text)
nums Int
1 of
              Just ([Float
y], Text
r) -> let p :: P
p = Float -> Float -> P
P Float
cx (if Bool
rel then Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
y else Float
y) in P -> Segment
LineTo P
p Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: Char -> P -> P -> Maybe P -> Text -> [Segment]
go Char
cmd P
p P
start Maybe P
forall a. Maybe a
Nothing (Text -> Text
skipSep Text
r)
              Maybe ([Float], Text)
_ -> []
            Char
'c' -> case Int -> Maybe ([Float], Text)
nums Int
6 of
              Just ([Float
x1, Float
y1, Float
x2, Float
y2, Float
x, Float
y], Text
r) ->
                let c2 :: P
c2 = P -> P
pt (Float -> Float -> P
P Float
x2 Float
y2)
                    p :: P
p = P -> P
pt (Float -> Float -> P
P Float
x Float
y)
                 in P -> P -> P -> Segment
CubicTo (P -> P
pt (Float -> Float -> P
P Float
x1 Float
y1)) P
c2 P
p Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: Char -> P -> P -> Maybe P -> Text -> [Segment]
go Char
cmd P
p P
start (P -> Maybe P
forall a. a -> Maybe a
Just P
c2) (Text -> Text
skipSep Text
r)
              Maybe ([Float], Text)
_ -> []
            Char
's' -> case Int -> Maybe ([Float], Text)
nums Int
4 of
              Just ([Float
x2, Float
y2, Float
x, Float
y], Text
r) ->
                let c1 :: P
c1 = P -> (P -> P) -> Maybe P -> P
forall b a. b -> (a -> b) -> Maybe a -> b
maybe P
cur (P -> P -> P
reflect P
cur) Maybe P
ctrl
                    c2 :: P
c2 = P -> P
pt (Float -> Float -> P
P Float
x2 Float
y2)
                    p :: P
p = P -> P
pt (Float -> Float -> P
P Float
x Float
y)
                 in P -> P -> P -> Segment
CubicTo P
c1 P
c2 P
p Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: Char -> P -> P -> Maybe P -> Text -> [Segment]
go Char
cmd P
p P
start (P -> Maybe P
forall a. a -> Maybe a
Just P
c2) (Text -> Text
skipSep Text
r)
              Maybe ([Float], Text)
_ -> []
            Char
'q' -> case Int -> Maybe ([Float], Text)
nums Int
4 of
              Just ([Float
x1, Float
y1, Float
x, Float
y], Text
r) ->
                let c1 :: P
c1 = P -> P
pt (Float -> Float -> P
P Float
x1 Float
y1)
                    p :: P
p = P -> P
pt (Float -> Float -> P
P Float
x Float
y)
                 in P -> P -> Segment
QuadTo P
c1 P
p Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: Char -> P -> P -> Maybe P -> Text -> [Segment]
go Char
cmd P
p P
start (P -> Maybe P
forall a. a -> Maybe a
Just P
c1) (Text -> Text
skipSep Text
r)
              Maybe ([Float], Text)
_ -> []
            Char
't' -> case Int -> Maybe ([Float], Text)
nums Int
2 of
              Just ([Float
x, Float
y], Text
r) ->
                let c1 :: P
c1 = P -> (P -> P) -> Maybe P -> P
forall b a. b -> (a -> b) -> Maybe a -> b
maybe P
cur (P -> P -> P
reflect P
cur) Maybe P
ctrl
                    p :: P
p = P -> P
pt (Float -> Float -> P
P Float
x Float
y)
                 in P -> P -> Segment
QuadTo P
c1 P
p Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: Char -> P -> P -> Maybe P -> Text -> [Segment]
go Char
cmd P
p P
start (P -> Maybe P
forall a. a -> Maybe a
Just P
c1) (Text -> Text
skipSep Text
r)
              Maybe ([Float], Text)
_ -> []
            Char
'a' -> case Text
-> Maybe ((Float, Float, Float, Bool, Bool, Float, Float), Text)
arcArgs Text
t of
              Just ((Float
rx, Float
ry, Float
rot, Bool
large, Bool
sweep, Float
x, Float
y), Text
r) ->
                let p :: P
p = P -> P
pt (Float -> Float -> P
P Float
x Float
y)
                 in Float -> Float -> Float -> Bool -> Bool -> P -> Segment
ArcTo Float
rx Float
ry Float
rot Bool
large Bool
sweep P
p Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: Char -> P -> P -> Maybe P -> Text -> [Segment]
go Char
cmd P
p P
start Maybe P
forall a. Maybe a
Nothing (Text -> Text
skipSep Text
r)
              Maybe ((Float, Float, Float, Bool, Bool, Float, Float), Text)
_ -> []
            Char
_ -> []
    reflect :: P -> P -> P
reflect (P Float
cx Float
cy) (P Float
x Float
y) = Float -> Float -> P
P (Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x) (Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y)
    takeNumbers :: Int -> Text -> Maybe ([Float], Text)
    takeNumbers :: Int -> Text -> Maybe ([Float], Text)
takeNumbers Int
0 Text
t = ([Float], Text) -> Maybe ([Float], Text)
forall a. a -> Maybe a
Just ([], Text
t)
    takeNumbers Int
n Text
t = do
      (x, rest) <- Text -> Maybe (Float, Text)
readNumber Text
t
      (xs, rest') <- takeNumbers (n - 1) (skipSep rest)
      pure (x : xs, rest')
    -- Arc flags may be written without separators: @a1 1 0 00.5.5@.
    arcArgs :: Text
-> Maybe ((Float, Float, Float, Bool, Bool, Float, Float), Text)
arcArgs Text
t = do
      (rx, r1) <- Text -> Maybe (Float, Text)
readNumber Text
t
      (ry, r2) <- readNumber (skipSep r1)
      (rot, r3) <- readNumber (skipSep r2)
      (large, r4) <- flag (skipSep r3)
      (sweep, r5) <- flag (skipSep r4)
      (x, r6) <- readNumber (skipSep r5)
      (y, r7) <- readNumber (skipSep r6)
      pure ((rx, ry, rot, large, sweep, x, y), r7)
    flag :: Text -> Maybe (Bool, Text)
flag Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
      Just (Char
'0', Text
r) -> (Bool, Text) -> Maybe (Bool, Text)
forall a. a -> Maybe a
Just (Bool
False, Text
r)
      Just (Char
'1', Text
r) -> (Bool, Text) -> Maybe (Bool, Text)
forall a. a -> Maybe a
Just (Bool
True, Text
r)
      Maybe (Char, Text)
_ -> Maybe (Bool, Text)
forall a. Maybe a
Nothing

rectSegments :: Float -> Float -> Float -> Float -> Maybe Float -> Maybe Float -> [Segment]
rectSegments :: Float
-> Float
-> Float
-> Float
-> Maybe Float
-> Maybe Float
-> [Segment]
rectSegments Float
x Float
y Float
w Float
h Maybe Float
mrx Maybe Float
mry
  | Float
w Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 Bool -> Bool -> Bool
|| Float
h Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = []
  | Float
rx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 Bool -> Bool -> Bool
|| Float
ry Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = [P -> Segment
MoveTo (Float -> Float -> P
P Float
x Float
y), P -> Segment
LineTo (Float -> Float -> P
P (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w) Float
y), P -> Segment
LineTo (Float -> Float -> P
P (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h)), P -> Segment
LineTo (Float -> Float -> P
P Float
x (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h)), Segment
ClosePath]
  | Bool
otherwise =
      [ P -> Segment
MoveTo (Float -> Float -> P
P (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rx) Float
y)
      , P -> Segment
LineTo (Float -> Float -> P
P (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
rx) Float
y)
      , Float -> Float -> Float -> Bool -> Bool -> P -> Segment
ArcTo Float
rx Float
ry Float
0 Bool
False Bool
True (Float -> Float -> P
P (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ry))
      , P -> Segment
LineTo (Float -> Float -> P
P (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ry))
      , Float -> Float -> Float -> Bool -> Bool -> P -> Segment
ArcTo Float
rx Float
ry Float
0 Bool
False Bool
True (Float -> Float -> P
P (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
rx) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h))
      , P -> Segment
LineTo (Float -> Float -> P
P (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rx) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h))
      , Float -> Float -> Float -> Bool -> Bool -> P -> Segment
ArcTo Float
rx Float
ry Float
0 Bool
False Bool
True (Float -> Float -> P
P Float
x (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ry))
      , P -> Segment
LineTo (Float -> Float -> P
P Float
x (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ry))
      , Float -> Float -> Float -> Bool -> Bool -> P -> Segment
ArcTo Float
rx Float
ry Float
0 Bool
False Bool
True (Float -> Float -> P
P (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rx) Float
y)
      , Segment
ClosePath
      ]
  where
    rx :: Float
rx = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe (Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe Float
0 Maybe Float
mry) Maybe Float
mrx)
    ry :: Float
ry = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe (Float -> Maybe Float -> Float
forall a. a -> Maybe a -> a
fromMaybe Float
0 Maybe Float
mrx) Maybe Float
mry)

ellipseSegments :: Float -> Float -> Float -> Float -> [Segment]
ellipseSegments :: Float -> Float -> Float -> Float -> [Segment]
ellipseSegments Float
cx Float
cy Float
rx Float
ry
  | Float
rx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 Bool -> Bool -> Bool
|| Float
ry Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = []
  | Bool
otherwise =
      [ P -> Segment
MoveTo (Float -> Float -> P
P (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rx) Float
cy)
      , Float -> Float -> Float -> Bool -> Bool -> P -> Segment
ArcTo Float
rx Float
ry Float
0 Bool
False Bool
True (Float -> Float -> P
P (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
rx) Float
cy)
      , Float -> Float -> Float -> Bool -> Bool -> P -> Segment
ArcTo Float
rx Float
ry Float
0 Bool
False Bool
True (Float -> Float -> P
P (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rx) Float
cy)
      , Segment
ClosePath
      ]

polySegments :: Bool -> Text -> [Segment]
polySegments :: Bool -> Text -> [Segment]
polySegments Bool
closed Text
pts = case [Float] -> [P]
pairs (Text -> [Float]
numberList Text
pts) of
  [] -> []
  P
p : [P]
ps -> P -> Segment
MoveTo P
p Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: (P -> Segment) -> [P] -> [Segment]
forall a b. (a -> b) -> [a] -> [b]
map P -> Segment
LineTo [P]
ps [Segment] -> [Segment] -> [Segment]
forall a. [a] -> [a] -> [a]
++ [Segment
ClosePath | Bool
closed]
  where
    pairs :: [Float] -> [P]
pairs (Float
x : Float
y : [Float]
rest) = Float -> Float -> P
P Float
x Float
y P -> [P] -> [P]
forall a. a -> [a] -> [a]
: [Float] -> [P]
pairs [Float]
rest
    pairs [Float]
_ = []

--------------------------------------------------------------------------------
-- Rings
--------------------------------------------------------------------------------

-- | Point lists in flat arrays: ring @i@ is points @starts[i]@ up to
-- @starts[i + 1]@, stored x then y, with a number the builder tagged it with.
data Rings = Rings !(PrimArray Float) !(PrimArray Int) !(PrimArray Int)

ringCount :: Rings -> Int
ringCount :: Rings -> Int
ringCount (Rings PrimArray Float
_ PrimArray Int
starts PrimArray Int
_) = PrimArray Int -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Int
starts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

-- | Rings from a walk that calls @point x y@ for each point and @end tag@
-- after each ring's last. The walk runs twice, to size the arrays and then
-- to fill them, so it must visit the same points both times.
{-# INLINE buildRings #-}
buildRings :: (forall s. (Float -> Float -> ST s ()) -> (Int -> ST s ()) -> ST s ()) -> Rings
buildRings :: (forall s.
 (Float -> Float -> ST s ()) -> (Int -> ST s ()) -> ST s ())
-> Rings
buildRings forall s.
(Float -> Float -> ST s ()) -> (Int -> ST s ()) -> ST s ()
walk = (forall s. ST s Rings) -> Rings
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s Rings) -> Rings)
-> (forall s. ST s Rings) -> Rings
forall a b. (a -> b) -> a -> b
$ do
  counts <- Int -> ST s (MutablePrimArray (PrimState (ST s)) Int)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
2
  setPrimArray counts 0 2 (0 :: Int)
  let bump Int
k = MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
counts Int
k ST s Int -> (Int -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutablePrimArray (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
counts Int
k (Int -> ST s ()) -> (Int -> Int) -> Int -> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  walk (\Float
_ Float
_ -> Int -> ST s ()
bump Int
0) (\Int
_ -> Int -> ST s ()
bump Int
1)
  nPoints <- readPrimArray counts 0
  nRings <- readPrimArray counts 1
  points <- newPrimArray (2 * nPoints)
  starts <- newPrimArray (nRings + 1)
  tags <- newPrimArray nRings
  writePrimArray starts 0 0
  setPrimArray counts 0 2 0
  walk
    ( \Float
x Float
y -> do
        k <- MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
counts Int
0
        writePrimArray points (2 * k) x
        writePrimArray points (2 * k + 1) y
        writePrimArray counts 0 (k + 1)
    )
    ( \Int
tag -> do
        r <- MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
counts Int
1
        readPrimArray counts 0 >>= writePrimArray starts (r + 1)
        writePrimArray tags r tag
        writePrimArray counts 1 (r + 1)
    )
  Rings <$> unsafeFreezePrimArray points <*> unsafeFreezePrimArray starts <*> unsafeFreezePrimArray tags

--------------------------------------------------------------------------------
-- Flattening
--------------------------------------------------------------------------------

-- | Flatten segments through a transform into contours in device pixels,
-- each tagged 1 when closed. Curves are split until they are within a
-- quarter pixel of their chords.
flatten :: Matrix -> SmallArray Segment -> Rings
flatten :: Matrix -> SmallArray Segment -> Rings
flatten Matrix
m SmallArray Segment
segs = (forall s.
 (Float -> Float -> ST s ()) -> (Int -> ST s ()) -> ST s ())
-> Rings
buildRings (Matrix
-> SmallArray Segment
-> (Float -> Float -> ST s ())
-> (Int -> ST s ())
-> ST s ()
forall s.
Matrix
-> SmallArray Segment
-> (Float -> Float -> ST s ())
-> (Int -> ST s ())
-> ST s ()
flattenWalk Matrix
m SmallArray Segment
segs)

{-# INLINE flattenWalk #-}
flattenWalk :: Matrix -> SmallArray Segment -> (Float -> Float -> ST s ()) -> (Int -> ST s ()) -> ST s ()
flattenWalk :: forall s.
Matrix
-> SmallArray Segment
-> (Float -> Float -> ST s ())
-> (Int -> ST s ())
-> ST s ()
flattenWalk Matrix
m SmallArray Segment
segs Float -> Float -> ST s ()
point Int -> ST s ()
end =
  let count :: Int
count = SmallArray Segment -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray Segment
segs
      emit :: P -> ST s ()
emit P
p = let P Float
x Float
y = Matrix -> P -> P
apply Matrix
m P
p in Float -> Float -> ST s ()
point Float
x Float
y
      finish :: Int -> Bool -> ST s ()
finish Int
n Bool
closed = Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Int -> ST s ()
end (if Bool
closed then Int
1 else Int
0))
      -- A segment with no subpath open starts one at the current point.
      begin :: Int -> Bool -> P -> ST s Int
begin Int
n Bool
started P
cur = if Bool
started Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n else P -> ST s ()
emit P
cur ST s () -> ST s Int -> ST s Int
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1 :: Int)
      go :: Int -> Int -> Bool -> P -> P -> ST s ()
go !Int
i !Int
n !Bool
started P
cur P
start
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
count = Int -> Bool -> ST s ()
finish Int
n Bool
False
        | Bool
otherwise = case SmallArray Segment -> Int -> Segment
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray Segment
segs Int
i of
            MoveTo P
p -> Int -> Bool -> ST s ()
finish Int
n Bool
False ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P -> ST s ()
emit P
p ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> Bool -> P -> P -> ST s ()
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
1 Bool
True P
p P
p
            LineTo P
p -> do
              n1 <- Int -> Bool -> P -> ST s Int
begin Int
n Bool
started P
cur
              emit p
              go (i + 1) (n1 + 1) True p start
            CubicTo P
c1 P
c2 P
p -> do
              n1 <- Int -> Bool -> P -> ST s Int
begin Int
n Bool
started P
cur
              k <- cubicPoints point (apply m cur) (apply m c1) (apply m c2) (apply m p)
              go (i + 1) (n1 + k) True p start
            QuadTo P
c1 P
p -> do
              n1 <- Int -> Bool -> P -> ST s Int
begin Int
n Bool
started P
cur
              let P x0 y0 = cur
                  P x1 y1 = c1
                  P x2 y2 = p
                  q1 = Float -> Float -> P
P (Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
3 Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
x1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x0)) (Float
y0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
3 Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
y1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y0))
                  q2 = Float -> Float -> P
P (Float
x2 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
3 Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
x1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x2)) (Float
y2 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
3 Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
y1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y2))
              k <- cubicPoints point (apply m cur) (apply m q1) (apply m q2) (apply m p)
              go (i + 1) (n1 + k) True p start
            ArcTo Float
rx Float
ry Float
rot Bool
large Bool
sweep P
p -> do
              n1 <- Int -> Bool -> P -> ST s Int
begin Int
n Bool
started P
cur
              k <- arcPoints emit cur rx ry rot large sweep p
              go (i + 1) (n1 + k) True p start
            Segment
ClosePath -> Int -> Bool -> ST s ()
finish Int
n Bool
True ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> Bool -> P -> P -> ST s ()
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0 Bool
False P
start P
start
   in Int -> Int -> Bool -> P -> P -> ST s ()
go Int
0 Int
0 Bool
False (Float -> Float -> P
P Float
0 Float
0) (Float -> Float -> P
P Float
0 Float
0)

-- | The points after the start of a cubic, subdividing by flatness, and how
-- many there were.
{-# INLINE cubicPoints #-}
cubicPoints :: (Float -> Float -> ST s ()) -> P -> P -> P -> P -> ST s Int
cubicPoints :: forall s.
(Float -> Float -> ST s ()) -> P -> P -> P -> P -> ST s Int
cubicPoints Float -> Float -> ST s ()
point = Int -> P -> P -> P -> P -> ST s Int
go (Int
0 :: Int)
  where
    go :: Int -> P -> P -> P -> P -> ST s Int
go Int
depth P
a P
b P
c P
d
      | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
12 Bool -> Bool -> Bool
|| P -> P -> P -> P -> Bool
flat P
a P
b P
c P
d = let P Float
x Float
y = P
d in Float -> Float -> ST s ()
point Float
x Float
y ST s () -> ST s Int -> ST s Int
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
      | Bool
otherwise = do
          let ab :: P
ab = P -> P -> P
mid P
a P
b
              bc :: P
bc = P -> P -> P
mid P
b P
c
              cd :: P
cd = P -> P -> P
mid P
c P
d
              abc :: P
abc = P -> P -> P
mid P
ab P
bc
              bcd :: P
bcd = P -> P -> P
mid P
bc P
cd
              abcd :: P
abcd = P -> P -> P
mid P
abc P
bcd
          k1 <- Int -> P -> P -> P -> P -> ST s Int
go (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) P
a P
ab P
abc P
abcd
          k2 <- go (depth + 1) abcd bcd cd d
          pure (k1 + k2)
    mid :: P -> P -> P
mid (P Float
x0 Float
y0) (P Float
x1 Float
y1) = Float -> Float -> P
P ((Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
x1) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) ((Float
y0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
y1) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
    flat :: P -> P -> P -> P -> Bool
flat (P Float
x0 Float
y0) (P Float
x1 Float
y1) (P Float
x2 Float
y2) (P Float
x3 Float
y3) =
      let ux :: Float
ux = Float
3 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x3
          uy :: Float
uy = Float
3 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y0 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y3
          vx :: Float
vx = Float
3 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x2 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x3 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x0
          vy :: Float
vy = Float
3 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y2 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y3 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y0
       in Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (Float
ux Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ux) (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
vx) Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (Float
uy Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
uy) (Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
vy) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
16 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.25 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.25

-- | The points after the start of an SVG arc, by the endpoint-to-centre
-- conversion in the SVG specification, in user space, and how many there
-- were.
{-# INLINE arcPoints #-}
arcPoints :: (P -> ST s ()) -> P -> Float -> Float -> Float -> Bool -> Bool -> P -> ST s Int
arcPoints :: forall s.
(P -> ST s ())
-> P -> Float -> Float -> Float -> Bool -> Bool -> P -> ST s Int
arcPoints P -> ST s ()
emit (P Float
x1 Float
y1) Float
rx0 Float
ry0 Float
rotDeg Bool
large Bool
sweep (P Float
x2 Float
y2)
  | Float
rx0 Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 Bool -> Bool -> Bool
|| Float
ry0 Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 Bool -> Bool -> Bool
|| (Float
x1 Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
x2 Bool -> Bool -> Bool
&& Float
y1 Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
y2) = P -> ST s ()
emit (Float -> Float -> P
P Float
x2 Float
y2) ST s () -> ST s Int -> ST s Int
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
  | Bool
otherwise = do
      [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
steps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> P -> ST s ()
emit (Int -> P
pointAt Int
i)
      P -> ST s ()
emit (Float -> Float -> P
P Float
x2 Float
y2)
      Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
steps
  where
    phi :: Float
phi = Float
rotDeg Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
180
    cosP :: Float
cosP = Float -> Float
forall a. Floating a => a -> a
cos Float
phi
    sinP :: Float
sinP = Float -> Float
forall a. Floating a => a -> a
sin Float
phi
    dx :: Float
dx = (Float
x1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x2) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
    dy :: Float
dy = (Float
y1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y2) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
    x1' :: Float
x1' = Float
cosP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
sinP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dy
    y1' :: Float
y1' = Float -> Float
forall a. Num a => a -> a
negate Float
sinP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
cosP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dy
    lambda :: Float
lambda = (Float
x1' Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x1') Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
rx0 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
rx0) Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
y1' Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y1') Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
ry0 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ry0)
    scale :: Float
scale = if Float
lambda Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
1 then Float -> Float
forall a. Floating a => a -> a
sqrt Float
lambda else Float
1
    rx :: Float
rx = Float -> Float
forall a. Num a => a -> a
abs Float
rx0 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scale
    ry :: Float
ry = Float -> Float
forall a. Num a => a -> a
abs Float
ry0 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scale
    num :: Float
num = Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y1' Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y1' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x1' Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x1'
    den :: Float
den = Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y1' Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y1' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x1' Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x1'
    coef :: Float
coef = (if Bool
large Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
sweep then -Float
1 else Float
1) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
forall a. Floating a => a -> a
sqrt (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
num Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
den))
    cx' :: Float
cx' = Float
coef Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y1' Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
ry
    cy' :: Float
cy' = Float
coef Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
forall a. Num a => a -> a
negate (Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x1' Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
rx)
    cx :: Float
cx = Float
cosP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
cx' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
sinP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
cy' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
x1 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
x2) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
    cy :: Float
cy = Float
sinP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
cx' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
cosP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
cy' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
y1 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
y2) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
    angle :: a -> a -> a -> a -> a
angle a
ux a
uy a
vx a
vy = a -> a -> a
forall a. RealFloat a => a -> a -> a
atan2 (a
ux a -> a -> a
forall a. Num a => a -> a -> a
* a
vy a -> a -> a
forall a. Num a => a -> a -> a
- a
uy a -> a -> a
forall a. Num a => a -> a -> a
* a
vx) (a
ux a -> a -> a
forall a. Num a => a -> a -> a
* a
vx a -> a -> a
forall a. Num a => a -> a -> a
+ a
uy a -> a -> a
forall a. Num a => a -> a -> a
* a
vy)
    theta1 :: Float
theta1 = Float -> Float -> Float -> Float -> Float
forall {a}. RealFloat a => a -> a -> a -> a -> a
angle Float
1 Float
0 ((Float
x1' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cx') Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
rx) ((Float
y1' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cy') Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
ry)
    dtheta0 :: Float
dtheta0 = Float -> Float -> Float -> Float -> Float
forall {a}. RealFloat a => a -> a -> a -> a -> a
angle ((Float
x1' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cx') Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
rx) ((Float
y1' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cy') Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
ry) ((Float -> Float
forall a. Num a => a -> a
negate Float
x1' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cx') Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
rx) ((Float -> Float
forall a. Num a => a -> a
negate Float
y1' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cy') Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
ry)
    dtheta :: Float
dtheta
      | Bool -> Bool
not Bool
sweep Bool -> Bool -> Bool
&& Float
dtheta0 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 = Float
dtheta0 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
forall a. Floating a => a
pi
      | Bool
sweep Bool -> Bool -> Bool
&& Float
dtheta0 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0 = Float
dtheta0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
forall a. Floating a => a
pi
      | Bool
otherwise = Float
dtheta0
    steps :: Int
steps = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
4 (Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Float -> Float
forall a. Num a => a -> a
abs Float
dtheta Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
16)) :: Int)
    pointAt :: Int -> P
pointAt Int
i =
      let t :: Float
t = Float
theta1 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dtheta Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
steps
          ex :: Float
ex = Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
forall a. Floating a => a -> a
cos Float
t
          ey :: Float
ey = Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
forall a. Floating a => a -> a
sin Float
t
       in Float -> Float -> P
P (Float
cosP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ex Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
sinP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ey Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
cx) (Float
sinP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ex Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
cosP Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ey Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
cy)

--------------------------------------------------------------------------------
-- Stroking
--------------------------------------------------------------------------------

-- | Polygons covering a stroke of width @w@ along the contours, each wound
-- counter-clockwise so a non-zero fill of all of them is their union.
strokePolygons :: Float -> LineCap -> LineJoin -> Float -> Rings -> Rings
strokePolygons :: Float -> LineCap -> LineJoin -> Float -> Rings -> Rings
strokePolygons Float
w LineCap
cap LineJoin
join Float
miterLimit Rings
contours = (forall s.
 (Float -> Float -> ST s ()) -> (Int -> ST s ()) -> ST s ())
-> Rings
buildRings (Float
-> LineCap
-> LineJoin
-> Float
-> Rings
-> (Float -> Float -> ST s ())
-> (Int -> ST s ())
-> ST s ()
forall s.
Float
-> LineCap
-> LineJoin
-> Float
-> Rings
-> (Float -> Float -> ST s ())
-> (Int -> ST s ())
-> ST s ()
strokeWalk Float
w LineCap
cap LineJoin
join Float
miterLimit Rings
contours)

{-# INLINE strokeWalk #-}
strokeWalk :: Float -> LineCap -> LineJoin -> Float -> Rings -> (Float -> Float -> ST s ()) -> (Int -> ST s ()) -> ST s ()
strokeWalk :: forall s.
Float
-> LineCap
-> LineJoin
-> Float
-> Rings
-> (Float -> Float -> ST s ())
-> (Int -> ST s ())
-> ST s ()
strokeWalk Float
w LineCap
cap LineJoin
join Float
miterLimit contours :: Rings
contours@(Rings PrimArray Float
cpts PrimArray Int
cstarts PrimArray Int
ctags) Float -> Float -> ST s ()
point Int -> ST s ()
end =
  let hw :: Float
hw = Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
      at :: Int -> P
at Int
k = Float -> Float -> P
P (PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
cpts (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k)) (PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
cpts (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
      close :: P -> P -> Bool
close (P Float
x0 Float
y0) (P Float
x1 Float
y1) = Float -> Float
forall a. Num a => a -> a
abs (Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x1) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e-4 Bool -> Bool -> Bool
&& Float -> Float
forall a. Num a => a -> a
abs (Float
y0 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y1) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e-4
      emitP :: P -> ST s ()
emitP (P Float
x Float
y) = Float -> Float -> ST s ()
point Float
x Float
y
      -- Twice the signed area of a polygon's corners, positive when they
      -- wind counter-clockwise.
      turn :: P -> P -> Float
turn (P Float
x0 Float
y0) (P Float
x1 Float
y1) = Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x1 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y0
      -- A triangle or quad in the order given, or reversed when that winds
      -- clockwise.
      triangle :: P -> P -> P -> ST s ()
triangle P
a P
b P
c = do
        if P -> P -> Float
turn P
a P
b Float -> Float -> Float
forall a. Num a => a -> a -> a
+ P -> P -> Float
turn P
b P
c Float -> Float -> Float
forall a. Num a => a -> a -> a
+ P -> P -> Float
turn P
c P
a Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0
          then P -> ST s ()
emitP P
c ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P -> ST s ()
emitP P
b ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P -> ST s ()
emitP P
a
          else P -> ST s ()
emitP P
a ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P -> ST s ()
emitP P
b ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P -> ST s ()
emitP P
c
        Int -> ST s ()
end Int
0
      quad :: P -> P -> P -> P -> ST s ()
quad P
a P
b P
c P
d = do
        if P -> P -> Float
turn P
a P
b Float -> Float -> Float
forall a. Num a => a -> a -> a
+ P -> P -> Float
turn P
b P
c Float -> Float -> Float
forall a. Num a => a -> a -> a
+ P -> P -> Float
turn P
c P
d Float -> Float -> Float
forall a. Num a => a -> a -> a
+ P -> P -> Float
turn P
d P
a Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0
          then P -> ST s ()
emitP P
d ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P -> ST s ()
emitP P
c ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P -> ST s ()
emitP P
b ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P -> ST s ()
emitP P
a
          else P -> ST s ()
emitP P
a ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P -> ST s ()
emitP P
b ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P -> ST s ()
emitP P
c ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P -> ST s ()
emitP P
d
        Int -> ST s ()
end Int
0
      normal :: P -> P -> (Float, Float)
normal (P Float
x0 Float
y0) (P Float
x1 Float
y1) =
        let dx :: Float
dx = Float
x1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x0
            dy :: Float
dy = Float
y1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y0
            len :: Float
len = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1e-6 (Float -> Float
forall a. Floating a => a -> a
sqrt (Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dy Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dy))
         in (Float -> Float
forall a. Num a => a -> a
negate Float
dy Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
len Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
hw, Float
dx Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
len Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
hw)
      segmentQuad :: P -> P -> ST s ()
segmentQuad a :: P
a@(P Float
ax Float
ay) b :: P
b@(P Float
bx Float
by) = do
        let (Float
nx, Float
ny) = P -> P -> (Float, Float)
normal P
a P
b
        -- The quad winds clockwise as built, whatever its direction.
        P -> ST s ()
emitP (Float -> Float -> P
P (Float
ax Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
nx) (Float
ay Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ny))
        P -> ST s ()
emitP (Float -> Float -> P
P (Float
bx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
nx) (Float
by Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ny))
        P -> ST s ()
emitP (Float -> Float -> P
P (Float
bx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
nx) (Float
by Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ny))
        P -> ST s ()
emitP (Float -> Float -> P
P (Float
ax Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
nx) (Float
ay Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ny))
        Int -> ST s ()
end Int
0
      corner :: P -> P -> P -> ST s ()
corner P
prev v :: P
v@(P Float
vx Float
vy) P
next = do
        let (Float
n1x, Float
n1y) = P -> P -> (Float, Float)
normal P
prev P
v
            (Float
n2x, Float
n2y) = P -> P -> (Float, Float)
normal P
v P
next
            bevel :: ST s ()
bevel = do
              P -> P -> P -> ST s ()
triangle P
v (Float -> Float -> P
P (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
n1x) (Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
n1y)) (Float -> Float -> P
P (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
n2x) (Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
n2y))
              P -> P -> P -> ST s ()
triangle P
v (Float -> Float -> P
P (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
n1x) (Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
n1y)) (Float -> Float -> P
P (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
n2x) (Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
n2y))
        case LineJoin
join of
          LineJoin
JoinRound -> P -> ST s ()
disc P
v
          LineJoin
JoinBevel -> ST s ()
bevel
          LineJoin
JoinMiter -> do
            let mx :: Float
mx = Float
n1x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
n2x
                my :: Float
my = Float
n1y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
n2y
                mlen2 :: Float
mlen2 = Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
my Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
my
                -- The miter point sits along the bisector at hw / cos(half angle).
                scale :: Float
scale = if Float
mlen2 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e-9 then Float
0 else Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
hw Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
hw Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
mlen2
                ratio :: Float
ratio = if Float
mlen2 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1e-9 then Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
0 else Float -> Float
forall a. Floating a => a -> a
sqrt (Float
scale Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scale Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
mlen2) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
hw
            if Float
ratio Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
miterLimit
              then ST s ()
bevel
              else do
                P -> P -> P -> P -> ST s ()
quad P
v (Float -> Float -> P
P (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
n1x) (Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
n1y)) (Float -> Float -> P
P (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scale) (Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
my Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scale)) (Float -> Float -> P
P (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
n2x) (Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
n2y))
                P -> P -> P -> P -> ST s ()
quad P
v (Float -> Float -> P
P (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
n1x) (Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
n1y)) (Float -> Float -> P
P (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scale) (Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
my Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scale)) (Float -> Float -> P
P (Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
n2x) (Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
n2y))
      endCap :: P -> P -> ST s ()
endCap inner :: P
inner@(P Float
ix Float
iy) e :: P
e@(P Float
ex Float
ey) = case LineCap
cap of
        LineCap
CapButt -> () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        LineCap
CapRound -> P -> ST s ()
disc P
e
        LineCap
CapSquare -> do
          let dx :: Float
dx = Float
ex Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ix
              dy :: Float
dy = Float
ey Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
iy
              len :: Float
len = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1e-6 (Float -> Float
forall a. Floating a => a -> a
sqrt (Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dy Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dy))
              ux :: Float
ux = Float
dx Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
len Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
hw
              uy :: Float
uy = Float
dy Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
len Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
hw
              (Float
nx, Float
ny) = P -> P -> (Float, Float)
normal P
inner P
e
          -- Wound clockwise as built, like a segment's quad.
          P -> ST s ()
emitP (Float -> Float -> P
P (Float
ex Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
nx) (Float
ey Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ny))
          P -> ST s ()
emitP (Float -> Float -> P
P (Float
ex Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
nx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ux) (Float
ey Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ny Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
uy))
          P -> ST s ()
emitP (Float -> Float -> P
P (Float
ex Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
nx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ux) (Float
ey Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ny Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
uy))
          P -> ST s ()
emitP (Float -> Float -> P
P (Float
ex Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
nx) (Float
ey Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ny))
          Int -> ST s ()
end Int
0
      disc :: P -> ST s ()
disc (P Float
cx Float
cy) = do
        let n :: Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
8 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
48 (Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Float
hw Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
2.5) :: Int))
        [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i ->
          let t :: Float
t = Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n in Float -> Float -> ST s ()
point (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
hw Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
forall a. Floating a => a -> a
cos Float
t) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
hw Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
forall a. Floating a => a -> a
sin Float
t)
        Int -> ST s ()
end Int
0
      square :: P -> ST s ()
square (P Float
cx Float
cy) = do
        P -> ST s ()
emitP (Float -> Float -> P
P (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
hw) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
hw))
        P -> ST s ()
emitP (Float -> Float -> P
P (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
hw) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
hw))
        P -> ST s ()
emitP (Float -> Float -> P
P (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
hw) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
hw))
        P -> ST s ()
emitP (Float -> Float -> P
P (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
hw) (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
hw))
        Int -> ST s ()
end Int
0
      contour :: Int -> ST s ()
contour Int
r = do
        let from :: Int
from = PrimArray Int -> Int -> Int
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Int
cstarts Int
r
            to :: Int
to = PrimArray Int -> Int -> Int
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Int
cstarts (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            closed :: Bool
closed = PrimArray Int -> Int -> Int
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Int
ctags Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
        -- The contour's points, dropping any that repeat the one before.
        kept <- Int -> ST s (MutablePrimArray (PrimState (ST s)) Int)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (Int
to Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
from)
        let dedupe !Int
k !Int
n
              | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
to = Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
              | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = do
                  prevK <- MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
kept (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                  if close (at prevK) (at k)
                    then dedupe (k + 1) n
                    else writePrimArray kept n k >> dedupe (k + 1) (n + 1)
              | Bool
otherwise = MutablePrimArray (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
kept Int
0 Int
k ST s () -> ST s Int -> ST s Int
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> ST s Int
dedupe (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
1
        n0 <- dedupe from 0
        firstK <- readPrimArray kept 0
        lastK <- readPrimArray kept (max 0 (n0 - 1))
        -- A closed contour that returns to its start ends on that point.
        let n = if Bool
closed Bool -> Bool -> Bool
&& Int
n0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& P -> P -> Bool
close (Int -> P
at Int
firstK) (Int -> P
at Int
lastK) then Int
n0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 else Int
n0
            pt Int
i = Int -> P
at (Int -> P) -> ST s Int -> ST s P
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
kept Int
i
        case n of
          Int
0 -> () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Int
1 -> do
            p <- Int -> ST s P
pt Int
0
            when (cap == CapRound) (disc p)
            when (cap == CapSquare) (square p)
          Int
_ -> do
            [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
              a <- Int -> ST s P
pt Int
i
              b <- pt (i + 1)
              segmentQuad a b
            Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
closed (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
              a <- Int -> ST s P
pt (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
              b <- pt 0
              segmentQuad a b
            let cornerAt :: Int -> ST s ()
cornerAt Int
i = do
                  prev <- Int -> ST s P
pt ((Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n)
                  v <- pt i
                  next <- pt ((i + 1) `mod` n)
                  corner prev v next
            if Bool
closed
              then [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] Int -> ST s ()
cornerAt
              else [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2] Int -> ST s ()
cornerAt
            Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
closed (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
              first <- Int -> ST s P
pt Int
0
              second <- pt 1
              beforeLast <- pt (n - 2)
              final <- pt (n - 1)
              endCap second first
              endCap beforeLast final
   in [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Rings -> Int
ringCount Rings
contours Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] Int -> ST s ()
contour

--------------------------------------------------------------------------------
-- Rasterizing
--------------------------------------------------------------------------------

-- | Render the document into a @width@ by @height@ RGBA image (rows top to
-- bottom), scaled to fit and centred as SVG's default @xMidYMid meet@ does.
-- @current@ is what @currentColor@, and an unspecified fill, paint with.
rasterizeSvg :: Int -> Int -> Color -> Svg -> ByteString
rasterizeSvg :: Int -> Int -> Color -> Svg -> ByteString
rasterizeSvg Int
width Int
height Color
current Svg
svg
  | Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
height Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = ByteString
BS.empty
  | Bool
otherwise = Int -> (Ptr Word8 -> IO ()) -> ByteString
BSI.unsafeCreate (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) ((Ptr Word8 -> IO ()) -> ByteString)
-> (Ptr Word8 -> IO ()) -> ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
out ->
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
        let al :: Float
al = PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
image (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
            byte :: a -> Word8
byte a
x = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
255 (a -> Int
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
255) :: Int))) :: Word8
            unpremul :: Int -> IO ()
unpremul Int
k = Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
out (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k) (if Float
al Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 then Word8
0 else Float -> Word8
forall {a}. RealFrac a => a -> Word8
byte (PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
image (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
al))
        Int -> IO ()
unpremul Int
0
        Int -> IO ()
unpremul Int
1
        Int -> IO ()
unpremul Int
2
        Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
out (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (Float -> Word8
forall {a}. RealFrac a => a -> Word8
byte Float
al)
  where
    image :: PrimArray Float
image = (forall s. ST s (PrimArray Float)) -> PrimArray Float
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (PrimArray Float)) -> PrimArray Float)
-> (forall s. ST s (PrimArray Float)) -> PrimArray Float
forall a b. (a -> b) -> a -> b
$ do
      -- Premultiplied RGBA in [0, 1].
      acc <- Int -> ST s (MutablePrimArray (PrimState (ST s)) Float)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4)
      setPrimArray acc 0 (width * height * 4) (0 :: Float)
      cov <- newPrimArray (width * height)
      let Box vx vy vw vh = svgViewBox svg
          s = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
vw) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
vh)
          tx = (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
vw Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
s) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
s
          ty = (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
vh Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
s) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
s
          view = Float -> Float -> Float -> Float -> Float -> Float -> Matrix
Matrix Float
s Float
0 Float
0 Float
s Float
tx Float
ty
      forM_ (svgShapes svg) $ \(Shape SmallArray Segment
segs Matrix
m PaintStyle
style) -> do
        let full :: Matrix
full = Matrix
view Matrix -> Matrix -> Matrix
`mul` Matrix
m
            contours :: Rings
contours = Matrix -> SmallArray Segment -> Rings
flatten Matrix
full SmallArray Segment
segs
            Matrix Float
a Float
b Float
c Float
d Float
_ Float
_ = Matrix
full
            scaleOf :: Float
scaleOf = Float -> Float
forall a. Floating a => a -> a
sqrt (Float -> Float
forall a. Num a => a -> a
abs (Float
a Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
d Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
c))
            opacity :: Float
opacity = PaintStyle -> Float
psOpacity PaintStyle
style
            paintColor :: Paint -> Maybe Color
paintColor Paint
p = case Paint
p of
              Paint
PaintNone -> Maybe Color
forall a. Maybe a
Nothing
              Paint
PaintCurrent -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
current
              PaintColor Color
col -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
col
            -- An unspecified fill paints black, or the current colour in a
            -- monochrome document, so an icon without paints tints.
            fill :: Paint
fill = Paint -> Maybe Paint -> Paint
forall a. a -> Maybe a -> a
fromMaybe (if Svg -> Bool
svgMonochrome Svg
svg then Paint
PaintCurrent else Color -> Paint
PaintColor (Word8 -> Word8 -> Word8 -> Word8 -> Color
colorRGBA Word8
0 Word8
0 Word8
0 Word8
255)) (PaintStyle -> Maybe Paint
psFill PaintStyle
style)
        Maybe Color -> (Color -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Paint -> Maybe Color
paintColor Paint
fill) ((Color -> ST s ()) -> ST s ()) -> (Color -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Color
col -> do
          Int
-> Int -> MutablePrimArray s Float -> FillRule -> Rings -> ST s ()
forall s.
Int
-> Int -> MutablePrimArray s Float -> FillRule -> Rings -> ST s ()
coverPolygons Int
width Int
height MutablePrimArray s Float
cov (PaintStyle -> FillRule
psRule PaintStyle
style) Rings
contours
          Int
-> Int
-> MutablePrimArray s Float
-> MutablePrimArray s Float
-> Color
-> Float
-> ST s ()
forall s.
Int
-> Int
-> MutablePrimArray s Float
-> MutablePrimArray s Float
-> Color
-> Float
-> ST s ()
composite Int
width Int
height MutablePrimArray s Float
acc MutablePrimArray s Float
cov Color
col (Float
opacity Float -> Float -> Float
forall a. Num a => a -> a -> a
* PaintStyle -> Float
psFillOpacity PaintStyle
style)
        Maybe Color -> (Color -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Paint -> Maybe Color
paintColor (Paint -> Maybe Paint -> Paint
forall a. a -> Maybe a -> a
fromMaybe Paint
PaintNone (PaintStyle -> Maybe Paint
psStroke PaintStyle
style))) ((Color -> ST s ()) -> ST s ()) -> (Color -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Color
col ->
          Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PaintStyle -> Float
psStrokeWidth PaintStyle
style Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
            let wanted :: Float
wanted = PaintStyle -> Float
psStrokeWidth PaintStyle
style Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scaleOf
                w :: Float
w = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 Float
wanted
                polys :: Rings
polys = Float -> LineCap -> LineJoin -> Float -> Rings -> Rings
strokePolygons Float
w (PaintStyle -> LineCap
psCap PaintStyle
style) (PaintStyle -> LineJoin
psJoin PaintStyle
style) (PaintStyle -> Float
psMiterLimit PaintStyle
style) Rings
contours
            Int
-> Int -> MutablePrimArray s Float -> FillRule -> Rings -> ST s ()
forall s.
Int
-> Int -> MutablePrimArray s Float -> FillRule -> Rings -> ST s ()
coverPolygons Int
width Int
height MutablePrimArray s Float
cov FillRule
NonZero Rings
polys
            -- A hairline thinner than a pixel keeps its weight as opacity.
            Int
-> Int
-> MutablePrimArray s Float
-> MutablePrimArray s Float
-> Color
-> Float
-> ST s ()
forall s.
Int
-> Int
-> MutablePrimArray s Float
-> MutablePrimArray s Float
-> Color
-> Float
-> ST s ()
composite Int
width Int
height MutablePrimArray s Float
acc MutablePrimArray s Float
cov Color
col (Float
opacity Float -> Float -> Float
forall a. Num a => a -> a -> a
* PaintStyle -> Float
psStrokeOpacity PaintStyle
style Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
1 (Float
wanted Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
w))
      unsafeFreezePrimArray acc

-- | Coverage of the rings with at least three points in @cov@ (cleared
-- first): five sample rows a pixel, each span's coverage split exactly
-- across the pixels it crosses.
--
-- Edges are counted per pixel row they start in and then written in row
-- order, so the sweep down the rows admits each row's edges as a block,
-- drops an edge past its bottom, and insertion sorts a row's few crossings
-- in a scratch array.
coverPolygons :: Int -> Int -> MutablePrimArray s Float -> FillRule -> Rings -> ST s ()
coverPolygons :: forall s.
Int
-> Int -> MutablePrimArray s Float -> FillRule -> Rings -> ST s ()
coverPolygons Int
width Int
height MutablePrimArray s Float
cov FillRule
rule rings :: Rings
rings@(Rings PrimArray Float
pts PrimArray Int
starts PrimArray Int
_) = do
  MutablePrimArray (PrimState (ST s)) Float
-> Int -> Int -> Float -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> Int -> a -> m ()
setPrimArray MutablePrimArray s Float
MutablePrimArray (PrimState (ST s)) Float
cov Int
0 (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height) Float
0
  let capacity :: Int
capacity = PrimArray Float -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Float
pts Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
      -- Each edge that can cover a row: its first row, top, bottom, x at the
      -- top, slope and winding.
      {-# INLINE forEdges #-}
      forEdges :: (Int -> Float -> Float -> Float -> Float -> Int -> ST s ()) -> ST s ()
      forEdges :: forall s.
(Int -> Float -> Float -> Float -> Float -> Int -> ST s ())
-> ST s ()
forEdges Int -> Float -> Float -> Float -> Float -> Int -> ST s ()
visit =
        [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Rings -> Int
ringCount Rings
rings Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
r -> do
          let from :: Int
from = PrimArray Int -> Int -> Int
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Int
starts Int
r
              to :: Int
to = PrimArray Int -> Int -> Int
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Int
starts (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
to Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
from Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
            [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
from .. Int
to Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
k -> do
              let k' :: Int
k' = if Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
to then Int
from else Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                  ax :: Float
ax = PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
pts (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k)
                  ay :: Float
ay = PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
pts (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                  bx :: Float
bx = PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
pts (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k')
                  by :: Float
by = PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
pts (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                  up :: Bool
up = Float
ay Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
by
                  x0 :: Float
x0 = if Bool
up then Float
ax else Float
bx
                  y0 :: Float
y0 = if Bool
up then Float
ay else Float
by
                  x1 :: Float
x1 = if Bool
up then Float
bx else Float
ax
                  y1 :: Float
y1 = if Bool
up then Float
by else Float
ay
              Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
ay Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
by Bool -> Bool -> Bool
&& Float
y1 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Float
y0 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                Int -> Float -> Float -> Float -> Float -> Int -> ST s ()
visit (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
y0)) Float
y0 Float
y1 Float
x0 ((Float
x1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x0) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
y1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y0)) (if Bool
up then Int
1 else -Int
1)
  -- Where each row's edges begin: counts, then running totals.
  rowStart <- Int -> ST s (MutablePrimArray (PrimState (ST s)) Int)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  setPrimArray rowStart 0 (height + 1) (0 :: Int)
  forEdges $ \Int
row Float
_ Float
_ Float
_ Float
_ Int
_ -> MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
rowStart (Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ST s Int -> (Int -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutablePrimArray (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
rowStart (Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> ST s ()) -> (Int -> Int) -> Int -> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  forM_ [1 .. height] $ \Int
row -> do
    before <- MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
rowStart (Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    readPrimArray rowStart row >>= writePrimArray rowStart row . (+ before)
  -- Four numbers an edge, in row order: top, bottom, x at the top, slope;
  -- windings apart.
  edges <- newPrimArray (capacity * 4)
  windings <- newPrimArray capacity
  cursor <- newPrimArray height
  copyMutablePrimArray cursor 0 rowStart 0 height
  forEdges $ \Int
row Float
y0 Float
y1 Float
x0 Float
slope Int
dir -> do
    e <- MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
cursor Int
row
    writePrimArray cursor row (e + 1)
    writePrimArray edges (e * 4) y0
    writePrimArray edges (e * 4 + 1) y1
    writePrimArray edges (e * 4 + 2) x0
    writePrimArray edges (e * 4 + 3) slope
    writePrimArray windings e (dir :: Int)
  totalEdges <- readPrimArray rowStart height
  active <- newPrimArray capacity
  crossX <- newPrimArray capacity
  crossDir <- newPrimArray capacity
  let samples = Int
5 :: Int
      weight = Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
samples :: Float
      inside :: Int -> Bool
      inside Int
w = case FillRule
rule of
        FillRule
NonZero -> Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
        FillRule
EvenOdd -> Int -> Bool
forall a. Integral a => a -> Bool
odd Int
w
      add Int
i Float
v = MutablePrimArray (PrimState (ST s)) Float -> Int -> ST s Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Float
MutablePrimArray (PrimState (ST s)) Float
cov Int
i ST s Float -> (Float -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Float
c -> MutablePrimArray (PrimState (ST s)) Float
-> Int -> Float -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Float
MutablePrimArray (PrimState (ST s)) Float
cov Int
i (Float
c Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
v)
      spanCover Int
base Float
xa0 Float
xb0 = do
        let xa :: Float
xa = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) Float
xa0)
            xb :: Float
xb = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) Float
xb0)
        Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
xb Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
xa) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
          let ia :: Int
ia = Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
xa :: Int
              ib :: Int
ib = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
xb)
          if Int
ia Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ib
            then Int -> Float -> ST s ()
add (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ia) ((Float
xb Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
xa) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
weight)
            else do
              Int -> Float -> ST s ()
add (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ia) ((Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
ia Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
xa) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
weight)
              [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
ia Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 .. Int
ib Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Int -> Float -> ST s ()
add (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) Float
weight
              Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ib Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
width) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int -> Float -> ST s ()
add (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ib) ((Float
xb Float -> Float -> Float
forall a. Num a => a -> a -> a
- Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ib) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
weight)
      -- The row's edges join the active list.
      admit !Int
e !Int
stop !Int
n
        | Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
stop = Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
        | Bool
otherwise = MutablePrimArray (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
active Int
n Int
e ST s () -> ST s Int -> ST s Int
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> Int -> ST s Int
admit (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
stop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      -- A crossing goes where it sorts among the @j@ before it.
      insertCrossing !Int
j !Float
x !Int
d
        | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = do
            xj <- MutablePrimArray (PrimState (ST s)) Float -> Int -> ST s Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Float
MutablePrimArray (PrimState (ST s)) Float
crossX (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            if xj > x
              then do
                writePrimArray crossX j xj
                readPrimArray crossDir (j - 1) >>= writePrimArray crossDir j
                insertCrossing (j - 1) x d
              else writePrimArray crossX j x >> writePrimArray crossDir j (d :: Int)
        | Bool
otherwise = MutablePrimArray (PrimState (ST s)) Float
-> Int -> Float -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Float
MutablePrimArray (PrimState (ST s)) Float
crossX Int
0 Float
x ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MutablePrimArray (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
crossDir Int
0 Int
d
      walk !Int
base !Int
crossings !Int
k !Int
w
        | Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
crossings = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise = do
            d <- MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
crossDir Int
k
            let w' = Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d
            when (inside w') $ do
              xa <- readPrimArray crossX k
              xb <- readPrimArray crossX (k + 1)
              spanCover base xa xb
            walk base crossings (k + 1) w'
      -- One sample row: drop edges above it, collect the crossings of the
      -- rest, then cover the spans inside the fill.
      sample !Int
r !Int
si !Int
n !Int
a !Int
kept !Int
crossings
        | Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = do
            e <- MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
active Int
a
            let sy = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
si Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.5) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
weight
            y1 <- readPrimArray edges (e * 4 + 1)
            if y1 <= sy
              then sample r si n (a + 1) kept crossings
              else do
                writePrimArray active kept e
                y0 <- readPrimArray edges (e * 4)
                if sy < y0
                  then sample r si n (a + 1) (kept + 1) crossings
                  else do
                    x0 <- readPrimArray edges (e * 4 + 2)
                    slope <- readPrimArray edges (e * 4 + 3)
                    d <- readPrimArray windings e
                    insertCrossing crossings (x0 + (sy - y0) * slope) d
                    sample r si n (a + 1) (kept + 1) (crossings + 1)
        | Bool
otherwise = do
            Int -> Int -> Int -> Int -> ST s ()
walk (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width) Int
crossings Int
0 Int
0
            if Int
si Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
samples
              then Int -> Int -> Int -> Int -> Int -> Int -> ST s ()
sample Int
r (Int
si Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
kept Int
0 Int
0 Int
0
              else Int -> Int -> ST s ()
rows (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
kept
      rows !Int
r !Int
n
        | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
height = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise = do
            from <- MutablePrimArray (PrimState (ST s)) Int -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Int
MutablePrimArray (PrimState (ST s)) Int
rowStart Int
r
            to <- readPrimArray rowStart (r + 1)
            -- Past the last edge's bottom nothing is left to cover.
            if n == 0 && from >= totalEdges
              then pure ()
              else admit from to n >>= \Int
n' -> Int -> Int -> Int -> Int -> Int -> Int -> ST s ()
sample Int
r Int
0 Int
n' Int
0 Int
0 Int
0
  rows 0 0

-- | Draw @col@ at @alpha@ through the coverage over the accumulated image.
composite :: Int -> Int -> MutablePrimArray s Float -> MutablePrimArray s Float -> Color -> Float -> ST s ()
composite :: forall s.
Int
-> Int
-> MutablePrimArray s Float
-> MutablePrimArray s Float
-> Color
-> Float
-> ST s ()
composite Int
width Int
height MutablePrimArray s Float
acc MutablePrimArray s Float
cov Color
col Float
alpha =
  [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    c <- MutablePrimArray (PrimState (ST s)) Float -> Int -> ST s Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Float
MutablePrimArray (PrimState (ST s)) Float
cov Int
i
    when (c > 0) $ do
      let sa = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
1 Float
c Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
alpha Float -> Float -> Float
forall a. Num a => a -> a -> a
* Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Color -> Word8
colorA Color
col) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
255
          blend Int
k Float
src = do
            dst <- MutablePrimArray (PrimState (ST s)) Float -> Int -> ST s Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray s Float
MutablePrimArray (PrimState (ST s)) Float
acc (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k)
            writePrimArray acc (i * 4 + k) (src * sa + dst * (1 - sa))
      blend 0 (fromIntegral (colorR col) / 255)
      blend 1 (fromIntegral (colorG col) / 255)
      blend 2 (fromIntegral (colorB col) / 255)
      dstA <- readPrimArray acc (i * 4 + 3)
      writePrimArray acc (i * 4 + 3) (sa + dstA * (1 - sa))