{-# 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
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CMYK] -> ShowS
$cshowList :: [CMYK] -> ShowS
show :: CMYK -> [Char]
$cshow :: CMYK -> [Char]
showsPrec :: Int -> CMYK -> ShowS
$cshowsPrec :: Int -> CMYK -> ShowS
Show, CMYK -> CMYK -> Bool
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FontSlant] -> ShowS
$cshowList :: [FontSlant] -> ShowS
show :: FontSlant -> [Char]
$cshow :: FontSlant -> [Char]
showsPrec :: Int -> FontSlant -> ShowS
$cshowsPrec :: Int -> FontSlant -> ShowS
Show, FontSlant -> FontSlant -> Bool
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FontWeight] -> ShowS
$cshowList :: [FontWeight] -> ShowS
show :: FontWeight -> [Char]
$cshow :: FontWeight -> [Char]
showsPrec :: Int -> FontWeight -> ShowS
$cshowsPrec :: Int -> FontWeight -> ShowS
Show, FontWeight -> FontWeight -> Bool
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 -> [Char]
_face    :: String
    , PostscriptFont -> FontSlant
_slant   :: FontSlant
    , PostscriptFont -> FontWeight
_weight  :: FontWeight
    , PostscriptFont -> Double
_size    :: Double
    , PostscriptFont -> Bool
_isLocal :: Bool
    } deriving (PostscriptFont -> PostscriptFont -> Bool
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PostscriptFont] -> ShowS
$cshowList :: [PostscriptFont] -> ShowS
show :: PostscriptFont -> [Char]
$cshow :: PostscriptFont -> [Char]
showsPrec :: Int -> PostscriptFont -> ShowS
$cshowsPrec :: Int -> PostscriptFont -> ShowS
Show)

makeLenses '' PostscriptFont

defaultFont :: PostscriptFont
defaultFont :: PostscriptFont
defaultFont = [Char]
-> FontSlant -> FontWeight -> Double -> Bool -> PostscriptFont
PostscriptFont [Char]
"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
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 { forall m. PSWriter m -> State Builder m
runPSWriter :: State B.Builder m }
  deriving (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
<$ :: forall a b. a -> PSWriter b -> PSWriter a
$c<$ :: forall a b. a -> PSWriter b -> PSWriter a
fmap :: forall a b. (a -> b) -> PSWriter a -> PSWriter b
$cfmap :: forall a b. (a -> b) -> PSWriter a -> PSWriter b
Functor, Functor PSWriter
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
<* :: forall a b. PSWriter a -> PSWriter b -> PSWriter a
$c<* :: forall a b. PSWriter a -> PSWriter b -> PSWriter a
*> :: forall a b. PSWriter a -> PSWriter b -> PSWriter b
$c*> :: forall a b. PSWriter a -> PSWriter b -> PSWriter b
liftA2 :: forall a b c.
(a -> b -> c) -> PSWriter a -> PSWriter b -> PSWriter c
$cliftA2 :: forall a b c.
(a -> b -> c) -> PSWriter a -> PSWriter b -> PSWriter c
<*> :: forall a b. PSWriter (a -> b) -> PSWriter a -> PSWriter b
$c<*> :: forall a b. PSWriter (a -> b) -> PSWriter a -> PSWriter b
pure :: forall a. a -> PSWriter a
$cpure :: forall a. a -> PSWriter a
Applicative, Applicative PSWriter
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 :: forall a. a -> PSWriter a
$creturn :: forall a. a -> PSWriter a
>> :: forall a b. PSWriter a -> PSWriter b -> PSWriter b
$c>> :: forall a b. PSWriter a -> PSWriter b -> PSWriter b
>>= :: forall a b. PSWriter a -> (a -> PSWriter b) -> PSWriter b
$c>>= :: forall a b. PSWriter a -> (a -> PSWriter b) -> PSWriter b
Monad, MonadState B.Builder)

