module Graphics.PS.PS (ps,eps,stringFromPS) where
import Graphics.PS.Pt
import qualified Graphics.PS.Matrix as M
import Graphics.PS.Path
import Graphics.PS.Font
import Graphics.PS.Unit
import Graphics.PS.GS
import qualified Graphics.PS.Paper as P
import qualified Graphics.PS.Image as I
import Data.List
import System.IO
import Data.Monoid (Monoid, mappend, mempty, mconcat, Endo(Endo,appEndo), )
data PS = Name String
| LName String
| Op String
| Comment String
| Int Int
| Double Double
| String String
| Matrix M.Matrix
| Array [PS]
| Proc [PS]
| Dict [(PS,PS)]
| Seq [PS]
dsc :: String -> [String] -> PS
dsc k [] = Comment ('%' : k)
dsc k v = Comment (concat ("%" : k : ": " : intersperse " " v))
header,headerEps :: PS
header = Comment "!PS-Adobe-3.0"
headerEps = Comment "!PS-Adobe-3.0 EPSF-3.0"
title :: String -> PS
title t = dsc "Title" [t]
creator :: String -> PS
creator t = dsc "Creator" [t]
languageLevel :: Int -> PS
languageLevel n = dsc "LanguageLevel" [show n]
pages :: Int -> PS
pages n = dsc "Pages" [show n]
bbox :: P.BBox -> PS
bbox (P.BBox i j k l) = dsc "BoundingBox" [show i,show j,show k,show l]
bbox (P.HRBBox i j k l i' j' k' l') =
Seq [dsc "BoundingBox" [show i,show j,show k,show l],
dsc "HiResBoundingBox" [show i',show j',show k',show l']]
endComments :: PS
endComments = dsc "EndComments" []
page :: (Show a) => String -> a -> PS
page t n = dsc "Page" [t, show n]
trailer :: PS
trailer = dsc "Trailer" []
eof :: PS
eof = dsc "EOF" []
documentMedia :: String -> Int -> Int -> PS
documentMedia tag w h = dsc "DocumentMedia" [tag, show w, show h, "0", "()", "()"]
alias :: String -> String -> PS
alias o a = Seq [LName a, Proc [Name o], Op "def"]
pdfCompat :: [(String, String)]
pdfCompat = [("gsave", "q"),
("grestore", "Q"),
("stroke", "S"),
("fill", "f"),
("setrgbcolor", "RG"),
("setlinewidth", "w"),
("setlinecap", "J"),
("setlinejoin", "j"),
("setdash", "d"),
("setmiterlimit", "M"),
("moveto", "m"),
("lineto", "l"),
("curveto", "c"),
("closepath", "h"),
("concat", "cm"),
("show", "Tj"),
("selectfont", "Tf"),
("clip", "W")]
prolog :: PS
prolog =
let f (a,b) = alias a b
in Seq (map f pdfCompat)
stroke :: PS
stroke = Op "S"
fill :: PS
fill = Op "f"
false :: PS
false = Name "false"
save :: PS
save = Op "q"
restore :: PS
restore = Op "Q"
showPage :: PS
showPage = Op "showpage"
rgb :: Color -> PS
rgb (RGB r g b) = Seq [Double r, Double g, Double b, Op "RG"]
lineWidth :: Double -> PS
lineWidth w = Seq [Double w, Op "w"]
lineCap :: (Enum a) => a -> PS
lineCap c = Seq [Int (fromEnum c), Op "j"]
lineJoin :: (Enum a) => a -> PS
lineJoin j = Seq [Int (fromEnum j), Op "J"]
dash :: [Int] -> Int -> PS
dash d o = Seq [Array (map Int d), Int o, Op "d"]
miterLimit :: Double -> PS
miterLimit m = Seq [Double m, Op "M"]
moveTo :: Pt -> PS
moveTo (Pt x y) = Seq [Double x, Double y, Op "m"]
lineTo :: Pt -> PS
lineTo (Pt x y) = Seq [Double x, Double y, Op "l"]
transform :: M.Matrix -> PS
transform m = Seq [Matrix m, Op "cm"]
curveTo :: Pt -> Pt -> Pt -> PS
curveTo a b c = Seq (map Double (ptXYs [a,b,c]) ++ [Op "c"])
closePath :: Pt -> PS
closePath (Pt x y) = Seq [Double x, Double y, Op "h"]
selectFont :: Font -> PS
selectFont (Font f n) = Seq [LName f, Double n, Op "Tf"]
charPath :: String -> PS
charPath g = Seq [String g, false, Op "charpath"]
gs :: GS -> PS
gs (GS c w k j (d, o) m) =
Seq [rgb c
,lineWidth w
,lineCap k
,lineJoin j
,dash d o
,miterLimit m]
path :: Path -> PS
path (MoveTo p) = moveTo p
path (LineTo p) = lineTo p
path (Text f g) = Seq [selectFont f, charPath g]
path (CurveTo c1 c2 p) = curveTo c1 c2 p
path (ClosePath p) = closePath p
path (PTransform m p) = Seq [transform m, path p]
path (Join a b) = Seq [path a, path b]
image :: I.Image -> PS
image I.Empty = Comment "Empty"
image (I.Stroke g p) = Seq [path p, gs g, stroke]
image (I.Fill g p) = Seq [path p, gs g, fill]
image (I.ITransform m i) = Seq [transform m, image i]
image (I.Over a b) = Seq [save
,image b
,restore
,image a]
mlist :: M.Matrix -> [Double]
mlist (M.Matrix a b c d e f) = [a,b,c,d,e,f]
infixl 1 >+>
(>+>) :: Monoid m => m -> m -> m
(>+>) = mappend
bracket :: (Monoid m) =>
(String -> m) -> String -> String -> [a] -> (a -> m) -> m
bracket f o c p g =
let h a = f a >+> f " "
in h o >+> mconcat (map g p) >+> h c
escape :: String -> String
escape = concatMap (\c -> if elem c "()" then ['\\', c] else [c])
put :: (Monoid m) => (String -> m) -> PS -> m
put f (Name n) = f n >+> f " "
put f (LName n) = f "/" >+> f n >+> f " "
put f (Op o) = f o >+> f "\n"
put f (Comment o) = f "%" >+> f o >+> f "\n"
put f (Int n) = f (show n) >+> f " "
put f (Double n) = f (show n) >+> f " "
put f (String s) = f "(" >+> f (escape s) >+> f ") "
put f (Array a) = bracket f "[" "]" a (put f)
put f (Proc p) = bracket f "{" "}" p (put f)
put f (Matrix m) = put f (Array (map Double (mlist m)))
put f (Dict d) =
let g = concatMap (\(a,b) -> [a,b])
in bracket f "<<" ">>" (g d) (put f)
put f (Seq a) = mconcat (map (put f) a)
ps' :: (I.Image, Int) -> PS
ps' (p, n) = Seq [page "Graphics.PS" n, image p, showPage]
paper_ps :: P.Paper -> P.Paper
paper_ps (P.Paper w h) =
let f n = floor (mm_pt (fromIntegral n)::Double)
in P.Paper (f w) (f h)
ps :: FilePath -> P.Paper -> [I.Image] -> IO ()
ps f d p =
writeFile f (stringFromPS f d p)
stringFromPS :: String -> P.Paper -> [I.Image] -> String
stringFromPS t d p =
let g = put (\s -> Endo (s++))
(P.Paper width height) = paper_ps d
in flip appEndo "" $
g header >+>
g (title t) >+>
g (creator "Graphics.PS") >+>
g (languageLevel 2) >+>
g (pages (length p)) >+>
g (documentMedia "Default" width height) >+>
g endComments >+>
g prolog >+>
mconcat (map (g . ps') (zip p [1..])) >+>
g trailer >+>
g eof
newtype MonadMonoid m = MonadMonoid {appMonadMonoid :: m ()}
instance Monad m => Monoid (MonadMonoid m) where
mempty = MonadMonoid (return ())
mappend (MonadMonoid a) (MonadMonoid b) =
MonadMonoid (a >> b)
mconcat = MonadMonoid . mapM_ appMonadMonoid
eps :: String -> P.BBox -> I.Image -> IO ()
eps f d p =
withFile f WriteMode $ \h ->
let g = put (MonadMonoid . hPutStr h)
in mapM_ (appMonadMonoid . g) $
[headerEps
,title ("Graphics.PS: " ++ f)
,creator "Graphics.PS"
,languageLevel 2
,bbox d
,endComments
,prolog
,image p]