ghc/tests/programs/lex/lex.stdin

   1 module Graph  where
   2
   3 import Parse
   4 import StdLib
   5 import PSlib
   6 import GRIP
   7
   8 paperX = 280::Int
   9 paperY = 190::Int
  10
  11 fromInt :: Num a => Int -> a
  12 fromInt = fromInteger . toInteger
  13
  14 gspostscript str = initialise stdheader ++ portrait ++ str ++ "showpage\n"
  15 postscript str = initialise stdheader ++ landscape ++ str ++ "showpage\n"
  16
  17 ePostscript (reqdx,reqdy) str = initialise (stdheader++
  18         "%%BoundingBox: 0 0 "++show (cms2pts reqdx)++" "++show (cms2pts reqdy)++"\n"
  19                         ++ "%%EndComments\n")
  20         ++ scale (fromInt reqdx*10/fromInt paperX) (fromInt reqdy*10/fromInt paperY) ++ str ++
  21         showpage
  22
  23 initGraph title pedata (topX,topY) (xlabel,ylabel) keys =
  24         drawBox (Pt 0 0) paperX paperY ++
  25         drawBox (Pt 1 1) (paperX-2) 5 ++
  26         drawBox (Pt 1 (paperY-7)) (paperX-2) 6 ++
  27         setfont "BOLD" ++ moveto (Pt (paperX `div` 2) (paperY-6)) ++ cjustify (title) ++
  28         setfont "NORM" ++
  29         placePEs pedata ++
  30         translate 20 25 ++
  31         newpath ++ moveto (Pt 0 (-5)) ++ lineto (Pt 0 dimY) ++
  32         moveto (Pt (-5) 0) ++ lineto (Pt dimX 0) ++ stroke ++
  33         setfont "SMALL" ++
  34         markXAxis dimX topX++
  35         markYAxis dimY topY++
  36         moveto (Pt 0 (dimY+4)) ++ rjustify ylabel ++ stroke ++
  37         moveto (Pt dimX (-8)) ++ rjustify xlabel ++ stroke ++
  38         setfont "NORM" ++
  39         dokeys dimX keys
  40
  41 placePEs (pes,on) | checkPEs (tail pes) on =
  42                 showActive (length pes) (length used) ++
  43                 showUsed pes used ++ setfont "NORM"
  44                 where used = if on==[] then tail pes else on
  45
  46
  47 cms2pts :: Int -> Int
  48 cms2pts x = round (28.4584 * fromInt x)
  49
  50 plotCurve ::  Int -> [Point] -> Postscript
  51 plotCurve x pts = setgray x ++ fillObject pts
  52
  53 plot :: [Point] -> Postscript
  54 plot points = plotCurve 5 (Pt 0 0:points)
  55
  56 dokeys left keys = concat (map2 format (places 0) keys)
  57         where
  58         format pt@(Pt x y) (col,tex,pc) = fillBox pt 16 9 col ++ stroke ++ moveto (Pt (x+17) (y+3))
  59                                         ++ text tex ++ stroke ++ moveto (Pt (x+8) (y+3)) ++
  60                                         inv col ++ setfont "BOLD" ++ cjustify (pc) ++
  61                                         stroke ++ setfont "NORM" ++ setgray 10
  62         no=left `div` length keys
  63         places n | n == no = []
  64         places n = (Pt (n*no) (-17)):places (n+1)
  65
  66 showActive t f =
  67                 setfont "LARGE" ++ moveto (Pt 10 16) ++ cjustify (show f) ++
  68                 setfont "SMALL" ++ moveto (Pt 10 12) ++ cjustify "PE(s)" ++ stroke ++
  69                 setfont "SMALL" ++ moveto (Pt 10 8) ++ cjustify "displayed" ++ stroke ++
  70                 setfont "NORM"
  71
  72 showUsed (m:pes) on = moveto (Pt 2 2) ++ setfont "SMALL" ++ text "Configuration:" ++
  73                         dopes (paperX-27) (("SMALLITALIC",showPE m):map f pes) ++ stroke
  74         where
  75         f pe | elem pe on = ("SMALLBOLD",showPE pe)
  76              | otherwise = ("SMALL",showPE pe)
  77
  78 dopes left pes = concat (map2 format (places 0) pes)
  79         where
  80         format pt@(Pt x y) (font,tex) = setfont font ++ moveto pt  ++ text tex ++ stroke
  81         no=left `div` ((length pes*2)+1)
  82         f x = (no*((x*2)+1)) + 27
  83         places n | n>2*no = []
  84         places n = (Pt (f n) 2):places (n+1)
  85
  86
  87
  88 checkPEs pes [] = True
  89 checkPEs pes (p:ps) | elem p pes = checkPEs pes ps
  90                     | otherwise = error ("Attempt to gather information from inactive PE - "++ showPE p)
  91
  92 showPE :: PElement -> String
  93 showPE (PE str no) = str++"."++show no
  94
  95 inv x | x>=5 = setgray 0
  96       | otherwise = setgray 10
  97
  98 dimX = paperX-30
  99 dimY = paperY-40
 100
 101 markXAxis :: Int -> Int -> Postscript
 102 markXAxis dimX maxX = label 10 ++ markOnX 100
 103         where
 104         label 0 = ""
 105         label x = newpath ++ moveto (Pt (notch x) 0) ++ rlineto 0 (-2) ++
 106                   moveto (Pt (notch x) (-5)) ++
 107                   cjustify (printFloat (t x)) ++ stroke ++ label (x-1)
 108         t x = fromInt x*(fromInt maxX / fromInt 10)
 109         notch x = x*(dimX `div` 10)
 110
 111 markOnX n = mapcat notches [1..n] ++ stroke
 112         where
 113         notches n = movetofloat (m*fromInt n) 0 ++  (rlineto 0 (-1)) ++ stroke
 114         m = fromInt dimX/fromInt n
 115
 116
 117 markYAxis :: Int -> Int -> Postscript
 118 markYAxis dimY maxY = label 10 ++ markOnY (calibrate maxY)
 119         where
 120         label 0 = ""
 121         label x = newpath ++ moveto (Pt 0 (notch x)) ++ rlineto (-2) 0 ++
 122                   moveto (Pt (-3) (notch x)) ++
 123                   rjustify (printFloat (t x)) ++ stroke ++ label (x-1)
 124         t x = fromInt x*(fromInt maxY / fromInt 10)
 125         notch x = x*(dimY `div` 10)
 126
 127 calibrate x | x<=1 = 1
 128             | x<=100 = x
 129             | otherwise = calibrate (x `div` 10)
 130
 131 markOnY n = mapcat notches [1..n] ++ stroke
 132         where
 133         notches n = movetofloat 0 (m*fromInt n) ++  (rlineto (-1) 0)
 134         m = fromInt dimY/fromInt n
 135
 136 movetofloat x y = show x ++ " " ++ show y ++ " moveto\n"
 137
 138
 139 determineScale :: [Point] -> (Int,Int)
 140 determineScale pts = (axisScale x, axisScale y)
 141         where   (min,Pt x y) = minandmax pts
 142
 143 axisScale :: Int -> Int
 144 axisScale x = axisScale' x 1
 145 axisScale' x m  | x <= m = m
 146                 | x <= m*2 = m*2
 147                 | x <= m*5 = m*5
 148                 | x <= m*10 = m*10
 149                 | otherwise = axisScale' x (m*10)
 150
 151 minandmax :: [Point] -> (Point,Point)
 152 minandmax [] = error "No points"
 153 minandmax (p:ps) = f (p,p) ps
 154         where
 155         f p [] = p
 156         f (Pt minx miny,Pt maxx maxy) (Pt x y:ps) = f (Pt minx' miny',Pt maxx' maxy') ps
 157                         where   minx' = min x minx
 158                                 miny' = min y miny
 159                                 maxx' = max x maxx
 160                                 maxy' = max y maxy
 161
 162
 163 printFloat :: Float -> String
 164 printFloat x = f (show (round (x*10)))
 165                 where
 166                 f "0" = "0"
 167                 f r | x<1 = "0."++r
 168                 f (r:"0") | x<10 = [r]
 169                 f (r:m) | x<10 = r:'.':m
 170                 f _ = show (round x)