module Graphics.PS.PS (ps) 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
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 :: PS
header = Comment "!PS-Adobe-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]
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 = Seq [Op "matrix", Op "currentmatrix"]
restore :: PS
restore = Op "setmatrix"
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"])
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 (PTransform m p) = Seq [ save
, transform m
, path p
, restore ]
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 [ save
, transform m
, image i
, restore ]
image (I.Over a b) = Seq [image b, image a]
mlist :: M.Matrix -> [Double]
mlist (M.Matrix a b c d e f) = [a,b,c,d,e,f]
bracket :: (String -> IO ()) -> String -> String -> [a] -> (a -> IO ()) -> IO ()
bracket f o c p g =
let h a = f a >> f " "
in h o >> mapM_ g p >> h c
escape :: String -> String
escape = concatMap (\c -> if elem c "()" then ['\\', c] else [c])
put :: (String -> IO ()) -> PS -> IO ()
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) = mapM_ (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 :: String -> P.Paper -> [I.Image] -> IO ()
ps f d p = do
h <- openFile f WriteMode
let g = put (hPutStr h)
(P.Paper width height) = paper_ps d
mapM_ g [ header
, title ("Graphics.PS: " ++ f)
, creator "Graphics.PS"
, languageLevel 2
, pages (length p)
, documentMedia "Default" width height
, endComments
, prolog ]
mapM_ g (map ps' (zip p [1..]))
mapM_ g [ trailer
, eof]
hClose h