{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE Rank2Types                 #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE ViewPatterns               #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.PGF
-- Copyright   :  (c) 2015 Christopher Chalmers
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Interface to PGF. See the manual http://www.ctan.org/pkg/pgf for details.
--
------------------------------------------------------------------------------
module Graphics.Rendering.PGF
  ( renderWith
  , RenderM
  , Render
  , initialState
  -- * Environments
  , scope
  -- , scopeHeader
  -- , resetState
  -- , scopeFooter
  , epsilon
  -- * Lenses
  -- , fillRule
  , style
  -- * units
  , bp
  , pt
  , mm
  , px
  -- * RenderM commands
  , ln
  , raw
  , rawString
  , pgf
  , bracers
  , brackets
  -- * Paths
  , path
  , trail
  , segment
  , usePath
  , lineTo
  , curveTo
  , moveTo
  , closePath
  , clip
  , stroke
  , fill
  , asBoundingBox
  -- , rectangleBoundingBox
  -- * Strokeing Options
  , setDash
  , setLineWidth
  , setLineCap
  , setLineJoin
  , setMiterLimit
  , setLineColor
  , setLineOpacity
  -- * Fill Options
  , setFillColor
  , setFillRule
  , setFillOpacity
  -- * Transformations
  , setTransform
  , applyTransform
  , baseTransform
  , applyScale
  , resetNonTranslations
  -- * Shading
  , linearGradient
  , radialGradient
  , colorSpec
  , shadePath
  , opacityGroup
  -- * images
  , image
  , embeddedImage
  , embeddedImage'
  -- * Text
  , renderText
  , setTextAlign
  , setTextRotation
  , setFontWeight
  , setFontSlant
  ) where

import           Codec.Compression.Zlib
import           Codec.Picture
import           Control.Monad.RWS
import           Data.ByteString.Builder
import           Data.ByteString.Char8        (ByteString)
import qualified Data.ByteString.Char8        as B (replicate)
import           Data.ByteString.Internal     (fromForeignPtr)
import qualified Data.ByteString.Lazy         as LB
import qualified Data.Foldable                as F (foldMap)
import           Data.List                    (intersperse)
import           Data.Maybe                   (catMaybes)
import           Data.Typeable
import qualified Data.Vector.Storable         as S
import           Numeric

import           Diagrams.Core.Transform
import           Diagrams.Prelude             hiding (Render, image, moveTo,
                                               opacity, opacityGroup, stroke,
                                               (<>))
import           Diagrams.TwoD.Text           (FontSlant (..), FontWeight (..),
                                               TextAlignment (..))

import           Diagrams.Backend.PGF.Surface


-- * Types, lenses & runners

-- | Render state, mainly to be used for convenience when build, this module
--   only uses the indent properly.
data RenderState n = RenderState
  { RenderState n -> P2 n
_pos        :: P2 n -- ^ Current position
  , RenderState n -> Int
_indent     :: Int  -- ^ Current indentation
  , RenderState n -> Style V2 n
_style      :: Style V2 n
  }

makeLenses ''RenderState

data RenderInfo = RenderInfo
  { RenderInfo -> TexFormat
_format :: TexFormat
  , RenderInfo -> Bool
_pprint :: Bool
  }

makeLenses ''RenderInfo

-- | Type for render monad.
type RenderM n m = RWS RenderInfo Builder (RenderState n) m

-- | Convenient type for building.
type Render n = RenderM n ()

-- | Starting state for running the builder.
initialState :: (Typeable n, Floating n) => RenderState n
initialState :: RenderState n
initialState = RenderState :: forall n. P2 n -> Int -> Style V2 n -> RenderState n
RenderState
  { _pos :: P2 n
_pos        = P2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin
  , _indent :: Int
_indent     = Int
0
  , _style :: Style V2 n
_style      = Colour Double -> Style V2 n -> Style V2 n
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc Colour Double
forall a. Num a => Colour a
black Style V2 n
forall a. Monoid a => a
mempty -- Until I think of something better:
                                  -- (square 1 # opacity 0.5) doesn't work otherwise
  }

renderWith :: (RealFloat n, Typeable n)
  => Surface -> Bool -> Bool -> V2 n -> Render n -> Builder
renderWith :: Surface -> Bool -> Bool -> V2 n -> Render n -> Builder
renderWith Surface
s Bool
readable Bool
standalone V2 n
bounds Render n
r = Builder
builder
  where
    bounds' :: V2 n
bounds' = (n -> n) -> V2 n -> V2 n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> n
forall a. Num a => Integer -> a
fromInteger (Integer -> n) -> (n -> Integer) -> n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor) V2 n
bounds
    (()
_,Builder
builder) = Render n -> RenderInfo -> RenderState n -> ((), Builder)
forall r w s a. RWS r w s a -> r -> s -> (a, w)
evalRWS Render n
r'
                          (TexFormat -> Bool -> RenderInfo
RenderInfo (Surface
sSurface -> Getting TexFormat Surface TexFormat -> TexFormat
forall s a. s -> Getting a s a -> a
^.Getting TexFormat Surface TexFormat
Lens' Surface TexFormat
texFormat) Bool
readable)
                          RenderState n
forall n. (Typeable n, Floating n) => RenderState n
initialState
    r' :: Render n
r' = do
      Bool -> Render n -> Render n
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
standalone (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
        Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n)
-> (String -> Render n) -> String -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Render n
forall n. String -> Render n
rawString (String -> Render n) -> String -> Render n
forall a b. (a -> b) -> a -> b
$ Surface
sSurface -> Getting String Surface String -> String
forall s a. s -> Getting a s a -> a
^.Getting String Surface String
Lens' Surface String
preamble
        Render n
-> ((V2 Int -> String) -> Render n)
-> Maybe (V2 Int -> String)
-> Render n
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Render n
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              (Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n)
-> ((V2 Int -> String) -> Render n)
-> (V2 Int -> String)
-> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Render n
forall n. String -> Render n
rawString (String -> Render n)
-> ((V2 Int -> String) -> String) -> (V2 Int -> String) -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((V2 Int -> String) -> V2 Int -> String
forall a b. (a -> b) -> a -> b
$ (n -> Int) -> V2 n -> V2 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling V2 n
bounds'))
              (Surface
sSurface
-> Getting
     (Maybe (V2 Int -> String)) Surface (Maybe (V2 Int -> String))
-> Maybe (V2 Int -> String)
forall s a. s -> Getting a s a -> a
^.Getting
  (Maybe (V2 Int -> String)) Surface (Maybe (V2 Int -> String))
Lens' Surface (Maybe (V2 Int -> String))
pageSize)
        Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n)
-> (String -> Render n) -> String -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Render n
forall n. String -> Render n
rawString (String -> Render n) -> String -> Render n
forall a b. (a -> b) -> a -> b
$ Surface
sSurface -> Getting String Surface String -> String
forall s a. s -> Getting a s a -> a
^.Getting String Surface String
Lens' Surface String
beginDoc
      Render n -> Render n
forall n. Render n -> Render n
picture (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ V2 n -> Render n
forall n. RealFloat n => V2 n -> Render n
rectangleBoundingBox V2 n
bounds' Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render n
r
      Bool -> Render n -> Render n
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
standalone (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ String -> Render n
forall n. String -> Render n
rawString (String -> Render n) -> String -> Render n
forall a b. (a -> b) -> a -> b
$ Surface
sSurface -> Getting String Surface String -> String
forall s a. s -> Getting a s a -> a
^.Getting String Surface String
Lens' Surface String
endDoc

-- low level utilities -------------------------------------------------

-- builder functions
raw :: Builder -> Render n
raw :: Builder -> Render n
raw = Builder -> Render n
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
{-# INLINE raw #-}

rawByteString :: ByteString -> Render n
rawByteString :: ByteString -> Render n
rawByteString = Builder -> Render n
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Builder -> Render n)
-> (ByteString -> Builder) -> ByteString -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString
{-# INLINE rawByteString #-}

rawString :: String -> Render n
rawString :: String -> Render n
rawString = Builder -> Render n
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Builder -> Render n) -> (String -> Builder) -> String -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
stringUtf8
{-# INLINE rawString #-}

pgf :: Builder -> Render n
pgf :: Builder -> Render n
pgf Builder
c = Builder -> Render n
forall n. Builder -> Render n
raw (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ Builder
"\\pgf" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
c
{-# INLINE pgf #-}

rawChar :: Char -> Render n
rawChar :: Char -> Render n
rawChar = Builder -> Render n
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Builder -> Render n) -> (Char -> Builder) -> Char -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Builder
char8
{-# INLINE rawChar #-}

-- | Emit the indentation when 'pprint' is True.
emit :: Render n
emit :: Render n
emit = do
  Bool
pp <- Getting Bool RenderInfo Bool
-> RWST RenderInfo Builder (RenderState n) Identity Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool RenderInfo Bool
Lens' RenderInfo Bool
pprint
  Bool -> Render n -> Render n
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pp (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
    Int
tab <- Getting Int (RenderState n) Int
-> RWST RenderInfo Builder (RenderState n) Identity Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int (RenderState n) Int
forall n. Lens' (RenderState n) Int
indent
    ByteString -> Render n
forall n. ByteString -> Render n
rawByteString (ByteString -> Render n) -> ByteString -> Render n
forall a b. (a -> b) -> a -> b
$ Int -> Char -> ByteString
B.replicate Int
tab Char
' '
{-# INLINE emit #-}

ln :: Render n -> Render n
ln :: Render n -> Render n
ln Render n
r = do
  Render n
forall n. Render n
emit
  Render n
r
  Char -> Render n
forall n. Char -> Render n
rawChar Char
'\n'
{-# INLINE ln #-}

-- | Wrap a `Render n` in { .. }.
bracers :: Render n -> Render n
bracers :: Render n -> Render n
bracers Render n
r = do
  Char -> Render n
forall n. Char -> Render n
rawChar Char
'{'
  Render n
r
  Char -> Render n
forall n. Char -> Render n
rawChar Char
'}'
{-# INLINE bracers #-}

bracersBlock :: Render n -> Render n
bracersBlock :: Render n -> Render n
bracersBlock Render n
rs = do
  Builder -> Render n
forall n. Builder -> Render n
raw Builder
"{\n"
  Render n -> Render n
forall n. Render n -> Render n
inBlock Render n
rs
  Render n
forall n. Render n
emit
  Char -> Render n
forall n. Char -> Render n
rawChar Char
'}'

-- | Wrap a `Render n` in [ .. ].
brackets :: Render n -> Render n
brackets :: Render n -> Render n
brackets Render n
r = do
  Char -> Render n
forall n. Char -> Render n
rawChar Char
'['
  Render n
r
  Char -> Render n
forall n. Char -> Render n
rawChar Char
']'
{-# INLINE brackets #-}

parens :: Render n -> Render n
parens :: Render n -> Render n
parens Render n
r = do
  Char -> Render n
forall n. Char -> Render n
rawChar Char
'('
  Render n
r
  Char -> Render n
forall n. Char -> Render n
rawChar Char
')'
{-# INLINE parens #-}

-- | Intersperse list of Render ns with commas.
commaIntersperce :: [Render n] -> Render n
commaIntersperce :: [Render n] -> Render n
commaIntersperce = [Render n] -> Render n
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([Render n] -> Render n)
-> ([Render n] -> [Render n]) -> [Render n] -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render n -> [Render n] -> [Render n]
forall a. a -> [a] -> [a]
intersperse (Char -> Render n
forall n. Char -> Render n
rawChar Char
',')

-- | Place a Render n in an indented block
inBlock :: Render n -> Render n
inBlock :: Render n -> Render n
inBlock Render n
r = do
  (Int -> Identity Int) -> RenderState n -> Identity (RenderState n)
forall n. Lens' (RenderState n) Int
indent ((Int -> Identity Int)
 -> RenderState n -> Identity (RenderState n))
-> Int -> Render n
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Int
2
  Render n
r
  (Int -> Identity Int) -> RenderState n -> Identity (RenderState n)
forall n. Lens' (RenderState n) Int
indent ((Int -> Identity Int)
 -> RenderState n -> Identity (RenderState n))
-> Int -> Render n
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
-= Int
2

-- numbers and points --------------------------------------------------

-- | Render a point.
point :: RealFloat n => P2 n -> Render a
point :: P2 n -> Render a
point = (n, n) -> Render a
forall n a. RealFloat n => (n, n) -> Render a
tuplePoint ((n, n) -> Render a) -> (P2 n -> (n, n)) -> P2 n -> Render a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. P2 n -> (n, n)
forall n. P2 n -> (n, n)
unp2

bracerPoint :: RealFloat n => P2 n -> Render a
bracerPoint :: P2 n -> Render a
bracerPoint (P (V2 n
x n
y)) = do
  Render a -> Render a
forall n. Render n -> Render n
bracers (n -> Render a
forall a n. RealFloat a => a -> Render n
bp n
x)
  Render a -> Render a
forall n. Render n -> Render n
bracers (n -> Render a
forall a n. RealFloat a => a -> Render n
bp n
y)

-- | Render n a tuple as a point.
tuplePoint :: RealFloat n => (n,n) -> Render a
tuplePoint :: (n, n) -> Render a
tuplePoint (n
x,n
y) = do
  Builder -> Render a
forall n. Builder -> Render n
pgf Builder
"qpoint"
  Render a -> Render a
forall n. Render n -> Render n
bracers (n -> Render a
forall a n. RealFloat a => a -> Render n
bp n
x)
  Render a -> Render a
forall n. Render n -> Render n
bracers (n -> Render a
forall a n. RealFloat a => a -> Render n
bp n
y)

-- | Render n a n to four decimal places.
n :: RealFloat a => a -> Render n
n :: a -> Render n
n a
x = String -> Render n
forall n. String -> Render n
rawString (String -> Render n) -> String -> Render n
forall a b. (a -> b) -> a -> b
$ Maybe Int -> a -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4) a
x String
""

-- | Render n length with bp (big point = 1 px at 72 dpi) units.
bp :: RealFloat a => a -> Render n
bp :: a -> Render n
bp = (Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder -> Render n
forall n. Builder -> Render n
raw Builder
"bp") (Render n -> Render n) -> (a -> Render n) -> a -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Render n
forall a n. RealFloat a => a -> Render n
n

-- | Render n length with px units.
px :: RealFloat a => a -> Render n
px :: a -> Render n
px = (Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder -> Render n
forall n. Builder -> Render n
raw Builder
"px") (Render n -> Render n) -> (a -> Render n) -> a -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Render n
forall a n. RealFloat a => a -> Render n
n

-- | Render n length with mm units.
mm :: RealFloat a => a -> Render n
mm :: a -> Render n
mm = (Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder -> Render n
forall n. Builder -> Render n
raw Builder
"mm") (Render n -> Render n) -> (a -> Render n) -> a -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Render n
forall a n. RealFloat a => a -> Render n
n -- . (*0.35278)

-- | Render n length with pt units.
pt :: RealFloat a => a -> Render n
pt :: a -> Render n
pt = (Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder -> Render n
forall n. Builder -> Render n
raw Builder
"pt") (Render n -> Render n) -> (a -> Render n) -> a -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Render n
forall a n. RealFloat a => a -> Render n
n -- . (*1.00375)

-- | ε = 0.0001 is the limit at which lines are no longer stroked.
epsilon :: Fractional n => n
epsilon :: n
epsilon = n
0.0001

-- environments --------------------------------------------------------

picture :: Render n -> Render n
picture :: Render n -> Render n
picture Render n
r = do
  TexFormat
f <- Getting TexFormat RenderInfo TexFormat
-> RWST RenderInfo Builder (RenderState n) Identity TexFormat
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TexFormat RenderInfo TexFormat
Lens' RenderInfo TexFormat
format
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n)
-> (Builder -> Render n) -> Builder -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Render n
forall n. Builder -> Render n
raw (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ case TexFormat
f of
    TexFormat
LaTeX    -> Builder
"\\begin{pgfpicture}"
    TexFormat
ConTeXt  -> Builder
"\\startpgfpicture"
    TexFormat
PlainTeX -> Builder
"\\pgfpicture"
  Render n -> Render n
forall n. Render n -> Render n
inBlock Render n
r
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n)
-> (Builder -> Render n) -> Builder -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Render n
forall n. Builder -> Render n
raw (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ case TexFormat
f of
    TexFormat
LaTeX    -> Builder
"\\end{pgfpicture}"
    TexFormat
ConTeXt  -> Builder
"\\stoppgfpicture"
    TexFormat
PlainTeX -> Builder
"\\endpgfpicture"

rectangleBoundingBox :: RealFloat n => V2 n -> Render n
rectangleBoundingBox :: V2 n -> Render n
rectangleBoundingBox V2 n
bounds = do
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
    Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"pathrectangle"
    Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"pointorigin"
    Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ (n, n) -> Render n
forall n a. RealFloat n => (n, n) -> Render a
tuplePoint (V2 n -> (n, n)
forall n. V2 n -> (n, n)
unr2 V2 n
bounds)
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
    Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"usepath"
    Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"use as bounding box"

-- | Wrap the rendering in a scope.
scope :: Render n -> Render n
scope :: Render n -> Render n
scope Render n
r = do
  TexFormat
f <- Getting TexFormat RenderInfo TexFormat
-> RWST RenderInfo Builder (RenderState n) Identity TexFormat
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TexFormat RenderInfo TexFormat
Lens' RenderInfo TexFormat
format
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n)
-> (Builder -> Render n) -> Builder -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Render n
forall n. Builder -> Render n
raw (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ case TexFormat
f of
    TexFormat
LaTeX    -> Builder
"\\begin{pgfscope}"
    TexFormat
ConTeXt  -> Builder
"\\startpgfscope"
    TexFormat
PlainTeX -> Builder
"\\pgfscope"
  Render n -> Render n
forall n. Render n -> Render n
inBlock Render n
r
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n)
-> (Builder -> Render n) -> Builder -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Render n
forall n. Builder -> Render n
raw (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ case TexFormat
f of
    TexFormat
LaTeX    -> Builder
"\\end{pgfscope}"
    TexFormat
ConTeXt  -> Builder
"\\stoppgfscope"
    TexFormat
PlainTeX -> Builder
"\\endpgfscope"

-- opacity groups ------------------------------------------------------

transparencyGroup :: Render n -> Render n
transparencyGroup :: Render n -> Render n
transparencyGroup Render n
r = do
  TexFormat
f <- Getting TexFormat RenderInfo TexFormat
-> RWST RenderInfo Builder (RenderState n) Identity TexFormat
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TexFormat RenderInfo TexFormat
Lens' RenderInfo TexFormat
format
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n)
-> (Builder -> Render n) -> Builder -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Render n
forall n. Builder -> Render n
raw (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ case TexFormat
f of
    TexFormat
LaTeX    -> Builder
"\\begin{pgftransparencygroup}"
    TexFormat
ConTeXt  -> Builder
"\\startpgftransparencygroup"
    TexFormat
PlainTeX -> Builder
"\\pgftransparencygroup"
  Render n -> Render n
forall n. Render n -> Render n
inBlock Render n
r
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n)
-> (Builder -> Render n) -> Builder -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Render n
forall n. Builder -> Render n
raw (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ case TexFormat
f of
    TexFormat
LaTeX    -> Builder
"\\end{pgftransparencygroup}"
    TexFormat
ConTeXt  -> Builder
"\\stoppgftransparencygroup"
    TexFormat
PlainTeX -> Builder
"\\endpgftransparencygroup"

opacityGroup :: RealFloat a => a -> Render n -> Render n
opacityGroup :: a -> Render n -> Render n
opacityGroup a
x Render n
r = Render n -> Render n
forall n. Render n -> Render n
scope (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  a -> Render n
forall a n. RealFloat a => a -> Render n
setFillOpacity a
x
  Render n -> Render n
forall n. Render n -> Render n
transparencyGroup Render n
r

-- colours -------------------------------------------------------------

texColor :: RealFloat a => a -> a -> a -> Render n
texColor :: a -> a -> a -> Render n
texColor a
r a
g a
b = do
  a -> Render n
forall a n. RealFloat a => a -> Render n
n a
r
  Char -> Render n
forall n. Char -> Render n
rawChar Char
','
  a -> Render n
forall a n. RealFloat a => a -> Render n
n a
g
  Char -> Render n
forall n. Char -> Render n
rawChar Char
','
  a -> Render n
forall a n. RealFloat a => a -> Render n
n a
b

contextColor :: RealFloat a => a -> a -> a -> Render n
contextColor :: a -> a -> a -> Render n
contextColor a
r a
g a
b = do
  Builder -> Render n
forall n. Builder -> Render n
raw Builder
"r=" Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Render n
forall a n. RealFloat a => a -> Render n
n a
r
  Char -> Render n
forall n. Char -> Render n
rawChar Char
','
  Builder -> Render n
forall n. Builder -> Render n
raw Builder
"g=" Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Render n
forall a n. RealFloat a => a -> Render n
n a
g
  Char -> Render n
forall n. Char -> Render n
rawChar Char
','
  Builder -> Render n
forall n. Builder -> Render n
raw Builder
"b=" Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Render n
forall a n. RealFloat a => a -> Render n
n a
b

-- | Defines an RGB colour with the given name, using the Tex format.
defineColour :: RealFloat a => ByteString -> a -> a -> a -> Render n
defineColour :: ByteString -> a -> a -> a -> Render n
defineColour ByteString
name a
r a
g a
b = do
  TexFormat
f <- Getting TexFormat RenderInfo TexFormat
-> RWST RenderInfo Builder (RenderState n) Identity TexFormat
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TexFormat RenderInfo TexFormat
Lens' RenderInfo TexFormat
format
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ case TexFormat
f of
    TexFormat
ConTeXt  -> do
      Builder -> Render n
forall n. Builder -> Render n
raw Builder
"\\definecolor"
      Render n -> Render n
forall n. Render n -> Render n
brackets (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ ByteString -> Render n
forall n. ByteString -> Render n
rawByteString ByteString
name
      Render n -> Render n
forall n. Render n -> Render n
brackets (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ a -> a -> a -> Render n
forall a n. RealFloat a => a -> a -> a -> Render n
contextColor a
r a
g a
b
    TexFormat
_        -> do
      Builder -> Render n
forall n. Builder -> Render n
raw Builder
"\\definecolor"
      Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ ByteString -> Render n
forall n. ByteString -> Render n
rawByteString ByteString
name
      Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"rgb"
      Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ a -> a -> a -> Render n
forall a n. RealFloat a => a -> a -> a -> Render n
texColor a
r a
g a
b

parensColor :: Color c => c -> Render n
parensColor :: c -> Render n
parensColor c
c = Render n -> Render n
forall n. Render n -> Render n
parens (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Render n
forall a n. RealFloat a => a -> a -> a -> Render n
texColor Double
r Double
g Double
b
  where (Double
r,Double
g,Double
b,Double
_) = c -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA c
c


-- paths ---------------------------------------------------------------

-- | Close the current path.
closePath :: Render n
closePath :: Render n
closePath = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"pathclose"

-- | Move path to point.
moveTo :: RealFloat n => P2 n -> Render n
moveTo :: P2 n -> Render n
moveTo P2 n
v = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  (P2 n -> Identity (P2 n))
-> RenderState n -> Identity (RenderState n)
forall n. Lens' (RenderState n) (P2 n)
pos ((P2 n -> Identity (P2 n))
 -> RenderState n -> Identity (RenderState n))
-> P2 n -> Render n
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= P2 n
v
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"pathqmoveto"
  P2 n -> Render n
forall n a. RealFloat n => P2 n -> Render a
bracerPoint P2 n
v

-- | Move path by vector.
lineTo :: RealFloat n => V2 n -> Render n
lineTo :: V2 n -> Render n
lineTo V2 n
v = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  P2 n
p <- Getting (P2 n) (RenderState n) (P2 n)
-> RWST RenderInfo Builder (RenderState n) Identity (P2 n)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (P2 n) (RenderState n) (P2 n)
forall n. Lens' (RenderState n) (P2 n)
pos
  let v' :: P2 n
v' = P2 n
p P2 n -> Diff (Point V2) n -> P2 n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ Diff (Point V2) n
V2 n
v
  (P2 n -> Identity (P2 n))
-> RenderState n -> Identity (RenderState n)
forall n. Lens' (RenderState n) (P2 n)
pos ((P2 n -> Identity (P2 n))
 -> RenderState n -> Identity (RenderState n))
-> P2 n -> Render n
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= P2 n
v'
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"pathqlineto"
  P2 n -> Render n
forall n a. RealFloat n => P2 n -> Render a
bracerPoint P2 n
v'

-- | Make curved path from vectors.
curveTo :: RealFloat n => V2 n -> V2 n -> V2 n -> Render n
curveTo :: V2 n -> V2 n -> V2 n -> Render n
curveTo V2 n
v2 V2 n
v3 V2 n
v4 = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  P2 n
p <- Getting (P2 n) (RenderState n) (P2 n)
-> RWST RenderInfo Builder (RenderState n) Identity (P2 n)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (P2 n) (RenderState n) (P2 n)
forall n. Lens' (RenderState n) (P2 n)
pos
  let [P2 n
v2',P2 n
v3',P2 n
v4'] = (V2 n -> P2 n) -> [V2 n] -> [P2 n]
forall a b. (a -> b) -> [a] -> [b]
map (P2 n
p P2 n -> Diff (Point V2) n -> P2 n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^) [V2 n
v2,V2 n
v3,V2 n
v4]
  (P2 n -> Identity (P2 n))
-> RenderState n -> Identity (RenderState n)
forall n. Lens' (RenderState n) (P2 n)
pos ((P2 n -> Identity (P2 n))
 -> RenderState n -> Identity (RenderState n))
-> P2 n -> Render n
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= P2 n
v4'
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"pathqcurveto"
  (P2 n -> Render n) -> [P2 n] -> Render n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ P2 n -> Render n
forall n a. RealFloat n => P2 n -> Render a
bracerPoint [P2 n
v2', P2 n
v3', P2 n
v4']

-- | Stroke the defined path using parameters from current scope.
stroke :: Render n
stroke :: Render n
stroke = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"usepathqstroke"

-- | Fill the defined path using parameters from current scope.
fill :: Render n
fill :: Render n
fill = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"usepathqfill"

-- | Use the defined path a clip for everything that follows in the current
--   scope. Stacks.
clip :: Render n
clip :: Render n
clip = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"usepathqclip"

path :: RealFloat n => Path V2 n -> Render n
path :: Path V2 n -> Render n
path (Path [Located (Trail V2 n)]
trs) = do
  (Located (Trail V2 n) -> Render n)
-> [Located (Trail V2 n)] -> Render n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Located (Trail V2 n) -> Render n
forall n.
RealFloat n =>
Located (Trail V2 n)
-> RWST RenderInfo Builder (RenderState n) Identity ()
renderTrail [Located (Trail V2 n)]
trs
  where
    renderTrail :: Located (Trail V2 n)
-> RWST RenderInfo Builder (RenderState n) Identity ()
renderTrail (Located (Trail V2 n)
-> (Point (V (Trail V2 n)) (N (Trail V2 n)), Trail V2 n)
forall a. Located a -> (Point (V a) (N a), a)
viewLoc -> (Point (V (Trail V2 n)) (N (Trail V2 n))
p, Trail V2 n
tr)) = do
      P2 n -> RWST RenderInfo Builder (RenderState n) Identity ()
forall n. RealFloat n => P2 n -> Render n
moveTo Point (V (Trail V2 n)) (N (Trail V2 n))
P2 n
p
      Trail V2 n -> RWST RenderInfo Builder (RenderState n) Identity ()
forall n. RealFloat n => Trail V2 n -> Render n
trail Trail V2 n
tr

trail :: RealFloat n => Trail V2 n -> Render n
trail :: Trail V2 n -> Render n
trail Trail V2 n
t = (Trail' Line V2 n -> Render n) -> Trail V2 n -> Render n
forall (v :: * -> *) n r.
(Metric v, OrderedField n) =>
(Trail' Line v n -> r) -> Trail v n -> r
withLine ([Segment Closed V2 n] -> Render n
render' ([Segment Closed V2 n] -> Render n)
-> (Trail' Line V2 n -> [Segment Closed V2 n])
-> Trail' Line V2 n
-> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trail' Line V2 n -> [Segment Closed V2 n]
forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments) Trail V2 n
t
  where
    render' :: [Segment Closed V2 n] -> Render n
render' [Segment Closed V2 n]
segs = do
      (Segment Closed V2 n -> Render n)
-> [Segment Closed V2 n] -> Render n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Segment Closed V2 n -> Render n
forall n. RealFloat n => Segment Closed V2 n -> Render n
segment [Segment Closed V2 n]
segs
      Bool -> Render n -> Render n
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Trail V2 n -> Bool
forall (v :: * -> *) n. Trail v n -> Bool
isLoop Trail V2 n
t) Render n
forall n. Render n
closePath

segment ::  RealFloat n => Segment Closed V2 n -> Render n
segment :: Segment Closed V2 n -> Render n
segment (Linear (OffsetClosed V2 n
v))       = V2 n -> Render n
forall n. RealFloat n => V2 n -> Render n
lineTo V2 n
v
segment (Cubic V2 n
v1 V2 n
v2 (OffsetClosed V2 n
v3)) = V2 n -> V2 n -> V2 n -> Render n
forall n. RealFloat n => V2 n -> V2 n -> V2 n -> Render n
curveTo V2 n
v1 V2 n
v2 V2 n
v3

-- | @usePath fill stroke@ combined in one function.
usePath :: Bool -> Bool -> Render n
usePath :: Bool -> Bool -> Render n
usePath Bool
False Bool
False     = () -> Render n
forall (m :: * -> *) a. Monad m => a -> m a
return ()
usePath Bool
doFill Bool
doStroke = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"usepathq"
  Bool -> Render n -> Render n
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doFill (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"fill"
  Bool -> Render n -> Render n
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doStroke (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"stroke"

-- | Uses the current path as the bounding box for whole picture.
asBoundingBox :: Render n
asBoundingBox :: Render n
asBoundingBox = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"usepath"
  Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"use as bounding box"

-- rectangleBoundingBox :: (n,n) -> Render n
-- rectangleBoundingBox xy = do
--   ln $ do
--     pgf "pathrectangle"
--     bracers $ pgf "pointorigin"
--     bracers $ tuplePoint xy
--   asBoundingBox

-- stroke properties

-- | Sets the line width in current scope. Must be done before stroking.
setLineWidth :: RealFloat n => n -> Render n
setLineWidth :: n -> Render n
setLineWidth n
w = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"setlinewidth"
  Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ n -> Render n
forall a n. RealFloat a => a -> Render n
bp n
w

-- | Sets the line cap in current scope. Must be done before stroking.
setLineCap :: LineCap -> Render n
setLineCap :: LineCap -> Render n
setLineCap LineCap
cap = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n)
-> (Builder -> Render n) -> Builder -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Render n
forall n. Builder -> Render n
pgf (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ case LineCap
cap of
   LineCap
LineCapButt   -> Builder
"setbuttcap"
   LineCap
LineCapRound  -> Builder
"setroundcap"
   LineCap
LineCapSquare -> Builder
"setrectcap"

-- | Sets the line join in current scope. Must be done before stroking.
setLineJoin :: LineJoin -> Render n
setLineJoin :: LineJoin -> Render n
setLineJoin LineJoin
lJoin = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n)
-> (Builder -> Render n) -> Builder -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Render n
forall n. Builder -> Render n
pgf (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ case LineJoin
lJoin of
   LineJoin
LineJoinBevel -> Builder
"setbeveljoin"
   LineJoin
LineJoinRound -> Builder
"setroundjoin"
   LineJoin
LineJoinMiter -> Builder
"setmiterjoin"

-- | Sets the miter limit in the current scope. Must be done before stroking.
setMiterLimit :: RealFloat n => n -> Render n
setMiterLimit :: n -> Render n
setMiterLimit n
l = do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"setmiterlimit"
  Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ n -> Render n
forall a n. RealFloat a => a -> Render n
bp n
l

-- stroke parameters ---------------------------------------------------

-- | Sets the dash for the current scope. Must be done before stroking.
setDash :: RealFloat n => Dashing n -> Render n
setDash :: Dashing n -> Render n
setDash (Dashing [n]
ds n
offs) = [n] -> n -> Render n
forall n. RealFloat n => [n] -> n -> Render n
setDash' [n]
ds n
offs

-- \pgfsetdash{{0.5cm}{0.5cm}{0.1cm}{0.2cm}}{0cm}
-- | Takes the dash distances and offset, must be done before stroking.
setDash' :: RealFloat n => [n] -> n -> Render n
setDash' :: [n] -> n -> Render n
setDash' [n]
ds n
off = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"setdash"
  Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ (n -> Render n) -> [n] -> Render n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> (n -> Render n) -> n -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Render n
forall a n. RealFloat a => a -> Render n
bp) [n]
ds
  Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ n -> Render n
forall a n. RealFloat a => a -> Render n
bp n
off

-- | Sets the stroke colour in current scope. If colour has opacity < 1, the
--   scope opacity is set accordingly. Must be done before stroking.
setLineColor :: (RealFloat a, Color c) => c -> Render a
setLineColor :: c -> Render a
setLineColor c
c = do
  ByteString -> Double -> Double -> Double -> Render a
forall a n. RealFloat a => ByteString -> a -> a -> a -> Render n
defineColour ByteString
"sc" Double
r Double
g Double
b
  Render a -> Render a
forall n. Render n -> Render n
ln (Render a -> Render a) -> Render a -> Render a
forall a b. (a -> b) -> a -> b
$ Builder -> Render a
forall n. Builder -> Render n
pgf Builder
"setstrokecolor{sc}"
  --
  Bool -> Render a -> Render a
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
1) (Render a -> Render a) -> Render a -> Render a
forall a b. (a -> b) -> a -> b
$ a -> Render a
forall n. RealFloat n => n -> Render n
setLineOpacity (Double -> a
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
a)
  where
    (Double
r,Double
g,Double
b,Double
a) = c -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA c
c

-- | Sets the stroke opacity for the current scope. Should be a value between 0
--   and 1. Must be done  before stroking.
setLineOpacity :: RealFloat n => n -> Render n
setLineOpacity :: n -> Render n
setLineOpacity n
a = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"setstrokeopacity"
  Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ n -> Render n
forall a n. RealFloat a => a -> Render n
n n
a

-- filling -------------------------------------------------------------

-- | Set the fill rule to winding or even-odd for current scope. Must be done
--   before filling.
setFillRule :: FillRule -> Render n
setFillRule :: FillRule -> Render n
setFillRule FillRule
rule = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ case FillRule
rule of
  FillRule
Winding -> Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"setnonzerorule"
  FillRule
EvenOdd -> Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"seteorule"

-- | Sets the fill colour for current scope. If an alpha colour is used, the
--   fill opacity is set accordingly. Must be done before filling.
setFillColor :: Color c => c -> Render n
setFillColor :: c -> Render n
setFillColor (c -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA -> (Double
r,Double
g,Double
b,Double
a)) = do
  ByteString -> Double -> Double -> Double -> Render n
forall a n. RealFloat a => ByteString -> a -> a -> a -> Render n
defineColour ByteString
"fc" Double
r Double
g Double
b
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"setfillcolor{fc}"
  --
  Bool -> Render n -> Render n
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
1) (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Double -> Render n
forall a n. RealFloat a => a -> Render n
setFillOpacity (Double -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
a :: Double)

-- | Sets the stroke opacity for the current scope. Should be a value between 0
--   and 1. Must be done  before stroking.
setFillOpacity :: RealFloat a => a -> Render n
setFillOpacity :: a -> Render n
setFillOpacity a
a = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"setfillopacity"
  Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ a -> Render n
forall a n. RealFloat a => a -> Render n
n a
a

-- transformations -----------------------------------------------------

getMatrix :: Num n => Transformation V2 n -> (n, n, n, n, n, n)
getMatrix :: Transformation V2 n -> (n, n, n, n, n, n)
getMatrix Transformation V2 n
t = (n
a1,n
a2,n
b1,n
b2,n
c1,n
c2)
 where
   [n
a1, n
a2, n
b1, n
b2, n
c1, n
c2] = [[n]] -> [n]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[n]] -> [n]) -> [[n]] -> [n]
forall a b. (a -> b) -> a -> b
$ Transformation V2 n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep Transformation V2 n
t

-- \pgftransformcm{⟨a⟩}{⟨b⟩}{⟨c⟩}{⟨d⟩}{⟨pointa}

-- | Applies a transformation to the current scope. This transformation only
--   effects coordinates and text, not line withs or dash spacing. (See
--   applyDeepTransform). Must be set before the path is used.
applyTransform :: RealFloat n => Transformation V2 n -> Render n
applyTransform :: Transformation V2 n -> Render n
applyTransform Transformation V2 n
t
  | Bool
isID      = () -> Render n
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
shiftOnly = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
      Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"transformshift"
      Render n -> Render n
forall n. Render n -> Render n
bracers Render n
p
  | Bool
otherwise = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
    Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"transformcm"
    (n -> Render n) -> [n] -> Render n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> (n -> Render n) -> n -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Render n
forall a n. RealFloat a => a -> Render n
n) [n
a, n
b, n
c, n
d] Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render n -> Render n
forall n. Render n -> Render n
bracers Render n
p
  where
    (n
a,n
b,n
c,n
d,n
e,n
f) = Transformation V2 n -> (n, n, n, n, n, n)
forall n. Num n => Transformation V2 n -> (n, n, n, n, n, n)
getMatrix Transformation V2 n
t
    p :: Render n
p             = (n, n) -> Render n
forall n a. RealFloat n => (n, n) -> Render a
tuplePoint (n
e,n
f)
    --
    shiftOnly :: Bool
shiftOnly = (n
a,n
b,n
c,n
d) (n, n, n, n) -> (n, n, n, n) -> Bool
forall a. Eq a => a -> a -> Bool
== (n
1,n
0,n
0,n
1)
    isID :: Bool
isID      = Bool
shiftOnly Bool -> Bool -> Bool
&& (n
e,n
f) (n, n) -> (n, n) -> Bool
forall a. Eq a => a -> a -> Bool
== (n
0,n
0)

-- | Resets the transform and sets it. Must be set before the path is used.
setTransform :: RealFloat n => Transformation V2 n -> Render n
setTransform :: Transformation V2 n -> Render n
setTransform Transformation V2 n
t = do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"settransformentries"
  (n -> Render n) -> [n] -> Render n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> (n -> Render n) -> n -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Render n
forall a n. RealFloat a => a -> Render n
n) [n
a, n
b, n
c, n
d] Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (n -> Render n) -> [n] -> Render n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> (n -> Render n) -> n -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Render n
forall a n. RealFloat a => a -> Render n
bp) [n
e, n
f]
  where
    (n
a,n
b,n
c,n
d,n
e,n
f) = Transformation V2 n -> (n, n, n, n, n, n)
forall n. Num n => Transformation V2 n -> (n, n, n, n, n, n)
getMatrix Transformation V2 n
t

applyScale :: RealFloat n => n -> Render n
applyScale :: n -> Render n
applyScale n
s = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"transformscale"
  Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ n -> Render n
forall a n. RealFloat a => a -> Render n
n n
s

resetNonTranslations :: Render n
resetNonTranslations :: Render n
resetNonTranslations = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"transformresetnontranslations"

-- | Base transforms are applied by the document reader.
baseTransform :: RealFloat n => Transformation V2 n -> Render n
baseTransform :: Transformation V2 n -> Render n
baseTransform Transformation V2 n
t = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"lowlevel"
  Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Transformation V2 n -> Render n
forall n. RealFloat n => Transformation V2 n -> Render n
setTransform Transformation V2 n
t

-- setShadetransform :: Transformation V2 -> Render n
-- setShadetransform (dropTransl -> t) = do
--   pgf "setadditionalshadetransform"
--   bracersBlock $ applyTransform t

-- shading -------------------------------------------------------------

linearGradient :: RealFloat n => Path V2 n -> LGradient n -> Render n
linearGradient :: Path V2 n -> LGradient n -> Render n
linearGradient Path V2 n
p LGradient n
lg = Render n -> Render n
forall n. Render n -> Render n
scope (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Path V2 n -> Render n
forall n. RealFloat n => Path V2 n -> Render n
path Path V2 n
p
  let ([GradientStop n]
stops', T2 n
t) = Path V2 n -> LGradient n -> ([GradientStop n], T2 n)
forall n.
RealFloat n =>
Path V2 n -> LGradient n -> ([GradientStop n], T2 n)
calcLinearStops Path V2 n
p LGradient n
lg
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
    Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"declarehorizontalshading"
    Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"ft"    -- fill texture
    Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"100bp" -- gradient is always 100 x 100 square
    Render n -> Render n
forall n. Render n -> Render n
bracersBlock (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ n -> [GradientStop n] -> Render n
forall n. RealFloat n => n -> [GradientStop n] -> Render n
colorSpec n
1 [GradientStop n]
stops'
  Render n
forall n. Render n
clip
  T2 n -> Render n
forall n. RealFloat n => Transformation V2 n -> Render n
baseTransform T2 n
t
  Render n -> Render n
forall n. Render n -> Render n
useShading (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"ft"

-- | Calculate the correct linear stops such that the path is completely
--   filled. PGF doesn't have spread methods so this has to be done
--   manually.
calcLinearStops :: RealFloat n
                => Path V2 n -> LGradient n -> ([GradientStop n], T2 n)
calcLinearStops :: Path V2 n -> LGradient n -> ([GradientStop n], T2 n)
calcLinearStops (Path []) LGradient n
_ = ([], T2 n
forall a. Monoid a => a
mempty)
calcLinearStops Path V2 n
pth (LGradient [GradientStop n]
stops Point V2 n
p0 Point V2 n
p1 T2 n
gt SpreadMethod
sm)
  = (n -> n -> [GradientStop n] -> SpreadMethod -> [GradientStop n]
forall n.
RealFloat n =>
n -> n -> [GradientStop n] -> SpreadMethod -> [GradientStop n]
linearStops' n
x0 n
x1 [GradientStop n]
stops SpreadMethod
sm, T2 n
t T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> T2 n
ft)
  where
    -- Transform such that the transform t origin is start of the
    -- gradient, transform t unitX is the end.
    t :: T2 n
t = T2 n
gt
        -- encorperate the start and end points
     T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> V2 n -> T2 n
forall (v :: * -> *) n. v n -> Transformation v n
translation (Point V2 n
p0 Point V2 n -> Getting (V2 n) (Point V2 n) (V2 n) -> V2 n
forall s a. s -> Getting a s a -> a
^. Getting (V2 n) (Point V2 n) (V2 n)
forall (f :: * -> *) a. Iso' (Point f a) (f a)
_Point)
     T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> n -> T2 n
forall (v :: * -> *) n.
(Additive v, Fractional n) =>
n -> Transformation v n
scaling (V2 n -> n
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (Point V2 n
p1 Point V2 n -> Point V2 n -> Diff (Point V2) n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 n
p0))
     T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> Direction V2 n -> T2 n
forall n. OrderedField n => Direction V2 n -> T2 n
rotationTo (Point V2 n -> Point V2 n -> Direction V2 n
forall (v :: * -> *) n.
(Additive v, Num n) =>
Point v n -> Point v n -> Direction v n
dirBetween Point V2 n
p1 Point V2 n
p0)

    -- Use the inverse transformed path and make the pre-transformed
    -- gradient fit to it. Then when we transform the gradient we know
    -- it'll fit the path.
    p' :: Path V2 n
p' = Transformation (V (Path V2 n)) (N (Path V2 n))
-> Path V2 n -> Path V2 n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (T2 n -> T2 n
forall (v :: * -> *) n.
(Functor v, Num n) =>
Transformation v n -> Transformation v n
inv T2 n
t) Path V2 n
pth
    Just (n
x0,n
x1) = Path V2 n -> Maybe (n, n)
forall (v :: * -> *) n a.
(InSpace v n a, R1 v, Enveloped a) =>
a -> Maybe (n, n)
extentX Path V2 n
p'
    Just (n
y0,n
y1) = Path V2 n -> Maybe (n, n)
forall (v :: * -> *) n a.
(InSpace v n a, R2 v, Enveloped a) =>
a -> Maybe (n, n)
extentY Path V2 n
p'

    -- Final transform to fit the gradient to the path. The origin on
    -- the gradient is its centre so we translate by - V2 50 50 to get
    -- to the lower corner (because of this we set the size of the
    -- gradient to always be 100 x 100 for simplicity). Then scales up
    -- the gradient to cover the path and moves it into position.
    ft :: T2 n
ft = V2 n -> T2 n
forall (v :: * -> *) n. v n -> Transformation v n
translation (n -> n -> V2 n
forall a. a -> a -> V2 a
V2 n
x0 n
y0) T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> V2 n -> T2 n
forall (v :: * -> *) n.
(Additive v, Fractional n) =>
v n -> Transformation v n
scalingV ((n -> n -> n
forall a. Num a => a -> a -> a
*n
0.01) (n -> n) -> (n -> n) -> n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> n
forall a. Num a => a -> a
abs (n -> n) -> V2 n -> V2 n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> n -> n -> V2 n
forall a. a -> a -> V2 a
V2 (n
x0 n -> n -> n
forall a. Num a => a -> a -> a
- n
x1) (n
y0 n -> n -> n
forall a. Num a => a -> a -> a
- n
y1)) T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> V2 n -> T2 n
forall (v :: * -> *) n. v n -> Transformation v n
translation V2 n
50

scalingV :: (Additive v, Fractional n) => v n -> Transformation v n
scalingV :: v n -> Transformation v n
scalingV v n
v = (v n :-: v n) -> Transformation v n
forall (v :: * -> *) n.
(Additive v, Num n) =>
(v n :-: v n) -> Transformation v n
fromSymmetric ((v n :-: v n) -> Transformation v n)
-> (v n :-: v n) -> Transformation v n
forall a b. (a -> b) -> a -> b
$ (n -> n -> n) -> v n -> v n -> v n
forall (f :: * -> *) a.
Additive f =>
(a -> a -> a) -> f a -> f a -> f a
liftU2 n -> n -> n
forall a. Num a => a -> a -> a
(*) v n
v (v n -> v n) -> (v n -> v n) -> v n :-: v n
forall u v. (u -> v) -> (v -> u) -> u :-: v
<-> (n -> n -> n) -> v n -> v n -> v n
forall (f :: * -> *) a.
Additive f =>
(a -> a -> a) -> f a -> f a -> f a
liftU2 ((n -> n -> n) -> n -> n -> n
forall a b c. (a -> b -> c) -> b -> a -> c
flip n -> n -> n
forall a. Fractional a => a -> a -> a
(/)) v n
v

useShading :: Render n -> Render n
useShading :: Render n -> Render n
useShading Render n
nm = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"useshading"
  Render n -> Render n
forall n. Render n -> Render n
bracers Render n
nm


_translation :: Lens' (Transformation v n) (v n)
_translation :: (v n -> f (v n)) -> Transformation v n -> f (Transformation v n)
_translation v n -> f (v n)
f (Transformation v n :-: v n
a v n :-: v n
b v n
v) = v n -> f (v n)
f v n
v f (v n) -> (v n -> Transformation v n) -> f (Transformation v n)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \v n
v' -> (v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
forall (v :: * -> *) n.
(v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
Transformation v n :-: v n
a v n :-: v n
b v n
v'

linearStops' :: RealFloat n
             => n -> n -> [GradientStop n] -> SpreadMethod -> [GradientStop n]
linearStops' :: n -> n -> [GradientStop n] -> SpreadMethod -> [GradientStop n]
linearStops' n
x0 n
x1 [GradientStop n]
stops SpreadMethod
sm =
  SomeColor -> n -> GradientStop n
forall d. SomeColor -> d -> GradientStop d
GradientStop SomeColor
c1' n
0 GradientStop n -> [GradientStop n] -> [GradientStop n]
forall a. a -> [a] -> [a]
: (GradientStop n -> Bool) -> [GradientStop n] -> [GradientStop n]
forall a. (a -> Bool) -> [a] -> [a]
filter (n -> Bool
forall a. (Ord a, Num a) => a -> Bool
inRange (n -> Bool) -> (GradientStop n -> n) -> GradientStop n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting n (GradientStop n) n -> GradientStop n -> n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting n (GradientStop n) n
forall n. Lens' (GradientStop n) n
stopFraction) [GradientStop n]
stops' [GradientStop n] -> [GradientStop n] -> [GradientStop n]
forall a. [a] -> [a] -> [a]
++ [SomeColor -> n -> GradientStop n
forall d. SomeColor -> d -> GradientStop d
GradientStop SomeColor
c2' n
100]
  where
    stops' :: [GradientStop n]
stops' = case SpreadMethod
sm of
      SpreadMethod
GradPad     -> ASetter [GradientStop n] [GradientStop n] n n
-> (n -> n) -> [GradientStop n] -> [GradientStop n]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((GradientStop n -> Identity (GradientStop n))
-> [GradientStop n] -> Identity [GradientStop n]
forall s t a b. Each s t a b => Traversal s t a b
each ((GradientStop n -> Identity (GradientStop n))
 -> [GradientStop n] -> Identity [GradientStop n])
-> ((n -> Identity n)
    -> GradientStop n -> Identity (GradientStop n))
-> ASetter [GradientStop n] [GradientStop n] n n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Identity n) -> GradientStop n -> Identity (GradientStop n)
forall n. Lens' (GradientStop n) n
stopFraction) n -> n
normalise [GradientStop n]
stops
      SpreadMethod
GradRepeat  -> ((Int -> [GradientStop n]) -> [Int] -> [GradientStop n])
-> [Int] -> (Int -> [GradientStop n]) -> [GradientStop n]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> [GradientStop n]) -> [Int] -> [GradientStop n]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap [Int
i0 .. Int
i1] ((Int -> [GradientStop n]) -> [GradientStop n])
-> (Int -> [GradientStop n]) -> [GradientStop n]
forall a b. (a -> b) -> a -> b
$ \Int
i ->
                       [GradientStop n] -> [GradientStop n]
increaseFirst ([GradientStop n] -> [GradientStop n])
-> [GradientStop n] -> [GradientStop n]
forall a b. (a -> b) -> a -> b
$
                         ASetter [GradientStop n] [GradientStop n] n n
-> (n -> n) -> [GradientStop n] -> [GradientStop n]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((GradientStop n -> Identity (GradientStop n))
-> [GradientStop n] -> Identity [GradientStop n]
forall s t a b. Each s t a b => Traversal s t a b
each ((GradientStop n -> Identity (GradientStop n))
 -> [GradientStop n] -> Identity [GradientStop n])
-> ((n -> Identity n)
    -> GradientStop n -> Identity (GradientStop n))
-> ASetter [GradientStop n] [GradientStop n] n n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Identity n) -> GradientStop n -> Identity (GradientStop n)
forall n. Lens' (GradientStop n) n
stopFraction)
                              (n -> n
normalise (n -> n) -> (n -> n) -> n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> n -> n
forall a. Num a => a -> a -> a
+ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
                              [GradientStop n]
stops
      SpreadMethod
GradReflect -> ((Int -> [GradientStop n]) -> [Int] -> [GradientStop n])
-> [Int] -> (Int -> [GradientStop n]) -> [GradientStop n]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> [GradientStop n]) -> [Int] -> [GradientStop n]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap [Int
i0 .. Int
i1] ((Int -> [GradientStop n]) -> [GradientStop n])
-> (Int -> [GradientStop n]) -> [GradientStop n]
forall a b. (a -> b) -> a -> b
$ \Int
i ->
                       ASetter [GradientStop n] [GradientStop n] n n
-> (n -> n) -> [GradientStop n] -> [GradientStop n]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((GradientStop n -> Identity (GradientStop n))
-> [GradientStop n] -> Identity [GradientStop n]
forall s t a b. Each s t a b => Traversal s t a b
each ((GradientStop n -> Identity (GradientStop n))
 -> [GradientStop n] -> Identity [GradientStop n])
-> ((n -> Identity n)
    -> GradientStop n -> Identity (GradientStop n))
-> ASetter [GradientStop n] [GradientStop n] n n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Identity n) -> GradientStop n -> Identity (GradientStop n)
forall n. Lens' (GradientStop n) n
stopFraction)
                            (n -> n
normalise (n -> n) -> (n -> n) -> n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> n -> n
forall a. Num a => a -> a -> a
+ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
                            (Int -> [GradientStop n] -> [GradientStop n]
forall a n.
(Integral a, Num n) =>
a -> [GradientStop n] -> [GradientStop n]
reverseOdd Int
i [GradientStop n]
stops)

    -- for repeat it sometimes complains if two are exactly the same so
    -- increase the first by a little
    increaseFirst :: [GradientStop n] -> [GradientStop n]
increaseFirst = ASetter [GradientStop n] [GradientStop n] n n
-> (n -> n) -> [GradientStop n] -> [GradientStop n]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((GradientStop n -> Identity (GradientStop n))
-> [GradientStop n] -> Identity [GradientStop n]
forall s a. Cons s s a a => Traversal' s a
_head ((GradientStop n -> Identity (GradientStop n))
 -> [GradientStop n] -> Identity [GradientStop n])
-> ((n -> Identity n)
    -> GradientStop n -> Identity (GradientStop n))
-> ASetter [GradientStop n] [GradientStop n] n n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Identity n) -> GradientStop n -> Identity (GradientStop n)
forall n. Lens' (GradientStop n) n
stopFraction) (n -> n -> n
forall a. Num a => a -> a -> a
+n
0.001)
    reverseOdd :: a -> [GradientStop n] -> [GradientStop n]
reverseOdd a
i
      | a -> Bool
forall a. Integral a => a -> Bool
odd a
i     = [GradientStop n] -> [GradientStop n]
forall a. [a] -> [a]
reverse ([GradientStop n] -> [GradientStop n])
-> ([GradientStop n] -> [GradientStop n])
-> [GradientStop n]
-> [GradientStop n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter [GradientStop n] [GradientStop n] n n
-> (n -> n) -> [GradientStop n] -> [GradientStop n]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((GradientStop n -> Identity (GradientStop n))
-> [GradientStop n] -> Identity [GradientStop n]
forall s t a b. Each s t a b => Traversal s t a b
each ((GradientStop n -> Identity (GradientStop n))
 -> [GradientStop n] -> Identity [GradientStop n])
-> ((n -> Identity n)
    -> GradientStop n -> Identity (GradientStop n))
-> ASetter [GradientStop n] [GradientStop n] n n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Identity n) -> GradientStop n -> Identity (GradientStop n)
forall n. Lens' (GradientStop n) n
stopFraction) (n
1 n -> n -> n
forall a. Num a => a -> a -> a
-)
      | Bool
otherwise = [GradientStop n] -> [GradientStop n]
forall a. a -> a
id
    i0 :: Int
i0 = n -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor n
x0 :: Int
    i1 :: Int
i1 = n -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling n
x1
    c1' :: SomeColor
c1' = AlphaColour Double -> SomeColor
forall c. Color c => c -> SomeColor
SomeColor (AlphaColour Double -> SomeColor)
-> AlphaColour Double -> SomeColor
forall a b. (a -> b) -> a -> b
$ [GradientStop n] -> n -> AlphaColour Double
forall n.
RealFloat n =>
[GradientStop n] -> n -> AlphaColour Double
colourInterp [GradientStop n]
stops' n
0
    c2' :: SomeColor
c2' = AlphaColour Double -> SomeColor
forall c. Color c => c -> SomeColor
SomeColor (AlphaColour Double -> SomeColor)
-> AlphaColour Double -> SomeColor
forall a b. (a -> b) -> a -> b
$ [GradientStop n] -> n -> AlphaColour Double
forall n.
RealFloat n =>
[GradientStop n] -> n -> AlphaColour Double
colourInterp [GradientStop n]
stops' n
100
    inRange :: a -> Bool
inRange a
x   = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
100
    normalise :: n -> n
normalise n
x = n
100 n -> n -> n
forall a. Num a => a -> a -> a
* (n
x n -> n -> n
forall a. Num a => a -> a -> a
- n
x0) n -> n -> n
forall a. Fractional a => a -> a -> a
/ (n
x1 n -> n -> n
forall a. Num a => a -> a -> a
- n
x0)

colourInterp :: RealFloat n => [GradientStop n] -> n -> AlphaColour Double
colourInterp :: [GradientStop n] -> n -> AlphaColour Double
colourInterp [GradientStop n]
cs0 n
x = [GradientStop n] -> AlphaColour Double
go [GradientStop n]
cs0
  where
    go :: [GradientStop n] -> AlphaColour Double
go (GradientStop SomeColor
c1 n
a : c :: GradientStop n
c@(GradientStop SomeColor
c2 n
b) : [GradientStop n]
cs)
      | n
x n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
a         = SomeColor -> AlphaColour Double
forall c. Color c => c -> AlphaColour Double
toAlphaColour SomeColor
c1
      | n
x n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
a Bool -> Bool -> Bool
&& n
x n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
b = Double
-> AlphaColour Double -> AlphaColour Double -> AlphaColour Double
forall a (f :: * -> *).
(Num a, AffineSpace f) =>
a -> f a -> f a -> f a
blend Double
y (SomeColor -> AlphaColour Double
forall c. Color c => c -> AlphaColour Double
toAlphaColour SomeColor
c2) (SomeColor -> AlphaColour Double
forall c. Color c => c -> AlphaColour Double
toAlphaColour SomeColor
c1)
      | Bool
otherwise      = [GradientStop n] -> AlphaColour Double
go (GradientStop n
c GradientStop n -> [GradientStop n] -> [GradientStop n]
forall a. a -> [a] -> [a]
: [GradientStop n]
cs)
      where
        y :: Double
y = n -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (n -> Double) -> n -> Double
forall a b. (a -> b) -> a -> b
$ (n
x n -> n -> n
forall a. Num a => a -> a -> a
- n
a) n -> n -> n
forall a. Fractional a => a -> a -> a
/ (n
b n -> n -> n
forall a. Num a => a -> a -> a
- n
a)
    go [GradientStop SomeColor
c2 n
_] = SomeColor -> AlphaColour Double
forall c. Color c => c -> AlphaColour Double
toAlphaColour SomeColor
c2
    go [GradientStop n]
_ = AlphaColour Double
forall a. Num a => AlphaColour a
transparent

radialGradient :: RealFloat n => Path V2 n -> RGradient n -> Render n
radialGradient :: Path V2 n -> RGradient n -> Render n
radialGradient Path V2 n
p RGradient n
rg = Render n -> Render n
forall n. Render n -> Render n
scope (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Path V2 n -> Render n
forall n. RealFloat n => Path V2 n -> Render n
path Path V2 n
p
  let ([GradientStop n]
stops', T2 n
t, P2 n
p0) = Path V2 n -> RGradient n -> ([GradientStop n], T2 n, P2 n)
forall n.
RealFloat n =>
Path V2 n -> RGradient n -> ([GradientStop n], T2 n, P2 n)
calcRadialStops Path V2 n
p RGradient n
rg
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
    Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"declareradialshading"
    Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"ft"
    Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ P2 n -> Render n
forall n a. RealFloat n => P2 n -> Render a
point P2 n
p0
    Render n -> Render n
forall n. Render n -> Render n
bracersBlock (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ n -> [GradientStop n] -> Render n
forall n. RealFloat n => n -> [GradientStop n] -> Render n
colorSpec n
1 [GradientStop n]
stops'
  Render n
forall n. Render n
clip
  T2 n -> Render n
forall n. RealFloat n => Transformation V2 n -> Render n
baseTransform T2 n
t
  Render n -> Render n
forall n. Render n -> Render n
useShading (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"ft"

-- | Calculate the correct linear stops such that the path is completely
--   filled. PGF doesn't have spread methods so this has to be done
--   manually.
calcRadialStops :: RealFloat n
                => Path V2 n -> RGradient n -> ([GradientStop n], T2 n, P2 n)
calcRadialStops :: Path V2 n -> RGradient n -> ([GradientStop n], T2 n, P2 n)
calcRadialStops (Path []) RGradient n
_ = ([], T2 n
forall a. Monoid a => a
mempty, P2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin)
calcRadialStops Path V2 n
pth (RGradient [GradientStop n]
stops P2 n
p0 n
r0 P2 n
p1 n
r1 T2 n
gt SpreadMethod
_sm)
  = ([GradientStop n]
stops', T2 n
t T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> T2 n
ft, V2 n -> P2 n
forall (f :: * -> *) a. f a -> Point f a
P Diff (Point V2) n
V2 n
cv)
  where
    cv :: Diff (Point V2) n
cv = P2 n
tp0 P2 n -> P2 n -> Diff (Point V2) n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
tp1
    tp0 :: P2 n
tp0 = T2 n -> P2 n -> P2 n
forall (v :: * -> *) n.
(Additive v, Num n) =>
Transformation v n -> Point v n -> Point v n
papply T2 n
gt P2 n
p0
    tp1 :: P2 n
tp1 = T2 n -> P2 n -> P2 n
forall (v :: * -> *) n.
(Additive v, Num n) =>
Transformation v n -> Point v n -> Point v n
papply T2 n
gt P2 n
p1
    -- Transform such that the transform t origin is start of the
    -- gradient, transform t unitX is the end.
    t :: T2 n
t = T2 n
gt
     T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> V2 n -> T2 n
forall (v :: * -> *) n. v n -> Transformation v n
translation (P2 n
p1 P2 n -> Getting (V2 n) (P2 n) (V2 n) -> V2 n
forall s a. s -> Getting a s a -> a
^. Getting (V2 n) (P2 n) (V2 n)
forall (f :: * -> *) a. Iso' (Point f a) (f a)
_Point)
     T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> n -> T2 n
forall (v :: * -> *) n.
(Additive v, Fractional n) =>
n -> Transformation v n
scaling n
r1

    -- Similar to linear gradients but not so precise, d is a (bad and
    -- probably incorrect) lower bound for the required radius of the
    -- circle to cover the path.
    p' :: Path V2 n
p' = Transformation (V (Path V2 n)) (N (Path V2 n))
-> Path V2 n -> Path V2 n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (T2 n -> T2 n
forall (v :: * -> *) n.
(Functor v, Num n) =>
Transformation v n -> Transformation v n
inv T2 n
t) Path V2 n
pth
    Just (n
x0,n
x1) = Path V2 n -> Maybe (n, n)
forall (v :: * -> *) n a.
(InSpace v n a, R1 v, Enveloped a) =>
a -> Maybe (n, n)
extentX Path V2 n
p'
    Just (n
y0,n
y1) = Path V2 n -> Maybe (n, n)
forall (v :: * -> *) n a.
(InSpace v n a, R2 v, Enveloped a) =>
a -> Maybe (n, n)
extentY Path V2 n
p'
    d :: n
d = n
2 n -> n -> n
forall a. Num a => a -> a -> a
* n -> n -> n
forall a. Ord a => a -> a -> a
max (n -> n -> n
forall a. Ord a => a -> a -> a
max (n -> n
forall a. Num a => a -> a
abs (n -> n) -> n -> n
forall a b. (a -> b) -> a -> b
$ n
x0 n -> n -> n
forall a. Num a => a -> a -> a
- n
x1) (n -> n
forall a. Num a => a -> a
abs (n -> n) -> n -> n
forall a b. (a -> b) -> a -> b
$ n
y0 n -> n -> n
forall a. Num a => a -> a -> a
- n
y1)) (GradientStop n
lstop GradientStop n -> Getting n (GradientStop n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (GradientStop n) n
forall n. Lens' (GradientStop n) n
stopFraction)

    -- Adjust for gradient size having radius 100
    ft :: T2 n
ft = n -> T2 n
forall (v :: * -> *) n.
(Additive v, Fractional n) =>
n -> Transformation v n
scaling n
0.01

    -- Stops are scaled to start at r0 and end at r1. The gradient is
    -- extended to d to try to cover the path.
    --
    -- The problem is extending the size of the gradient in this way
    -- affects how the gradient scales if it is off-centre. This needs
    -- to be fixed.
    --
    -- Only the GradPad spread method is supported for now.
    stops' :: [GradientStop n]
stops' = [GradientStop n] -> GradientStop n
forall a. [a] -> a
head [GradientStop n]
stops GradientStop n -> [GradientStop n] -> [GradientStop n]
forall a. a -> [a] -> [a]
: ASetter [GradientStop n] [GradientStop n] n n
-> (n -> n) -> [GradientStop n] -> [GradientStop n]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((GradientStop n -> Identity (GradientStop n))
-> [GradientStop n] -> Identity [GradientStop n]
forall s t a b. Each s t a b => Traversal s t a b
each ((GradientStop n -> Identity (GradientStop n))
 -> [GradientStop n] -> Identity [GradientStop n])
-> ((n -> Identity n)
    -> GradientStop n -> Identity (GradientStop n))
-> ASetter [GradientStop n] [GradientStop n] n n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Identity n) -> GradientStop n -> Identity (GradientStop n)
forall n. Lens' (GradientStop n) n
stopFraction) n -> n
refrac [GradientStop n]
stops [GradientStop n] -> [GradientStop n] -> [GradientStop n]
forall a. [a] -> [a] -> [a]
++ [GradientStop n
lstop GradientStop n
-> (GradientStop n -> GradientStop n) -> GradientStop n
forall a b. a -> (a -> b) -> b
& (n -> Identity n) -> GradientStop n -> Identity (GradientStop n)
forall n. Lens' (GradientStop n) n
stopFraction ((n -> Identity n) -> GradientStop n -> Identity (GradientStop n))
-> n -> GradientStop n -> GradientStop n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ n
100n -> n -> n
forall a. Num a => a -> a -> a
*n
d]
    refrac :: n -> n
refrac n
x = n
100 n -> n -> n
forall a. Num a => a -> a -> a
* ((n
r0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
x n -> n -> n
forall a. Num a => a -> a -> a
* (n
r1 n -> n -> n
forall a. Num a => a -> a -> a
- n
r0)) n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
r1) -- start at r0, end at r1
    lstop :: GradientStop n
lstop = [GradientStop n] -> GradientStop n
forall a. [a] -> a
last [GradientStop n]
stops

-- Dirty adjustments for spread methods (PGF doesn't seem to have them).
-- adjustStops :: RealFloat n => [GradientStop n] -> SpreadMethod -> [GradientStop n]
-- adjustStops stops method =
--   case method of
--     GradPad     -> (stopFraction .~ 0) (head stops) : map (stopFraction +~ 1) stops
--                 ++ [(stopFraction +~ 2) (last stops)]
--     GradReflect -> correct . concat . replicate 10
--                  $ [stops, zipWith (\a b -> a & (stopColor .§ b)) stops (reverse stops)]
--     GradRepeat  -> correct . replicate 10 $ stops
  -- where
  --   correct  = ifoldMap (\i -> map (stopFraction +~ (lastStop * fromIntegral i)) )
  --   lastStop = last stops ^. stopFraction

-- (.§) :: Lens s t b b -> s -> s -> t
-- (.§) l a b = b & l #~ (a ^# l)
-- {-# INLINE (.§) #-}

colorSpec :: RealFloat n => n -> [GradientStop n] -> Render n
colorSpec :: n -> [GradientStop n] -> Render n
colorSpec n
d = (Render n -> Render n) -> [Render n] -> Render n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Render n -> Render n
forall n. Render n -> Render n
ln
            ([Render n] -> Render n)
-> ([GradientStop n] -> [Render n]) -> [GradientStop n] -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Render n] -> [Render n]
forall (m :: * -> *) a. Monad m => [m a] -> [m a]
combinePairs
            ([Render n] -> [Render n])
-> ([GradientStop n] -> [Render n])
-> [GradientStop n]
-> [Render n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render n -> [Render n] -> [Render n]
forall a. a -> [a] -> [a]
intersperse (Char -> Render n
forall n. Char -> Render n
rawChar Char
';')
            ([Render n] -> [Render n])
-> ([GradientStop n] -> [Render n])
-> [GradientStop n]
-> [Render n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GradientStop n -> Render n) -> [GradientStop n] -> [Render n]
forall a b. (a -> b) -> [a] -> [b]
map GradientStop n -> Render n
mkColor
  where
    mkColor :: GradientStop n -> Render n
mkColor (GradientStop SomeColor
c n
sf) = do
      Builder -> Render n
forall n. Builder -> Render n
raw Builder
"rgb"
      Render n -> Render n
forall n. Render n -> Render n
parens (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ n -> Render n
forall a n. RealFloat a => a -> Render n
bp (n
dn -> n -> n
forall a. Num a => a -> a -> a
*n
sf)
      Builder -> Render n
forall n. Builder -> Render n
raw Builder
"="
      SomeColor -> Render n
forall c n. Color c => c -> Render n
parensColor SomeColor
c

combinePairs :: Monad m => [m a] -> [m a]
combinePairs :: [m a] -> [m a]
combinePairs (m a
x1:m a
x2:[m a]
xs) = (m a
x1 m a -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
x2) m a -> [m a] -> [m a]
forall a. a -> [a] -> [a]
: [m a] -> [m a]
forall (m :: * -> *) a. Monad m => [m a] -> [m a]
combinePairs [m a]
xs
combinePairs [m a]
xs         = [m a]
xs

shadePath :: RealFloat n => Angle n -> Render n -> Render n
shadePath :: Angle n -> Render n -> Render n
shadePath (Getting n (Angle n) n -> Angle n -> n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting n (Angle n) n
forall n. Floating n => Iso' (Angle n) n
deg -> n
θ) Render n
name = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"shadepath"
  Render n -> Render n
forall n. Render n -> Render n
bracers Render n
name
  Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ n -> Render n
forall a n. RealFloat a => a -> Render n
n n
θ

-- external images -----------------------------------------------------

-- \pgfimage[⟨options ⟩]{⟨filename ⟩}

-- | Images are wraped in a \pgftext.
image :: RealFloat n => DImage n External -> Render n
image :: DImage n External -> Render n
image (DImage (ImageRef String
ref) Int
w Int
h Transformation V2 n
t2) = Render n -> Render n
forall n. Render n -> Render n
scope (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Transformation V2 n -> Render n
forall n. RealFloat n => Transformation V2 n -> Render n
applyTransform Transformation V2 n
t2
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
    Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"text"
    Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
      Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"image"
      Render n -> Render n
forall n. Render n -> Render n
brackets (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
        Builder -> Render n
forall n. Builder -> Render n
raw Builder
"width=" Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> Render n
forall a n. RealFloat a => a -> Render n
bp (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w :: Double)
        Char -> Render n
forall n. Char -> Render n
rawChar Char
','
        Builder -> Render n
forall n. Builder -> Render n
raw Builder
"height=" Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> Render n
forall a n. RealFloat a => a -> Render n
bp (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h :: Double)
      Render n -> Render n
forall n. Render n -> Render n
bracers (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ String -> Render n
forall n. String -> Render n
rawString String
ref

-- embedded images -----------------------------------------------------

embeddedImage :: RealFloat n => DImage n Embedded -> Render n
embeddedImage :: DImage n Embedded -> Render n
embeddedImage (DImage (ImageRaster (ImageRGB8 Image PixelRGB8
img)) Int
w Int
h Transformation V2 n
t) =
  ByteString -> Int -> Int -> Transformation V2 n -> Render n
forall n.
RealFloat n =>
ByteString -> Int -> Int -> T2 n -> Render n
embeddedImage' (Image PixelRGB8 -> ByteString
hexImage Image PixelRGB8
img) Int
w Int
h Transformation V2 n
t
  -- TODO: Support more formats (like grey scale and alpha channels)
embeddedImage DImage n Embedded
_ = String -> Render n
forall a. HasCallStack => String -> a
error String
"Unsupported embedded image. Only ImageRGB8 is currently supported."

-- | Convert an 'Image' to a zlib compressed lazy 'ByteString' of the
--   raw image data. This is a suitable format for an embedded PDF image
--   stream.
hexImage :: Image PixelRGB8 -> LB.ByteString
hexImage :: Image PixelRGB8 -> ByteString
hexImage (Image PixelRGB8 -> Vector (PixelBaseComponent PixelRGB8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData -> Vector (PixelBaseComponent PixelRGB8)
v) = ByteString -> ByteString
compress (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.fromStrict ByteString
bs
  where
    bs :: ByteString
bs         = ForeignPtr Word8 -> Int -> Int -> ByteString
fromForeignPtr ForeignPtr Word8
p Int
i Int
nn
    (ForeignPtr Word8
p, Int
i, Int
nn) = Vector Word8 -> (ForeignPtr Word8, Int, Int)
forall a. Storable a => Vector a -> (ForeignPtr a, Int, Int)
S.unsafeToForeignPtr Vector Word8
Vector (PixelBaseComponent PixelRGB8)
v

embeddedImage' :: RealFloat n => LB.ByteString -> Int -> Int -> T2 n -> Render n
embeddedImage' :: ByteString -> Int -> Int -> T2 n -> Render n
embeddedImage' ByteString
img Int
w Int
h T2 n
t = Render n -> Render n
forall n. Render n -> Render n
scope (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  T2 n -> Render n
forall n. RealFloat n => Transformation V2 n -> Render n
baseTransform T2 n
t
  Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"\\immediate\\pdfliteral{"
  Builder -> Render n
forall n. Builder -> Render n
rawLn Builder
"q" -- save state

  -- Scale the image to it's actual size and translate so the origin is
  -- at the centre.
  Builder -> Render n
forall n. Builder -> Render n
rawLn (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ Int -> Builder
s Int
w Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" 0 0 " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
s Int
h Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" -" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
half Int
w Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" -" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
half Int
h Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" cm"
  Builder -> Render n
forall n. Builder -> Render n
rawLn Builder
"BI"           -- begin image
  Builder -> Render n
forall n. Builder -> Render n
rawLn (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ Builder
"/W " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
s Int
w -- width in pixels
  Builder -> Render n
forall n. Builder -> Render n
rawLn (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ Builder
"/H " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
s Int
h -- height in pixels
  Builder -> Render n
forall n. Builder -> Render n
rawLn Builder
"/CS /RGB"     -- RGB colour space
  Builder -> Render n
forall n. Builder -> Render n
rawLn Builder
"/BPC 8"       -- 8 bits per component

  -- Filters for the encoded image:
  --   ASCIIHexDecode -- decode from hexadecimal to binary
  --   FlateDecode    -- decompress using zlib deflate compression
  Builder -> Render n
forall n. Builder -> Render n
rawLn Builder
"/F [/AHx /Fl]"

  -- We use hex format for the image data so tex can output it without
  -- any problems. Base85 might be possible and would be 2-3x smaller
  -- but there's some problem chars tex complains about. Base64 would
  -- be ideal but the pdf spec doesn't seem to support it.
  --
  -- This is an inline image which is only really suitable for small
  -- images. An XObject might be more appropriate. See
  -- http://partners.adobe.com/public/developer/en/pdf/PDFReference.pdf
  -- for more information.
  Builder -> Render n
forall n. Builder -> Render n
rawLn Builder
"ID" -- image data
  Builder -> Render n
forall n. Builder -> Render n
rawLn (Builder -> Render n) -> Builder -> Render n
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
hexChunk ByteString
img Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'>'
  Builder -> Render n
forall n. Builder -> Render n
rawLn Builder
"EI" -- end image
  Builder -> Render n
forall n. Builder -> Render n
rawLn Builder
"Q"  -- restore state
  Builder -> Render n
forall n. Builder -> Render n
rawLn Builder
"}"
    where
      rawLn :: Builder -> RWST RenderInfo Builder (RenderState n) Identity ()
rawLn Builder
r = Builder -> RWST RenderInfo Builder (RenderState n) Identity ()
forall n. Builder -> Render n
raw Builder
r RWST RenderInfo Builder (RenderState n) Identity ()
-> RWST RenderInfo Builder (RenderState n) Identity ()
-> RWST RenderInfo Builder (RenderState n) Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> RWST RenderInfo Builder (RenderState n) Identity ()
forall n. Char -> Render n
rawChar Char
'\n'
      s :: Int -> Builder
s       = Int -> Builder
intDec
      half :: Int -> Builder
half Int
x  = Int -> Builder
s (Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> if Int -> Bool
forall a. Integral a => a -> Bool
odd Int
x then Builder
".5" else Builder
forall a. Monoid a => a
mempty

-- | Insert hex encode and add a newline every 80 chars. This is useful for
--   readable output and stopping tex from choking when streaming. Note
--   that new-lines and spaces are ignored with the hex decode filter.
hexChunk :: LB.ByteString -> Builder
hexChunk :: ByteString -> Builder
hexChunk (Int64 -> ByteString -> (ByteString, ByteString)
LB.splitAt Int64
40 -> (ByteString
a,ByteString
b))
  | ByteString -> Bool
LB.null ByteString
b = ByteString -> Builder
lazyByteStringHex ByteString
a
  | Bool
otherwise = ByteString -> Builder
lazyByteStringHex ByteString
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'\n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
hexChunk ByteString
b

-- text ----------------------------------------------------------------

renderText :: [Render n] -> Render n -> Render n
renderText :: [Render n] -> Render n -> Render n
renderText [Render n]
ops Render n
txt = Render n -> Render n
forall n. Render n -> Render n
ln (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
  Builder -> Render n
forall n. Builder -> Render n
pgf Builder
"text"
  Render n -> Render n
forall n. Render n -> Render n
brackets (Render n -> Render n)
-> ([Render n] -> Render n) -> [Render n] -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Render n] -> Render n
forall n. [Render n] -> Render n
commaIntersperce ([Render n] -> Render n) -> [Render n] -> Render n
forall a b. (a -> b) -> a -> b
$ [Render n]
ops
  Render n -> Render n
forall n. Render n -> Render n
bracers Render n
txt

-- | Returns a list of values to be put in square brackets like
--   @\pgftext[left,top]{txt}@.
setTextAlign :: RealFloat n => TextAlignment n -> [Render n]
setTextAlign :: TextAlignment n -> [Render n]
setTextAlign TextAlignment n
a = case TextAlignment n
a of
  TextAlignment n
BaselineText         -> [Builder -> Render n
forall n. Builder -> Render n
raw Builder
"base", Builder -> Render n
forall n. Builder -> Render n
raw Builder
"left"]
  BoxAlignedText n
xt n
yt -> [Maybe (Render n)] -> [Render n]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Render n)
xt', Maybe (Render n)
yt']
    where
      xt' :: Maybe (Render n)
xt' | n
xt n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0.75 = Render n -> Maybe (Render n)
forall a. a -> Maybe a
Just (Render n -> Maybe (Render n)) -> Render n -> Maybe (Render n)
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"right"
          | n
xt n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
0.25 = Render n -> Maybe (Render n)
forall a. a -> Maybe a
Just (Render n -> Maybe (Render n)) -> Render n -> Maybe (Render n)
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"left"
          | Bool
otherwise = Maybe (Render n)
forall a. Maybe a
Nothing
      yt' :: Maybe (Render n)
yt' | n
yt n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0.75 = Render n -> Maybe (Render n)
forall a. a -> Maybe a
Just (Render n -> Maybe (Render n)) -> Render n -> Maybe (Render n)
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"top"
          | n
yt n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
0.25 = Render n -> Maybe (Render n)
forall a. a -> Maybe a
Just (Render n -> Maybe (Render n)) -> Render n -> Maybe (Render n)
forall a b. (a -> b) -> a -> b
$ Builder -> Render n
forall n. Builder -> Render n
raw Builder
"bottom"
          | Bool
otherwise = Maybe (Render n)
forall a. Maybe a
Nothing

setTextRotation :: RealFloat n => Angle n -> [Render n]
setTextRotation :: Angle n -> [Render n]
setTextRotation Angle n
a = case Angle n
aAngle n -> Getting n (Angle n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (Angle n) n
forall n. Floating n => Iso' (Angle n) n
deg of
  n
0 -> []
  n
θ -> [Builder -> Render n
forall n. Builder -> Render n
raw Builder
"rotate=" Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> n -> Render n
forall a n. RealFloat a => a -> Render n
n n
θ]

-- | Set the font weight by rendering @\bf @. Nothing is done for normal
--   weight.
setFontWeight :: FontWeight -> Render n
setFontWeight :: FontWeight -> Render n
setFontWeight FontWeight
FontWeightBold = Builder -> Render n
forall n. Builder -> Render n
raw Builder
"\\bf "
setFontWeight FontWeight
_              = () -> Render n
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Set the font slant by rendering @\bf @. Nothing is done for normal weight.
setFontSlant :: FontSlant -> Render n
setFontSlant :: FontSlant -> Render n
setFontSlant FontSlant
FontSlantNormal  = () -> Render n
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setFontSlant FontSlant
FontSlantItalic  = Builder -> Render n
forall n. Builder -> Render n
raw Builder
"\\it "
setFontSlant FontSlant
FontSlantOblique = Builder -> Render n
forall n. Builder -> Render n
raw Builder
"\\sl "