{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TemplateHaskell            #-}

{-# OPTIONS_GHC -fno-warn-unused-imports #-}
  -- for Data.Semigroup

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Postscript
-- Copyright   :  (c) 2013 diagrams team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Generic tools for generating Postscript files.  There is some
-- limited support for tracking the state of the renderer when
-- given a side-effecting (in the Postscript) command.  Only drawing
-- operations are supported, not general Postscript language generation.
--
-- In the future the tracking of rendering state could lead to optimizing
-- output, but for now little optimization is attempted.  Most systems are
-- equiped with tools to optimize Postscript such as 'eps2eps'.
--
-- For details on the PostScript language see the PostScript(R) Language
-- Reference: <http://www.adobe.com/products/postscript/pdfs/PLRM.pdf>
-----------------------------------------------------------------------------
module Graphics.Rendering.Postscript
  ( Render
  , RenderState, drawState
  , Surface
  , PSWriter(..)
  , renderWith
  , renderPagesWith
  , renderBuilder
  , renderPagesBuilder
  , withEPSSurface
  , newPath
  , moveTo
  , lineTo
  , curveTo
  , relLineTo
  , relCurveTo
  , arc
  , closePath
  , stroke
  , fill
  , fillPreserve
  , transform
  , save
  , restore
  , gsave
  , grestore
  , saveMatrix
  , restoreMatrix
  , translate
  , scale
  , rotate
  , strokeColor
  , strokeColorCMYK
  , fillColor
  , fillColorCMYK
  , lineWidth
  , lineCap
  , lineJoin
  , miterLimit
  , setDash
  , showText
  , showTextCentered
  , showTextAlign
  , showTextInBox
  , clip

  , FontSlant(..)
  , FontWeight(..)
  , face, slant, weight, size, isLocal

  , fillRule, font

  , CMYK(..), cyan, magenta, yellow, blacK
  ) where

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative
import           Data.Monoid                (mconcat, mempty)
#endif
import           Control.Lens               (Lens', makeLenses, use, (%=), (.=))
import           Control.Monad.State.Strict
import qualified Data.ByteString.Builder    as B
import           Data.Char                  (isPrint, ord)
import           Data.List                  (intersperse)
import           Data.Semigroup             (Semigroup (..))
import           Data.String                (fromString)
import           Diagrams.Attributes        (Color (..), LineCap (..),
                                             LineJoin (..), SomeColor (..),
                                             colorToSRGBA)
import           Diagrams.TwoD.Attributes   (Texture (..))
import           Diagrams.TwoD.Path         hiding (fillRule, stroke)
import           Numeric                    (showIntAtBase)
import           System.IO                  (IOMode (..), withFile)

data CMYK = CMYK
    { CMYK -> Double
_cyan    :: Double
    , CMYK -> Double
_magenta :: Double
    , CMYK -> Double
_yellow  :: Double
    , CMYK -> Double
_blacK   :: Double
    }
    deriving (Int -> CMYK -> ShowS
[CMYK] -> ShowS
CMYK -> String
(Int -> CMYK -> ShowS)
-> (CMYK -> String) -> ([CMYK] -> ShowS) -> Show CMYK
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CMYK] -> ShowS
$cshowList :: [CMYK] -> ShowS
show :: CMYK -> String
$cshow :: CMYK -> String
showsPrec :: Int -> CMYK -> ShowS
$cshowsPrec :: Int -> CMYK -> ShowS
Show, CMYK -> CMYK -> Bool
(CMYK -> CMYK -> Bool) -> (CMYK -> CMYK -> Bool) -> Eq CMYK
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CMYK -> CMYK -> Bool
$c/= :: CMYK -> CMYK -> Bool
== :: CMYK -> CMYK -> Bool
$c== :: CMYK -> CMYK -> Bool
Eq)

makeLenses ''CMYK

data FontSlant = FontSlantNormal
               | FontSlantItalic
               | FontSlantOblique
               | FontSlant Double
            deriving (Int -> FontSlant -> ShowS
[FontSlant] -> ShowS
FontSlant -> String
(Int -> FontSlant -> ShowS)
-> (FontSlant -> String)
-> ([FontSlant] -> ShowS)
-> Show FontSlant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FontSlant] -> ShowS
$cshowList :: [FontSlant] -> ShowS
show :: FontSlant -> String
$cshow :: FontSlant -> String
showsPrec :: Int -> FontSlant -> ShowS
$cshowsPrec :: Int -> FontSlant -> ShowS
Show, FontSlant -> FontSlant -> Bool
(FontSlant -> FontSlant -> Bool)
-> (FontSlant -> FontSlant -> Bool) -> Eq FontSlant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FontSlant -> FontSlant -> Bool
$c/= :: FontSlant -> FontSlant -> Bool
== :: FontSlant -> FontSlant -> Bool
$c== :: FontSlant -> FontSlant -> Bool
Eq)

data FontWeight = FontWeightNormal
                | FontWeightBold
            deriving (Int -> FontWeight -> ShowS
[FontWeight] -> ShowS
FontWeight -> String
(Int -> FontWeight -> ShowS)
-> (FontWeight -> String)
-> ([FontWeight] -> ShowS)
-> Show FontWeight
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FontWeight] -> ShowS
$cshowList :: [FontWeight] -> ShowS
show :: FontWeight -> String
$cshow :: FontWeight -> String
showsPrec :: Int -> FontWeight -> ShowS
$cshowsPrec :: Int -> FontWeight -> ShowS
Show, FontWeight -> FontWeight -> Bool
(FontWeight -> FontWeight -> Bool)
-> (FontWeight -> FontWeight -> Bool) -> Eq FontWeight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FontWeight -> FontWeight -> Bool
$c/= :: FontWeight -> FontWeight -> Bool
== :: FontWeight -> FontWeight -> Bool
$c== :: FontWeight -> FontWeight -> Bool
Eq)

