module Diagrams.Backend.Postscript
(
Postscript(..)
, B
, Options(..), psfileName, psSizeSpec, psOutputFormat
, OutputFormat(..)
) where
import qualified Graphics.Rendering.Postscript as C
import Diagrams.Backend.Postscript.CMYK
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)
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) where
hashWithSalt s (PostscriptOptions fn sz out) =
s `hashWithSalt` fn
`hashWithSalt` sz
`hashWithSalt` out
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 fColorCMYK
, 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)
fColorCMYK c = C.fillColorCMYK (getFillColorCMYK 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 fColorCMYK
, handle lColor
, handle lColorCMYK
, 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
lColorCMYK = C.strokeColorCMYK . getLineColorCMYK
fColor c = C.fillColor (getFillColor c) >> C.fillPreserve
fColorCMYK c = C.fillColorCMYK (getFillColorCMYK 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