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