data PostscriptFont = PostscriptFont
    { PostscriptFont -> String
_face    :: String
    , PostscriptFont -> FontSlant
_slant   :: FontSlant
    , PostscriptFont -> FontWeight
_weight  :: FontWeight
    , PostscriptFont -> Double
_size    :: Double
    , PostscriptFont -> Bool
_isLocal :: Bool
    } deriving (PostscriptFont -> PostscriptFont -> Bool
(PostscriptFont -> PostscriptFont -> Bool)
-> (PostscriptFont -> PostscriptFont -> Bool) -> Eq PostscriptFont
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PostscriptFont -> PostscriptFont -> Bool
$c/= :: PostscriptFont -> PostscriptFont -> Bool
== :: PostscriptFont -> PostscriptFont -> Bool
$c== :: PostscriptFont -> PostscriptFont -> Bool
Eq, Int -> PostscriptFont -> ShowS
[PostscriptFont] -> ShowS
PostscriptFont -> String
(Int -> PostscriptFont -> ShowS)
-> (PostscriptFont -> String)
-> ([PostscriptFont] -> ShowS)
-> Show PostscriptFont
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PostscriptFont] -> ShowS
$cshowList :: [PostscriptFont] -> ShowS
show :: PostscriptFont -> String
$cshow :: PostscriptFont -> String
showsPrec :: Int -> PostscriptFont -> ShowS
$cshowsPrec :: Int -> PostscriptFont -> ShowS
Show)

makeLenses '' PostscriptFont

defaultFont :: PostscriptFont
defaultFont :: PostscriptFont
defaultFont = String
-> FontSlant -> FontWeight -> Double -> Bool -> PostscriptFont
PostscriptFont String
"Helvetica" FontSlant
FontSlantNormal FontWeight
FontWeightNormal Double
1 Bool
True

-- Here we want to mirror the state of side-effecting calls
-- that we have emitted into the postscript file (at least
-- ones that we do not protect in other ways).
data DrawState = DS
                 { DrawState -> FillRule
_fillRule :: FillRule
                 , DrawState -> PostscriptFont
_font     :: PostscriptFont
                 } deriving (DrawState -> DrawState -> Bool
(DrawState -> DrawState -> Bool)
-> (DrawState -> DrawState -> Bool) -> Eq DrawState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DrawState -> DrawState -> Bool
$c/= :: DrawState -> DrawState -> Bool
== :: DrawState -> DrawState -> Bool
$c== :: DrawState -> DrawState -> Bool
Eq)

makeLenses ''DrawState

-- This reflects the defaults from the standard.
emptyDS :: DrawState
emptyDS :: DrawState
emptyDS = FillRule -> PostscriptFont -> DrawState
DS FillRule
Winding PostscriptFont
defaultFont

data RenderState = RS
                   { RenderState -> DrawState
_drawState :: !DrawState   -- The current state.
                   , RenderState -> [DrawState]
_saved     :: ![DrawState] -- A stack of passed states pushed by save and poped with restore.
                   }

makeLenses ''RenderState

emptyRS :: RenderState
emptyRS :: RenderState
emptyRS = DrawState -> [DrawState] -> RenderState
RS DrawState
emptyDS []

--
-- | Type for a monad that writes Postscript using the commands we will define later.

-- | Type for a monad that writes Postscript using the commands we will define later.
newtype PSWriter m = PSWriter { PSWriter m -> State Builder m
runPSWriter :: State B.Builder m }
  deriving (a -> PSWriter b -> PSWriter a
(a -> b) -> PSWriter a -> PSWriter b
(forall a b. (a -> b) -> PSWriter a -> PSWriter b)
-> (forall a b. a -> PSWriter b -> PSWriter a) -> Functor PSWriter
forall a b. a -> PSWriter b -> PSWriter a
forall a b. (a -> b) -> PSWriter a -> PSWriter b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PSWriter b -> PSWriter a
$c<$ :: forall a b. a -> PSWriter b -> PSWriter a
fmap :: (a -> b) -> PSWriter a -> PSWriter b
$cfmap :: forall a b. (a -> b) -> PSWriter a -> PSWriter b
Functor, Functor PSWriter
a -> PSWriter a
Functor PSWriter
-> (forall a. a -> PSWriter a)
-> (forall a b. PSWriter (a -> b) -> PSWriter a -> PSWriter b)
-> (forall a b c.
    (a -> b -> c) -> PSWriter a -> PSWriter b -> PSWriter c)
-> (forall a b. PSWriter a -> PSWriter b -> PSWriter b)
-> (forall a b. PSWriter a -> PSWriter b -> PSWriter a)
-> Applicative PSWriter
PSWriter a -> PSWriter b -> PSWriter b
PSWriter a -> PSWriter b -> PSWriter a
PSWriter (a -> b) -> PSWriter a -> PSWriter b
(a -> b -> c) -> PSWriter a -> PSWriter b -> PSWriter c
forall a. a -> PSWriter a
forall a b. PSWriter a -> PSWriter b -> PSWriter a
forall a b. PSWriter a -> PSWriter b -> PSWriter b
forall a b. PSWriter (a -> b) -> PSWriter a -> PSWriter b
forall a b c.
(a -> b -> c) -> PSWriter a -> PSWriter b -> PSWriter c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: PSWriter a -> PSWriter b -> PSWriter a
$c<* :: forall a b. PSWriter a -> PSWriter b -> PSWriter a
*> :: PSWriter a -> PSWriter b -> PSWriter b
$c*> :: forall a b. PSWriter a -> PSWriter b -> PSWriter b
liftA2 :: (a -> b -> c) -> PSWriter a -> PSWriter b -> PSWriter c
$cliftA2 :: forall a b c.
(a -> b -> c) -> PSWriter a -> PSWriter b -> PSWriter c
<*> :: PSWriter (a -> b) -> PSWriter a -> PSWriter b
$c<*> :: forall a b. PSWriter (a -> b) -> PSWriter a -> PSWriter b
pure :: a -> PSWriter a
$cpure :: forall a. a -> PSWriter a
$cp1Applicative :: Functor PSWriter
Applicative, Applicative PSWriter
a -> PSWriter a
Applicative PSWriter
-> (forall a b. PSWriter a -> (a -> PSWriter b) -> PSWriter b)
-> (forall a b. PSWriter a -> PSWriter b -> PSWriter b)
-> (forall a. a -> PSWriter a)
-> Monad PSWriter
PSWriter a -> (a -> PSWriter b) -> PSWriter b
PSWriter a -> PSWriter b -> PSWriter b
forall a. a -> PSWriter a
forall a b. PSWriter a -> PSWriter b -> PSWriter b
forall a b. PSWriter a -> (a -> PSWriter b) -> PSWriter b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> PSWriter a
$creturn :: forall a. a -> PSWriter a
>> :: PSWriter a -> PSWriter b -> PSWriter b
$c>> :: forall a b. PSWriter a -> PSWriter b -> PSWriter b
>>= :: PSWriter a -> (a -> PSWriter b) -> PSWriter b
$c>>= :: forall a b. PSWriter a -> (a -> PSWriter b) -> PSWriter b
$cp1Monad :: Applicative PSWriter
Monad, MonadState B.Builder)