tell' :: (MonadState s m, Semigroup s) => s -> m ()
#if MIN_VERSION_mtl(2,2,0)
tell' :: forall s (m :: * -> *). (MonadState s m, Semigroup s) => s -> m ()
tell' s
x = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (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 { forall m. Render m -> StateT RenderState PSWriter m
runRender :: StateT RenderState PSWriter m }
  deriving (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
<$ :: forall a b. a -> Render b -> Render a
$c<$ :: forall a b. a -> Render b -> Render a
fmap :: forall a b. (a -> b) -> Render a -> Render b
$cfmap :: forall a b. (a -> b) -> Render a -> Render b
Functor, Functor Render
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
<* :: forall a b. Render a -> Render b -> Render a
$c<* :: forall a b. Render a -> Render b -> Render a
*> :: forall a b. Render a -> Render b -> Render b
$c*> :: forall a b. Render a -> Render b -> Render b
liftA2 :: forall a b c. (a -> b -> c) -> Render a -> Render b -> Render c
$cliftA2 :: forall a b c. (a -> b -> c) -> Render a -> Render b -> Render c
<*> :: forall a b. Render (a -> b) -> Render a -> Render b
$c<*> :: forall a b. Render (a -> b) -> Render a -> Render b
pure :: forall a. a -> Render a
$cpure :: forall a. a -> Render a
Applicative, Applicative Render
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 :: forall a. a -> Render a
$creturn :: forall a. a -> Render a
>> :: forall a b. Render a -> Render b -> Render b
$c>> :: forall a b. Render a -> Render b -> Render b
>>= :: forall a b. Render a -> (a -> Render b) -> Render b
$c>>= :: forall a b. Render a -> (a -> Render b) -> Render b
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 -> [Char]
fileName :: String }

doRender :: Render a -> PSWriter a
doRender :: forall a. Render a -> PSWriter a
doRender Render a
r = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (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 :: forall (m :: * -> *) a. MonadIO m => Surface -> Render a -> m a
renderWith Surface
s Render a
r = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile (Surface -> [Char]
fileName Surface
s) IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    Handle -> Builder -> IO ()
B.hPutBuilder Handle
h Builder
b
    forall (m :: * -> *) a. Monad m => a -> m a
return a
v
  where
    (Builder
b, a
v) = 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 :: forall a. Surface -> Render a -> (Builder, a)
renderBuilder Surface
s Render a
r =
    let (a
v, Builder
ss) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. PSWriter m -> State Builder m
runPSWriter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Render a -> PSWriter a
doRender forall a b. (a -> b) -> a -> b
$ Render a
r
    in (Surface -> Int -> Builder
header Surface
s Int
1 forall a. Semigroup a => a -> a -> a
<> Builder
ss 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 :: forall (m :: * -> *) a. MonadIO m => Surface -> [Render a] -> m [a]
renderPagesWith Surface
s [Render a]
rs = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile (Surface -> [Char]
fileName Surface
s) IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    Handle -> Builder -> IO ()
B.hPutBuilder Handle
h Builder
b
    forall (m :: * -> *) a. Monad m => a -> m a
return [a]
v
  where
    (Builder
b, [a]
v) = 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 :: forall a. Surface -> [Render a] -> (Builder, [a])
renderPagesBuilder Surface
s [Render a]
rs =
    let ([a]
vs, [Builder]
sss) = forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {a}. Render a -> Int -> (a, Builder)
page) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Render a]
rs [Int
1..]
    in (Surface -> Int -> Builder
header Surface
s (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Render a]
rs) forall a. Semigroup a => a -> a -> a
<> 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) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. PSWriter m -> State Builder m
runPSWriter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Render a -> PSWriter a
doRender forall a b. (a -> b) -> a -> b
$  Render a
r
      in (a
v, Builder
ss 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 :: forall r. [Char] -> Int -> Int -> (Surface -> r) -> r
withEPSSurface [Char]
file Int
w Int
h Surface -> r
f = Surface -> r
f Surface
s
  where s :: Surface
s = (Int -> Builder)
-> (Int -> Builder) -> Int -> Int -> [Char] -> Surface
Surface (Int -> Int -> Int -> Builder
epsHeader Int
w Int
h) Int -> Builder
epsFooter Int
w Int
h [Char]
file

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

renderWordsPS :: (a -> B.Builder) -> [a] -> Render ()
renderWordsPS :: forall a. (a -> Builder) -> [a] -> Render ()
renderWordsPS a -> Builder
f = Builder -> Render ()
renderPS  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse Builder
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall a -> Builder
f Builder
n [a]
vs = Builder -> [Builder] -> Render ()
mkPSCall' Builder
n (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 forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Builder
" " [Builder]
vs) forall a. Semigroup a => a -> a -> a
<> 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 = forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"arc" [Double
a,Double
b,Double
c, Double
d forall a. Num a => a -> a -> a
* Double
180 forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi, Double
eforall a. Num a => a -> a -> a
* Double
180 forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi]

-- | Move the current point.
moveTo :: Double -> Double -> Render ()
moveTo :: Double -> Double -> Render ()
moveTo Double
x Double
y = 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 = 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 = 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 = 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 = 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 <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' RenderState DrawState
drawState forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: [Char] -> Render ()
showText [Char]
s = do
    Render ()
renderFont
    [Char] -> Render ()
stringPS [Char]
s
    Builder -> Render ()
renderPS Builder
" show"

-- | Draw a string by first measuring the width then offseting by half.
showTextCentered :: String -> Render ()
showTextCentered :: [Char] -> Render ()
showTextCentered [Char]
s = do
    Render ()
renderFont
    [Char] -> Render ()
stringPS [Char]
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) -> [Char] -> Render ()
showTextInBox (Double
a,Double
b) (Double
c,Double
d) [Char]
s = do
    Render ()
