{-# 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                (when)
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
  { forall n. RenderState n -> P2 n
_pos        :: P2 n -- ^ Current position
  , forall n. RenderState n -> Int
_indent     :: Int  -- ^ Current indentation
  , forall n. 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 :: forall n. (Typeable n, Floating n) => RenderState n
initialState = RenderState
  { _pos :: P2 n
_pos        = forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin
  , _indent :: Int
_indent     = Int
0
  , _style :: Style V2 n
_style      = forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc forall a. Num a => Colour a
black 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 :: forall n.
(RealFloat n, Typeable n) =>
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' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
floor) V2 n
bounds
    (()
_,Builder
builder) = forall r w s a. RWS r w s a -> r -> s -> (a, w)
evalRWS Render n
r'
                          (TexFormat -> Bool -> RenderInfo
RenderInfo (Surface
sforall s a. s -> Getting a s a -> a
^.Lens' Surface TexFormat
texFormat) Bool
readable)
                          forall n. (Typeable n, Floating n) => RenderState n
initialState
    r' :: Render n
r' = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
standalone forall a b. (a -> b) -> a -> b
$ do
        forall n. Render n -> Render n
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. String -> Render n
rawString forall a b. (a -> b) -> a -> b
$ Surface
sforall s a. s -> Getting a s a -> a
^.Lens' Surface String
preamble
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              (forall n. Render n -> Render n
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. String -> Render n
rawString forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (RealFrac a, Integral b) => a -> b
ceiling V2 n
bounds'))
              (Surface
sforall s a. s -> Getting a s a -> a
^.Lens' Surface (Maybe (V2 Int -> String))
pageSize)
        forall n. Render n -> Render n
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. String -> Render n
rawString forall a b. (a -> b) -> a -> b
$ Surface
sforall s a. s -> Getting a s a -> a
^.Lens' Surface String
beginDoc
      forall n. Render n -> Render n
picture forall a b. (a -> b) -> a -> b
$ forall n. RealFloat n => V2 n -> Render n
rectangleBoundingBox V2 n
bounds' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render n
r
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
standalone forall a b. (a -> b) -> a -> b
$ forall n. String -> Render n
rawString forall a b. (a -> b) -> a -> b
$ Surface
sforall s a. s -> Getting a s a -> a
^.Lens' Surface String
endDoc

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

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

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

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

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

rawChar :: Char -> Render n
rawChar :: forall n. Char -> Render n
rawChar = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell 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 :: forall n. Render n
emit = do
  Bool
pp <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' RenderInfo Bool
pprint
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pp forall a b. (a -> b) -> a -> b
$ do
    Int
tab <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall n. Lens' (RenderState n) Int
indent
    forall n. ByteString -> Render n
rawByteString forall a b. (a -> b) -> a -> b
$ Int -> Char -> ByteString
B.replicate Int
tab Char
' '
{-# INLINE emit #-}

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

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

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

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

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

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

-- | Place a Render n in an indented block
inBlock :: Render n -> Render n
inBlock :: forall n. Render n -> Render n
inBlock Render n
r = do
  forall n. Lens' (RenderState n) Int
indent forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Int
2
  Render n
r
  forall n. Lens' (RenderState n) Int
indent 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 :: forall n a. RealFloat n => P2 n -> Render a
point = forall n a. RealFloat n => (n, n) -> Render a
tuplePoint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. P2 n -> (n, n)
unp2

bracerPoint :: RealFloat n => P2 n -> Render a
bracerPoint :: forall n a. RealFloat n => P2 n -> Render a
bracerPoint (P (V2 n
x n
y)) = do
  forall n. Render n -> Render n
bracers (forall a n. RealFloat a => a -> Render n
bp n
x)
  forall n. Render n -> Render n
bracers (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 :: forall n a. RealFloat n => (n, n) -> Render a
tuplePoint (n
x,n
y) = do
  forall n. Builder -> Render n
pgf Builder
"qpoint"
  forall n. Render n -> Render n
bracers (forall a n. RealFloat a => a -> Render n
bp n
x)
  forall n. Render n -> Render n
bracers (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 :: forall a n. RealFloat a => a -> Render n
n a
x = forall n. String -> Render n
rawString forall a b. (a -> b) -> a -> b
$ forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat (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 :: forall a n. RealFloat a => a -> Render n
bp = (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall n. Builder -> Render n
raw Builder
"bp") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a n. RealFloat a => a -> Render n
n

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

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

-- | Render n length with pt units.
pt :: RealFloat a => a -> Render n
pt :: forall a n. RealFloat a => a -> Render n
pt = (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall n. Builder -> Render n
raw Builder
"pt") forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall n. Fractional n => n
epsilon = n
0.0001

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

picture :: Render n -> Render n
picture :: forall n. Render n -> Render n
picture Render n
r = do
  TexFormat
f <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' RenderInfo TexFormat
format
  forall n. Render n -> Render n
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Builder -> Render n
raw forall a b. (a -> b) -> a -> b
$ case TexFormat
f of
    TexFormat
LaTeX    -> Builder
"\\begin{pgfpicture}"
    TexFormat
ConTeXt  -> Builder
"\\startpgfpicture"
    TexFormat
PlainTeX -> Builder
"\\pgfpicture"
  forall n. Render n -> Render n
inBlock Render n
r
  forall n. Render n -> Render n
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Builder -> Render n
raw 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 :: forall n. RealFloat n => V2 n -> Render n
rectangleBoundingBox V2 n
bounds = do
  forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
    forall n. Builder -> Render n
pgf Builder
"pathrectangle"
    forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
pgf Builder
"pointorigin"
    forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall n a. RealFloat n => (n, n) -> Render a
tuplePoint (forall n. V2 n -> (n, n)
unr2 V2 n
bounds)
  forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
    forall n. Builder -> Render n
pgf Builder
"usepath"
    forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"use as bounding box"

-- | Wrap the rendering in a scope.
scope :: Render n -> Render n
scope :: forall n. Render n -> Render n
scope Render n
r = do
  TexFormat
f <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' RenderInfo TexFormat
format
  forall n. Render n -> Render n
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Builder -> Render n
raw forall a b. (a -> b) -> a -> b
$ case TexFormat
f of
    TexFormat
LaTeX    -> Builder
"\\begin{pgfscope}"
    TexFormat
ConTeXt  -> Builder
"\\startpgfscope"
    TexFormat
PlainTeX -> Builder
"\\pgfscope"
  forall n. Render n -> Render n
inBlock Render n
r
  forall n. Render n -> Render n
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Builder -> Render n
raw 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 :: forall n. Render n -> Render n
transparencyGroup Render n
r = do
  TexFormat
f <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' RenderInfo TexFormat
format
  forall n. Render n -> Render n
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Builder -> Render n
raw forall a b. (a -> b) -> a -> b
$ case TexFormat
f of
    TexFormat
LaTeX    -> Builder
"\\begin{pgftransparencygroup}"
    TexFormat
ConTeXt  -> Builder
"\\startpgftransparencygroup"
    TexFormat
PlainTeX -> Builder
"\\pgftransparencygroup"
  forall n. Render n -> Render n
inBlock Render n
r
  forall n. Render n -> Render n
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Builder -> Render n
raw 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 :: forall a n. RealFloat a => a -> Render n -> Render n
opacityGroup a
x Render n
r = forall n. Render n -> Render n
scope forall a b. (a -> b) -> a -> b
$ do
  forall a n. RealFloat a => a -> Render n
setFillOpacity a
x
  forall n. Render n -> Render n
transparencyGroup Render n
r

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

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

contextColor :: RealFloat a => a -> a -> a -> Render n
contextColor :: forall a n. RealFloat a => a -> a -> a -> Render n
contextColor a
r a
g a
b = do
  forall n. Builder -> Render n
raw Builder
"r=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a n. RealFloat a => a -> Render n
n a
r
  forall n. Char -> Render n
rawChar Char
','
  forall n. Builder -> Render n
raw Builder
"g=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a n. RealFloat a => a -> Render n
n a
g
  forall n. Char -> Render n
rawChar Char
','
  forall n. Builder -> Render n
raw Builder
"b=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 :: forall a n. RealFloat a => ByteString -> a -> a -> a -> Render n
defineColour ByteString
name a
r a
g a
b = do
  TexFormat
f <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' RenderInfo TexFormat
format
  forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ case TexFormat
f of
    TexFormat
ConTeXt  -> do
      forall n. Builder -> Render n
raw Builder
"\\definecolor"
      forall n. Render n -> Render n
brackets forall a b. (a -> b) -> a -> b
$ forall n. ByteString -> Render n
rawByteString ByteString
name
      forall n. Render n -> Render n
brackets forall a b. (a -> b) -> a -> b
$ forall a n. RealFloat a => a -> a -> a -> Render n
contextColor a
r a
g a
b
    TexFormat
_        -> do
      forall n. Builder -> Render n
raw Builder
"\\definecolor"
      forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall n. ByteString -> Render n
rawByteString ByteString
name
      forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"rgb"
      forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall a n. RealFloat a => a -> a -> a -> Render n
texColor a
r a
g a
b

parensColor :: Color c => c -> Render n
parensColor :: forall c n. Color c => c -> Render n
parensColor c
c = forall n. Render n -> Render n
parens forall a b. (a -> b) -> a -> b
$ 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
_) = forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA c
c


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

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

-- | Move path to point.
moveTo :: RealFloat n => P2 n -> Render n
moveTo :: forall n. RealFloat n => P2 n -> Render n
moveTo P2 n
v = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  forall n. Lens' (RenderState n) (P2 n)
pos forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= P2 n
v
  forall n. Builder -> Render n
pgf Builder
"pathqmoveto"
  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 :: forall n. RealFloat n => V2 n -> Render n
lineTo V2 n
v = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  P2 n
p <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall n. Lens' (RenderState n) (P2 n)
pos
  let v' :: P2 n
v' = P2 n
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 n
v
  forall n. Lens' (RenderState n) (P2 n)
pos forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= P2 n
v'
  forall n. Builder -> Render n
pgf Builder
"pathqlineto"
  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 :: forall n. RealFloat n => V2 n -> V2 n -> V2 n -> Render n
curveTo V2 n
v2 V2 n
v3 V2 n
v4 = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  P2 n
p <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall n. Lens' (RenderState n) (P2 n)
pos
  let [P2 n
v2',P2 n
v3',P2 n
v4'] = forall a b. (a -> b) -> [a] -> [b]
map (P2 n
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^) [V2 n
v2,V2 n
v3,V2 n
v4]
  forall n. Lens' (RenderState n) (P2 n)
pos forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= P2 n
v4'
  forall n. Builder -> Render n
pgf Builder
"pathqcurveto"
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 :: forall n. Render n
stroke = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
pgf Builder
"usepathqstroke"

-- | Fill the defined path using parameters from current scope.
fill :: Render n
fill :: forall n. Render n
fill = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ 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 :: forall n. Render n
clip = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
pgf Builder
"usepathqclip"

path :: RealFloat n => Path V2 n -> Render n
path :: forall n. RealFloat n => Path V2 n -> Render n
path (Path [Located (Trail V2 n)]
trs) = do
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 (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
      forall n. RealFloat n => P2 n -> Render n
moveTo Point (V (Trail V2 n)) (N (Trail V2 n))
p
      forall n. RealFloat n => Trail V2 n -> Render n
trail Trail V2 n
tr

trail :: RealFloat n => Trail V2 n -> Render n
trail :: forall n. RealFloat n => Trail V2 n -> Render n
trail Trail V2 n
t = 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' forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall n. RealFloat n => Segment Closed V2 n -> Render n
segment [Segment Closed V2 n]
segs
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (v :: * -> *) n. Trail v n -> Bool
isLoop Trail V2 n
t) forall n. Render n
closePath

segment ::  RealFloat n => Segment Closed V2 n -> Render n
segment :: forall n. RealFloat n => Segment Closed V2 n -> Render n
segment (Linear (OffsetClosed V2 n
v))       = forall n. RealFloat n => V2 n -> Render n
lineTo V2 n
v
segment (Cubic V2 n
v1 V2 n
v2 (OffsetClosed V2 n
v3)) = 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 :: forall n. Bool -> Bool -> Render n
usePath Bool
False Bool
False     = forall (m :: * -> *) a. Monad m => a -> m a
return ()
usePath Bool
doFill Bool
doStroke = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  forall n. Builder -> Render n
pgf Builder
"usepathq"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doFill forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"fill"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doStroke forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"stroke"

-- | Uses the current path as the bounding box for whole picture.
asBoundingBox :: Render n
asBoundingBox :: forall n. Render n
asBoundingBox = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  forall n. Builder -> Render n
pgf Builder
"usepath"
  forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ 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 :: forall n. RealFloat n => n -> Render n
setLineWidth n
w = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  forall n. Builder -> Render n
pgf Builder
"setlinewidth"
  forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ 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 :: forall n. LineCap -> Render n
setLineCap LineCap
cap = forall n. Render n -> Render n
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Builder -> Render n
pgf 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 :: forall n. LineJoin -> Render n
setLineJoin LineJoin
lJoin = forall n. Render n -> Render n
ln forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Builder -> Render n
pgf 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 :: forall n. RealFloat n => n -> Render n
setMiterLimit n
l = do
  forall n. Builder -> Render n
pgf Builder
"setmiterlimit"
  forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ 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 :: forall n. RealFloat n => Dashing n -> Render n
setDash (Dashing [n]
ds n
offs) = 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' :: forall n. RealFloat n => [n] -> n -> Render n
setDash' [n]
ds n
off = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  forall n. Builder -> Render n
pgf Builder
"setdash"
  forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall n. Render n -> Render n
bracers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a n. RealFloat a => a -> Render n
bp) [n]
ds
  forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ 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 :: forall a c. (RealFloat a, Color c) => c -> Render a
setLineColor c
c = do
  forall a n. RealFloat a => ByteString -> a -> a -> a -> Render n
defineColour ByteString
"sc" Double
r Double
g Double
b
  forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
pgf Builder
"setstrokecolor{sc}"
  --
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
a forall a. Eq a => a -> a -> Bool
/= Double
1) forall a b. (a -> b) -> a -> b
$ forall n. RealFloat n => n -> Render n
setLineOpacity (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
a)
  where
    (Double
r,Double
g,Double
b,Double
a) = 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 :: forall n. RealFloat n => n -> Render n
setLineOpacity n
a = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  forall n. Builder -> Render n
pgf Builder
"setstrokeopacity"
  forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ 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 :: forall n. FillRule -> Render n
setFillRule FillRule
rule = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ case FillRule
rule of
  FillRule
Winding -> forall n. Builder -> Render n
pgf Builder
"setnonzerorule"
  FillRule
EvenOdd -> 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 :: forall c n. Color c => c -> Render n
setFillColor (forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA -> (Double
r,Double
g,Double
b,Double
a)) = do
  forall a n. RealFloat a => ByteString -> a -> a -> a -> Render n
defineColour ByteString
"fc" Double
r Double
g Double
b
  forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
pgf Builder
"setfillcolor{fc}"
  --
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
a forall a. Eq a => a -> a -> Bool
/= Double
1) forall a b. (a -> b) -> a -> b
$ forall a n. RealFloat a => a -> Render n
setFillOpacity (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 :: forall a n. RealFloat a => a -> Render n
setFillOpacity a
a = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  forall n. Builder -> Render n
pgf Builder
"setfillopacity"
  forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ 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 :: forall n. Num n => 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] = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ 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 :: forall n. RealFloat n => Transformation V2 n -> Render n
applyTransform Transformation V2 n
t
  | Bool
isID      = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
shiftOnly = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
      forall n. Builder -> Render n
pgf Builder
"transformshift"
      forall n. Render n -> Render n
bracers Render n
p
  | Bool
otherwise = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
    forall n. Builder -> Render n
pgf Builder
"transformcm"
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall n. Render n -> Render n
bracers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a n. RealFloat a => a -> Render n
n) [n
a, n
b, n
c, n
d] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall n. Render n -> Render n
bracers Render n
p
  where
    (n
a,n
b,n
c,n
d,n
e,n
f) = forall n. Num n => Transformation V2 n -> (n, n, n, n, n, n)
getMatrix Transformation V2 n
t
    p :: Render n
p             = 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) 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) 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 :: forall n. RealFloat n => Transformation V2 n -> Render n
setTransform Transformation V2 n
t = do
  forall n. Builder -> Render n
pgf Builder
"settransformentries"
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall n. Render n -> Render n
bracers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a n. RealFloat a => a -> Render n
n) [n
a, n
b, n
c, n
d] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall n. Render n -> Render n
bracers forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = 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 :: forall n. RealFloat n => n -> Render n
applyScale n
s = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  forall n. Builder -> Render n
pgf Builder
"transformscale"
  forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall a n. RealFloat a => a -> Render n