tell' :: (MonadState s m, Semigroup s) => s -> m ()
#if MIN_VERSION_mtl(2,2,0)
tell' :: s -> m ()
tell' s
x = (s -> s) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
x)
#else
tell' x = do
  s' <- get
  put $! s' <> x
#endif

-- | Type of the monad that tracks the state from side-effecting commands.
newtype Render m = Render { Render m -> StateT RenderState PSWriter m
runRender :: StateT RenderState PSWriter m }
  deriving (a -> Render b -> Render a
(a -> b) -> Render a -> Render b
(forall a b. (a -> b) -> Render a -> Render b)
-> (forall a b. a -> Render b -> Render a) -> Functor Render
forall a b. a -> Render b -> Render a
forall a b. (a -> b) -> Render a -> Render b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Render b -> Render a
$c<$ :: forall a b. a -> Render b -> Render a
fmap :: (a -> b) -> Render a -> Render b
$cfmap :: forall a b. (a -> b) -> Render a -> Render b
Functor, Functor Render
a -> Render a
Functor Render
-> (forall a. a -> Render a)
-> (forall a b. Render (a -> b) -> Render a -> Render b)
-> (forall a b c.
    (a -> b -> c) -> Render a -> Render b -> Render c)
-> (forall a b. Render a -> Render b -> Render b)
-> (forall a b. Render a -> Render b -> Render a)
-> Applicative Render
Render a -> Render b -> Render b
Render a -> Render b -> Render a
Render (a -> b) -> Render a -> Render b
(a -> b -> c) -> Render a -> Render b -> Render c
forall a. a -> Render a
forall a b. Render a -> Render b -> Render a
forall a b. Render a -> Render b -> Render b
forall a b. Render (a -> b) -> Render a -> Render b
forall a b c. (a -> b -> c) -> Render a -> Render b -> Render c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Render a -> Render b -> Render a
$c<* :: forall a b. Render a -> Render b -> Render a
*> :: Render a -> Render b -> Render b
$c*> :: forall a b. Render a -> Render b -> Render b
liftA2 :: (a -> b -> c) -> Render a -> Render b -> Render c
$cliftA2 :: forall a b c. (a -> b -> c) -> Render a -> Render b -> Render c
<*> :: Render (a -> b) -> Render a -> Render b
$c<*> :: forall a b. Render (a -> b) -> Render a -> Render b
pure :: a -> Render a
$cpure :: forall a. a -> Render a
$cp1Applicative :: Functor Render
Applicative, Applicative Render
a -> Render a
Applicative Render
-> (forall a b. Render a -> (a -> Render b) -> Render b)
-> (forall a b. Render a -> Render b -> Render b)
-> (forall a. a -> Render a)
-> Monad Render
Render a -> (a -> Render b) -> Render b
Render a -> Render b -> Render b
forall a. a -> Render a
forall a b. Render a -> Render b -> Render b
forall a b. Render a -> (a -> Render b) -> Render b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Render a
$creturn :: forall a. a -> Render a
>> :: Render a -> Render b -> Render b
$c>> :: forall a b. Render a -> Render b -> Render b
>>= :: Render a -> (a -> Render b) -> Render b
$c>>= :: forall a b. Render a -> (a -> Render b) -> Render b
$cp1Monad :: Applicative Render
Monad, MonadState RenderState)

-- | Abstraction of the drawing surface details.
data Surface = Surface { Surface -> Int -> Builder
header :: Int -> B.Builder, Surface -> Int -> Builder
footer :: Int -> B.Builder, Surface -> Int
_width :: Int, Surface -> Int
_height :: Int, Surface -> String
fileName :: String }

doRender :: Render a -> PSWriter a
doRender :: Render a -> PSWriter a
doRender Render a
r = StateT RenderState PSWriter a -> RenderState -> PSWriter a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Render a -> StateT RenderState PSWriter a
forall m. Render m -> StateT RenderState PSWriter m
runRender Render a
r) RenderState
emptyRS

-- | Handles opening and closing the file associated with the
--   passed 'Surface' and renders the commands built up in the
--   'Render' argument.
renderWith :: MonadIO m => Surface -> Render a -> m a
renderWith :: Surface -> Render a -> m a
renderWith Surface
s Render a
r = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO a) -> IO a
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile (Surface -> String
fileName Surface
s) IOMode
WriteMode ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    Handle -> Builder -> IO ()
B.hPutBuilder Handle
h Builder
b
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
  where
    (Builder
b, a
v) = Surface -> Render a -> (Builder, a)
forall a. Surface -> Render a -> (Builder, a)
renderBuilder Surface
s Render a
r

