{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# 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
(Postscript -> Postscript -> Bool)
-> (Postscript -> Postscript -> Bool) -> Eq Postscript
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
Eq Postscript
-> (Postscript -> Postscript -> Ordering)
-> (Postscript -> Postscript -> Bool)
-> (Postscript -> Postscript -> Bool)
-> (Postscript -> Postscript -> Bool)
-> (Postscript -> Postscript -> Bool)
-> (Postscript -> Postscript -> Postscript)
-> (Postscript -> Postscript -> Postscript)
-> Ord 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
$cp1Ord :: Eq Postscript
Ord,ReadPrec [Postscript]
ReadPrec Postscript
Int -> ReadS Postscript
ReadS [Postscript]
(Int -> ReadS Postscript)
-> ReadS [Postscript]
-> ReadPrec Postscript
-> ReadPrec [Postscript]
-> Read 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
(Int -> Postscript -> ShowS)
-> (Postscript -> String)
-> ([Postscript] -> ShowS)
-> Show Postscript
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
(OutputFormat -> OutputFormat -> Bool)
-> (OutputFormat -> OutputFormat -> Bool) -> Eq OutputFormat
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
Eq OutputFormat
-> (OutputFormat -> OutputFormat -> Ordering)
-> (OutputFormat -> OutputFormat -> Bool)
-> (OutputFormat -> OutputFormat -> Bool)
-> (OutputFormat -> OutputFormat -> Bool)
-> (OutputFormat -> OutputFormat -> Bool)
-> (OutputFormat -> OutputFormat -> OutputFormat)
-> (OutputFormat -> OutputFormat -> OutputFormat)
-> Ord 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
$cp1Ord :: Eq OutputFormat
Ord, ReadPrec [OutputFormat]
ReadPrec OutputFormat
Int -> ReadS OutputFormat
ReadS [OutputFormat]
(Int -> ReadS OutputFormat)
-> ReadS [OutputFormat]
-> ReadPrec OutputFormat
-> ReadPrec [OutputFormat]
-> Read 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
(Int -> OutputFormat -> ShowS)
-> (OutputFormat -> String)
-> ([OutputFormat] -> ShowS)
-> Show OutputFormat
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]
(OutputFormat -> OutputFormat)
-> (OutputFormat -> OutputFormat)
-> (Int -> OutputFormat)
-> (OutputFormat -> Int)
-> (OutputFormat -> [OutputFormat])
-> (OutputFormat -> OutputFormat -> [OutputFormat])
-> (OutputFormat -> OutputFormat -> [OutputFormat])
-> (OutputFormat -> OutputFormat -> OutputFormat -> [OutputFormat])
-> Enum 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
OutputFormat -> OutputFormat -> Bounded OutputFormat
forall a. a -> a -> Bounded a
maxBound :: OutputFormat
$cmaxBound :: OutputFormat
minBound :: OutputFormat
$cminBound :: OutputFormat
Bounded, Typeable, (forall x. OutputFormat -> Rep OutputFormat x)
-> (forall x. Rep OutputFormat x -> OutputFormat)
-> Generic OutputFormat
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 :: Style V2 Double -> Bool -> PostscriptState
PostscriptState
{ _accumStyle :: Style V2 Double
_accumStyle = Style V2 Double
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 :: Render a -> RenderM a
liftC = Render a -> RenderM a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
runRenderM :: RenderM a -> C.Render a
runRenderM :: RenderM a -> Render a
runRenderM = (RenderM a -> PostscriptState -> Render a)
-> PostscriptState -> RenderM a -> Render a
forall a b c. (a -> b -> c) -> b -> a -> c
flip RenderM a -> PostscriptState -> Render a
forall (m :: * -> *) s a. Monad m => StateStackT s m a -> s -> m a
SS.evalStateStackT PostscriptState
forall a. Default a => a
def
save :: RenderM ()
save :: RenderM ()
save = RenderM ()
forall s (m :: * -> *). MonadStateStack s m => m ()
SS.save RenderM () -> RenderM () -> RenderM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.save
restore :: RenderM ()
restore :: RenderM ()
restore = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.restore RenderM () -> RenderM () -> RenderM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RenderM ()
forall s (m :: * -> *). MonadStateStack s m => m ()
SS.restore
instance Semigroup (Render Postscript V2 Double) where
C x <> :: Render Postscript V2 Double
-> Render Postscript V2 Double -> Render Postscript V2 Double
<> C y = RenderM () -> Render Postscript V2 Double
C (RenderM ()
x RenderM () -> RenderM () -> RenderM ()
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 (RenderM () -> Render Postscript V2 Double)
-> RenderM () -> Render Postscript V2 Double
forall a b. (a -> b) -> a -> b
$ () -> RenderM ()
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
(Int -> Options Postscript V2 Double -> ShowS)
-> (Options Postscript V2 Double -> String)
-> ([Options Postscript V2 Double] -> ShowS)
-> Show (Options Postscript V2 Double)
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
(Options Postscript V2 Double
-> Options Postscript V2 Double -> Bool)
-> (Options Postscript V2 Double
-> Options Postscript V2 Double -> Bool)
-> Eq (Options Postscript V2 Double)
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 = (Builder, ()) -> Builder
forall a b. (a, b) -> a
fst (Surface -> Render () -> (Builder, ())
forall a. Surface -> Render a -> (Builder, a)
C.renderBuilder Surface
surface Render ()
r)
V2 Double
w Double
h = Double -> SizeSpec V2 Double -> V2 Double
forall (v :: * -> *) n.
(Foldable v, Functor v, Num n, Ord n) =>
n -> SizeSpec v n -> v n
specToSize Double
100 (Options Postscript V2 Double
optsOptions Postscript V2 Double
-> Getting
(SizeSpec V2 Double)
(Options Postscript V2 Double)
(SizeSpec V2 Double)
-> SizeSpec V2 Double
forall s a. s -> Getting a s a -> a
^.Getting
(SizeSpec V2 Double)
(Options Postscript V2 Double)
(SizeSpec V2 Double)
Lens' (Options Postscript V2 Double) (SizeSpec V2 Double)
psSizeSpec)
r :: Render ()
r = RenderM () -> Render ()
forall a. RenderM a -> Render a
runRenderM (RenderM () -> Render ())
-> (RTree Postscript V2 Double Annotation -> RenderM ())
-> RTree Postscript V2 Double Annotation
-> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render Postscript V2 Double -> RenderM ()
runC (Render Postscript V2 Double -> RenderM ())
-> (RTree Postscript V2 Double Annotation
-> Render Postscript V2 Double)
-> RTree Postscript V2 Double Annotation
-> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTree Postscript V2 Double Annotation
-> Render Postscript V2 Double
forall a.
RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender (RTree Postscript V2 Double Annotation -> Render ())
-> RTree Postscript V2 Double Annotation -> Render ()
forall a b. (a -> b) -> a -> b
$ RTree Postscript V2 Double Annotation
t
in case Options Postscript V2 Double
optsOptions Postscript V2 Double
-> Getting OutputFormat (Options Postscript V2 Double) OutputFormat
-> OutputFormat
forall s a. s -> Getting a s a -> a
^.Getting OutputFormat (Options Postscript V2 Double) OutputFormat
Lens' (Options Postscript V2 Double) OutputFormat
psOutputFormat of
OutputFormat
EPS -> String -> Int -> Int -> (Surface -> Builder) -> Builder
forall r. String -> Int -> Int -> (Surface -> r) -> r
C.withEPSSurface (Options Postscript V2 Double
optsOptions Postscript V2 Double
-> Getting String (Options Postscript V2 Double) String -> String
forall s a. s -> Getting a s a -> a
^.Getting String (Options Postscript V2 Double) String
Lens' (Options Postscript V2 Double) String
psfileName) (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Double
w) (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Double
h) Surface -> Builder
surfaceF
adjustDia :: Postscript
-> Options Postscript V2 Double
-> QDiagram Postscript V2 Double m
-> (Options Postscript V2 Double, Transformation V2 Double,
QDiagram Postscript V2 Double m)
adjustDia = Lens' (Options Postscript V2 Double) (SizeSpec V2 Double)
-> Postscript
-> Options Postscript V2 Double
-> QDiagram Postscript V2 Double m
-> (Options Postscript V2 Double, Transformation V2 Double,
QDiagram Postscript V2 Double m)
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 r) = RenderM ()
r
getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib :: (a -> b) -> RenderM (Maybe b)
getStyleAttrib a -> b
f = ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Maybe a -> Maybe b)
-> (Style V2 Double -> Maybe a) -> Style V2 Double -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style V2 Double -> Maybe a
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr) (Style V2 Double -> Maybe b)
-> StateStackT PostscriptState Render (Style V2 Double)
-> RenderM (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Style V2 Double) PostscriptState (Style V2 Double)
-> StateStackT PostscriptState Render (Style V2 Double)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Style V2 Double) PostscriptState (Style V2 Double)
Lens' PostscriptState (Style V2 Double)
accumStyle
toRender :: RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender :: RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender (Node (RPrim Prim Postscript V2 Double
p) Forest (RNode Postscript V2 Double a)
_) = Postscript
-> Prim Postscript V2 Double
-> Render
Postscript
(V (Prim Postscript V2 Double))
(N (Prim Postscript V2 Double))
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) Forest (RNode Postscript V2 Double a)
rs) = RenderM () -> Render Postscript V2 Double
C (RenderM () -> Render Postscript V2 Double)
-> RenderM () -> Render Postscript V2 Double
forall a b. (a -> b) -> a -> b
$ do
RenderM ()
save
Style V2 Double -> RenderM ()
forall (v :: * -> *). Style v Double -> RenderM ()
postscriptStyle Style V2 Double
sty
(Style V2 Double -> Identity (Style V2 Double))
-> PostscriptState -> Identity PostscriptState
Lens' PostscriptState (Style V2 Double)
accumStyle ((Style V2 Double -> Identity (Style V2 Double))
-> PostscriptState -> Identity PostscriptState)
-> (Style V2 Double -> Style V2 Double) -> RenderM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Style V2 Double -> Style V2 Double -> Style V2 Double
forall a. Semigroup a => a -> a -> a
<> Style V2 Double
sty)
Render Postscript V2 Double -> RenderM ()
runC (Render Postscript V2 Double -> RenderM ())
-> Render Postscript V2 Double -> RenderM ()
forall a b. (a -> b) -> a -> b
$ (RTree Postscript V2 Double a -> Render Postscript V2 Double)
-> Forest (RNode Postscript V2 Double a)
-> Render Postscript V2 Double
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap RTree Postscript V2 Double a -> Render Postscript V2 Double
forall a.
RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender Forest (RNode Postscript V2 Double a)
rs
RenderM ()
restore
toRender (Node RNode Postscript V2 Double a
_ Forest (RNode Postscript V2 Double a)
rs) = (RTree Postscript V2 Double a -> Render Postscript V2 Double)
-> Forest (RNode Postscript V2 Double a)
-> Render Postscript V2 Double
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap RTree Postscript V2 Double a -> Render Postscript V2 Double
forall a.
RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender Forest (RNode Postscript V2 Double a)
rs
instance Hashable (Options Postscript V2 Double) where
hashWithSalt :: Int -> Options Postscript V2 Double -> Int
hashWithSalt Int
s (PostscriptOptions fn sz out) =
Int
s Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` String
fn
Int -> SizeSpec V2 Double -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` SizeSpec V2 Double
sz
Int -> OutputFormat -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` OutputFormat
out
psfileName :: Lens' (Options Postscript V2 Double) String
psfileName :: (String -> f String)
-> Options Postscript V2 Double -> f (Options Postscript V2 Double)
psfileName = (Options Postscript V2 Double -> String)
-> (Options Postscript V2 Double
-> String -> Options Postscript V2 Double)
-> Lens' (Options Postscript V2 Double) String
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(PostscriptOptions {_psfileName = f}) -> String
f)
(\Options Postscript V2 Double
o String
f -> Options Postscript V2 Double
R:OptionsPostscriptV2Double
o {_psfileName :: String
_psfileName = String
f})
psSizeSpec :: Lens' (Options Postscript V2 Double) (SizeSpec V2 Double)
psSizeSpec :: (SizeSpec V2 Double -> f (SizeSpec V2 Double))
-> Options Postscript V2 Double -> f (Options Postscript V2 Double)
psSizeSpec = (Options Postscript V2 Double -> SizeSpec V2 Double)
-> (Options Postscript V2 Double
-> SizeSpec V2 Double -> Options Postscript V2 Double)
-> Lens' (Options Postscript V2 Double) (SizeSpec V2 Double)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(PostscriptOptions {_psSizeSpec = s}) -> SizeSpec V2 Double
s)
(\Options Postscript V2 Double
o SizeSpec V2 Double
s -> Options Postscript V2 Double
R:OptionsPostscriptV2Double
o {_psSizeSpec :: SizeSpec V2 Double
_psSizeSpec = SizeSpec V2 Double
s})
psOutputFormat :: Lens' (Options Postscript V2 Double) OutputFormat
psOutputFormat :: (OutputFormat -> f OutputFormat)
-> Options Postscript V2 Double -> f (Options Postscript V2 Double)
psOutputFormat = (Options Postscript V2 Double -> OutputFormat)
-> (Options Postscript V2 Double
-> OutputFormat -> Options Postscript V2 Double)
-> Lens' (Options Postscript V2 Double) OutputFormat
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(PostscriptOptions {_psOutputFormat = t}) -> OutputFormat
t)
(\Options Postscript V2 Double
o OutputFormat
t -> Options Postscript V2 Double
R:OptionsPostscriptV2Double
o {_psOutputFormat :: OutputFormat
_psOutputFormat = OutputFormat
t})
renderDias :: (Semigroup m, Monoid m) =>
Options Postscript V2 Double -> [QDiagram Postscript V2 Double m] -> IO [()]
renderDias :: 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
optsOptions Postscript V2 Double
-> Getting OutputFormat (Options Postscript V2 Double) OutputFormat
-> OutputFormat
forall s a. s -> Getting a s a -> a
^.Getting OutputFormat (Options Postscript V2 Double) OutputFormat
Lens' (Options Postscript V2 Double) OutputFormat
psOutputFormat of
OutputFormat
EPS -> String -> Int -> Int -> (Surface -> IO [()]) -> IO [()]
forall r. String -> Int -> Int -> (Surface -> r) -> r
C.withEPSSurface (Options Postscript V2 Double
optsOptions Postscript V2 Double
-> Getting String (Options Postscript V2 Double) String -> String
forall s a. s -> Getting a s a -> a
^.Getting String (Options Postscript V2 Double) String
Lens' (Options Postscript V2 Double) String
psfileName) (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Double
w) (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Double
h) Surface -> IO [()]
surfaceF
where
surfaceF :: Surface -> IO [()]
surfaceF Surface
surface = Surface -> [Render ()] -> IO [()]
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 = (QDiagram Postscript V2 Double m
-> (Options Postscript V2 Double, QDiagram Postscript V2 Double m))
-> [QDiagram Postscript V2 Double m]
-> [(Options Postscript V2 Double,
QDiagram Postscript V2 Double m)]
forall a b. (a -> b) -> [a] -> [b]
map ((Options Postscript V2 Double, Transformation V2 Double,
QDiagram Postscript V2 Double m)
-> (Options Postscript V2 Double, QDiagram Postscript V2 Double m)
forall a b b. (a, b, b) -> (a, b)
dropMid ((Options Postscript V2 Double, Transformation V2 Double,
QDiagram Postscript V2 Double m)
-> (Options Postscript V2 Double, QDiagram Postscript V2 Double m))
-> (QDiagram Postscript V2 Double m
-> (Options Postscript V2 Double, Transformation V2 Double,
QDiagram Postscript V2 Double m))
-> QDiagram Postscript V2 Double m
-> (Options Postscript V2 Double, QDiagram Postscript V2 Double m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Postscript
-> Options Postscript V2 Double
-> QDiagram Postscript V2 Double m
-> (Options Postscript V2 Double, Transformation V2 Double,
QDiagram Postscript V2 Double m)
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 = Double -> Transformation V2 Double
forall (v :: * -> *) n.
(Additive v, Fractional n) =>
n -> Transformation v n
scaling (Double -> Double
forall a. Floating a => a -> a
sqrt (Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
h))
rs :: [Render ()]
rs = ((Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> Render ())
-> [(Options Postscript V2 Double,
QDiagram Postscript V2 Double m)]
-> [Render ()]
forall a b. (a -> b) -> [a] -> [b]
map (RenderM () -> Render ()
forall a. RenderM a -> Render a
runRenderM (RenderM () -> Render ())
-> ((Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> RenderM ())
-> (Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render Postscript V2 Double -> RenderM ()
runC (Render Postscript V2 Double -> RenderM ())
-> ((Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> Render Postscript V2 Double)
-> (Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTree Postscript V2 Double Annotation
-> Render Postscript V2 Double
forall a.
RTree Postscript V2 Double a -> Render Postscript V2 Double
toRender (RTree Postscript V2 Double Annotation
-> Render Postscript V2 Double)
-> ((Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> RTree Postscript V2 Double Annotation)
-> (Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> Render Postscript V2 Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation V2 Double
-> QDiagram Postscript V2 Double m
-> RTree Postscript V2 Double Annotation
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 (QDiagram Postscript V2 Double m
-> RTree Postscript V2 Double Annotation)
-> ((Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> QDiagram Postscript V2 Double m)
-> (Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> RTree Postscript V2 Double Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> QDiagram Postscript V2 Double m
forall a b. (a, b) -> b
snd) [(Options Postscript V2 Double, QDiagram Postscript V2 Double m)]
optsdss
sizes :: [V2 Double]
sizes = ((Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> V2 Double)
-> [(Options Postscript V2 Double,
QDiagram Postscript V2 Double m)]
-> [V2 Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> SizeSpec V2 Double -> V2 Double
forall (v :: * -> *) n.
(Foldable v, Functor v, Num n, Ord n) =>
n -> SizeSpec v n -> v n
specToSize Double
1 (SizeSpec V2 Double -> V2 Double)
-> ((Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> SizeSpec V2 Double)
-> (Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> V2 Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
(SizeSpec V2 Double)
(Options Postscript V2 Double)
(SizeSpec V2 Double)
-> Options Postscript V2 Double -> SizeSpec V2 Double
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(SizeSpec V2 Double)
(Options Postscript V2 Double)
(SizeSpec V2 Double)
Lens' (Options Postscript V2 Double) (SizeSpec V2 Double)
psSizeSpec (Options Postscript V2 Double -> SizeSpec V2 Double)
-> ((Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> Options Postscript V2 Double)
-> (Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> SizeSpec V2 Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Options Postscript V2 Double, QDiagram Postscript V2 Double m)
-> Options Postscript V2 Double
forall a b. (a, b) -> a
fst) [(Options Postscript V2 Double, QDiagram Postscript V2 Double m)]
optsdss
V2 Double
w Double
h = (V2 Double -> V2 Double -> V2 Double)
-> V2 Double -> [V2 Double] -> V2 Double
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> a) -> a -> t a -> a
foldBy ((Double -> Double -> Double) -> V2 Double -> V2 Double -> V2 Double
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Double -> Double -> Double
forall a. Ord a => a -> a -> a
max) V2 Double
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 :: a -> RenderM ()
renderC = Render Postscript V2 Double -> RenderM ()
runC (Render Postscript V2 Double -> RenderM ())
-> (a -> Render Postscript V2 Double) -> a -> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Postscript -> a -> Render Postscript (V a) (N a)
forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render Postscript
Postscript
postscriptStyle :: Style v Double -> RenderM ()
postscriptStyle :: Style v Double -> RenderM ()
postscriptStyle Style v Double
s =
[RenderM ()] -> RenderM ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
([RenderM ()] -> RenderM ())
-> ([Maybe (RenderM ())] -> [RenderM ()])
-> [Maybe (RenderM ())]
-> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (RenderM ())] -> [RenderM ()]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (RenderM ())] -> RenderM ())
-> [Maybe (RenderM ())] -> RenderM ()
forall a b. (a -> b) -> a -> b
$ [ (Clip Double -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle Clip Double -> RenderM ()
clip
, (FillRule -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle FillRule -> RenderM ()
lFillRule
, (LineWidth Double -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineWidth Double -> RenderM ()
lWidth
, (LineJoin -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineJoin -> RenderM ()
lJoin
, (LineMiterLimit -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineMiterLimit -> RenderM ()
lMiter
, (LineCap -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineCap -> RenderM ()
lCap
, (Dashing Double -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle Dashing Double -> RenderM ()
lDashing
]
where
handle :: AttributeClass a => (a -> RenderM ()) -> Maybe (RenderM ())
handle :: (a -> RenderM ()) -> Maybe (RenderM ())
handle a -> RenderM ()
f = a -> RenderM ()
f (a -> RenderM ()) -> Maybe a -> Maybe (RenderM ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Style v Double -> Maybe a
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v Double
s
clip :: Clip Double -> RenderM ()
clip = (Path V2 Double -> RenderM ()) -> [Path V2 Double] -> RenderM ()
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 RenderM () -> RenderM () -> RenderM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.clip) ([Path V2 Double] -> RenderM ())
-> (Clip Double -> [Path V2 Double]) -> Clip Double -> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unwrapped (Clip Double) -> Clip Double)
-> Clip Double -> Unwrapped (Clip Double)
forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op Unwrapped (Clip Double) -> Clip Double
forall n. [Path V2 n] -> Clip n
Clip
lFillRule :: FillRule -> RenderM ()
lFillRule = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ())
-> (FillRule -> Render ()) -> FillRule -> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter RenderState RenderState FillRule FillRule
-> FillRule -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState
Lens' RenderState DrawState
C.drawState ((DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState)
-> ((FillRule -> Identity FillRule)
-> DrawState -> Identity DrawState)
-> ASetter RenderState RenderState FillRule FillRule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FillRule -> Identity FillRule) -> DrawState -> Identity DrawState
Lens' DrawState FillRule
C.fillRule) (FillRule -> Render ())
-> (FillRule -> FillRule) -> FillRule -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FillRule -> FillRule
getFillRule
lWidth :: LineWidth Double -> RenderM ()
lWidth = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ())
-> (LineWidth Double -> Render ())
-> LineWidth Double
-> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Render ()
C.lineWidth (Double -> Render ())
-> (LineWidth Double -> Double) -> LineWidth Double -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineWidth Double -> Double
forall n. LineWidth n -> n
getLineWidth
lCap :: LineCap -> RenderM ()
lCap = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ())
-> (LineCap -> Render ()) -> LineCap -> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> Render ()
C.lineCap (LineCap -> Render ())
-> (LineCap -> LineCap) -> LineCap -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> LineCap
getLineCap
lJoin :: LineJoin -> RenderM ()
lJoin = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ())
-> (LineJoin -> Render ()) -> LineJoin -> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> Render ()
C.lineJoin (LineJoin -> Render ())
-> (LineJoin -> LineJoin) -> LineJoin -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> LineJoin
getLineJoin
lMiter :: LineMiterLimit -> RenderM ()
lMiter = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ())
-> (LineMiterLimit -> Render ()) -> LineMiterLimit -> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Render ()
C.miterLimit (Double -> Render ())
-> (LineMiterLimit -> Double) -> LineMiterLimit -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineMiterLimit -> Double
getLineMiterLimit
lDashing :: Dashing Double -> RenderM ()
lDashing (Dashing Double -> Dashing Double
forall n. Dashing n -> Dashing n
getDashing -> Dashing [Double]
ds Double
offs) = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
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) = Transformation V2 Double -> V2 Double -> V2 Double
forall (v :: * -> *) n. Transformation v n -> v n -> v n
apply Transformation V2 Double
t V2 Double
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX
(V2 Double
b1 Double
b2) = Transformation V2 Double -> V2 Double -> V2 Double
forall (v :: * -> *) n. Transformation v n -> v n -> v n
apply Transformation V2 Double
t V2 Double
forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY
(V2 Double
c1 Double
c2) = Transformation V2 Double -> V2 Double
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 (RenderM () -> Render Postscript V2 Double)
-> (Render () -> RenderM ())
-> Render ()
-> Render Postscript V2 Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> Render Postscript V2 Double)
-> Render () -> Render Postscript V2 Double
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Render ()) -> (Double, Double) -> Render ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Render ()
C.relLineTo (V2 Double -> (Double, Double)
forall n. V2 n -> (n, n)
unr2 V2 Double
v)
render Postscript
_ (Cubic (V2 Double -> (Double, Double)
forall n. V2 n -> (n, n)
unr2 -> (Double
x1, Double
y1))
(V2 Double -> (Double, Double)
forall n. V2 n -> (n, n)
unr2 -> (Double
x2, Double
y2))
(OffsetClosed (V2 Double -> (Double, Double)
forall n. V2 n -> (n, n)
unr2 -> (Double
x3, Double
y3))))
= RenderM () -> Render Postscript V2 Double
C (RenderM () -> Render Postscript V2 Double)
-> (Render () -> RenderM ())
-> Render ()
-> Render Postscript V2 Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> Render Postscript V2 Double)
-> Render () -> Render Postscript V2 Double
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
_ = (Trail' Line V2 Double -> Render Postscript V2 Double)
-> (Trail' Loop V2 Double -> Render Postscript V2 Double)
-> Trail V2 Double
-> Render Postscript V2 Double
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 (RenderM () -> Render Postscript V2 Double)
-> RenderM () -> Render Postscript V2 Double
forall a b. (a -> b) -> a -> b
$ do
(Segment Closed V2 Double -> RenderM ())
-> [Segment Closed V2 Double] -> RenderM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Segment Closed V2 Double -> RenderM ()
forall a.
(Renderable a Postscript, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC (Trail' Line V2 Double -> [Segment Closed V2 Double]
forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments Trail' Line V2 Double
ln)
(Bool -> Identity Bool)
-> PostscriptState -> Identity PostscriptState
Lens' PostscriptState Bool
ignoreFill ((Bool -> Identity Bool)
-> PostscriptState -> Identity PostscriptState)
-> Bool -> RenderM ()
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 (RenderM () -> Render Postscript V2 Double)
-> RenderM () -> Render Postscript V2 Double
forall a b. (a -> b) -> a -> b
$ do
case Trail' Loop V2 Double
-> ([Segment Closed V2 Double], Segment Open V2 Double)
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
_) -> (Segment Closed V2 Double -> RenderM ())
-> [Segment Closed V2 Double] -> RenderM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Segment Closed V2 Double -> RenderM ()
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)
_ -> (Segment Closed V2 Double -> RenderM ())
-> [Segment Closed V2 Double] -> RenderM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Segment Closed V2 Double -> RenderM ()
forall a.
(Renderable a Postscript, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC (Trail' Line V2 Double -> [Segment Closed V2 Double]
forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments (Trail' Line V2 Double -> [Segment Closed V2 Double])
-> (Trail' Loop V2 Double -> Trail' Line V2 Double)
-> Trail' Loop V2 Double
-> [Segment Closed V2 Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trail' Loop V2 Double -> Trail' Line V2 Double
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail' Loop v n -> Trail' Line v n
cutLoop (Trail' Loop V2 Double -> [Segment Closed V2 Double])
-> Trail' Loop V2 Double -> [Segment Closed V2 Double]
forall a b. (a -> b) -> a -> b
$ Trail' Loop V2 Double
lp)
Render () -> RenderM ()
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 (RenderM () -> Render Postscript V2 Double)
-> RenderM () -> Render Postscript V2 Double
forall a b. (a -> b) -> a -> b
$ do
Path V2 Double -> RenderM ()
postscriptPath Path V2 Double
p
Maybe (Texture Double)
f <- (FillTexture Double -> Texture Double)
-> RenderM (Maybe (Texture Double))
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FillTexture Double -> Texture Double
forall n. FillTexture n -> Texture n
getFillTexture
Maybe (Texture Double)
s <- (LineTexture Double -> Texture Double)
-> RenderM (Maybe (Texture Double))
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib LineTexture Double -> Texture Double
forall n. LineTexture n -> Texture n
getLineTexture
Maybe CMYK
fk <- (FillColorCMYK -> CMYK) -> RenderM (Maybe CMYK)
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FillColorCMYK -> CMYK
getFillColorCMYK
Maybe CMYK
sk <- (LineColorCMYK -> CMYK) -> RenderM (Maybe CMYK)
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib LineColorCMYK -> CMYK
getLineColorCMYK
Bool
ign <- Getting Bool PostscriptState Bool
-> StateStackT PostscriptState Render Bool
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Bool PostscriptState Bool
Lens' PostscriptState Bool
ignoreFill
Maybe (Texture Double) -> Maybe CMYK -> RenderM ()
setFillColor Maybe (Texture Double)
f Maybe CMYK
fk
Bool -> RenderM () -> RenderM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Maybe (Texture Double) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Texture Double)
f Bool -> Bool -> Bool
|| Maybe CMYK -> Bool
forall a. Maybe a -> Bool
isJust Maybe CMYK
fk) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ign) (RenderM () -> RenderM ()) -> RenderM () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.fillPreserve
Maybe (Texture Double) -> Maybe CMYK -> RenderM ()
setStrokeColor Maybe (Texture Double)
s Maybe CMYK
sk
Render () -> RenderM ()
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
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ Render ()
-> (Texture Double -> Render ())
-> Maybe (Texture Double)
-> Render ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Render ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Texture Double -> Render ()
forall n. Texture n -> Render ()
C.fillColor Maybe (Texture Double)
c
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ Render () -> (CMYK -> Render ()) -> Maybe CMYK -> Render ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Render ()
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
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ Render ()
-> (Texture Double -> Render ())
-> Maybe (Texture Double)
-> Render ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Render ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Texture Double -> Render ()
forall n. Texture n -> Render ()
C.strokeColor Maybe (Texture Double)
c
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ Render () -> (CMYK -> Render ()) -> Maybe CMYK -> Render ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Render ()
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
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.newPath
(Bool -> Identity Bool)
-> PostscriptState -> Identity PostscriptState
Lens' PostscriptState Bool
ignoreFill ((Bool -> Identity Bool)
-> PostscriptState -> Identity PostscriptState)
-> Bool -> RenderM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
(Located (Trail V2 Double) -> RenderM ())
-> [Located (Trail V2 Double)] -> RenderM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ Located (Trail V2 Double) -> RenderM ()
forall a.
(Renderable a Postscript, V a ~ V2, N a ~ Double) =>
Located a -> RenderM ()
renderTrail [Located (Trail V2 Double)]
trs
where renderTrail :: Located a -> RenderM ()
renderTrail (Located a -> (Point (V a) (N a), a)
forall a. Located a -> (Point (V a) (N a), a)
viewLoc -> (Point (V a) (N a) -> (Double, Double)
forall n. P2 n -> (n, n)
unp2 -> (Double, Double)
pt, a
tr)) = do
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Render ()) -> (Double, Double) -> Render ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Render ()
C.moveTo (Double, Double)
pt
a -> RenderM ()
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' :: (a -> m ()) -> Maybe a -> m ()
if' = m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
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 (RenderM () -> Render Postscript V2 Double)
-> RenderM () -> Render Postscript V2 Double
forall a b. (a -> b) -> a -> b
$ do
Maybe String
ff <- (Font -> String) -> RenderM (Maybe String)
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib Font -> String
getFont
Maybe FontSlant
fs <- (FontSlant -> FontSlant) -> RenderM (Maybe FontSlant)
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib (FontSlant -> FontSlant
fromFontSlant (FontSlant -> FontSlant)
-> (FontSlant -> FontSlant) -> FontSlant -> FontSlant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontSlant -> FontSlant
getFontSlant)
Maybe FontWeight
fw <- (FontWeight -> FontWeight) -> RenderM (Maybe FontWeight)
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib (FontWeight -> FontWeight
fromFontWeight (FontWeight -> FontWeight)
-> (FontWeight -> FontWeight) -> FontWeight -> FontWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontWeight -> FontWeight
getFontWeight)
Maybe Double
size' <- (FontSize Double -> Double) -> RenderM (Maybe Double)
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FontSize Double -> Double
forall n. FontSize n -> n
getFontSize
Maybe (Texture Double)
f <- (FillTexture Double -> Texture Double)
-> RenderM (Maybe (Texture Double))
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FillTexture Double -> Texture Double
forall n. FillTexture n -> Texture n
getFillTexture
Maybe CMYK
fk <- (FillColorCMYK -> CMYK) -> RenderM (Maybe CMYK)
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
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ do
(Double -> Render ()) -> Maybe Double -> Render ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (ASetter RenderState RenderState Double Double
-> Double -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState
Lens' RenderState DrawState
C.drawState ((DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState)
-> ((Double -> Identity Double) -> DrawState -> Identity DrawState)
-> ASetter RenderState RenderState Double Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PostscriptFont -> Identity PostscriptFont)
-> DrawState -> Identity DrawState
Lens' DrawState PostscriptFont
C.font ((PostscriptFont -> Identity PostscriptFont)
-> DrawState -> Identity DrawState)
-> ((Double -> Identity Double)
-> PostscriptFont -> Identity PostscriptFont)
-> (Double -> Identity Double)
-> DrawState
-> Identity DrawState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Identity Double)
-> PostscriptFont -> Identity PostscriptFont
Lens' PostscriptFont Double
C.size)) Maybe Double
size'
(String -> Render ()) -> Maybe String -> Render ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (ASetter RenderState RenderState String String
-> String -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState
Lens' RenderState DrawState
C.drawState ((DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState)
-> ((String -> Identity String) -> DrawState -> Identity DrawState)
-> ASetter RenderState RenderState String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PostscriptFont -> Identity PostscriptFont)
-> DrawState -> Identity DrawState
Lens' DrawState PostscriptFont
C.font ((PostscriptFont -> Identity PostscriptFont)
-> DrawState -> Identity DrawState)
-> ((String -> Identity String)
-> PostscriptFont -> Identity PostscriptFont)
-> (String -> Identity String)
-> DrawState
-> Identity DrawState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Identity String)
-> PostscriptFont -> Identity PostscriptFont
Lens' PostscriptFont String
C.face)) Maybe String
ff
(FontSlant -> Render ()) -> Maybe FontSlant -> Render ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (ASetter RenderState RenderState FontSlant FontSlant
-> FontSlant -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState
Lens' RenderState DrawState
C.drawState ((DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState)
-> ((FontSlant -> Identity FontSlant)
-> DrawState -> Identity DrawState)
-> ASetter RenderState RenderState FontSlant FontSlant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PostscriptFont -> Identity PostscriptFont)
-> DrawState -> Identity DrawState
Lens' DrawState PostscriptFont
C.font ((PostscriptFont -> Identity PostscriptFont)
-> DrawState -> Identity DrawState)
-> ((FontSlant -> Identity FontSlant)
-> PostscriptFont -> Identity PostscriptFont)
-> (FontSlant -> Identity FontSlant)
-> DrawState
-> Identity DrawState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FontSlant -> Identity FontSlant)
-> PostscriptFont -> Identity PostscriptFont
Lens' PostscriptFont FontSlant
C.slant)) Maybe FontSlant
fs
(FontWeight -> Render ()) -> Maybe FontWeight -> Render ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (ASetter RenderState RenderState FontWeight FontWeight
-> FontWeight -> Render ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState
Lens' RenderState DrawState
C.drawState ((DrawState -> Identity DrawState)
-> RenderState -> Identity RenderState)
-> ((FontWeight -> Identity FontWeight)
-> DrawState -> Identity DrawState)
-> ASetter RenderState RenderState FontWeight FontWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PostscriptFont -> Identity PostscriptFont)
-> DrawState -> Identity DrawState
Lens' DrawState PostscriptFont
C.font ((PostscriptFont -> Identity PostscriptFont)
-> DrawState -> Identity DrawState)
-> ((FontWeight -> Identity FontWeight)
-> PostscriptFont -> Identity PostscriptFont)
-> (FontWeight -> Identity FontWeight)
-> DrawState
-> Identity DrawState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FontWeight -> Identity FontWeight)
-> PostscriptFont -> Identity PostscriptFont
Lens' PostscriptFont FontWeight
C.weight)) Maybe FontWeight
fw
Bool -> RenderM () -> RenderM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Texture Double) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Texture Double)
f Bool -> Bool -> Bool
|| Maybe CMYK -> Bool
forall a. Maybe a -> Bool
isJust Maybe CMYK
fk) (RenderM () -> RenderM ()) -> RenderM () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.fillPreserve
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
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 -> Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ Double -> Double -> String -> Render ()
C.showTextAlign Double
xt Double
yt String
str
TextAlignment Double
BaselineText -> Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Render ()
C.moveTo Double
0 Double
0 Render () -> Render () -> Render ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Render ()
C.showText String
str
RenderM ()
restore