diagrams-pgf-1.4: src/Graphics/Rendering/PGF.hs
{-# 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
{ _pos :: P2 n -- ^ Current position
, _indent :: Int -- ^ Current indentation
, _style :: Style V2 n
}
makeLenses ''RenderState
data RenderInfo = RenderInfo
{ _format :: TexFormat
, _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
{ _pos = origin
, _indent = 0
, _style = lc black 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 s readable standalone bounds r = builder
where
bounds' = fmap (fromInteger . floor) bounds
(_,builder) = evalRWS r'
(RenderInfo (s^.texFormat) readable)
initialState
r' = do
when standalone $ do
ln . rawString $ s^.preamble
maybe (return ())
(ln . rawString . ($ fmap ceiling bounds'))
(s^.pageSize)
ln . rawString $ s^.beginDoc
picture $ rectangleBoundingBox bounds' >> r
when standalone $ rawString $ s^.endDoc
-- low level utilities -------------------------------------------------
-- builder functions
raw :: Builder -> Render n
raw = tell
{-# INLINE raw #-}
rawByteString :: ByteString -> Render n
rawByteString = tell . byteString
{-# INLINE rawByteString #-}
rawString :: String -> Render n
rawString = tell . stringUtf8
{-# INLINE rawString #-}
pgf :: Builder -> Render n
pgf c = raw $ "\\pgf" <> c
{-# INLINE pgf #-}
rawChar :: Char -> Render n
rawChar = tell . char8
{-# INLINE rawChar #-}
-- | Emit the indentation when 'pprint' is True.
emit :: Render n
emit = do
pp <- view pprint
when pp $ do
tab <- use indent
rawByteString $ B.replicate tab ' '
{-# INLINE emit #-}
ln :: Render n -> Render n
ln r = do
emit
r
rawChar '\n'
{-# INLINE ln #-}
-- | Wrap a `Render n` in { .. }.
bracers :: Render n -> Render n
bracers r = do
rawChar '{'
r
rawChar '}'
{-# INLINE bracers #-}
bracersBlock :: Render n -> Render n
bracersBlock rs = do
raw "{\n"
inBlock rs
emit
rawChar '}'
-- | Wrap a `Render n` in [ .. ].
brackets :: Render n -> Render n
brackets r = do
rawChar '['
r
rawChar ']'
{-# INLINE brackets #-}
parens :: Render n -> Render n
parens r = do
rawChar '('
r
rawChar ')'
{-# INLINE parens #-}
-- | Intersperse list of Render ns with commas.
commaIntersperce :: [Render n] -> Render n
commaIntersperce = sequence_ . intersperse (rawChar ',')
-- | Place a Render n in an indented block
inBlock :: Render n -> Render n
inBlock r = do
indent += 2
r
indent -= 2
-- numbers and points --------------------------------------------------
-- | Render a point.
point :: RealFloat n => P2 n -> Render a
point = tuplePoint . unp2
bracerPoint :: RealFloat n => P2 n -> Render a
bracerPoint (P (V2 x y)) = do
bracers (bp x)
bracers (bp y)
-- | Render n a tuple as a point.
tuplePoint :: RealFloat n => (n,n) -> Render a
tuplePoint (x,y) = do
pgf "qpoint"
bracers (bp x)
bracers (bp y)
-- | Render n a n to four decimal places.
n :: RealFloat a => a -> Render n
n x = rawString $ showFFloat (Just 4) x ""
-- | Render n length with bp (big point = 1 px at 72 dpi) units.
bp :: RealFloat a => a -> Render n
bp = (>> raw "bp") . n
-- | Render n length with px units.
px :: RealFloat a => a -> Render n
px = (>> raw "px") . n
-- | Render n length with mm units.
mm :: RealFloat a => a -> Render n
mm = (>> raw "mm") . n -- . (*0.35278)
-- | Render n length with pt units.
pt :: RealFloat a => a -> Render n
pt = (>> raw "pt") . n -- . (*1.00375)
-- | ε = 0.0001 is the limit at which lines are no longer stroked.
epsilon :: Fractional n => n
epsilon = 0.0001
-- environments --------------------------------------------------------
picture :: Render n -> Render n
picture r = do
f <- view format
ln . raw $ case f of
LaTeX -> "\\begin{pgfpicture}"
ConTeXt -> "\\startpgfpicture"
PlainTeX -> "\\pgfpicture"
inBlock r
ln . raw $ case f of
LaTeX -> "\\end{pgfpicture}"
ConTeXt -> "\\stoppgfpicture"
PlainTeX -> "\\endpgfpicture"
rectangleBoundingBox :: RealFloat n => V2 n -> Render n
rectangleBoundingBox bounds = do
ln $ do
pgf "pathrectangle"
bracers $ pgf "pointorigin"
bracers $ tuplePoint (unr2 bounds)
ln $ do
pgf "usepath"
bracers $ raw "use as bounding box"
-- | Wrap the rendering in a scope.
scope :: Render n -> Render n
scope r = do
f <- view format
ln . raw $ case f of
LaTeX -> "\\begin{pgfscope}"
ConTeXt -> "\\startpgfscope"
PlainTeX -> "\\pgfscope"
inBlock r
ln . raw $ case f of
LaTeX -> "\\end{pgfscope}"
ConTeXt -> "\\stoppgfscope"
PlainTeX -> "\\endpgfscope"
-- opacity groups ------------------------------------------------------
transparencyGroup :: Render n -> Render n
transparencyGroup r = do
f <- view format
ln . raw $ case f of
LaTeX -> "\\begin{pgftransparencygroup}"
ConTeXt -> "\\startpgftransparencygroup"
PlainTeX -> "\\pgftransparencygroup"
inBlock r
ln . raw $ case f of
LaTeX -> "\\end{pgftransparencygroup}"
ConTeXt -> "\\stoppgftransparencygroup"
PlainTeX -> "\\endpgftransparencygroup"
opacityGroup :: RealFloat a => a -> Render n -> Render n
opacityGroup x r = scope $ do
setFillOpacity x
transparencyGroup r
-- colours -------------------------------------------------------------
texColor :: RealFloat a => a -> a -> a -> Render n
texColor r g b = do
n r
rawChar ','
n g
rawChar ','
n b
contextColor :: RealFloat a => a -> a -> a -> Render n
contextColor r g b = do
raw "r=" >> n r
rawChar ','
raw "g=" >> n g
rawChar ','
raw "b=" >> n b
-- | Defines an RGB colour with the given name, using the Tex format.
defineColour :: RealFloat a => ByteString -> a -> a -> a -> Render n
defineColour name r g b = do
f <- view format
ln $ case f of
ConTeXt -> do
raw "\\definecolor"
brackets $ rawByteString name
brackets $ contextColor r g b
_ -> do
raw "\\definecolor"
bracers $ rawByteString name
bracers $ raw "rgb"
bracers $ texColor r g b
parensColor :: Color c => c -> Render n
parensColor c = parens $ texColor r g b
where (r,g,b,_) = colorToSRGBA c
-- paths ---------------------------------------------------------------
-- | Close the current path.
closePath :: Render n
closePath = ln $ pgf "pathclose"
-- | Move path to point.
moveTo :: RealFloat n => P2 n -> Render n
moveTo v = ln $ do
pos .= v
pgf "pathqmoveto"
bracerPoint v
-- | Move path by vector.
lineTo :: RealFloat n => V2 n -> Render n
lineTo v = ln $ do
p <- use pos
let v' = p .+^ v
pos .= v'
pgf "pathqlineto"
bracerPoint v'
-- | Make curved path from vectors.
curveTo :: RealFloat n => V2 n -> V2 n -> V2 n -> Render n
curveTo v2 v3 v4 = ln $ do
p <- use pos
let [v2',v3',v4'] = map (p .+^) [v2,v3,v4]
pos .= v4'
pgf "pathqcurveto"
mapM_ bracerPoint [v2', v3', v4']
-- | Stroke the defined path using parameters from current scope.
stroke :: Render n
stroke = ln $ pgf "usepathqstroke"
-- | Fill the defined path using parameters from current scope.
fill :: Render n
fill = ln $ pgf "usepathqfill"
-- | Use the defined path a clip for everything that follows in the current
-- scope. Stacks.
clip :: Render n
clip = ln $ pgf "usepathqclip"
path :: RealFloat n => Path V2 n -> Render n
path (Path trs) = do
mapM_ renderTrail trs
where
renderTrail (viewLoc -> (p, tr)) = do
moveTo p
trail tr
trail :: RealFloat n => Trail V2 n -> Render n
trail t = withLine (render' . lineSegments) t
where
render' segs = do
mapM_ segment segs
when (isLoop t) closePath
segment :: RealFloat n => Segment Closed V2 n -> Render n
segment (Linear (OffsetClosed v)) = lineTo v
segment (Cubic v1 v2 (OffsetClosed v3)) = curveTo v1 v2 v3
-- | @usePath fill stroke@ combined in one function.
usePath :: Bool -> Bool -> Render n
usePath False False = return ()
usePath doFill doStroke = ln $ do
pgf "usepathq"
when doFill $ raw "fill"
when doStroke $ raw "stroke"
-- | Uses the current path as the bounding box for whole picture.
asBoundingBox :: Render n
asBoundingBox = ln $ do
pgf "usepath"
bracers $ raw "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 w = ln $ do
pgf "setlinewidth"
bracers $ bp w
-- | Sets the line cap in current scope. Must be done before stroking.
setLineCap :: LineCap -> Render n
setLineCap cap = ln . pgf $ case cap of
LineCapButt -> "setbuttcap"
LineCapRound -> "setroundcap"
LineCapSquare -> "setrectcap"
-- | Sets the line join in current scope. Must be done before stroking.
setLineJoin :: LineJoin -> Render n
setLineJoin lJoin = ln . pgf $ case lJoin of
LineJoinBevel -> "setbeveljoin"
LineJoinRound -> "setroundjoin"
LineJoinMiter -> "setmiterjoin"
-- | Sets the miter limit in the current scope. Must be done before stroking.
setMiterLimit :: RealFloat n => n -> Render n
setMiterLimit l = do
pgf "setmiterlimit"
bracers $ bp l
-- stroke parameters ---------------------------------------------------
-- | Sets the dash for the current scope. Must be done before stroking.
setDash :: RealFloat n => Dashing n -> Render n
setDash (Dashing ds offs) = setDash' ds 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' ds off = ln $ do
pgf "setdash"
bracers $ mapM_ (bracers . bp) ds
bracers $ bp 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 = do
defineColour "sc" r g b
ln $ pgf "setstrokecolor{sc}"
--
when (a /= 1) $ setLineOpacity (realToFrac a)
where
(r,g,b,a) = colorToSRGBA 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 a = ln $ do
pgf "setstrokeopacity"
bracers $ 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 rule = ln $ case rule of
Winding -> pgf "setnonzerorule"
EvenOdd -> pgf "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 (colorToSRGBA -> (r,g,b,a)) = do
defineColour "fc" r g b
ln $ pgf "setfillcolor{fc}"
--
when (a /= 1) $ setFillOpacity (realToFrac 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 = ln $ do
pgf "setfillopacity"
bracers $ n a
-- transformations -----------------------------------------------------
getMatrix :: Num n => Transformation V2 n -> (n, n, n, n, n, n)
getMatrix t = (a1,a2,b1,b2,c1,c2)
where
[a1, a2, b1, b2, c1, c2] = concat $ matrixHomRep 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 t
| isID = return ()
| shiftOnly = ln $ do
pgf "transformshift"
bracers p
| otherwise = ln $ do
pgf "transformcm"
mapM_ (bracers . n) [a, b, c, d] >> bracers p
where
(a,b,c,d,e,f) = getMatrix t
p = tuplePoint (e,f)
--
shiftOnly = (a,b,c,d) == (1,0,0,1)
isID = shiftOnly && (e,f) == (0,0)
-- | Resets the transform and sets it. Must be set before the path is used.
setTransform :: RealFloat n => Transformation V2 n -> Render n
setTransform t = do
pgf "settransformentries"
mapM_ (bracers . n) [a, b, c, d] >> mapM_ (bracers . bp) [e, f]
where
(a,b,c,d,e,f) = getMatrix t
applyScale :: RealFloat n => n -> Render n
applyScale s = ln $ do
pgf "transformscale"
bracers $ n s
resetNonTranslations :: Render n
resetNonTranslations = ln $ pgf "transformresetnontranslations"
-- | Base transforms are applied by the document reader.
baseTransform :: RealFloat n => Transformation V2 n -> Render n
baseTransform t = ln $ do
pgf "lowlevel"
bracers $ setTransform 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 p lg = scope $ do
path p
let (stops', t) = calcLinearStops p lg
ln $ do
pgf "declarehorizontalshading"
bracers $ raw "ft" -- fill texture
bracers $ raw "100bp" -- gradient is always 100 x 100 square
bracersBlock $ colorSpec 1 stops'
clip
baseTransform t
useShading $ raw "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 []) _ = ([], mempty)
calcLinearStops pth (LGradient stops p0 p1 gt sm)
= (linearStops' x0 x1 stops sm, t <> ft)
where
-- Transform such that the transform t origin is start of the
-- gradient, transform t unitX is the end.
t = gt
-- encorperate the start and end points
<> translation (p0 ^. _Point)
<> scaling (norm (p1 .-. p0))
<> rotationTo (dirBetween p1 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' = transform (inv t) pth
Just (x0,x1) = extentX p'
Just (y0,y1) = extentY 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 = translation (V2 x0 y0) <> scalingV ((*0.01) . abs <$> V2 (x0 - x1) (y0 - y1)) <> translation 50
scalingV :: (Additive v, Fractional n) => v n -> Transformation v n
scalingV v = fromSymmetric $ liftU2 (*) v <-> liftU2 (flip (/)) v
useShading :: Render n -> Render n
useShading nm = ln $ do
pgf "useshading"
bracers nm
_translation :: Lens' (Transformation v n) (v n)
_translation f (Transformation a b v) = f v <&> \v' -> Transformation a b v'
linearStops' :: RealFloat n
=> n -> n -> [GradientStop n] -> SpreadMethod -> [GradientStop n]
linearStops' x0 x1 stops sm =
GradientStop c1' 0 : filter (inRange . view stopFraction) stops' ++ [GradientStop c2' 100]
where
stops' = case sm of
GradPad -> over (each . stopFraction) normalise stops
GradRepeat -> flip F.foldMap [i0 .. i1] $ \i ->
increaseFirst $
over (each . stopFraction)
(normalise . (+ fromIntegral i))
stops
GradReflect -> flip F.foldMap [i0 .. i1] $ \i ->
over (each . stopFraction)
(normalise . (+ fromIntegral i))
(reverseOdd i stops)
-- for repeat it sometimes complains if two are exactly the same so
-- increase the first by a little
increaseFirst = over (_head . stopFraction) (+0.001)
reverseOdd i
| odd i = reverse . over (each . stopFraction) (1 -)
| otherwise = id
i0 = floor x0 :: Int
i1 = ceiling x1
c1' = SomeColor $ colourInterp stops' 0
c2' = SomeColor $ colourInterp stops' 100
inRange x = x > 0 && x < 100
normalise x = 100 * (x - x0) / (x1 - x0)
colourInterp :: RealFloat n => [GradientStop n] -> n -> AlphaColour Double
colourInterp cs0 x = go cs0
where
go (GradientStop c1 a : c@(GradientStop c2 b) : cs)
| x <= a = toAlphaColour c1
| x > a && x < b = blend y (toAlphaColour c2) (toAlphaColour c1)
| otherwise = go (c : cs)
where
y = realToFrac $ (x - a) / (b - a)
go [GradientStop c2 _] = toAlphaColour c2
go _ = transparent
radialGradient :: RealFloat n => Path V2 n -> RGradient n -> Render n
radialGradient p rg = scope $ do
path p
let (stops', t, p0) = calcRadialStops p rg
ln $ do
pgf "declareradialshading"
bracers $ raw "ft"
bracers $ point p0
bracersBlock $ colorSpec 1 stops'
clip
baseTransform t
useShading $ raw "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 []) _ = ([], mempty, origin)
calcRadialStops pth (RGradient stops p0 r0 p1 r1 gt _sm)
= (stops', t <> ft, P cv)
where
cv = tp0 .-. tp1
tp0 = papply gt p0
tp1 = papply gt p1
-- Transform such that the transform t origin is start of the
-- gradient, transform t unitX is the end.
t = gt
<> translation (p1 ^. _Point)
<> scaling 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' = transform (inv t) pth
Just (x0,x1) = extentX p'
Just (y0,y1) = extentY p'
d = 2 * max (max (abs $ x0 - x1) (abs $ y0 - y1)) (lstop ^. stopFraction)
-- Adjust for gradient size having radius 100
ft = scaling 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' = head stops : over (each . stopFraction) refrac stops ++ [lstop & stopFraction .~ 100*d]
refrac x = 100 * ((r0 + x * (r1 - r0)) / r1) -- start at r0, end at r1
lstop = last 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 d = mapM_ ln
. combinePairs
. intersperse (rawChar ';')
. map mkColor
where
mkColor (GradientStop c sf) = do
raw "rgb"
parens $ bp (d*sf)
raw "="
parensColor c
combinePairs :: Monad m => [m a] -> [m a]
combinePairs (x1:x2:xs) = (x1 >> x2) : combinePairs xs
combinePairs xs = xs
shadePath :: RealFloat n => Angle n -> Render n -> Render n
shadePath (view deg -> θ) name = ln $ do
pgf "shadepath"
bracers name
bracers $ n θ
-- external images -----------------------------------------------------
-- \pgfimage[⟨options ⟩]{⟨filename ⟩}
-- | Images are wraped in a \pgftext.
image :: RealFloat n => DImage n External -> Render n
image (DImage (ImageRef ref) w h t2) = scope $ do
applyTransform t2
ln $ do
pgf "text"
bracers $ do
pgf "image"
brackets $ do
raw "width=" >> bp (fromIntegral w :: Double)
rawChar ','
raw "height=" >> bp (fromIntegral h :: Double)
bracers $ rawString ref
-- embedded images -----------------------------------------------------
embeddedImage :: RealFloat n => DImage n Embedded -> Render n
embeddedImage (DImage (ImageRaster (ImageRGB8 img)) w h t) =
embeddedImage' (hexImage img) w h t
-- TODO: Support more formats (like grey scale and alpha channels)
embeddedImage _ = error "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 (imageData -> v) = compress $ LB.fromStrict bs
where
bs = fromForeignPtr p i nn
(p, i, nn) = S.unsafeToForeignPtr v
embeddedImage' :: RealFloat n => LB.ByteString -> Int -> Int -> T2 n -> Render n
embeddedImage' img w h t = scope $ do
baseTransform t
ln $ raw "\\immediate\\pdfliteral{"
rawLn "q" -- save state
-- Scale the image to it's actual size and translate so the origin is
-- at the centre.
rawLn $ s w <> " 0 0 " <> s h <> " -" <> half w <> " -" <> half h <> " cm"
rawLn "BI" -- begin image
rawLn $ "/W " <> s w -- width in pixels
rawLn $ "/H " <> s h -- height in pixels
rawLn "/CS /RGB" -- RGB colour space
rawLn "/BPC 8" -- 8 bits per component
-- Filters for the encoded image:
-- ASCIIHexDecode -- decode from hexadecimal to binary
-- FlateDecode -- decompress using zlib deflate compression
rawLn "/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.
rawLn "ID" -- image data
rawLn $ hexChunk img <> char8 '>'
rawLn "EI" -- end image
rawLn "Q" -- restore state
rawLn "}"
where
rawLn r = raw r >> rawChar '\n'
s = intDec
half x = s (x `div` 2) <> if odd x then ".5" else 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 (LB.splitAt 40 -> (a,b))
| LB.null b = lazyByteStringHex a
| otherwise = lazyByteStringHex a <> char8 '\n' <> hexChunk b
-- text ----------------------------------------------------------------
renderText :: [Render n] -> Render n -> Render n
renderText ops txt = ln $ do
pgf "text"
brackets . commaIntersperce $ ops
bracers 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 a = case a of
BaselineText -> [raw "base", raw "left"]
BoxAlignedText xt yt -> catMaybes [xt', yt']
where
xt' | xt > 0.75 = Just $ raw "right"
| xt < 0.25 = Just $ raw "left"
| otherwise = Nothing
yt' | yt > 0.75 = Just $ raw "top"
| yt < 0.25 = Just $ raw "bottom"
| otherwise = Nothing
setTextRotation :: RealFloat n => Angle n -> [Render n]
setTextRotation a = case a^.deg of
0 -> []
θ -> [raw "rotate=" >> n θ]
-- | Set the font weight by rendering @\bf @. Nothing is done for normal
-- weight.
setFontWeight :: FontWeight -> Render n
setFontWeight FontWeightBold = raw "\\bf "
setFontWeight _ = return ()
-- | Set the font slant by rendering @\bf @. Nothing is done for normal weight.
setFontSlant :: FontSlant -> Render n
setFontSlant FontSlantNormal = return ()
setFontSlant FontSlantItalic = raw "\\it "
setFontSlant FontSlantOblique = raw "\\sl "