-- | Pure variant of 'renderWith'
renderBuilder :: Surface -> Render a -> (B.Builder, a)
renderBuilder :: Surface -> Render a -> (Builder, a)
renderBuilder Surface
s Render a
r =
    let (a
v, Builder
ss) = (State Builder a -> Builder -> (a, Builder))
-> Builder -> State Builder a -> (a, Builder)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Builder a -> Builder -> (a, Builder)
forall s a. State s a -> s -> (a, s)
runState Builder
forall a. Monoid a => a
mempty (State Builder a -> (a, Builder))
-> (Render a -> State Builder a) -> Render a -> (a, Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSWriter a -> State Builder a
forall m. PSWriter m -> State Builder m
runPSWriter (PSWriter a -> State Builder a)
-> (Render a -> PSWriter a) -> Render a -> State Builder a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render a -> PSWriter a
forall a. Render a -> PSWriter a
doRender (Render a -> (a, Builder)) -> Render a -> (a, Builder)
forall a b. (a -> b) -> a -> b
$ Render a
r
    in (Surface -> Int -> Builder
header Surface
s Int
1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
ss Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Surface -> Int -> Builder
footer Surface
s Int
1, a
v)

-- | Renders multiple pages given as a list of 'Render' actions
--   to the file associated with the 'Surface' argument.
renderPagesWith :: MonadIO m => Surface -> [Render a] -> m [a]
renderPagesWith :: Surface -> [Render a] -> m [a]
renderPagesWith Surface
s [Render a]
rs = IO [a] -> m [a]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [a] -> m [a]) -> IO [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO [a]) -> IO [a]
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile (Surface -> String
fileName Surface
s) IOMode
WriteMode ((Handle -> IO [a]) -> IO [a]) -> (Handle -> IO [a]) -> IO [a]
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    Handle -> Builder -> IO ()
B.hPutBuilder Handle
h Builder
b
    [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
v
  where
    (Builder
b, [a]
v) = Surface -> [Render a] -> (Builder, [a])
forall a. Surface -> [Render a] -> (Builder, [a])
renderPagesBuilder Surface
s [Render a]
rs

-- | Pure variant of 'renderPagesWith'
renderPagesBuilder :: Surface -> [Render a] -> (B.Builder, [a])
renderPagesBuilder :: Surface -> [Render a] -> (Builder, [a])
renderPagesBuilder Surface
s [Render a]
rs =
    let ([a]
vs, [Builder]
sss) = [(a, Builder)] -> ([a], [Builder])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(a, Builder)] -> ([a], [Builder]))
-> ([(Render a, Int)] -> [(a, Builder)])
-> [(Render a, Int)]
-> ([a], [Builder])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Render a, Int) -> (a, Builder))
-> [(Render a, Int)] -> [(a, Builder)]
forall a b. (a -> b) -> [a] -> [b]
map ((Render a -> Int -> (a, Builder))
-> (Render a, Int) -> (a, Builder)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Render a -> Int -> (a, Builder)
forall a. Render a -> Int -> (a, Builder)
page) ([(Render a, Int)] -> ([a], [Builder]))
-> [(Render a, Int)] -> ([a], [Builder])
forall a b. (a -> b) -> a -> b
$ [Render a] -> [Int] -> [(Render a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Render a]
rs [Int
1..]
    in (Surface -> Int -> Builder
header Surface
s ([Render a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Render a]
rs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
sss, [a]
vs)
 where
   page :: Render a -> Int -> (a, Builder)
page Render a
r Int
i =
      let (a
v, Builder
ss) = (State Builder a -> Builder -> (a, Builder))
-> Builder -> State Builder a -> (a, Builder)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Builder a -> Builder -> (a, Builder)
forall s a. State s a -> s -> (a, s)
runState Builder
forall a. Monoid a => a
mempty (State Builder a -> (a, Builder))
-> (Render a -> State Builder a) -> Render a -> (a, Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSWriter a -> State Builder a
forall m. PSWriter m -> State Builder m
runPSWriter (PSWriter a -> State Builder a)
-> (Render a -> PSWriter a) -> Render a -> State Builder a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render a -> PSWriter a
forall a. Render a -> PSWriter a
doRender (Render a -> (a, Builder)) -> Render a -> (a, Builder)
forall a b. (a -> b) -> a -> b
$  Render a
r
      in (a
v, Builder
ss Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Surface -> Int -> Builder
footer Surface
s Int
i)

-- | Builds a surface and performs an action on that surface.
withEPSSurface :: String -> Int -> Int -> (Surface -> r) -> r
withEPSSurface :: String -> Int -> Int -> (Surface -> r) -> r
withEPSSurface String
file Int
w Int
h Surface -> r
f = Surface -> r
f Surface
s
  where s :: Surface
s = (Int -> Builder)
-> (Int -> Builder) -> Int -> Int -> String -> Surface
Surface (Int -> Int -> Int -> Builder
epsHeader Int
w Int
h) Int -> Builder
epsFooter Int
w Int
h String
file

renderPS :: B.Builder -> Render ()
renderPS :: Builder -> Render ()
renderPS Builder
b = StateT RenderState PSWriter () -> Render ()
forall m. StateT RenderState PSWriter m -> Render m
Render (StateT RenderState PSWriter () -> Render ())
-> (Builder -> StateT RenderState PSWriter ())
-> Builder
-> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSWriter () -> StateT RenderState PSWriter ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PSWriter () -> StateT RenderState PSWriter ())
-> (Builder -> PSWriter ())
-> Builder
-> StateT RenderState PSWriter ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> PSWriter ()
forall s (m :: * -> *). (MonadState s m, Semigroup s) => s -> m ()
tell' (Builder -> Render ()) -> Builder -> Render ()
forall a b. (a -> b) -> a -> b
$ Builder
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"

renderWordsPS :: (a -> B.Builder) -> [a] -> Render ()
renderWordsPS :: (a -> Builder) -> [a] -> Render ()
renderWordsPS a -> Builder
f = Builder -> Render ()
renderPS  (Builder -> Render ()) -> ([a] -> Builder) -> [a] -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> ([a] -> [Builder]) -> [a] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
" " ([Builder] -> [Builder]) -> ([a] -> [Builder]) -> [a] -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Builder) -> [a] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map a -> Builder
f

-- | Clip with the current path.
clip :: Render ()
clip :: Render ()
clip = Builder -> Render ()
renderPS Builder
"clip"

mkPSCall :: (a -> B.Builder) -> B.Builder -> [a] -> Render ()
mkPSCall :: (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall a -> Builder
f Builder
n [a]
vs = Builder -> [Builder] -> Render ()
mkPSCall' Builder
n ((a -> Builder) -> [a] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map a -> Builder
f [a]
vs)

mkPSCall' :: B.Builder -> [B.Builder] -> Render()
mkPSCall' :: Builder -> [Builder] -> Render ()
mkPSCall' Builder
n [Builder]
vs = Builder -> Render ()
renderPS (Builder -> Render ()) -> Builder -> Render ()
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
" " [Builder]
vs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
n

-- | Start a new path.
newPath :: Render ()
newPath :: Render ()
newPath = Builder -> Render ()
renderPS Builder
"newpath"

-- | Close the current path.
closePath :: Render ()
closePath :: Render ()
closePath = Builder -> Render ()
renderPS Builder
"closepath"

-- | Draw an arc given a center, radius, start, and end angle.
arc :: Double -- ^ x-coordinate of center.
    -> Double -- ^ y-coordiante of center.
    -> Double -- ^ raidus.
    -> Double -- ^ start angle in radians.
    -> Double -- ^ end angle in radians.
    -> Render ()
arc :: Double -> Double -> Double -> Double -> Double -> Render ()
arc Double
a Double
b Double
c Double
d Double
e = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"arc" [Double
a,Double
b,Double
c, Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
180 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forall a. Floating a => a
pi, Double
eDouble -> Double -> Double
forall a. Num a => a -> a -> a
* Double
180 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forall a. Floating a => a
pi]

-- | Move the current point.
moveTo :: Double -> Double -> Render ()
moveTo :: Double -> Double -> Render ()
moveTo Double
x Double
y = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"moveto" [Double
x,Double
y]

-- | Add a line to the current path from the current point to the given point.
--   The current point is also moved with this command.
lineTo :: Double -> Double -> Render ()
lineTo :: Double -> Double -> Render ()
lineTo Double
x Double
y = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"lineto" [Double
x,Double
y]

-- | Add a cubic Bézier curve segment to the current path from the current point.
--   The current point is also moved with this command.
curveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()
curveTo :: Double
-> Double -> Double -> Double -> Double -> Double -> Render ()
curveTo Double
ax Double
ay Double
bx Double
by Double
cx Double
cy = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"curveto" [Double
ax,Double
ay,Double
bx,Double
by,Double
cx,Double
cy]

-- | Add a line segment to the current path using relative coordinates.
relLineTo :: Double -> Double -> Render ()
relLineTo :: Double -> Double -> Render ()
relLineTo Double
x Double
y = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"rlineto" [Double
x,Double
y]

-- | Add a cubic Bézier curve segment to the current path from the current point
--   using relative coordinates.
relCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()
relCurveTo :: Double
-> Double -> Double -> Double -> Double -> Double -> Render ()
relCurveTo Double
ax Double
ay Double
bx Double
by Double
cx Double
cy = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"rcurveto" [Double
ax,Double
ay,Double
bx,Double
by,Double
cx,Double
cy]

-- | Stroke the current path.
stroke :: Render ()
stroke :: Render ()
stroke = Builder -> Render ()
renderPS Builder
"s"

fill :: Render ()
fill :: Render ()
fill = do
    FillRule
rule <- Getting FillRule RenderState FillRule -> Render FillRule
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting FillRule RenderState FillRule -> Render FillRule)
-> Getting FillRule RenderState FillRule -> Render FillRule
forall a b. (a -> b) -> a -> b
$ (DrawState -> Const FillRule DrawState)
-> RenderState -> Const FillRule RenderState
Lens' RenderState DrawState
drawState ((DrawState -> Const FillRule DrawState)
 -> RenderState -> Const FillRule RenderState)
-> ((FillRule -> Const FillRule FillRule)
    -> DrawState -> Const FillRule DrawState)
-> Getting FillRule RenderState FillRule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FillRule -> Const FillRule FillRule)
-> DrawState -> Const FillRule DrawState
Lens' DrawState FillRule
fillRule
    case FillRule
