{-# 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.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
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
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 { 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
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)
data Surface = Surface { :: Int -> B.Builder, :: 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
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
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)
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
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)
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 :: 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
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 = (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]
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]
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]
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]
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]
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 :: 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"
fillPreserve :: Render ()
fillPreserve :: Render ()
fillPreserve = do
Render ()
gsave
Render ()
fill
Render ()
grestore
showText :: String -> Render ()
showText :: String -> Render ()
showText String
s = do
Render ()
renderFont
String -> Render ()
stringPS String
s
Builder -> Render ()
renderPS Builder
" show"
showTextCentered :: String -> Render ()
showTextCentered :: String -> Render ()
showTextCentered String
s = do
Render ()
renderFont
String -> Render ()
stringPS String
s
Builder -> Render ()
renderPS Builder
" showcentered"
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"
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"
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
"]"])
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]
:)
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
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]
:)
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
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 :: 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
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 ()
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 ()
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 = (Double -> Builder) -> Builder -> [Double] -> Render ()
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 = (Double -> Builder) -> Builder -> [Double] -> Render ()
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 = (Double -> Builder) -> Builder -> [Double] -> Render ()
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 = (Int -> Builder) -> Builder -> [Int] -> Render ()
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 = (Int -> Builder) -> Builder -> [Int] -> Render ()
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 = (Double -> Builder) -> Builder -> [Double] -> Render ()
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" [(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 :: 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 :: 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 :: 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
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
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"
]
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
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
""