n n
s

resetNonTranslations :: Render n
resetNonTranslations :: forall n. Render n
resetNonTranslations = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ 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 :: forall n. RealFloat n => Transformation V2 n -> Render n
baseTransform Transformation V2 n
t = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  forall n. Builder -> Render n
pgf Builder
"lowlevel"
  forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ 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 :: forall n. RealFloat n => Path V2 n -> LGradient n -> Render n
linearGradient Path V2 n
p LGradient n
lg = forall n. Render n -> Render n
scope forall a b. (a -> b) -> a -> b
$ do
  forall n. RealFloat n => Path V2 n -> Render n
path Path V2 n
p
  let ([GradientStop n]
stops', T2 n
t) = forall n.
RealFloat n =>
Path V2 n -> LGradient n -> ([GradientStop n], T2 n)
calcLinearStops Path V2 n
p LGradient n
lg
  forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
    forall n. Builder -> Render n
pgf Builder
"declarehorizontalshading"
    forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"ft"    -- fill texture
    forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"100bp" -- gradient is always 100 x 100 square
    forall n. Render n -> Render n
bracersBlock forall a b. (a -> b) -> a -> b
$ forall n. RealFloat n => n -> [GradientStop n] -> Render n
colorSpec n
1 [GradientStop n]
stops'
  forall n. Render n
