{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Diagrams.Backend.Postscript
(
Postscript(..)
, B
, Options(..), psfileName, psSizeSpec, psOutputFormat
, OutputFormat(..)
, renderDias
) where
import Diagrams.Backend.Postscript.CMYK
import Diagrams.Core.Compile
import qualified Graphics.Rendering.Postscript as C
import Diagrams.Prelude hiding (fillColor, view)
import Diagrams.TwoD.Adjust (adjustDia2D)
import Diagrams.TwoD.Path (Clip (Clip), getFillRule)
import Diagrams.TwoD.Text
import Control.Lens hiding (transform)
import Control.Monad (when)
import qualified Control.Monad.StateStack as SS
import Control.Monad.Trans (lift)
import Data.Maybe (catMaybes, isJust)
import qualified Data.ByteString.Builder as B
import qualified Data.Foldable as F
import Data.Hashable (Hashable (..))
import Data.Tree
import Data.Typeable
import GHC.Generics (Generic)
data Postscript = Postscript
deriving (Postscript -> Postscript -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Postscript -> Postscript -> Bool
$c/= :: Postscript -> Postscript -> Bool
== :: Postscript -> Postscript -> Bool
$c== :: Postscript -> Postscript -> Bool
Eq,Eq Postscript
Postscript -> Postscript -> Bool
Postscript -> Postscript -> Ordering
Postscript -> Postscript -> Postscript
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Postscript -> Postscript -> Postscript
$cmin :: Postscript -> Postscript -> Postscript
max :: Postscript -> Postscript -> Postscript
$cmax :: Postscript -> Postscript -> Postscript
>= :: Postscript -> Postscript -> Bool
$c>= :: Postscript -> Postscript -> Bool
> :: Postscript -> Postscript -> Bool
$c> :: Postscript -> Postscript -> Bool
<= :: Postscript -> Postscript -> Bool
$c<= :: Postscript -> Postscript -> Bool
< :: Postscript -> Postscript -> Bool
$c< :: Postscript -> Postscript -> Bool
compare :: Postscript -> Postscript -> Ordering
$ccompare :: Postscript -> Postscript -> Ordering
Ord,ReadPrec [Postscript]
ReadPrec Postscript
Int -> ReadS Postscript
ReadS [Postscript]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Postscript]
$creadListPrec :: ReadPrec [Postscript]
readPrec :: ReadPrec Postscript
$creadPrec :: ReadPrec Postscript
readList :: ReadS [Postscript]
$creadList :: ReadS [Postscript]
readsPrec :: Int -> ReadS Postscript
$creadsPrec :: Int -> ReadS Postscript
Read,Int -> Postscript -> ShowS
[Postscript] -> ShowS
Postscript -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Postscript] -> ShowS
$cshowList :: [Postscript] -> ShowS
show :: Postscript -> String
$cshow :: Postscript -> String
showsPrec :: Int -> Postscript -> ShowS
$cshowsPrec :: Int -> Postscript -> ShowS
Show,Typeable)
type B = Postscript
type instance V Postscript = V2
type instance N Postscript = Double
data OutputFormat = EPS
deriving (OutputFormat -> OutputFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutputFormat -> OutputFormat -> Bool
$c/= :: OutputFormat -> OutputFormat -> Bool
== :: OutputFormat -> OutputFormat -> Bool
$c== :: OutputFormat -> OutputFormat -> Bool
Eq, Eq OutputFormat
OutputFormat -> OutputFormat -> Bool
OutputFormat -> OutputFormat -> Ordering
OutputFormat -> OutputFormat -> OutputFormat
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OutputFormat -> OutputFormat -> OutputFormat
$cmin :: OutputFormat -> OutputFormat -> OutputFormat
max :: OutputFormat -> OutputFormat -> OutputFormat
$cmax :: OutputFormat -> OutputFormat -> OutputFormat
>= :: OutputFormat -> OutputFormat -> Bool
$c>= :: OutputFormat -> OutputFormat -> Bool
> :: OutputFormat -> OutputFormat -> Bool
$c> :: OutputFormat -> OutputFormat -> Bool
<= :: OutputFormat -> OutputFormat -> Bool
$c<= :: OutputFormat -> OutputFormat -> Bool
< :: OutputFormat -> OutputFormat -> Bool
$c< :: OutputFormat -> OutputFormat -> Bool
compare :: OutputFormat -> OutputFormat -> Ordering
$ccompare :: OutputFormat -> OutputFormat -> Ordering
Ord, ReadPrec [OutputFormat]
ReadPrec OutputFormat
Int -> ReadS OutputFormat
ReadS [OutputFormat]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [OutputFormat]
$creadListPrec :: ReadPrec [OutputFormat]
readPrec :: ReadPrec OutputFormat
$creadPrec :: ReadPrec OutputFormat
readList :: ReadS [OutputFormat]
$creadList :: ReadS [OutputFormat]
readsPrec :: Int -> ReadS OutputFormat
$creadsPrec :: Int -> ReadS OutputFormat
Read, Int -> OutputFormat -> ShowS
[OutputFormat] -> ShowS
OutputFormat -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OutputFormat] -> ShowS
$cshowList :: [OutputFormat] -> ShowS
show :: OutputFormat -> String
$cshow :: OutputFormat -> String
showsPrec :: Int -> OutputFormat -> ShowS
$cshowsPrec :: Int -> OutputFormat -> ShowS
Show, Int -> OutputFormat
OutputFormat -> Int
OutputFormat -> [OutputFormat]
OutputFormat -> OutputFormat
OutputFormat -> OutputFormat -> [OutputFormat]
OutputFormat -> OutputFormat -> OutputFormat -> [OutputFormat]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: OutputFormat -> OutputFormat -> OutputFormat -> [OutputFormat]
$cenumFromThenTo :: OutputFormat -> OutputFormat -> OutputFormat -> [OutputFormat]
enumFromTo :: OutputFormat -> OutputFormat -> [OutputFormat]
$cenumFromTo :: OutputFormat -> OutputFormat -> [OutputFormat]
enumFromThen :: OutputFormat -> OutputFormat -> [OutputFormat]
$cenumFromThen :: OutputFormat -> OutputFormat -> [OutputFormat]
enumFrom :: OutputFormat -> [OutputFormat]
$cenumFrom :: OutputFormat -> [OutputFormat]
fromEnum :: OutputFormat -> Int
$cfromEnum :: OutputFormat -> Int
toEnum :: Int -> OutputFormat
$ctoEnum :: Int -> OutputFormat
pred :: OutputFormat -> OutputFormat
$cpred :: OutputFormat -> OutputFormat
succ :: OutputFormat -> OutputFormat
$csucc :: OutputFormat -> OutputFormat
Enum, OutputFormat
forall a. a -> a -> Bounded a
maxBound :: OutputFormat
$cmaxBound :: OutputFormat
minBound :: OutputFormat
$cminBound :: OutputFormat
Bounded, Typeable, forall x. Rep OutputFormat x -> OutputFormat
forall x. OutputFormat -> Rep OutputFormat x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OutputFormat x -> OutputFormat
$cfrom :: forall x. OutputFormat -> Rep OutputFormat x
Generic)
instance Hashable OutputFormat
data PostscriptState
= PostscriptState { PostscriptState -> Style V2 Double
_accumStyle :: Style V2 Double
, PostscriptState -> Bool
_ignoreFill :: Bool
}
$(makeLenses ''PostscriptState)
instance Default PostscriptState where
def :: PostscriptState
def = PostscriptState
{ _accumStyle :: Style V2 Double
_accumStyle = forall a. Monoid a => a
mempty
, _ignoreFill :: Bool
_ignoreFill = Bool
False
}
type RenderM a = SS.StateStackT PostscriptState C.Render a
liftC :: C.Render a -> RenderM a
liftC :: forall a. Render a -> RenderM a
liftC = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
runRenderM :: RenderM a -> C.Render a
runRenderM :: forall a. RenderM a -> Render a
runRenderM = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateStackT s m a -> s -> m a
SS.evalStateStackT forall a. Default a => a
def
save :: RenderM ()
save :: RenderM ()
save = forall s (m :: * -> *). MonadStateStack s m => m ()
SS.save forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Render a -> RenderM a
liftC Render ()
C.save
restore :: RenderM ()
restore :: RenderM ()
restore = forall a. Render a -> RenderM a
liftC Render ()
C.restore forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *). MonadStateStack s m => m ()
SS.restore
instance Semigroup (Render Postscript V2 Double) where
C RenderM ()
x <> :: Render Postscript V2 Double
-> Render Postscript V2 Double -> Render Postscript V2 Double
<> C RenderM ()
y = RenderM () -> Render Postscript V2 Double
C (RenderM ()
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RenderM ()
y)
instance Monoid (Render Postscript V2 Double) where
mempty :: Render Postscript V2 Double
mempty = RenderM () -> Render Postscript V2 Double
C forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if !MIN_VERSION_base(4,11,0)
mappend = (<>)
#endif
instance Backend Postscript V2 Double where
data Render Postscript V2 Double = C (RenderM ())
type Result Postscript V2 Double = B.Builder
data Options Postscript V2 Double = PostscriptOptions
{ Options Postscript V2 Double -> String
_psfileName :: String
, Options Postscript V2 Double -> SizeSpec V2 Double
_psSizeSpec :: SizeSpec V2 Double
, Options Postscript V2 Double -> OutputFormat
_psOutputFormat :: OutputFormat
}
deriving (Int -> Options Postscript V2 Double -> ShowS
[Options Postscript V2 Double] -> ShowS
Options Postscript V2 Double -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options Postscript V2 Double] -> ShowS
$cshowList :: [Options Postscript V2 Double] -> ShowS
show :: Options Postscript V2 Double -> String
$cshow :: Options Postscript V2 Double -> String
showsPrec :: Int -> Options Postscript V2 Double -> ShowS
$cshowsPrec :: Int -> Options Postscript V2 Double -> ShowS
Show, Options Postscript V2 Double
-> Options Postscript V2 Double -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options Postscript V2 Double
-> Options Postscript V2 Double -> Bool
$c/= :: Options Postscript V2 Double
-> Options Postscript V2 Double -> Bool
== :: Options Postscript V2 Double
-> Options Postscript V2 Double -> Bool
$c== :: Options Postscript V2 Double
-> Options Postscript V2 Double -> Bool
Eq)
renderRTree :: Postscript
-> Options Postscript V2 Double
-> RTree Postscript V2 Double Annotation
-> Result Postscript V2 Double
renderRTree Postscript
_ Options Postscript V2 Double
opts RTree Postscript V2 Double Annotation
t =
let surfaceF :: Surface -> Builder
surfaceF Surface
surface = forall a b. (a, b) -> a
fst (forall a. Surface -> Render a -> (Builder, a)
C.renderBuilder Surface
surface Render ()
r)
V2 Double
w Double
h = forall (v :: * -> *) n.
(Foldable v, Functor v, Num n, Ord n) =>
n -> SizeSpec v n -> v n
specToSize Double
100 (Options Postscript V2 Double
optsforall s a. s -> Getting a s a -> a
^.Lens' (Options Postscript V2 Double) (SizeSpec V2 Double)
psSizeSpec)
r :: Render ()
r = forall a. RenderM a -> Render a
runRenderM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render Postscript V2 Double -> RenderM ()
runC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender forall a b. (a -> b) -> a -> b
$ RTree Postscript V2 Double Annotation
t
in case Options Postscript V2 Double
optsforall s a. s -> Getting a s a -> a
^.Lens' (Options Postscript V2 Double) OutputFormat
psOutputFormat of
OutputFormat
EPS -> forall r. String -> Int -> Int -> (Surface -> r) -> r
C.withEPSSurface (Options Postscript V2 Double
optsforall s a. s -> Getting a s a -> a
^.Lens' (Options Postscript V2 Double) String
psfileName) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
w) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
h) Surface -> Builder
surfaceF
adjustDia :: forall m.
(Additive V2, Monoid' m, Num Double) =>
Postscript
-> Options Postscript V2 Double
-> QDiagram Postscript V2 Double m
-> (Options Postscript V2 Double, Transformation V2 Double,
QDiagram Postscript V2 Double m)
adjustDia = forall n m b.
(TypeableFloat n, Monoid' m) =>
Lens' (Options b V2 n) (SizeSpec V2 n)
-> b
-> Options b V2 n
-> QDiagram b V2 n m
-> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m)
adjustDia2D Lens' (Options Postscript V2 Double) (SizeSpec V2 Double)
psSizeSpec
runC :: Render Postscript V2 Double -> RenderM ()
runC :: Render Postscript V2 Double -> RenderM ()
runC (C RenderM ()
r) = RenderM ()
r
getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib :: forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib a -> b
f = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' PostscriptState (Style V2 Double)
accumStyle
toRender :: RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender :: forall a.
RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender (Node (RPrim Prim Postscript V2 Double
p) [Tree (RNode Postscript V2 Double a)]
_) = forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render Postscript
Postscript Prim Postscript V2 Double
p
toRender (Node (RStyle Style V2 Double
sty) [Tree (RNode Postscript V2 Double a)]
rs) = RenderM () -> Render Postscript V2 Double
C forall a b. (a -> b) -> a -> b
$ do
RenderM ()
save
forall (v :: * -> *). Style v Double -> RenderM ()
postscriptStyle Style V2 Double
sty
Lens' PostscriptState (Style V2 Double)
accumStyle forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Semigroup a => a -> a -> a
<> Style V2 Double
sty)
Render Postscript V2 Double -> RenderM ()
runC forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap forall a.
RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender [Tree (RNode Postscript V2 Double a)]
rs
RenderM ()
restore
toRender (Node RNode Postscript V2 Double a
_ [Tree (RNode Postscript V2 Double a)]
rs) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap forall a.
RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender [Tree (RNode Postscript V2 Double a)]
rs
instance Hashable (Options Postscript V2 Double) where
hashWithSalt :: Int -> Options Postscript V2 Double -> Int
hashWithSalt Int
s (PostscriptOptions String
fn SizeSpec V2 Double
sz OutputFormat
out) =
Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` String
fn
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` SizeSpec V2 Double
sz
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` OutputFormat
out
psfileName :: Lens' (Options Postscript V2 Double) String
psfileName :: Lens' (Options Postscript V2 Double) String
psfileName = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(PostscriptOptions {_psfileName :: Options Postscript V2 Double -> String
_psfileName = String
f}) -> String
f)
(\Options Postscript V2 Double
o String
f -> Options Postscript V2 Double
o {_psfileName :: String
_psfileName = String
f})
psSizeSpec :: Lens' (Options Postscript V2 Double) (SizeSpec V2 Double)
psSizeSpec :: Lens' (Options Postscript V2 Double) (SizeSpec V2 Double)
psSizeSpec = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(PostscriptOptions {_psSizeSpec :: Options Postscript V2 Double -> SizeSpec V2 Double
_psSizeSpec = SizeSpec V2 Double
s}) -> SizeSpec V2 Double
s)
(\Options Postscript V2 Double
o SizeSpec V2 Double
s -> Options Postscript V2 Double
o {_psSizeSpec :: SizeSpec V2 Double
_psSizeSpec = SizeSpec V2 Double
s})
psOutputFormat :: Lens' (Options Postscript V2 Double) OutputFormat
psOutputFormat :: Lens' (Options Postscript V2 Double) OutputFormat
psOutputFormat = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(PostscriptOptions {_psOutputFormat :: Options Postscript V2 Double -> OutputFormat
_psOutputFormat = OutputFormat
t}) -> OutputFormat
t)
(\Options Postscript V2 Double
o OutputFormat
t -> Options Postscript V2 Double
o {_psOutputFormat :: OutputFormat
_psOutputFormat = OutputFormat
t})
renderDias :: (Semigroup m, Monoid m) =>
Options Postscript V2 Double -> [QDiagram Postscript V2 Double m] -> IO [()]
renderDias :: forall m.
(Semigroup m, Monoid m) =>
Options Postscript V2 Double
-> [QDiagram Postscript V2 Double m] -> IO [()]
renderDias Options Postscript V2 Double
opts [QDiagram Postscript V2 Double m]
ds = case Options Postscript V2 Double
optsforall s a. s -> Getting a s a -> a
^.Lens' (Options Postscript V2 Double) OutputFormat
psOutputFormat of
OutputFormat
EPS -> forall r. String -> Int -> Int -> (Surface -> r) -> r
C.withEPSSurface (Options Postscript V2 Double
optsforall s a. s -> Getting a s a -> a
^.Lens' (Options Postscript V2 Double) String
psfileName) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
w) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
h) Surface -> IO [()]
surfaceF
where
surfaceF :: Surface -> IO [()]
surfaceF Surface
surface = forall (m :: * -> *) a. MonadIO m => Surface -> [Render a] -> m [a]
C.renderPagesWith Surface
surface [Render ()]
rs
dropMid :: (a, b, b) -> (a, b)
dropMid (a
x, b
_, b
z) = (a
x,b
z)
optsdss :: [(Options Postscript V2 Double, QDiagram Postscript V2 Double m)]
optsdss = forall a b. (a -> b) -> [a] -> [b]
map (forall {a} {b} {b}. (a, b, b) -> (a, b)
dropMid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (v :: * -> *) n m.
(Backend b v n, Additive v, Monoid' m, Num n) =>
b
-> Options b v n
-> QDiagram b v n m
-> (Options b v n, Transformation v n, QDiagram b v n m)
adjustDia Postscript
Postscript Options Postscript V2 Double
opts) [QDiagram Postscript V2 Double m]
ds
g2o :: Transformation V2 Double
g2o = forall (v :: * -> *) n.
(Additive v, Fractional n) =>
n -> Transformation v n
scaling (forall a. Floating a => a -> a
sqrt (Double
w forall a. Num a => a -> a -> a
* Double
h))
rs :: [Render ()]
rs = forall a b. (a -> b) -> [a] -> [b]
map (forall a. RenderM a -> Render a
runRenderM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render Postscript V2 Double -> RenderM ()
runC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n m b.
(HasLinearMap v, Metric v, Typeable n, OrderedField n, Monoid m,
Semigroup m) =>
Transformation v n -> QDiagram b v n m -> RTree b v n Annotation
toRTree Transformation V2 Double
g2o forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Options Postscript V2 Double, QDiagram Postscript V2 Double m)]
optsdss
sizes :: [V2 Double]
sizes = forall a b. (a -> b) -> [a] -> [b]
map (forall (v :: * -> *) n.
(Foldable v, Functor v, Num n, Ord n) =>
n -> SizeSpec v n -> v n
specToSize Double
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' (Options Postscript V2 Double) (SizeSpec V2 Double)
psSizeSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Options Postscript V2 Double, QDiagram Postscript V2 Double m)]
optsdss
V2 Double
w Double
h = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> a) -> a -> t a -> a
foldBy (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Ord a => a -> a -> a
max) forall (f :: * -> *) a. (Additive f, Num a) => f a
zero [V2 Double]
sizes
renderC :: (Renderable a Postscript, V a ~ V2, N a ~ Double) => a -> RenderM ()
renderC :: forall a.
(Renderable a Postscript, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC = Render Postscript V2 Double -> RenderM ()
runC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render Postscript
Postscript
postscriptStyle :: Style v Double -> RenderM ()
postscriptStyle :: forall (v :: * -> *). Style v Double -> RenderM ()
postscriptStyle Style v Double
s =
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ [ forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle Clip Double -> RenderM ()
clip
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle FillRule -> RenderM ()
lFillRule
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineWidth Double -> RenderM ()
lWidth
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineJoin -> RenderM ()
lJoin
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineMiterLimit -> RenderM ()
lMiter
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineCap -> RenderM ()
lCap
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle Dashing Double -> RenderM ()
lDashing
]
where
handle :: AttributeClass a => (a -> RenderM ()) -> Maybe (RenderM ())
handle :: forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle a -> RenderM ()
f = a -> RenderM ()
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v Double
s
clip :: Clip Double -> RenderM ()
clip = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Path V2 Double
p -> Path V2 Double -> RenderM ()
postscriptPath Path V2 Double
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Render a -> RenderM a
liftC Render ()
C.clip) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op forall n. [Path V2 n] -> Clip n
Clip
lFillRule :: FillRule -> RenderM ()
lFillRule = forall a. Render a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign (Lens' RenderState DrawState
C.drawState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DrawState FillRule
C.fillRule) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FillRule -> FillRule
getFillRule
lWidth :: LineWidth Double -> RenderM ()
lWidth = forall a. Render a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Render ()
C.lineWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. LineWidth n -> n
getLineWidth
lCap :: LineCap -> RenderM ()
lCap = forall a. Render a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> Render ()
C.lineCap forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> LineCap
getLineCap
lJoin :: LineJoin -> RenderM ()
lJoin = forall a. Render a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> Render ()
C.lineJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> LineJoin
getLineJoin
lMiter :: LineMiterLimit -> RenderM ()
lMiter = forall a. Render a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Render ()
C.miterLimit forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineMiterLimit -> Double
getLineMiterLimit
lDashing :: Dashing Double -> RenderM ()
lDashing (forall n. Dashing n -> Dashing n
getDashing -> Dashing [Double]
ds Double
offs) = forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ [Double] -> Double -> Render ()
C.setDash [Double]
ds Double
offs
fromFontSlant :: FontSlant -> C.FontSlant
fromFontSlant :: FontSlant -> FontSlant
fromFontSlant FontSlant
FontSlantNormal = FontSlant
C.FontSlantNormal
fromFontSlant FontSlant
FontSlantItalic = FontSlant
C.FontSlantItalic
fromFontSlant FontSlant
FontSlantOblique = FontSlant
C.FontSlantOblique
fromFontWeight :: FontWeight -> C.FontWeight
fromFontWeight :: FontWeight -> FontWeight
fromFontWeight FontWeight
FontWeightNormal = FontWeight
C.FontWeightNormal
fromFontWeight FontWeight
FontWeightBold = FontWeight
C.FontWeightBold
fromFontWeight FontWeight
_ = FontWeight
C.FontWeightNormal
postscriptTransf :: Transformation V2 Double -> C.Render ()
postscriptTransf :: Transformation V2 Double -> Render ()
postscriptTransf Transformation V2 Double
t = Double
-> Double -> Double -> Double -> Double -> Double -> Render ()
C.transform Double
a1 Double
a2 Double
b1 Double
b2 Double
c1 Double
c2
where (V2 Double
a1 Double
a2) = forall (v :: * -> *) n. Transformation v n -> v n -> v n
apply Transformation V2 Double
t forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX
(V2 Double
b1 Double
b2) = forall (v :: * -> *) n. Transformation v n -> v n -> v n
apply Transformation V2 Double
t forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY
(V2 Double
c1 Double
c2) = forall (v :: * -> *) n. Transformation v n -> v n
transl Transformation V2 Double
t
instance Renderable (Segment Closed V2 Double) Postscript where
render :: Postscript
-> Segment Closed V2 Double
-> Render
Postscript
(V (Segment Closed V2 Double))
(N (Segment Closed V2 Double))
render Postscript
_ (Linear (OffsetClosed V2 Double
v)) = RenderM () -> Render Postscript V2 Double
C forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Render ()
C.relLineTo (forall n. V2 n -> (n, n)
unr2 V2 Double
v)
render Postscript
_ (Cubic (forall n. V2 n -> (n, n)
unr2 -> (Double
x1, Double
y1))
(forall n. V2 n -> (n, n)
unr2 -> (Double
x2, Double
y2))
(OffsetClosed (forall n. V2 n -> (n, n)
unr2 -> (Double
x3, Double
y3))))
= RenderM () -> Render Postscript V2 Double
C forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Double
-> Double -> Double -> Double -> Double -> Double -> Render ()
C.relCurveTo Double
x1 Double
y1 Double
x2 Double
y2 Double
x3 Double
y3
instance Renderable (Trail V2 Double) Postscript where
render :: Postscript
-> Trail V2 Double
-> Render Postscript (V (Trail V2 Double)) (N (Trail V2 Double))
render Postscript
_ = forall (v :: * -> *) n r.
(Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r
withTrail Trail' Line V2 Double -> Render Postscript V2 Double
renderLine Trail' Loop V2 Double -> Render Postscript V2 Double
renderLoop
where
renderLine :: Trail' Line V2 Double -> Render Postscript V2 Double
renderLine Trail' Line V2 Double
ln = RenderM () -> Render Postscript V2 Double
C forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a.
(Renderable a Postscript, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC (forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments Trail' Line V2 Double
ln)
Lens' PostscriptState Bool
ignoreFill forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
renderLoop :: Trail' Loop V2 Double -> Render Postscript V2 Double
renderLoop Trail' Loop V2 Double
lp = RenderM () -> Render Postscript V2 Double
C forall a b. (a -> b) -> a -> b
$ do
case forall (v :: * -> *) n.
Trail' Loop v n -> ([Segment Closed v n], Segment Open v n)
loopSegments Trail' Loop V2 Double
lp of
([Segment Closed V2 Double]
segs, Linear Offset Open V2 Double
_) -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a.
(Renderable a Postscript, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC [Segment Closed V2 Double]
segs
([Segment Closed V2 Double], Segment Open V2 Double)
_ -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a.
(Renderable a Postscript, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC (forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail' Loop v n -> Trail' Line v n
cutLoop forall a b. (a -> b) -> a -> b
$ Trail' Loop V2 Double
lp)
forall a. Render a -> RenderM a
liftC Render ()
C.closePath
instance Renderable (Path V2 Double) Postscript where
render :: Postscript
-> Path V2 Double
-> Render Postscript (V (Path V2 Double)) (N (Path V2 Double))
render Postscript
_ Path V2 Double
p = RenderM () -> Render Postscript V2 Double
C forall a b. (a -> b) -> a -> b
$ do
Path V2 Double -> RenderM ()
postscriptPath Path V2 Double
p
Maybe (Texture Double)
f <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. FillTexture n -> Texture n
getFillTexture
Maybe (Texture Double)
s <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. LineTexture n -> Texture n
getLineTexture
Maybe CMYK
fk <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FillColorCMYK -> CMYK
getFillColorCMYK
Maybe CMYK
sk <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib LineColorCMYK -> CMYK
getLineColorCMYK
Bool
ign <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' PostscriptState Bool
ignoreFill
Maybe (Texture Double) -> Maybe CMYK -> RenderM ()
setFillColor Maybe (Texture Double)
f Maybe CMYK
fk
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((forall a. Maybe a -> Bool
isJust Maybe (Texture Double)
f Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe CMYK
fk) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ign) forall a b. (a -> b) -> a -> b
$ forall a. Render a -> RenderM a
liftC Render ()
C.fillPreserve
Maybe (Texture Double) -> Maybe CMYK -> RenderM ()
setStrokeColor Maybe (Texture Double)
s Maybe CMYK
sk
forall a. Render a -> RenderM a
liftC Render ()
C.stroke
setFillColor :: Maybe (Texture Double) -> Maybe (CMYK) -> RenderM ()
setFillColor :: Maybe (Texture Double) -> Maybe CMYK -> RenderM ()
setFillColor Maybe (Texture Double)
c Maybe CMYK
cmyk = do
forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall n. Texture n -> Render ()
C.fillColor Maybe (Texture Double)
c
forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) CMYK -> Render ()
C.fillColorCMYK Maybe CMYK
cmyk
setStrokeColor :: Maybe (Texture Double) -> Maybe (CMYK) -> RenderM ()
setStrokeColor :: Maybe (Texture Double) -> Maybe CMYK -> RenderM ()
setStrokeColor Maybe (Texture Double)
c Maybe CMYK
cmyk = do
forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall n. Texture n -> Render ()
C.strokeColor Maybe (Texture Double)
c
forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) CMYK -> Render ()
C.strokeColorCMYK Maybe CMYK
cmyk
postscriptPath :: Path V2 Double -> RenderM ()
postscriptPath :: Path V2 Double -> RenderM ()
postscriptPath (Path [Located (Trail V2 Double)]
trs) = do
forall a. Render a -> RenderM a
liftC Render ()
C.newPath
Lens' PostscriptState Bool
ignoreFill forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ forall {a}.
(V a ~ V2, N a ~ Double, Renderable a Postscript) =>
Located a -> RenderM ()
renderTrail [Located (Trail V2 Double)]
trs
where renderTrail :: Located a -> RenderM ()
renderTrail (forall a. Located a -> (Point (V a) (N a), a)
viewLoc -> (forall n. P2 n -> (n, n)
unp2 -> (Double, Double)
pt, a
tr)) = do
forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Render ()
C.moveTo (Double, Double)
pt
forall a.
(Renderable a Postscript, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC a
tr
if' :: Monad m => (a -> m ()) -> Maybe a -> m ()
if' :: forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
instance Renderable (Text Double) Postscript where
render :: Postscript
-> Text Double
-> Render Postscript (V (Text Double)) (N (Text Double))
render Postscript
_ (Text Transformation V2 Double
tr TextAlignment Double
al String
str) = RenderM () -> Render Postscript V2 Double
C forall a b. (a -> b) -> a -> b
$ do
Maybe String
ff <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib Font -> String
getFont
Maybe FontSlant
fs <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib (FontSlant -> FontSlant
fromFontSlant forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontSlant -> FontSlant
getFontSlant)
Maybe FontWeight
fw <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib (FontWeight -> FontWeight
fromFontWeight forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontWeight -> FontWeight
getFontWeight)
Maybe Double
size' <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. FontSize n -> n
getFontSize
Maybe (Texture Double)
f <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. FillTexture n -> Texture n
getFillTexture
Maybe CMYK
fk <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FillColorCMYK -> CMYK
getFillColorCMYK
RenderM ()
save
Maybe (Texture Double) -> Maybe CMYK -> RenderM ()
setFillColor Maybe (Texture Double)
f Maybe CMYK
fk
forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign (Lens' RenderState DrawState
C.drawState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DrawState PostscriptFont
C.font forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PostscriptFont Double
C.size)) Maybe Double
size'
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign (Lens' RenderState DrawState
C.drawState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DrawState PostscriptFont
C.font forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PostscriptFont String
C.face)) Maybe String
ff
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign (Lens' RenderState DrawState
C.drawState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DrawState PostscriptFont
C.font forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PostscriptFont FontSlant
C.slant)) Maybe FontSlant
fs
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign (Lens' RenderState DrawState
C.drawState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DrawState PostscriptFont
C.font forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PostscriptFont FontWeight
C.weight)) Maybe FontWeight
fw
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (Texture Double)
f Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe CMYK
fk) forall a b. (a -> b) -> a -> b
$ forall a. Render a -> RenderM a
liftC Render ()
C.fillPreserve
forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Transformation V2 Double -> Render ()
postscriptTransf Transformation V2 Double
tr
case TextAlignment Double
al of
BoxAlignedText Double
xt Double
yt -> forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Double -> Double -> String -> Render ()
C.showTextAlign Double
xt Double
yt String
str
TextAlignment Double
BaselineText -> forall a. Render a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Double -> Double -> Render ()
C.moveTo Double
0 Double
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Render ()
C.showText String
str
RenderM ()
restore