1 --------------------------------------------------
    2 -- Copyright 1994 by Peter Thiemann
    3 -- $Log: PsOutput.hs,v $
    4 -- Revision 1.2  1999/01/18 19:38:47  sof
    5 -- Misc (backward compatible) changes to make srcs acceptable
    6 -- to a Haskell 98 compiler.
    7 --
    8 -- Revision 1.1  1996/01/08 20:02:34  partain
    9 -- Initial revision
   10 --
   11 -- Revision 1.4  1994/03/15  15:34:53  thiemann
   12 -- added full color support, XColorDB based
   13 --
   14 --Revision 1.3  1993/08/31  12:31:32  thiemann
   15 --Reflect changes in type FONT
   16 --
   17 --Revision 1.2  1993/08/25  15:11:11  thiemann
   18 --added PostScript prolog to use shorter command names
   19 --fixed backslash bug in psString
   20 --
   21 --Revision 1.1  1993/08/17  12:34:29  thiemann
   22 --Initial revision
   23 --
   24 -- $Locker:  $
   25 --------------------------------------------------
   26 module PsOutput (psShowsWrapper) where
   27 
   28 -- import EbnfLayout
   29 import Fonts (FONT, fontName, fontScale, noFont)
   30 import Color (Color (..), showsPsColor, noColor)
   31 import Info (Container (..), GObject (..), TDirection (..), WrapperType (..), INFO(..), ColorInfo(..))
   32 
   33 -- psState = (currentColor, currentFont, currentLinewidth)
   34 type PsState = (Color, FONT, Int, ShowS)
   35 type PsTrafo = PsState -> PsState
   36 
   37 initialState :: PsState
   38 initialState = (noColor, noFont, -1, id)
   39 
   40 setColor :: Color -> PsTrafo
   41 setColor clr st@(clr0, fnt0, lw0, shower)
   42   | clr == clr0 = st
   43   | otherwise   = (clr, fnt0, lw0, shower . showsPsColor clr)
   44 
   45 setFont :: FONT -> PsTrafo
   46 setFont font st@(clr0, fnt0, lw0, shower)
   47   | font == fnt0 = st
   48   | otherwise    = (clr0, font, lw0,
   49                     shower .
   50                     showString ('/':fontName font) . showString " findfont " .
   51                     shows (fontScale font) . showString " scalefont" .
   52                     showString " setfont\n")
   53                   
   54 
   55 setLineWidth :: Int -> PsTrafo
   56 setLineWidth lw st@(clr0, fnt0, lw0, shower)
   57   | lw == lw0 = st
   58   | otherwise = (clr0, fnt0, lw, shower . showsPsNum lw . showString " slw\n")
   59 
   60 drawBox :: Bool -> Int -> Int -> Int -> Int -> Int -> PsTrafo
   61 drawBox rounded ax ay width height lw (clr0, fnt0, lw0, shower) = 
   62          (clr0, fnt0, lw,
   63           shower . showsPsNum ax . showsPsNum ay .
   64           showsPsNum width . showsPsNum height . showsPsNum lw .
   65           showString (if rounded then " RBox\n" else " Box\n"))
   66 
   67 drawString :: Int -> Int -> String -> PsTrafo
   68 drawString ax ay str (clr0, fnt0, lw0, shower) = 
   69         (clr0, fnt0, lw0, 
   70          shower .
   71          showsMoveto ax ay .
   72          showChar '(' . showString (psString str) . showChar ')' .
   73          showString " show\n")
   74 
   75 drawRLine :: Int -> Int -> [(Int, Int)] -> PsTrafo
   76 drawRLine ax ay rels (clr0, fnt0, lw0, shower) =
   77         (clr0, fnt0, lw0,
   78          shower .
   79          showString "n" .
   80          showsMoveto ax ay .
   81          foldr (.) (showString " s\n") [ showsRLineto rx ry | (rx, ry) <- rels ])
   82 
   83 insertShowS :: ShowS -> PsTrafo
   84 insertShowS shower1 (clr0, fnt0, lw0, shower) = (clr0, fnt0, lw0, shower . shower1)
   85 
   86 runTrafo :: PsTrafo -> ShowS
   87 runTrafo f = shower where
   88                       (_, _, _, shower) = f initialState
   89 
   90 psShowsWrapper :: WrapperType
   91 psShowsWrapper title
   92          (borderDistX, borderDistY, lineWidth, fatLineWidth, arrowSize, ntFont, tFont,
   93           (ntColor, tColor, lineColor, fatLineColor))
   94                 container@(rx, ry, width, height, inOutY, gobj) =
   95         showString "%!PS-Adobe-1.0\n" .
   96         showString "%%DocumentFonts: " .
   97         showString ntFontName . 
   98         (if ntFontName == tFontName then id else (showChar ' ' . showString tFontName)) .
   99         showString "\n%%Title: " . showString title .
  100         showString "\n%%Creator: ebnf2ps (Copyright 1994 by Peter Thiemann)\n" .
  101         showString "%%Pages: 0\n" .
  102         showString "%%BoundingBox:" . 
  103         showsPsNum (psFloor rx) . showsPsNum (psFloor ry) .
  104         showsPsNum (psCeil (rx+width)) . showsPsNum (psCeil (ry+height)) .
  105         showString "\n%%EndComments\n" .
  106         showString psProlog .
  107         showString "%%EndProlog\n" .
  108         showString "\n$Ebnf2psBegin\n" .
  109         runTrafo (psShowsContainer rx ry container) .
  110         showString "\n$Ebnf2psEnd\n"
  111         where
  112   ntFontName = fontName ntFont
  113   tFontName  = fontName tFont
  114 
  115   psShowsContainer :: Int -> Int -> Container -> PsTrafo
  116   psShowsContainer ax ay (rx, ry, width, height, inOutY, gobj) =
  117         case gobj of
  118         AString color font theString ->
  119                 drawString ax1 ay1 theString .
  120                 setColor color .
  121                 setFont font
  122         ABox color rounded content ->
  123                 psShowsContainer ax1 ay1 content .
  124                 drawBox rounded ax1 ay1 width height fatLineWidth .
  125                 setColor color
  126         Arrow color size ->
  127             drawRLine  (ax1-size) (ay1+abs size) [(size, -abs size), (-size, -abs size)] .
  128             setLineWidth lineWidth .
  129             setColor color
  130         Aline color ->
  131             drawRLine ax1 ay1 [(width, height)] .
  132             setLineWidth lineWidth .
  133             setColor color
  134         ATurn color dir ->
  135             insertShowS(
  136                 showString "n" .
  137                 showsIt dir .
  138                 showString " s\n") .
  139             setLineWidth lineWidth .
  140             setColor color
  141                 where
  142                   showsIt SE = showsMoveto ax1 ay1 .
  143                                showsArcto ax1 (ay1+height) (ax1+width) (ay1+height) radius .
  144                                showsLineto (ax1+width) (ay1+height)
  145                   showsIt WN = showsMoveto ax1 ay1 .
  146                                showsArcto (ax1+width) ay1 (ax1+width) (ay1+height) radius .
  147                                showsLineto (ax1+width) (ay1+height)
  148                   showsIt SW = showsMoveto (ax1+width) ay1 .
  149                                showsArcto (ax1+width) (ay1+height) ax1 (ay1+height) radius .
  150                                showsLineto ax1 (ay1+height)
  151                   showsIt NE = showsMoveto (ax1+width) ay1 .
  152                                showsArcto ax1 ay1 ax1 (ay1+height) radius .
  153                                showsLineto ax1 (ay1+height)
  154                   radius = min height width
  155         AComposite contents ->
  156                 foldr (.) id (map (psShowsContainer ax1 ay1) contents)
  157     where
  158       ax1 = ax + rx
  159       ay1 = ay + ry
  160 
  161 -- showsPsColor color = showString " col" . showsColor color
  162 
  163 showsSetlinewidth lineWidth = showsPsNum lineWidth . showString " slw"
  164 
  165 showsMoveto x y =       showsPsXY x y . showString " m"
  166 
  167 showsLineto x y =       showsPsXY x y . showString " l"
  168 
  169 showsArcto x1 y1 x2 y2 r = showsPsXY x1 y1 . showsPsXY x2 y2 . showsPsNum r .
  170                            showString " apr\n"
  171 
  172 showsRMoveto x y =      showsPsXY x y . showString " rm"
  173 
  174 showsRLineto x y =      showsPsXY x y . showString " rl"
  175 
  176 showsPsXY x y =         showsPsNum x . showsPsNum y
  177 
  178 showsPsNum :: Int -> ShowS
  179 showsPsNum x =   showChar ' ' . shows x100 .
  180                         if x99 == 0 then id
  181                         else showChar '.' . shows x1 . shows x2
  182                         where (x100,x99) = x `divMod` 100
  183                               (x1,x2) = x99 `divMod` 10
  184 
  185 psFloor, psCeil :: Int -> Int
  186 psFloor x = 100 * (x `div` 100)
  187 psCeil  x = 100 * ((x + 99) `div` 100)
  188 
  189 -- showsPsInt :: Int -> showS
  190 -- showsPsInt x = showChar ' ' . showInt (x `div` 100)
  191         
  192 psString "" = ""
  193 psString ('(':cs) = "\\("   ++ psString cs
  194 psString (')':cs) = "\\)"   ++ psString cs
  195 psString ('\\':cs)= "\\\\"  ++ psString cs
  196 psString ('-':cs) = "\\261" ++ psString cs               -- endash looks much nicer
  197 psString (c:cs)   = c:psString cs
  198 
  199 -- Box:         width height linewidth Box -> -
  200 -- draw box at current point
  201 
  202 psProlog :: String
  203 psProlog = "\
  204 \/$Ebnf2psDict 100 dict def\n\
  205 \$Ebnf2psDict begin\n\
  206 \/l {lineto} bind def\n\
  207 \/m {moveto} bind def\n\
  208 \/rl {rlineto} bind def\n\
  209 \/rm {rmoveto} bind def\n\
  210 \/s {stroke} bind def\n\
  211 \/n {newpath} bind def\n\
  212 \/gs {gsave} bind def\n\
  213 \/gr {grestore} bind def\n\
  214 \/clp {closepath} bind def\n\
  215 \/slw {setlinewidth} bind def\n\
  216 \/graycol {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul\n\
  217 \4 -2 roll mul setrgbcolor} bind def\n\
  218 \/scol {3 {255 div 3 1 roll} repeat setrgbcolor} bind def\n\
  219 \ \
  220 \/apr {arcto 4 {pop} repeat} def\n\
  221 \/Box {\n\
  222 \  /linewidth exch def\n\
  223 \  linewidth sub /height exch def\n\
  224 \  linewidth sub /width exch def\n\
  225 \ \
  226 \  n m\n\
  227 \  width 0 rl\n\
  228 \  0 height rl\n\
  229 \  width neg 0 rl\n\
  230 \  0 height neg rl\n\
  231 \  clp linewidth slw s\n\
  232 \} def\n\
  233 \ \
  234 \/RBox {\n\
  235 \  /linewidth exch def\n\
  236 \  /height exch def\n\
  237 \  /width exch def\n\
  238 \  /lly exch def\n\
  239 \  /llx exch def\n\
  240 \  linewidth 2 div dup llx add /llx exch def lly add /lly exch def\n\
  241 \  /height height linewidth sub def\n\
  242 \  /width  width  linewidth sub def\n\
  243 \  /height2 height 2 div def\n\
  244 \  /width2  width  2 div def\n\
  245 \  /urx llx width add def\n\
  246 \  /ury lly height add def\n\
  247 \  /mmx llx width2 add def\n\
  248 \  /mmy lly height2 add def\n\
  249 \  /radius width2 height2 ge {height2} {width2} ifelse def\n\
  250 \ \
  251 \  n mmx lly m\n\
  252 \  urx lly urx mmy radius apr\n\
  253 \  urx ury mmx ury radius apr\n\
  254 \  llx ury llx mmy radius apr\n\
  255 \  llx lly mmx lly radius apr\n\
  256 \  mmx lly l\n\
  257 \  clp linewidth slw s\n\
  258 \} def\n\
  259 \end\n\
  260 \/$Ebnf2psBegin {$Ebnf2psDict begin /$Ebnf2psEnteredState save def} def\n\
  261 \/$Ebnf2psEnd {$Ebnf2psEnteredState restore end} def\n\
  262 \\n"