clip
  forall n. RealFloat n => Transformation V2 n -> Render n
baseTransform T2 n
t
  forall n. Render n -> Render n
useShading forall a b. (a -> b) -> a -> b
$ 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 :: forall n.
RealFloat n =>
Path V2 n -> LGradient n -> ([GradientStop n], T2 n)
calcLinearStops (Path []) LGradient 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)
  = (forall n.
RealFloat n =>
n -> n -> [GradientStop n] -> SpreadMethod -> [GradientStop n]
linearStops' n
x0 n
x1 [GradientStop n]
stops SpreadMethod
sm, T2 n
t 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
     forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n. v n -> Transformation v n
translation (Point V2 n
p0 forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *) a (g :: * -> *) b.
Iso (Point f a) (Point g b) (f a) (g b)
_Point)
     forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n.
(Additive v, Fractional n) =>
n -> Transformation v n
scaling (forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (Point V2 n
p1 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 n
p0))
     forall a. Semigroup a => a -> a -> a
<> forall n. OrderedField n => Direction V2 n -> T2 n
rotationTo (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' = forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (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) = 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) = 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 = forall (v :: * -> *) n. v n -> Transformation v n
translation (forall a. a -> a -> V2 a
V2 n
x0 n
y0) forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n.
(Additive v, Fractional n) =>
v n -> Transformation v n
scalingV ((forall a. Num a => a -> a -> a
*n
0.01) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> a -> V2 a
V2 (n
x0 forall a. Num a => a -> a -> a
- n
x1) (n
y0 forall a. Num a => a -> a -> a
- n
y1)) forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n. v n -> Transformation v n
translation V2 n
50

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

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


_translation :: Lens' (Transformation v n) (v n)
_translation :: forall (v :: * -> *) n. Lens' (Transformation v n) (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 forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \v n
v' -> 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' :: forall n.
RealFloat n =>
n -> n -> [GradientStop n] -> SpreadMethod -> [GradientStop n]
linearStops' n
x0 n
x1 [GradientStop n]
stops SpreadMethod
sm =
  forall d. SomeColor -> d -> GradientStop d
GradientStop SomeColor
c1' n
0 forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (forall {a}. (Ord a, Num a) => a -> Bool
inRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall n. Lens' (GradientStop n) n
stopFraction) [GradientStop n]
stops' forall a. [a] -> [a] -> [a]
++ [forall d. SomeColor -> d -> GradientStop d
GradientStop SomeColor
c2' n
100]
  where
    stops' :: [GradientStop n]
stops' = case SpreadMethod
sm of
      SpreadMethod
GradPad     -> forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s t a b. Each s t a b => Traversal s t a b
each forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Lens' (GradientStop n) n
stopFraction) n -> n
normalise [GradientStop n]
stops
      SpreadMethod