renderFont
    forall a. (a -> Builder) -> [a] -> Render ()
renderWordsPS Double -> Builder
B.doubleDec forall a b. (a -> b) -> a -> b
$ [Double
a,Double
b,Double
c,Double
d]
    [Char] -> Render ()
stringPS [Char]
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 -> [Char] -> Render ()
showTextAlign Double
xt Double
yt [Char]
s = do
    Render ()
renderFont
    Builder -> Render ()
renderPS Builder
" "
    forall a. (a -> Builder) -> [a] -> Render ()
renderWordsPS Double -> Builder
B.doubleDec [Double
xt, Double
yt]
    [Char] -> Render ()
stringPS [Char]
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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Double]
vs 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]) forall a b. (a -> b) -> a -> b
$
      Builder -> Render ()
renderPS (forall a. Show a => [a] -> Builder
matrixPS [Double]
vs 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 :: forall a. Show a => [a] -> Builder
matrixPS [a]
vs = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords ([Char]
"[" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [a]
vs forall a. [a] -> [a] -> [a]
++ [[Char]
"]"])

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

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

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

-- | Set the color of the fill.  Ignore gradients.
fillColor :: Texture n -> Render ()
fillColor :: forall n. Texture n -> Render ()
fillColor (SC (SomeColor c
c)) = forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"setrgbcolor" (forall c. Color c => c -> [Double]
colorPS c
c)
fillColor Texture n
_                  = 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 = 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 = 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 = 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 = 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 = 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 = 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" [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 :: forall a. (a -> Builder) -> [a] -> Builder
showArray a -> Builder
f [a]
as = Builder
"[" forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Builder
" " (forall a b. (a -> b) -> [a] -> [b]
map a -> Builder
f [a]
as)) 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 = 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 = 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 = forall a. (a -> Builder) -> Builder -> [a] -> Render ()
mkPSCall Double -> Builder
B.doubleDec Builder
"rotate" [Double
t]

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

epsHeader :: Int -> Int -> Int -> B.Builder
epsHeader :: Int -> Int -> Int -> Builder
epsHeader Int
w Int
h Int
pages = forall a. Monoid a => [a] -> a
mconcat
          [ Builder
"%!PS-Adobe-3.0", if Int
pages 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 = 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
    [Char]
n <- [Char] -> FontSlant -> FontWeight -> [Char]
fontFromName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Lens' PostscriptFont a -> Render a
f Lens' PostscriptFont [Char]
face forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Lens' PostscriptFont a -> Render a
f Lens' PostscriptFont FontSlant
slant forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Lens' PostscriptFont a -> Render a
f Lens' PostscriptFont FontWeight
weight
    Double
s <- forall a. Lens' PostscriptFont a -> Render a
f Lens' PostscriptFont Double
size
    Builder -> Render ()
renderPS forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Builder
"/", forall a. IsString a => [Char] -> a
fromString [Char]
n, Builder
" ", Double -> Builder
B.doubleDec Double
s, Builder
" selectfont"]
  where
    f :: Lens' PostscriptFont a -> Render a
    f :: forall a. Lens' PostscriptFont a -> Render a
f Lens' PostscriptFont a
x = forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' RenderState DrawState
drawState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DrawState PostscriptFont
font forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PostscriptFont a
x

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

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

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