rule of
      FillRule
Winding -> Builder -> Render ()
renderPS Builder
"fill"
      FillRule
EvenOdd -> Builder -> Render ()
renderPS Builder
"eofill"

-- | Fill the current path without affecting the graphics state.
fillPreserve :: Render ()
fillPreserve :: Render ()
fillPreserve = do
        Render ()
gsave
        Render ()
fill
        Render ()
grestore

-- | Draw a string at the current point.
showText :: String -> Render ()
showText :: String -> Render ()
showText String
s = do
    Render ()
renderFont
    String -> Render ()
stringPS String
s
    Builder -> Render ()
renderPS Builder
" show"

-- | Draw a string by first measuring the width then offseting by half.
showTextCentered :: String -> Render ()
showTextCentered :: String -> Render ()
showTextCentered String
s = do
    Render ()
renderFont
    String -> Render ()
stringPS String
s
    Builder -> Render ()
renderPS Builder
" showcentered"

-- | Draw a string uniformally scaling to fit within a bounding box.
showTextInBox :: (Double,Double) -> (Double,Double) -> String -> Render ()
showTextInBox :: (Double, Double) -> (Double, Double) -> String -> Render ()
showTextInBox (Double
a,Double
b) (Double
c,Double
d) String
s = do
    Render ()
renderFont
    (Double -> Builder) -> [Double] -> Render ()
forall a. (a -> Builder) -> [a] -> Render ()
renderWordsPS Double -> Builder
B.doubleDec ([Double] -> Render ()) -> [Double] -> Render ()
forall a b. (a -> b) -> a -> b
$ [Double
a,Double
b,Double
c,Double
d]
    String -> Render ()
stringPS String
s
    Builder -> Render ()
renderPS Builder
" showinbox"

-- | Draw a string with offset factors from center relative to the width and height.
showTextAlign :: Double -> Double -> String -> Render ()
showTextAlign :: Double -> Double -> String -> Render ()
showTextAlign Double
xt Double
yt String
s = do
    Render ()
renderFont
    Builder -> Render ()
renderPS Builder
" "
    (Double -> Builder) -> [Double] -> Render ()
forall a. (a -> Builder) -> [a] -> Render ()
renderWordsPS Double -> Builder
B.doubleDec [Double
xt, Double
yt]
    String -> Render ()