GradRepeat  -> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap [Int
i0 .. Int
i1] forall a b. (a -> b) -> a -> b
$ \Int
i ->
                       [GradientStop n] -> [GradientStop n]
increaseFirst forall a b. (a -> b) -> a -> b
$
                         forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s t a b. Each s t a b => Traversal s t a b
each forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Lens' (GradientStop n) n
stopFraction)
                              (n -> n
normalise forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
                              [GradientStop n]
stops
      SpreadMethod
GradReflect -> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap [Int
i0 .. Int
i1] forall a b. (a -> b) -> a -> b
$ \Int
i ->
                       forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s t a b. Each s t a b => Traversal s t a b
each forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Lens' (GradientStop n) n
stopFraction)
                            (n -> n
normalise forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
                            (forall {a} {b}.
(Integral a, Num b) =>
a -> [GradientStop b] -> [GradientStop b]
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 = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s a. Cons s s a a => Traversal' s a
_head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Lens' (GradientStop n) n
stopFraction) (forall a. Num a => a -> a -> a
+n
0.001)
    reverseOdd :: a -> [GradientStop b] -> [GradientStop b]
reverseOdd a
i
      | forall a. Integral a => a -> Bool
odd a
i     = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s t a b. Each s t a b => Traversal s t a b
each forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Lens' (GradientStop n) n
stopFraction) (b
1 forall a. Num a => a -> a -> a
-)
      | Bool
