> module PSPic where

> import Picture
> import Pic
> import qualified PostScript
> import PostScript (PostScript,PostScriptS)

> class HasPS p where
>   getPS          :: p                     -> PostScriptS

> linewidth d = Prop ("linewidth",PostScript.ps_of_double d)

> instance HasPS s => HasPS (Pic s) where
>   getPS EmptyPic         = id
>   getPS (Above p q)      = getPS q . getPS p
>   getPS (Prim s)         = getPS s
>   getPS (Prop (n, v) p)  = case n of
>     "linewidth" -> PostScript.gsave (((v ++ " setlinewidth") :) . getPS p)
>     "rgb" -> PostScript.gsave (((v ++ " setrgbcolor") :) . getPS p)
>     "font" -> case words v of
>                [font,size] ->
>                    PostScript.gsave (
>                      (('/' : font ++ " findfont "
>                       ++ size ++ " scalefont setfont") :) . getPS p)
>                _ -> getPS p
>     _ -> getPS p

> writeEPS :: (HasVert a, HasPS a) => String -> a -> IO ()
> writeEPS file p = case bbox p of
>   Nothing -> return () -- refusing to write empty pictures
>   Just (a,b) -> let bb = (c a, c b)
>                 in writeFile file $
>                    unlines (PostScript.prolog file bb ++ getPS p [])

> c = PostScript.Car
> cs = map c

> instance HasPS Shape where
>   getPS (Squat p) = id
>   getPS (Text p s) = ((PostScript.ps_of_point (c p) ++ " moveto") :) .
>                      (('(' : s ++ ") show") :)
>   getPS (Rectangle p@(x1,y1) q@(x2,y2)) =
>            getPS $ Polygon $ [p, (x1,y2), q, (x2,y1)]
>   getPS (Polygon vs) = ((PostScript.polygon_pspath (cs vs) ++ " fill") :)
>   getPS (PolygonOL vs) = ((PostScript.polygon_pspath (cs vs) ++ " stroke") :)
>   getPS (Polyline vs) = ((PostScript.pspath (cs vs) ++ " stroke") :)
>   getPS (Ellipse p q) = error "getPS Ellipse"
>   getPS (ShearEllipse p q r) = error "getPS ShearEllipse"