stringPS String
s
    Builder -> Render ()
renderPS Builder
" showalign"

-- | Apply a transform matrix to the current transform.
transform :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()
transform :: Double
-> Double -> Double -> Double -> Double -> Double -> Render ()
transform Double
ax Double
ay Double
bx Double
by Double
tx Double
ty = Bool -> Render () -> Render ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Double]
vs [Double] -> [Double] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Double
1.0,Double
0.0,Double
0.0,Double
1.0,Double
0.0,Double
0.0]) (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$
      Builder -> Render ()
renderPS ([Double] -> Builder
forall a. Show a => [a] -> Builder
matrixPS [Double]
vs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" concat")
    where vs :: [Double]
vs  = [Double
ax,Double
ay,Double
bx,Double
by,Double
tx,Double
ty]

matrixPS :: Show a => [a] -> B.Builder
matrixPS :: [a] -> Builder
matrixPS [a]
vs = String -> Builder
forall a. IsString a => String -> a
fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords (String
"[" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show [a]
vs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"]"])

-- | Push the current state of the renderer onto the state stack.
save :: Render ()
save :: Render ()
save = do
    Builder -> Render ()
renderPS Builder
"save"
    DrawState
d <- Getting DrawState RenderState DrawState -> Render DrawState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting DrawState RenderState DrawState
Lens' RenderState DrawState
drawState
    ([DrawState] -> Identity [DrawState])
-> RenderState -> Identity RenderState
Lens' RenderState [DrawState]
saved (([DrawState] -> Identity [DrawState])
 -> RenderState -> Identity RenderState)
-> ([DrawState] -> [DrawState]) -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (DrawState
dDrawState -> [DrawState] -> [DrawState]
forall a. a -> [a] -> [a]
:)

-- | Replace the current state by popping the state stack.
restore :: Render ()
restore :: Render ()
restore = do
    Builder -> Render ()
renderPS Builder
"restore"
    [DrawState]
s <- Getting [DrawState] RenderState [DrawState] -> Render [DrawState]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [DrawState] RenderState [DrawState]
Lens' RenderState [DrawState]
saved
    case [DrawState]
s of
      []     -> do ([DrawState] -> Identity [DrawState])
-> RenderState -> Identity RenderState
Lens' RenderState [DrawState]
saved (([DrawState] -> Identity [DrawState])
 -> RenderState -> Identity RenderState)