otherwise = forall a. a -> a
id
    i0 :: Int
i0 = forall a b. (RealFrac a, Integral b) => a -> b
floor n
x0 :: Int
    i1 :: Int
i1 = forall a b. (RealFrac a, Integral b) => a -> b
ceiling n
x1
    c1' :: SomeColor
c1' = forall c. Color c => c -> SomeColor
SomeColor forall a b. (a -> b) -> a -> b
$ forall n.
RealFloat n =>
[GradientStop n] -> n -> AlphaColour Double
colourInterp [GradientStop n]
stops' n
0
    c2' :: SomeColor
c2' = forall c. Color c => c -> SomeColor
SomeColor forall a b. (a -> b) -> a -> b
$ forall n.
RealFloat n =>
[GradientStop n] -> n -> AlphaColour Double
colourInterp [GradientStop n]
stops' n
100
    inRange :: a -> Bool
inRange a
x   = a
x forall a. Ord a => a -> a -> Bool
> a
0 Bool -> Bool -> Bool
&& a
x forall a. Ord a => a -> a -> Bool
< a
100
    normalise :: n -> n
normalise n
x = n
100 forall a. Num a => a -> a -> a
* (n
x forall a. Num a => a -> a -> a
- n
x0) forall a. Fractional a => a -> a -> a
/ (n
x1 forall a. Num a => a -> a -> a
- n
x0)

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

