{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
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
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
emptyDS :: DrawState
emptyDS :: DrawState
emptyDS = FillRule -> PostscriptFont -> DrawState
DS FillRule
Winding PostscriptFont
defaultFont
data RenderState = RS
{ RenderState -> DrawState
_drawState :: !DrawState
, RenderState -> [DrawState]
_saved :: ![DrawState]
}
makeLenses ''RenderState
emptyRS :: RenderState
emptyRS :: RenderState
emptyRS = DrawState -> [DrawState] -> RenderState
RS DrawState
emptyDS []
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
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)
data Surface = Surface { :: Int -> B.Builder, :: 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
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
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)
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
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)
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 :: 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
newPath :: Render ()
newPath :: Render ()
newPath = Builder -> Render ()
renderPS Builder
"newpath"
closePath :: Render ()
closePath :: Render ()
closePath = Builder -> Render ()
renderPS Builder
"closepath"
arc :: Double
-> Double
-> Double
-> Double
-> Double
-> 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]
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]
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]
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]
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]
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 :: 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"
fillPreserve :: Render ()
fillPreserve :: Render ()
fillPreserve = do
Render ()
gsave
Render ()
fill
Render ()
grestore
showText :: String -> Render ()
showText :: [Char] -> Render ()
showText [Char]
s = do
Render ()
renderFont
[Char] -> Render ()
stringPS [Char]
s
Builder -> Render ()
renderPS Builder
" show"
showTextCentered :: String -> Render ()
showTextCentered :: [Char] -> Render ()
showTextCentered [Char]
s = do
Render ()
renderFont
[Char] -> Render ()
stringPS [Char]
s
Builder -> Render ()
renderPS Builder
" showcentered"
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"
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"
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]
"]"])
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]
:)
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
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]
:)
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
saveMatrix :: Render ()
saveMatrix :: Render ()
saveMatrix = Builder -> Render ()
renderPS Builder
"matrix currentmatrix"
restoreMatrix :: Render ()
restoreMatrix :: Render ()
restoreMatrix = Builder -> Render ()
renderPS Builder
"setmatrix"
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
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 ()
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 ()
colorCMYK :: CMYK -> [Double]
colorCMYK :: CMYK -> [Double]
colorCMYK (CMYK Double
c Double
m Double
y Double
k) = [Double
c,Double
m,Double
y,Double
k]
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)
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)
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]
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]
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]
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]
setDash :: [Double]
-> Double
-> 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 :: 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 :: 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 :: 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
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
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"
]
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
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
""