-> [DrawState] -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= []
      (DrawState
x:[DrawState]
xs) -> do
        (DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState
Lens' RenderState DrawState
drawState ((DrawState -> Identity DrawState)
 -> RenderState -> Identity RenderState)
-> DrawState -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= DrawState
x
        ([DrawState] -> Identity [DrawState])
-> RenderState -> Identity RenderState
Lens' RenderState [DrawState]
saved     (([DrawState] -> Identity [DrawState])
 -> RenderState -> Identity RenderState)
-> [DrawState] -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [DrawState]
xs


-- | Push the current graphics state.
gsave :: Render ()
gsave :: Render ()
gsave = do
    Builder -> Render ()
renderPS Builder
"gsave"
    DrawState
d <- Getting DrawState RenderState DrawState -> Render DrawState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting DrawState RenderState DrawState
Lens' RenderState DrawState
drawState
    ([DrawState] -> Identity [DrawState])
-> RenderState -> Identity RenderState
Lens' RenderState [DrawState]
saved (([DrawState] -> Identity [DrawState])
 -> RenderState -> Identity RenderState)
-> ([DrawState] -> [DrawState]) -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (DrawState
dDrawState -> [DrawState] -> [DrawState]
forall a. a -> [a] -> [a]
:)

-- | Pop the current graphics state.
grestore :: Render ()
grestore :: Render ()
grestore = do
    Builder -> Render ()
renderPS Builder
"grestore"
    [DrawState]
s <- Getting [DrawState] RenderState [DrawState] -> Render [DrawState]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [DrawState] RenderState [DrawState]
Lens' RenderState [DrawState]
saved
    case [DrawState]
s of
      []     -> do ([DrawState] -> Identity [DrawState])
-> RenderState -> Identity RenderState
Lens' RenderState [DrawState]
saved (([DrawState] -> Identity [DrawState])
 -> RenderState -> Identity RenderState)
-> [DrawState] -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= []
      (DrawState
x:[DrawState]
xs) -> do
          (DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState
Lens' RenderState DrawState
drawState ((DrawState -> Identity DrawState)
 -> RenderState -> Identity RenderState)
-> DrawState -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= DrawState
x
          ([DrawState] -> Identity [DrawState])
-> RenderState -> Identity RenderState
Lens' RenderState [DrawState]
saved     (([DrawState] -> Identity [DrawState])
 -> RenderState -> Identity RenderState)
-> [DrawState] -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [DrawState]
xs

-- | Push the current transform matrix onto the execution stack.
saveMatrix :: Render ()
saveMatrix :: Render ()
saveMatrix = Builder -> Render ()
renderPS Builder
"matrix currentmatrix"

-- | Set the current transform matrix to be the matrix found by popping
--   the execution stack.
restoreMatrix :: Render ()
restoreMatrix :: Render ()
restoreMatrix = Builder -> Render ()
renderPS Builder
"setmatrix"

-- RGB colors
colorPS :: Color c => c -> [Double]
colorPS :: c -> [Double]
colorPS c
c = [ Double
r, Double
g, Double
b ]
  where (Double
r,Double
g,Double
b,Double
_) = c -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA c
c

-- | Set the color of the stroke.  Ignore gradients.
strokeColor :: Texture n -> Render ()
strokeColor :: Texture n -> Render ()
strokeColor (SC (SomeColor c
c)) = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"setrgbcolor" (c -> [Double]
forall c. Color c => c -> [Double]
colorPS c
c)
strokeColor Texture n
_ = () -> Render ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Set the color of the fill.  Ignore gradients.
fillColor :: Texture n -> Render ()
fillColor :: Texture n -> Render ()
fillColor (SC (SomeColor c
c)) = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"setrgbcolor" (c -> [Double]
forall c. Color c => c -> [Double]
colorPS c
c)
fillColor Texture n
_                  = () -> Render ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- CMYK colors
colorCMYK :: CMYK -> [Double]
colorCMYK :: CMYK -> [Double]
colorCMYK (CMYK Double
c Double
m Double
y Double
k) = [Double
c,Double
m,Double
y,Double
k]

-- | Set the color of the stroke.
strokeColorCMYK :: CMYK -> Render ()
strokeColorCMYK :: CMYK -> Render ()
strokeColorCMYK CMYK
c = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"setcmykcolor" (CMYK -> [Double]
colorCMYK CMYK
c)

-- | Set the color of the fill.
fillColorCMYK :: CMYK -> Render ()
fillColorCMYK :: CMYK -> Render ()
fillColorCMYK CMYK
c = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"setcmykcolor" (CMYK -> [Double]
colorCMYK CMYK
c)

-- | Set the line width.
lineWidth :: Double -> Render ()
lineWidth :: Double -> Render ()
lineWidth Double
w = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"setlinewidth" [Double
w]

-- | Set the line cap style.
lineCap :: LineCap -> Render ()
lineCap :: LineCap -> Render ()
lineCap LineCap
lc = (Int -> Builder) -> Builder -> [Int] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Int -> Builder
B.intDec Builder
"setlinecap" [LineCap -> Int
fromLineCap LineCap
lc]

-- | Set the line join method.
lineJoin :: LineJoin -> Render ()
lineJoin :: LineJoin -> Render ()
lineJoin LineJoin
lj = (Int -> Builder) -> Builder -> [Int] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Int -> Builder
B.intDec Builder
"setlinejoin" [LineJoin -> Int
fromLineJoin LineJoin
lj]

-- | Set the miter limit.
miterLimit :: Double -> Render ()
miterLimit :: Double -> Render ()
miterLimit Double
ml = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"setmiterlimit" [Double
ml]

-- | Set the dash style.
setDash :: [Double] -- ^ Dash pattern (even indices are "on").
        -> Double   -- ^ Offset.
        -> Render ()
setDash :: [Double] -> Double -> Render ()
setDash [Double]
as Double
offset = Builder -> [Builder] -> Render ()
mkPSCall' Builder
"setdash" [(Double -> Builder) -> [Double] -> Builder
forall a. (a -> Builder) -> [a] -> Builder
showArray Double -> Builder
B.doubleDec [Double]
as, Double -> Builder
B.doubleDec Double
offset]

showArray :: (a -> B.Builder) -> [a] -> B.Builder
showArray :: (a -> Builder) -> [a] -> Builder
showArray a -> Builder
f [a]
as = Builder
"[" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
" " ((a -> Builder) -> [a] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map a -> Builder
f [a]
as)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"]"

fromLineCap :: LineCap -> Int
fromLineCap :: LineCap -> Int
fromLineCap LineCap
LineCapRound  = Int
1
fromLineCap LineCap
LineCapSquare = Int
2
fromLineCap LineCap
_             = Int
0

fromLineJoin :: LineJoin -> Int
fromLineJoin :: LineJoin -> Int
fromLineJoin LineJoin
LineJoinRound = Int
1
fromLineJoin LineJoin
LineJoinBevel = Int
2
fromLineJoin LineJoin
_             = Int
0

-- | Translate the current transform matrix.
translate :: Double -> Double -> Render ()
translate :: Double -> Double -> Render ()
translate Double
x Double
y = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"translate" [Double
x,Double
y]

-- | Scale the current transform matrix.
scale :: Double -> Double -> Render ()
scale :: Double -> Double -> Render ()
scale Double
x Double
y = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"scale" [Double
x,Double
y]

-- | Rotate the current transform matrix.
rotate :: Double -> Render ()
rotate :: Double -> Render ()
rotate Double
t = (Double -> Builder) -> Builder -> [Double] -> Render ()
forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"rotate" [Double
t]

stringPS :: String -> Render ()
stringPS :: String -> Render ()
stringPS String
ss = StateT RenderState PSWriter () -> Render ()
forall m. StateT RenderState PSWriter m -> Render m
Render (StateT RenderState PSWriter () -> Render ())
-> StateT RenderState PSWriter () -> Render ()
forall a b. (a -> b) -> a -> b
$ PSWriter () -> StateT RenderState PSWriter ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PSWriter () -> StateT RenderState PSWriter ())
-> PSWriter () -> StateT RenderState PSWriter ()
forall a b. (a -> b) -> a -> b
$ do
    Builder -> PSWriter ()
forall s (m :: * -> *). (MonadState s m, Semigroup s) => s -> m ()
tell' Builder
"("
    Builder -> PSWriter ()
forall s (m :: * -> *). (MonadState s m, Semigroup s) => s -> m ()
tell' (String -> Builder
forall a. IsString a => String -> a
fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escape String
ss)
    Builder -> PSWriter ()
forall s (m :: * -> *). (MonadState s m, Semigroup s) => s -> m ()
tell' Builder
")"
  where escape :: Char -> String
escape Char
'\n' = String
"\\n"
        escape Char
'\r' = String
"\\r"
        escape Char
'\t' = String
"\\t"
        escape Char
'\b' = String
"\\b"
        escape Char
'\f' = String
"\\f"
        escape Char
'\\' = String
"\\"
        escape Char
'('  = String
"\\("
        escape Char
')'  = String
"\\)"
        escape Char
c | Char -> Bool
isPrint Char
c = [Char
c]
                 | Bool