radialGradient :: RealFloat n => Path V2 n -> RGradient n -> Render n
radialGradient :: forall n. RealFloat n => Path V2 n -> RGradient n -> Render n
radialGradient Path V2 n
p RGradient n
rg = forall n. Render n -> Render n
scope forall a b. (a -> b) -> a -> b
$ do
  forall n. RealFloat n => Path V2 n -> Render n
path Path V2 n
p
  let ([GradientStop n]
stops', T2 n
t, P2 n
p0) = forall n.
RealFloat n =>
Path V2 n -> RGradient n -> ([GradientStop n], T2 n, P2 n)
calcRadialStops Path V2 n
p RGradient n
rg
  forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
    forall n. Builder -> Render n
pgf Builder
"declareradialshading"
    forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"ft"
    forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall n a. RealFloat n => P2 n -> Render a
point P2 n
p0
    forall n. Render n -> Render n
bracersBlock forall a b. (a -> b) -> a -> b
$ forall n. RealFloat n => n -> [GradientStop n] -> Render n
colorSpec n
1 [GradientStop n]
stops'
  forall n. Render n
clip
  forall n. RealFloat n => Transformation V2 n -> Render n
baseTransform T2 n
t
  forall n. Render n -> Render n
useShading forall a b. (a -> b) -> a -> b
$ 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 :: forall n.
RealFloat n =>
Path V2 n -> RGradient n -> ([GradientStop n], T2 n, P2 n)
calcRadialStops (Path []) RGradient n
_ = ([], forall a. Monoid a => a
mempty, forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin)
calcRadialStops Path V2 n
pth (RGradient [GradientStop n]
stops Point V2 n
p0 n
r0 Point V2 n
p1 n
r1 T2 n
gt SpreadMethod
_sm)
  = ([GradientStop n]
stops', T2 n
t forall a. Semigroup a => a -> a -> a
<> T2 n
ft, forall (f :: * -> *) a. f a -> Point f a
P Diff (Point V2) n
cv)
  where
    cv :: Diff (Point V2) n
cv = Point V2 n
tp0 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 n
tp1
    tp0 :: Point V2 n
tp0 = forall (v :: * -> *) n.
(Additive v, Num n) =>
Transformation v n -> Point v n -> Point v n
papply T2 n
gt Point V2 n
p0
    tp1 :: Point V2 n
tp1 = forall (v :: * -> *) n.
(Additive v, Num n) =>
Transformation v n -> Point v n -> Point v n
papply T2 n
gt Point V2 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
     forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n. v n -> Transformation v n
translation (Point V2 n
p1 forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *) a (g :: * -> *) b.
Iso (Point f a) (Point g b) (f a) (g b)
_Point)
     forall a. Semigroup a => a -> a -> a
<> 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' = forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (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) = 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) = 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 forall a. Num a => a -> a -> a
* forall a. Ord a => a -> a -> a
max (forall a. Ord a => a -> a -> a
max (forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ n
x0 forall a. Num a => a -> a -> a
- n
x1) (forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ n
y0 forall a. Num a => a -> a -> a
- n
y1)) (GradientStop n
lstop forall s a. s -> Getting a s a -> a
^. forall n. Lens' (GradientStop n) n
stopFraction)

    -- Adjust for gradient size having radius 100
    ft :: T2 n
