module Wumpus.Core.OutputPostScript
(
writePS
, writeEPS
, writePS_latin1
, writeEPS_latin1
) where
import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.FormatCombinators
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicsState
import Wumpus.Core.OneList
import Wumpus.Core.PictureInternal
import Wumpus.Core.PostScriptDoc
import Wumpus.Core.TextEncoder
import Wumpus.Core.TextInternal
import Wumpus.Core.TextLatin1
import Wumpus.Core.Utils
import Control.Applicative hiding ( empty, some )
import Control.Monad
import qualified Data.Foldable as F
import Data.Maybe
import Data.Time
newtype PsMonad a = PsMonad {
getPsMonad :: TextEncoder -> GraphicsState -> (a,GraphicsState) }
instance Functor PsMonad where
fmap f mf = PsMonad $ \r s -> let (a,s1) = getPsMonad mf r s in (f a,s1)
instance Applicative PsMonad where
pure a = PsMonad $ \_ s -> (a,s)
mf <*> ma = PsMonad $ \r s -> let (f,s1) = getPsMonad mf r s
(a,s2) = getPsMonad ma r s1
in (f a,s2)
instance Monad PsMonad where
return a = PsMonad $ \_ s -> (a,s)
m >>= k = PsMonad $ \r s -> let (a,s1) = getPsMonad m r s
in (getPsMonad . k) a r s1
runPsMonad :: TextEncoder -> PsMonad a -> a
runPsMonad enc mf = fst $ getPsMonad mf enc zeroGS
askCharCode :: Int -> PsMonad (Either GlyphName GlyphName)
askCharCode i = PsMonad $ \r s -> case lookupByCharCode i r of
Just n -> (Right n,s)
Nothing -> (Left $ ps_fallback r,s)
getDrawColour :: PsMonad RGBi
getDrawColour = PsMonad $ \_ s -> (gs_draw_colour s, s)
setDrawColour :: RGBi -> PsMonad ()
setDrawColour a = PsMonad $ \_ s -> ((), s {gs_draw_colour=a})
getFontAttr :: PsMonad FontAttr
getFontAttr = PsMonad $ \_ s -> let sz = gs_font_size s
ff = gs_font_face s
in (FontAttr sz ff, s)
setFontAttr :: FontAttr -> PsMonad ()
setFontAttr (FontAttr sz ff) =
PsMonad $ \_ s -> ((), s { gs_font_size=sz,gs_font_face=ff })
getLineWidth :: PsMonad Double
getLineWidth = PsMonad $ \_ s -> (line_width $ gs_stroke_attr s, s)
setLineWidth :: Double -> PsMonad ()
setLineWidth a = PsMonad $ \_ s ->
((), s { gs_stroke_attr = fn $ gs_stroke_attr s })
where
fn sa = sa { line_width = a }
getMiterLimit :: PsMonad Double
getMiterLimit = PsMonad $ \_ s -> (miter_limit $ gs_stroke_attr s,s)
setMiterLimit :: Double -> PsMonad ()
setMiterLimit a = PsMonad $ \_ s ->
((), s { gs_stroke_attr = fn $ gs_stroke_attr s })
where
fn sa = sa { miter_limit = a }
getLineCap :: PsMonad LineCap
getLineCap = PsMonad $ \_ s -> (line_cap $ gs_stroke_attr s,s)
setLineCap :: LineCap -> PsMonad ()
setLineCap a = PsMonad $ \_ s ->
((), s { gs_stroke_attr = fn $ gs_stroke_attr s })
where
fn sa = sa { line_cap = a }
getLineJoin :: PsMonad LineJoin
getLineJoin = PsMonad $ \_ s -> (line_join $ gs_stroke_attr s,s)
setLineJoin :: LineJoin -> PsMonad ()
setLineJoin a = PsMonad $ \_ s ->
((), s { gs_stroke_attr = fn $ gs_stroke_attr s })
where
fn sa = sa { line_join = a }
getDashPattern :: PsMonad DashPattern
getDashPattern = PsMonad $ \_ s -> (dash_pattern $ gs_stroke_attr s,s)
setDashPattern :: DashPattern -> PsMonad ()
setDashPattern a = PsMonad $ \_ s ->
((), s { gs_stroke_attr = fn $ gs_stroke_attr s })
where
fn sa = sa { dash_pattern = a }
writePS :: (Real u, Floating u, PSUnit u)
=> FilePath -> TextEncoder -> [Picture u] -> IO ()
writePS filepath enc pic =
getZonedTime >>= \ztim -> writeFile filepath (show $ psDraw ztim enc pic)
writeEPS :: (Real u, Floating u, PSUnit u)
=> FilePath -> TextEncoder -> Picture u -> IO ()
writeEPS filepath enc pic =
getZonedTime >>= \ztim -> writeFile filepath (show $ epsDraw ztim enc pic)
writePS_latin1 :: (Real u, Floating u, PSUnit u)
=> FilePath -> [Picture u] -> IO ()
writePS_latin1 filepath = writePS filepath latin1Encoder
writeEPS_latin1 :: (Real u, Floating u, PSUnit u)
=> FilePath -> Picture u -> IO ()
writeEPS_latin1 filepath = writeEPS filepath latin1Encoder
psDraw :: (Real u, Floating u, PSUnit u)
=> ZonedTime -> TextEncoder -> [Picture u] -> Doc
psDraw timestamp enc pics =
let body = vcat $ runPsMonad enc $ zipWithM psDrawPage pages pics
in vcat [ psHeader 1 timestamp
, body
, psFooter
]
where
pages = map (\i -> (show i,i)) [1..]
psDrawPage :: (Real u, Floating u, PSUnit u)
=> (String,Int) -> Picture u -> PsMonad Doc
psDrawPage (lbl,ordinal) pic =
let (_,cmdtrans) = imageTranslation pic in
(\doc -> vcat [ dsc_Page lbl ordinal
, ps_gsave
, cmdtrans
, doc
, ps_grestore
, ps_showpage
])
<$> picture pic
epsDraw :: (Real u, Floating u, PSUnit u)
=> ZonedTime -> TextEncoder -> Picture u -> Doc
epsDraw timestamp enc pic =
let (bb,cmdtrans) = imageTranslation pic
body = runPsMonad enc (picture pic)
in vcat [ epsHeader bb timestamp
, ps_gsave
, cmdtrans
, body
, ps_grestore
, epsFooter
]
imageTranslation :: (Ord u, PSUnit u) => Picture u -> (BoundingBox u, Doc)
imageTranslation pic = case repositionDeltas pic of
(bb, Nothing) -> (bb, empty)
(bb, Just v) -> (bb, ps_translate v)
picture :: (Real u, Floating u, PSUnit u) => Picture u -> PsMonad Doc
picture (Leaf (_,xs) ones) = bracketTrafos xs $ revConcat primElement ones
picture (Picture (_,xs) ones) = bracketTrafos xs $ revConcat picture ones
picture (Clip (_,xs) cp pic) = bracketTrafos xs $
(vconcat <$> clipPath cp <*> picture pic)
picture (Group (_,xs) _ pic) = bracketTrafos xs (picture pic)
revConcat :: (a -> PsMonad Doc) -> OneList a -> PsMonad Doc
revConcat fn ones = some empty <$> F.foldrM step None ones
where
step e ac = (\d -> d `conc` ac) <$> fn e
conc d None = Some d
conc d (Some ac) = Some $ ac `vconcat` d
primElement :: (Real u, Floating u, PSUnit u) => PrimElement u -> PsMonad Doc
primElement (Atom prim) = primitive prim
primElement (XLinkGroup _ ones) = revConcat primElement ones
primitive :: (Real u, Floating u, PSUnit u) => Primitive u -> PsMonad Doc
primitive (PPath props pp) = primPath props pp
primitive (PLabel props lbl) = primLabel props lbl
primitive (PEllipse props ell) = primEllipse props ell
primPath :: PSUnit u
=> PathProps -> PrimPath u -> PsMonad Doc
primPath (CFill rgb) p =
(\rgbd -> vcat [rgbd, makeStartPath p, ps_closepath, ps_fill])
<$> deltaDrawColour rgb
primPath (CStroke attrs rgb) p =
(\rgbd attrd -> vcat [ rgbd, attrd, makeStartPath p
, ps_closepath, ps_stroke ])
<$> deltaDrawColour rgb <*> deltaStrokeAttrs attrs
primPath (OStroke attrs rgb) p =
(\rgbd attrd -> vcat [rgbd, attrd, makeStartPath p, ps_stroke])
<$> deltaDrawColour rgb <*> deltaStrokeAttrs attrs
primPath (CFillStroke fc attrs sc) p =
(\d1 d2 -> vcat [d1,d2])
<$> primPath (CFill fc) p <*> primPath (CStroke attrs sc) p
clipPath :: PSUnit u => PrimPath u -> PsMonad Doc
clipPath p = pure $ vcat [makeStartPath p , ps_closepath, ps_clip]
makeStartPath :: PSUnit u => PrimPath u -> Doc
makeStartPath (PrimPath start xs) =
vcat $ ps_newpath : ps_moveto start : map makePathSegment xs
makePathSegment :: PSUnit u => PrimPathSegment u -> Doc
makePathSegment (PLineTo p1) = ps_lineto p1
makePathSegment (PCurveTo p1 p2 p3) = ps_curveto p1 p2 p3
primEllipse :: (Real u, Floating u, PSUnit u)
=> EllipseProps -> PrimEllipse u -> PsMonad Doc
primEllipse props (PrimEllipse center hw hh ctm) =
bracketPrimCTM center (scaleCTM 1 (hh/hw) ctm) (drawF props)
where
drawF (EFill rgb) pt = fillArcPath rgb hw pt
drawF (EStroke sa rgb) pt = strokeArcPath rgb sa hw pt
drawF (EFillStroke fc sa sc) pt =
vconcat <$> fillArcPath fc hw pt <*> strokeArcPath sc sa hw pt
fillArcPath :: PSUnit u => RGBi -> u -> Point2 u -> PsMonad Doc
fillArcPath rgb radius pt =
(\rgbd -> vcat [ rgbd
, ps_newpath
, ps_arc pt radius 0 360
, ps_closepath
, ps_fill ])
<$> deltaDrawColour rgb
strokeArcPath :: PSUnit u
=> RGBi -> StrokeAttr -> u -> Point2 u -> PsMonad Doc
strokeArcPath rgb sa radius pt =
(\rgbd attrd -> vcat [ rgbd
, attrd
, ps_newpath
, ps_arc pt radius 0 360
, ps_closepath
, ps_stroke ])
<$> deltaDrawColour rgb <*> deltaStrokeAttrs sa
primLabel :: (Real u, Floating u, PSUnit u)
=> LabelProps -> PrimLabel u -> PsMonad Doc
primLabel (LabelProps rgb font) (PrimLabel basept body ctm) =
bracketPrimCTM basept ctm mf
where
mf pt = (\rgbd fontd showd -> vcat [ rgbd, fontd, showd ])
<$> deltaDrawColour rgb <*> deltaFontAttrs font
<*> labelBody pt body
labelBody :: PSUnit u => Point2 u -> LabelBody u -> PsMonad Doc
labelBody pt (StdLayout txt) = (\d1 -> ps_moveto pt `vconcat` d1)
<$> encodedText txt
labelBody pt (KernTextH xs) = kernTextH pt xs
labelBody pt (KernTextV xs) = kernTextV pt xs
encodedText :: EncodedText -> PsMonad Doc
encodedText etext = vcat <$> (mapM textChunk $ getEncodedText etext)
textChunk :: TextChunk -> PsMonad Doc
textChunk (TextSpan s) = pure (ps_show $ escapeSpecial s)
textChunk (TextEscName s) = pure (ps_glyphshow s)
textChunk (TextEscInt i) = (either failk ps_glyphshow) <$> askCharCode i
where
failk gly_name = missingCharCode i gly_name
kernTextH :: PSUnit u => Point2 u -> [KerningChar u] -> PsMonad Doc
kernTextH pt0 xs = snd <$> F.foldlM fn (pt0,empty) xs
where
fn (P2 x y,acc) (dx,ch) = (\doc1 -> let pt = P2 (x+dx) y in
(pt, vcat [acc, ps_moveto pt, doc1]))
<$> encodedChar ch
kernTextV :: PSUnit u => Point2 u -> [KerningChar u] -> PsMonad Doc
kernTextV pt0 xs = snd <$> F.foldlM fn (pt0,empty) xs
where
fn (P2 x y,acc) (dy,ch) = (\doc1 -> let pt = P2 x (ydy) in
(pt, vcat [acc, ps_moveto pt, doc1]))
<$> encodedChar ch
encodedChar :: EncodedChar -> PsMonad Doc
encodedChar (CharLiteral c) = pure (ps_show $ escapeSpecialChar c)
encodedChar (CharEscName s) = pure (ps_glyphshow s)
encodedChar (CharEscInt i) = (either failk ps_glyphshow) <$> askCharCode i
where
failk gly_name = missingCharCode i gly_name
deltaDrawColour :: RGBi -> PsMonad Doc
deltaDrawColour rgb = getDrawColour >>= \inh ->
if rgb==inh then return empty
else setDrawColour rgb >> return (ps_setrgbcolor rgb)
deltaStrokeAttrs :: StrokeAttr -> PsMonad Doc
deltaStrokeAttrs sa =
(\d1 d2 d3 d4 d5 -> hcat $ catMaybes [d1,d2,d3,d4,d5])
<$> lw <*> ml <*> lc <*> lj <*> dp
where
lw = let d = line_width sa in
getLineWidth >>= \inh ->
if d == inh
then return Nothing
else setLineWidth d >> return (Just $ ps_setlinewidth d)
ml = let d = miter_limit sa in
getMiterLimit >>= \inh ->
if d==inh
then return Nothing
else setMiterLimit d >> return (Just $ ps_setmiterlimit d)
lc = let d = line_cap sa in
getLineCap >>= \inh ->
if d==inh
then return Nothing
else setLineCap d >> return (Just $ ps_setlinecap d)
lj = let d = line_join sa in
getLineJoin >>= \inh ->
if d==inh
then return Nothing
else setLineJoin d >> return (Just $ ps_setlinejoin d)
dp = let d = dash_pattern sa in
getDashPattern >>= \inh ->
if d==inh
then return Nothing
else setDashPattern d >> return (Just $ ps_setdash d)
deltaFontAttrs :: FontAttr -> PsMonad Doc
deltaFontAttrs fa = getFontAttr >>= \inh ->
if fa==inh then return empty
else setFontAttr fa >> return (makeFontAttrs fa)
makeFontAttrs :: FontAttr -> Doc
makeFontAttrs (FontAttr sz face) =
vcat [ ps_findfont (font_name face), ps_scalefont sz, ps_setfont ]
bracketTrafos :: (Real u, Floating u, PSUnit u)
=> [AffineTrafo u] -> PsMonad Doc -> PsMonad Doc
bracketTrafos xs ma = bracketMatrix (concatTrafos xs) ma
bracketMatrix :: (Fractional u, PSUnit u)
=> Matrix3'3 u -> PsMonad Doc -> PsMonad Doc
bracketMatrix mtrx ma
| mtrx == identityMatrix = ma
| otherwise = (\doc -> vcat [inn, doc, out]) <$> ma
where
inn = ps_concat $ mtrx
out = ps_concat $ invert mtrx
bracketPrimCTM :: forall u. (Real u, Floating u, PSUnit u)
=> Point2 u -> PrimCTM u
-> (Point2 u -> PsMonad Doc) -> PsMonad Doc
bracketPrimCTM pt@(P2 x y) ctm mf
| ctm == identityCTM = mf pt
| otherwise = (\doc -> vcat [inn, doc, out]) <$> mf zeroPt'
where
zeroPt' :: Point2 u
zeroPt' = zeroPt
mtrx = translMatrixRepCTM x y ctm
inn = ps_concat $ mtrx
out = ps_concat $ invert mtrx