otherwise = Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> (Int -> Char) -> Int -> ShowS
forall a. (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase Int
7 (String
"01234567"String -> Int -> Char
forall a. [a] -> Int -> a
!!) (Char -> Int
ord Char
c) String
""

epsHeader :: Int -> Int -> Int -> B.Builder
epsHeader :: Int -> Int -> Int -> Builder
epsHeader Int
w Int
h Int
pages = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
          [ Builder
"%!PS-Adobe-3.0", if Int
pages Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Builder
" EPSF-3.0\n" else Builder
"\n"
          , Builder
"%%Creator: diagrams-postscript 0.1\n"
          , Builder
"%%BoundingBox: 0 0 ", Int -> Builder
B.intDec Int
w, Builder
" ", Int -> Builder
B.intDec Int
h, Builder
"\n"
          , Builder
"%%Pages: ", Int -> Builder
B.intDec Int
pages, Builder
"\n"
          , Builder
"%%EndComments\n\n"
          , Builder
"%%BeginProlog\n"
          , Builder
"%%BeginResource: procset diagrams-postscript 0 0\n"
          , Builder
"/s { 0.0 currentlinewidth ne { stroke } if } bind def\n"
          , Builder
"/nvhalf { 2 div neg exch 2 div neg exch } bind def\n"
          , Builder
"/showcentered { dup stringwidth nvhalf moveto show } bind def\n"
          , Builder
"/stringbbox { 0 0 moveto true charpath flattenpath pathbbox } bind def\n"
          , Builder
"/wh { 1 index 4 index sub 1 index 4 index sub } bind def\n"
          , Builder
"/showinbox { gsave dup stringbbox wh 11 7 roll mark 11 1 roll "
          , Builder
"wh dup 7 index div 2 index 9 index div 1 index 1 index lt "
          , Builder
"{ pop dup 9 index mul neg 3 index add 2 div 7 index add "
          , Builder
" 6 index 13 index abs add } "
          , Builder
"{ exch pop 6 index 12 index abs 2 index mul 7 index add } "
          , Builder
"ifelse 17 3 roll cleartomark 4 1 roll translate dup scale "
          , Builder
"0 0 moveto show grestore } bind def\n"
          , Builder
"/showalign { dup mark exch stringbbox wh 10 -1 roll exch 10 1 roll mul "
          , Builder
"neg 9 -2 roll mul 4 index add neg 8 2 roll cleartomark 3 1 roll moveto "
          , Builder
"show } bind def\n"
          , Builder
"%%EndResource\n"
          , Builder
"%%EndProlog\n"
          , Builder
"%%BeginSetup\n"
          , Builder
"%%EndSetup\n"
          , Builder
"%%Page: 1 1\n"
          ]

epsFooter :: Int -> B.Builder
epsFooter :: Int -> Builder
epsFooter Int
page = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
          [ Builder
"showpage\n"
          , Builder
"%%PageTrailer\n"
          , Builder
"%%EndPage: ", Int -> Builder
B.intDec Int
page, Builder
"\n"
          ]

---------------------------
-- Font

renderFont :: Render ()
renderFont :: Render ()
renderFont = do
    String
n <- String -> FontSlant -> FontWeight -> String
fontFromName (String -> FontSlant -> FontWeight -> String)
-> Render String -> Render (FontSlant -> FontWeight -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' PostscriptFont String -> Render String
forall a. Lens' PostscriptFont a -> Render a
f Lens' PostscriptFont String
face Render (FontSlant -> FontWeight -> String)
-> Render FontSlant -> Render (FontWeight -> String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Lens' PostscriptFont FontSlant -> Render FontSlant
forall a. Lens' PostscriptFont a -> Render a
f Lens' PostscriptFont FontSlant
slant Render (FontWeight -> String) -> Render FontWeight -> Render String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Lens' PostscriptFont FontWeight -> Render FontWeight
forall a. Lens' PostscriptFont a -> Render a
f Lens' PostscriptFont FontWeight
weight
    Double
s <- Lens' PostscriptFont Double -> Render Double
forall a. Lens' PostscriptFont a -> Render a
f Lens' PostscriptFont Double
size
    Builder -> Render ()
renderPS (Builder -> Render ()) -> Builder -> Render ()
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder
"/", String -> Builder
forall a. IsString a => String -> a
fromString String
n, Builder
" ", Double -> Builder
B.doubleDec Double
s, Builder
" selectfont"]
  where
    f :: Lens' PostscriptFont a -> Render a
    f :: Lens' PostscriptFont a -> Render a
f Lens' PostscriptFont a
x = Getting a RenderState a -> Render a
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting a RenderState a -> Render a)
-> Getting a RenderState a -> Render a
forall a b. (a -> b) -> a -> b
$ (DrawState -> Const a DrawState)
-> RenderState -> Const a RenderState
Lens' RenderState DrawState
drawState ((DrawState -> Const a DrawState)
 -> RenderState -> Const a RenderState)
-> ((a -> Const a a) -> DrawState -> Const a DrawState)
-> Getting a RenderState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PostscriptFont -> Const a PostscriptFont)
-> DrawState -> Const a DrawState
Lens' DrawState PostscriptFont
font ((PostscriptFont -> Const a PostscriptFont)
 -> DrawState -> Const a DrawState)
-> ((a -> Const a a) -> PostscriptFont -> Const a PostscriptFont)
-> (a -> Const a a)
-> DrawState
-> Const a DrawState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const a a) -> PostscriptFont -> Const a PostscriptFont
Lens' PostscriptFont a
x

-- This is a little hacky.  I'm not sure there are good options.
fontFromName :: String -> FontSlant -> FontWeight -> String
fontFromName :: String -> FontSlant -> FontWeight -> String
fontFromName String
n FontSlant
s FontWeight
w = String
fontName String -> ShowS
forall a. [a] -> [a] -> [a]
++ FontWeight -> String
forall p. IsString p => FontWeight -> p
bold FontWeight
w String -> ShowS
forall a. [a] -> [a] -> [a]
++ FontSlant -> String
forall p. IsString p => FontSlant -> p
italic FontSlant
s
  where
    fontName :: String
fontName = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
f String
n
    f :: Char -> Char
f Char
' ' = Char
'-'
    f Char
c   = Char
c

    bold :: FontWeight -> p
bold FontWeight
FontWeightNormal = p
""
    bold FontWeight
FontWeightBold   = p
"Bold"

    italic :: FontSlant -> p
italic FontSlant
FontSlantNormal  = p
""
    italic FontSlant
FontSlantItalic  = p
"Italic"
    italic FontSlant
FontSlantOblique = p
"Oblique"
    italic FontSlant
_                = p
""