ft = 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' = forall a. [a] -> a
head [GradientStop n]
stops forall a. a -> [a] -> [a]
: forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s t a b. Each s t a b => Traversal s t a b
each forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Lens' (GradientStop n) n
stopFraction) n -> n
refrac [GradientStop n]
stops forall a. [a] -> [a] -> [a]
++ [GradientStop n
lstop forall a b. a -> (a -> b) -> b
& forall n. Lens' (GradientStop n) n
stopFraction forall s t a b. ASetter s t a b -> b -> s -> t
.~ n
100forall a. Num a => a -> a -> a
*n
d]
    refrac :: n -> n
refrac n
x = n
100 forall a. Num a => a -> a -> a
* ((n
r0 forall a. Num a => a -> a -> a
+ n
x forall a. Num a => a -> a -> a
* (n
r1 forall a. Num a => a -> a -> a
- n
r0)) forall a. Fractional a => a -> a -> a
/ n
r1) -- start at r0, end at r1
    lstop :: GradientStop n
lstop = 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 :: forall n. RealFloat n => n -> [GradientStop n] -> Render n
colorSpec n
d = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall n. Render n -> Render n
ln
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => [m a] -> [m a]
combinePairs
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (forall n. Char -> Render n
rawChar Char
';')
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
      forall n. Builder -> Render n
raw Builder
"rgb"
      forall n. Render n -> Render n
parens forall a b. (a -> b) -> a -> b
$ forall a n. RealFloat a => a -> Render n
bp (n
dforall a. Num a => a -> a -> a
*n
sf)
      forall n. Builder -> Render n
raw Builder
"="
      forall c n. Color c => c -> Render n
parensColor SomeColor
c

combinePairs :: Monad m => [m a] -> [m a]
combinePairs :: forall (m :: * -> *) a. Monad m => [m a] -> [m a]
combinePairs (m a
x1:m a
x2:[m a]
xs) = (m a
x1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
x2) forall a. a -> [a] -> [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 :: forall n. RealFloat n => Angle n -> Render n -> Render n
shadePath (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall n. Floating n => Iso' (Angle n) n
deg -> n
θ) Render n
name = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  forall n. Builder -> Render n
pgf Builder
"shadepath"
  forall n. Render n -> Render n
bracers Render n
name
  forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ 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 :: forall n. RealFloat n => DImage n External -> Render n
image (DImage (ImageRef String
ref) Int
w Int
h Transformation V2 n
t2) = forall n. Render n -> Render n
scope forall a b. (a -> b) -> a -> b
$ do
  forall n. RealFloat n => Transformation V2 n -> Render n
applyTransform Transformation V2 n
t2
  forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
    forall n. Builder -> Render n
pgf Builder
"text"
    forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ do
      forall n. Builder -> Render n
pgf Builder
"image"
      forall n. Render n -> Render n
brackets forall a b. (a -> b) -> a -> b
$ do
        forall n. Builder -> Render n
raw Builder
"width=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a n. RealFloat a => a -> Render n
bp (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w :: Double)
        forall n. Char -> Render n
rawChar Char
','
        forall n. Builder -> Render n
raw Builder
"height=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a n. RealFloat a => a -> Render n
bp (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h :: Double)
      forall n. Render n -> Render n
bracers forall a b. (a -> b) -> a -> b
$ forall n. String -> Render n
rawString String
ref

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

embeddedImage :: RealFloat n => DImage n Embedded -> Render n
embeddedImage :: forall n. RealFloat n => DImage n Embedded -> Render n
embeddedImage (DImage (ImageRaster (ImageRGB8 Image PixelRGB8
img)) Int
w Int
h Transformation V2 n
t) =
  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
_ = 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 (forall a. Image a -> Vector (PixelBaseComponent a)
imageData -> Vector (PixelBaseComponent PixelRGB8)
v) = ByteString -> ByteString
compress 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) = forall a. Vector a -> (ForeignPtr a, Int, Int)
S.unsafeToForeignPtr Vector (PixelBaseComponent PixelRGB8)
v

embeddedImage' :: RealFloat n => LB.ByteString -> Int -> Int -> T2 n -> Render n
embeddedImage' :: forall n.
RealFloat n =>
ByteString -> Int -> Int -> T2 n -> Render n
embeddedImage' ByteString
img Int
w Int
h T2 n
t = forall n. Render n -> Render n
scope forall a b. (a -> b) -> a -> b
$ do
  forall n. RealFloat n => Transformation V2 n -> Render n
