module Diagrams.Backend.Postscript
(
Postscript(..)
, B
, Options(..), psfileName, psSizeSpec, psOutputFormat
, OutputFormat(..)
) where
import qualified Graphics.Rendering.Postscript as C
import Diagrams.Prelude hiding (view)
import Diagrams.TwoD.Adjust (adjustDia2D)
import Diagrams.TwoD.Path (Clip (Clip), getFillRule)
import Diagrams.TwoD.Text
import Diagrams.TwoD.Types
import Control.Lens hiding (transform)
import Control.Monad (when)
import Data.Maybe (catMaybes)
import qualified Data.Foldable as F
import Data.Hashable (Hashable)
import qualified Data.List.NonEmpty as N
import Data.Monoid.Split
import Data.Typeable
import GHC.Generics (Generic)
data Postscript = Postscript
deriving (Eq,Ord,Read,Show,Typeable)
type B = Postscript
data OutputFormat = EPS
deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Generic)
instance Hashable OutputFormat
instance Monoid (Render Postscript R2) where
mempty = C $ return ()
(C x) `mappend` (C y) = C (x >> y)
instance Backend Postscript R2 where
data Render Postscript R2 = C (C.Render ())
type Result Postscript R2 = IO ()
data Options Postscript R2 = PostscriptOptions
{ _psfileName :: String
, _psSizeSpec :: SizeSpec2D
, _psOutputFormat :: OutputFormat
}
deriving (Show, Generic)
withStyle _ s t (C r) = C $ do
C.save
postscriptMiscStyle s
r
postscriptTransf t
postscriptStyle s
C.stroke
C.restore
doRender _ (PostscriptOptions file size out) (C r) =
let surfaceF surface = C.renderWith surface r
(w,h) = sizeFromSpec size
in case out of
EPS -> C.withEPSSurface file (round w) (round h) surfaceF
adjustDia c opts d = adjustDia2D _psSizeSpec setPsSize c opts d
where setPsSize sz o = o { _psSizeSpec = sz }
instance Hashable (Options Postscript R2)
sizeFromSpec :: SizeSpec2D -> (Double, Double)
sizeFromSpec size = case size of
Width w' -> (w',w')
Height h' -> (h',h')
Dims w' h' -> (w',h')
Absolute -> (100,100)
psfileName :: Lens' (Options Postscript R2) String
psfileName = lens (\(PostscriptOptions {_psfileName = f}) -> f)
(\o f -> o {_psfileName = f})
psSizeSpec :: Lens' (Options Postscript R2) SizeSpec2D
psSizeSpec = lens (\(PostscriptOptions {_psSizeSpec = s}) -> s)
(\o s -> o {_psSizeSpec = s})
psOutputFormat :: Lens' (Options Postscript R2) OutputFormat
psOutputFormat = lens (\(PostscriptOptions {_psOutputFormat = t}) -> t)
(\o t -> o {_psOutputFormat = t})
instance MultiBackend Postscript R2 where
renderDias b opts ds = doRenderPages b (combineSizes (map fst rs)) (map snd rs) >> return ()
where
mkMax (x,y) = (Max x, Max y)
fromMaxPair (Max x, Max y) = (x,y)
rs = map mkRender ds
mkRender d = (opts', mconcat . map renderOne . prims $ d')
where
(opts', d') = adjustDia b opts d
renderOne (p, (M t, s)) = withStyle b s mempty (render b (transform t p))
renderOne (p, (t1 :| t2, s)) = withStyle b s t1 (render b (transform (t1 <> t2) p))
combineSizes [] = PostscriptOptions "" (Dims 100 100) EPS
combineSizes (o:os) = o { _psSizeSpec = uncurry Dims . fromMaxPair . sconcat $ f o N.:| fmap f os }
where f = mkMax . sizeFromSpec . _psSizeSpec
doRenderPages _ (PostscriptOptions file size out) pages =
let surfaceF surface = C.renderPagesWith surface (map (\(C r) -> r) pages)
(w,h) = sizeFromSpec size
in case out of
EPS -> C.withEPSSurface file (round w) (round h) surfaceF
renderC :: (Renderable a Postscript, V a ~ R2) => a -> C.Render ()
renderC a = case render Postscript a of C r -> r
postscriptMiscStyle :: Style v -> C.Render ()
postscriptMiscStyle s =
sequence_
. catMaybes $ [ handle clip
, handle fFace
, handle fSlant
, handle fWeight
, handle fSize
, handle fColor
, handle lFillRule
]
where
handle :: AttributeClass a => (a -> C.Render ()) -> Maybe (C.Render ())
handle f = f `fmap` getAttr s
clip = mapM_ (\p -> renderC p >> C.clip) . op Clip
fSize = assign (C.drawState . C.font . C.size) <$> getFontSize
fFace = assign (C.drawState . C.font . C.face) <$> getFont
fSlant = assign (C.drawState . C.font . C.slant) .fromFontSlant <$> getFontSlant
fWeight = assign (C.drawState . C.font . C.weight) . fromFontWeight <$> getFontWeight
fColor c = C.fillColor (getFillColor c)
lFillRule = assign (C.drawState . C.fillRule) . getFillRule
fromFontSlant :: FontSlant -> C.FontSlant
fromFontSlant FontSlantNormal = C.FontSlantNormal
fromFontSlant FontSlantItalic = C.FontSlantItalic
fromFontSlant FontSlantOblique = C.FontSlantOblique
fromFontWeight :: FontWeight -> C.FontWeight
fromFontWeight FontWeightNormal = C.FontWeightNormal
fromFontWeight FontWeightBold = C.FontWeightBold
postscriptStyle :: Style v -> C.Render ()
postscriptStyle s = sequence_
. catMaybes $ [ handle fColor
, handle lColor
, handle lWidth
, handle lJoin
, handle lMiter
, handle lCap
, handle lDashing
]
where handle :: (AttributeClass a) => (a -> C.Render ()) -> Maybe (C.Render ())
handle f = f `fmap` getAttr s
lColor = C.strokeColor . getLineColor
fColor c = C.fillColor (getFillColor c) >> C.fillPreserve
lWidth = C.lineWidth . getLineWidth
lCap = C.lineCap . getLineCap
lJoin = C.lineJoin . getLineJoin
lMiter = C.miterLimit . getLineMiterLimit
lDashing (getDashing -> Dashing ds offs) =
C.setDash ds offs
postscriptTransf :: Transformation R2 -> C.Render ()
postscriptTransf t = C.transform a1 a2 b1 b2 c1 c2
where (R2 a1 a2) = apply t unitX
(R2 b1 b2) = apply t unitY
(R2 c1 c2) = transl t
instance Renderable (Segment Closed R2) Postscript where
render _ (Linear (OffsetClosed (R2 x y))) = C $ C.relLineTo x y
render _ (Cubic (R2 x1 y1)
(R2 x2 y2)
(OffsetClosed (R2 x3 y3)))
= C $ C.relCurveTo x1 y1 x2 y2 x3 y3
instance Renderable (Trail R2) Postscript where
render _ t = flip withLine t $ renderT . lineSegments
where
renderT segs =
C $ do
mapM_ renderC segs
when (isLoop t) C.closePath
when (isLine t) $ (C.drawState . C.ignoreFill) .= True
instance Renderable (Path R2) Postscript where
render _ p = C $ C.newPath >> F.mapM_ renderTrail (op Path p)
where renderTrail (viewLoc -> (unp2 -> pt, tr)) = do
uncurry C.moveTo pt
renderC tr
instance Renderable Text Postscript where
render _ (Text tr al str) = C $ do
C.save
postscriptTransf tr
case al of
BoxAlignedText xt yt -> C.showTextAlign xt yt str
BaselineText -> C.moveTo 0 0 >> C.showText str
C.restore