1 module PSlib where
    2 
    3 -- This module implements provision of 
    4 -- control of postscript
    5 
    6 type Postscript = String
    7 
    8 data Point = Pt Int Int  deriving (Eq,Show{-was:Text-})
    9 
   10 initialise header = header ++  "/SMALL /Helvetica findfont 4 scalefont def\n" ++
   11                                 "/SMALLBOLD /Helvetica-Bold findfont 4 scalefont def\n" ++
   12                                 "/SMALLITALIC /Helvetica-Oblique findfont 4 scalefont def\n" ++
   13                                 "/NORM /Helvetica findfont 5 scalefont def\n" ++
   14                                 "/BOLD /Helvetica-Bold findfont 5 scalefont def\n" ++
   15                                 "/LARGE /Helvetica-Bold findfont 11 scalefont def\n" ++
   16                                 "NORM setfont\n"
   17                 ++ setcms ++ stdProcedures ++ thinlines
   18 
   19 setfont str = str ++ " setfont\n"
   20 
   21 stdheader :: Postscript
   22 stdheader = "%!PS-Adobe-2.0\n%%Created by Haskell Graph Package\n"
   23 
   24 gslandscape = ""
   25 landscape = translate 8 290 ++ rotate 270 ++ translate 20 10 ++ "0.9 0.9 scale\n"
   26 portrait = ""
   27 
   28 stdProcedures = rightshow ++ centreshow
   29 
   30 
   31 drawObject :: [Point] -> Postscript
   32 drawObject (pts) = newpath ++ moveto (Pt 0 0) ++ concat (map lineto pts) ++ 
   33                         thinlines  ++ stroke
   34 
   35 fillObject :: [Point] -> Postscript
   36 fillObject (pts) = newpath ++ moveto (Pt 0 0) ++ concat (map lineto pts) ++ 
   37                         closepath ++ fill ++ stroke
   38 
   39 fillBox :: Point -> Int -> Int  -> Int -> Postscript
   40 fillBox pt dx dy c = newpath ++ moveto pt ++ rlineto 0 dy ++ rlineto dx 0 ++ 
   41                         rlineto 0 (-dy) ++ closepath ++ setgray c ++ fill
   42 
   43 drawBox :: Point -> Int -> Int -> Postscript
   44 drawBox pt dx dy = thinlines ++ newpath ++ moveto pt ++ rlineto 0 dy ++ rlineto dx 0 ++ 
   45                         rlineto 0 (-dy) ++ closepath ++ stroke
   46 
   47 rjustify str = "("++str++") rightshow\n"
   48 cjustify str = "("++str++") centreshow\n"
   49 
   50 -- basic prodedures
   51 
   52 rightshow = "/rightshow\n{dup stringwidth pop\n0 exch sub\n0 rmoveto\nshow } def \n"
   53 centreshow = "/centreshow\n{dup stringwidth pop\n0 exch sub\n2 div\n0 rmoveto\nshow } def \n"
   54 
   55 -- basic functions.
   56 
   57 
   58 
   59 fill = "fill\n"
   60 stroke = "stroke\n"
   61 closepath = "closepath\n"
   62 newpath = "newpath\n"
   63 showpage = "showpage\n\n"
   64 gsave = "gsave\n"
   65 grestore = "grestore\n"
   66 
   67 text t = setgray 0 ++ "("++t++") show\n"
   68 
   69 setgray 0 = "0 setgray\n"
   70 setgray 10 = "1 setgray\n"
   71 setgray n = "."++show n++" setgray\n"
   72 
   73 moveto (Pt x y) = psCommand "moveto" [x,y] 
   74 
   75 rmoveto x y = psCommand "rmoveto" [x,y]
   76 
   77 lineto :: Point -> Postscript
   78 lineto (Pt x y) = psCommand "lineto" [x,y]
   79 
   80 rlineto x y = psCommand "rlineto" [x,y] 
   81 
   82 setlinewidth n = psCommand "setlinewidth" [n]
   83 
   84 thinlines = "0.2 setlinewidth\n"
   85 
   86 rotate n = psCommand "rotate" [n]
   87 
   88 psCommand c args = concat (map f args) ++c++"\n"
   89         where f x = show x++" "
   90 
   91 
   92 translate x y = psCommand "translate" [x,y]
   93 
   94 scale x y = psCommand "scale" [x,y]
   95 
   96 setcms = "2.84584 2.84584 scale\n"
   97 
   98 
   99 
  100