baseTransform T2 n
t
  forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"\\immediate\\pdfliteral{"
  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.
  forall n. Builder -> Render n
rawLn forall a b. (a -> b) -> a -> b
$ Int -> Builder
s Int
w forall a. Semigroup a => a -> a -> a
<> Builder
" 0 0 " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
s Int
h forall a. Semigroup a => a -> a -> a
<> Builder
" -" forall a. Semigroup a => a -> a -> a
<> Int -> Builder
half Int
w forall a. Semigroup a => a -> a -> a
<> Builder
" -" forall a. Semigroup a => a -> a -> a
<> Int -> Builder
half Int
h forall a. Semigroup a => a -> a -> a
<> Builder
" cm"
  forall n. Builder -> Render n
rawLn Builder
"BI"           -- begin image
  forall n. Builder -> Render n
rawLn forall a b. (a -> b) -> a -> b
$ Builder
"/W " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
s Int
w -- width in pixels
  forall n. Builder -> Render n
rawLn forall a b. (a -> b) -> a -> b
$ Builder
"/H " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
s Int
h -- height in pixels
  forall n. Builder -> Render n
rawLn Builder
"/CS /RGB"     -- RGB colour space
  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
  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.
  forall n. Builder -> Render n
rawLn Builder
"ID" -- image data
  forall n. Builder -> Render n
rawLn forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
hexChunk ByteString
img forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'>'
  forall n. Builder -> Render n
rawLn Builder
"EI" -- end image
  forall n. Builder -> Render n
rawLn Builder
"Q"  -- restore state
  forall n. Builder -> Render n
rawLn Builder
"}"
    where
      rawLn :: Builder -> RWST RenderInfo Builder (RenderState n) Identity ()
rawLn Builder
r = forall n. Builder -> Render n
raw Builder
r forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 forall a. Integral a => a -> a -> a
`div` Int
2) forall a. Semigroup a => a -> a -> a
<> if forall a. Integral a => a -> Bool
odd Int
x then Builder
".5" else 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 forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'\n' forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
hexChunk ByteString
b

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

renderText :: [Render n] -> Render n -> Render n
renderText :: forall n. [Render n] -> Render n -> Render n
renderText [Render n]
ops Render n
txt = forall n. Render n -> Render n
ln forall a b. (a -> b) -> a -> b
$ do
  forall n. Builder -> Render n
pgf Builder
"text"
  forall n. Render n -> Render n
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. [Render n] -> Render n
commaIntersperce forall a b. (a -> b) -> a -> b
$ [Render n]
ops
  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 :: forall n. RealFloat n => TextAlignment n -> [Render n]
setTextAlign TextAlignment n
a = case TextAlignment n
a of
  TextAlignment n
BaselineText         -> [forall n. Builder -> Render n
raw Builder
"base", forall n. Builder -> Render n
raw Builder
"left"]
  BoxAlignedText n
xt n
yt -> forall a. [Maybe a] -> [a]
catMaybes [Maybe (Render n)
xt', Maybe (Render n)
yt']
    where
      xt' :: Maybe (Render n)
xt' | n
xt forall a. Ord a => a -> a -> Bool
> n
0.75 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"right"
          | n
xt forall a. Ord a => a -> a -> Bool
< n
0.25 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"left"
          | Bool
otherwise = forall a. Maybe a
Nothing
      yt' :: Maybe (Render n)
yt' | n
yt forall a. Ord a => a -> a -> Bool
> n
0.75 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"top"
          | n
yt forall a. Ord a => a -> a -> Bool
< n
0.25 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. Builder -> Render n
raw Builder
"bottom"
          | Bool
otherwise = forall a. Maybe a
Nothing

setTextRotation :: RealFloat n => Angle n -> [Render n]
setTextRotation :: forall n. RealFloat n => Angle n -> [Render n]
setTextRotation Angle n
a = case Angle n
aforall s a. s -> Getting a s a -> a
^.forall n. Floating n => Iso' (Angle n) n
deg of
  n
0 -> []
  n
θ -> [forall n. Builder -> Render n
raw Builder
"rotate=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 :: forall n. FontWeight -> Render n
setFontWeight FontWeight
FontWeightBold = forall n. Builder -> Render n
raw Builder
"\\bf "
setFontWeight FontWeight
_              = 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 :: forall n. FontSlant -> Render n
setFontSlant FontSlant
FontSlantNormal  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
setFontSlant FontSlant
FontSlantItalic  = forall n. Builder -> Render n
raw Builder
"\\it "
setFontSlant FontSlant
FontSlantOblique = forall n. Builder -> Render n
raw Builder
"\\sl "