1(* Graphs.sml --- drawing bar charts, pie charts, cumulative graphs, ... 2 using Gdimage. For examples of use, see file testgdimage.sml. 3 sestoft@dina.kvl.dk 1998-05-13 4 *) 5 6open Gdimage; 7 8(* Creating a histogram of a given size, from a list of values *) 9 10(* So far no axes or tick marks *) 11 12fun histogram (w, h) [] = raise Fail "histogram: no data" 13 | histogram (w, h) obs = 14 let val max = foldl Int.max 0 obs 15 val yscale = real h / real (max + 2) 16 val im = image (w, h) (255, 255, 255) 17 val {blue, ...} = htmlcolors im 18 val n = length obs 19 val colwidth = w div n 20 val colspace = 1 + colwidth div 8 21 fun loop i [] = () 22 | loop i (x :: xr) = 23 let val x1 = i * colwidth 24 val y1 = h - round (yscale * real x) 25 val x2 = x1+colwidth-colspace 26 in 27 fillRect im (Color blue) ((x1, y1), (x2, h)); 28 loop (i+1) xr 29 end 30 in loop 0 obs; im end 31 32(* Allocate colors and return a coloration function *) 33 34fun makecolors im = 35 let val {black, white, silver, gray, maroon, red, purple, fuchsia, 36 green, lime, olive, yellow, navy, blue, teal, aqua} = 37 htmlcolors im 38 val colors = Array.fromList [red, navy, olive, aqua, black, purple, 39 lime, blue, maroon, silver, green, 40 yellow, teal] 41 val firstcolor = 42 Random.range (0, Array.length colors) (Random.newgen()) 43 fun color i = 44 Color (Array.sub(colors, (i + firstcolor) mod Array.length colors)) 45 in color end 46 47fun addlegend im itemnames black color = 48 let val (w, h) = size im 49 val longestitem = foldl Int.max 0 (map String.size itemnames) 50 val font = Small 51 val (fontw, fonth) = charsize font 52 val bh = fonth 53 val bw = 2 * bh 54 val sepw = bh 55 val marginsep = 10 56 val legendw = bw + sepw + fontw * longestitem + marginsep 57 val itemcount = length itemnames 58 val itemh = (h - 2 * marginsep) div itemcount 59 val seph = Int.min(bh, itemh - bh) 60 val x1 = w - legendw 61 val y0 = (h - itemcount * bh - (itemcount - 1) * seph) div 2 62 fun legend _ [] = () 63 | legend i (item1 :: itemr) = 64 let val y1 = i * (bh + seph) + y0 65 in 66 fillRect im (color i) ((x1, y1), (x1+bw, y1+bh)); 67 string im black font (x1+bw+sepw, y1) item1; 68 legend (i+1) itemr 69 end 70 in legend 0 itemnames; legendw end 71 72fun piechart _ [] _ = raise Fail "piechart: no data" 73 | piechart (wh as (w, h)) (obs as obs1 :: obsr) itemnames = 74 let (* The image and its color table *) 75 val im = image (w, h) (255, 255, 255) 76 val black = color im (0, 0, 0) 77 val color = makecolors im 78 79 val legendw = addlegend im itemnames black color 80 81 (* The pie-chart itself, to the left *) 82 val sum = if List.all (fn x => x > 0.0) obs then foldl op+ 0.0 obs 83 else raise Fail "piechart: all slices must be positive" 84 val radscale = 2.0 * Math.pi / sum 85 val piew = w - legendw 86 val pieh = h 87 val pied = Int.min(piew, pieh) - 20 88 val center = (piew div 2, h div 2) 89 val angleoffset = (Math.pi + obs1 * radscale) / 2.0 90 fun polar r a = (#1 center + round (r * Math.cos (a - angleoffset)), 91 #2 center + round (r * Math.sin (a - angleoffset))) 92 fun drawradius angle = 93 drawLine im (Color black) (center, polar (real pied / 2.0) angle) 94 fun fillslice i angle = 95 fill im (color i) (polar (real pied / 4.0) angle) 96 fun loop i lastsum [] = () 97 | loop i lastsum (x :: xr) = 98 (drawradius ((lastsum + x) * radscale); 99 fillslice i ((lastsum + x / 2.0) * radscale); 100 loop (i+1) (lastsum + x) xr) 101 102 in 103 drawArc im (Color black) { c = center, wh = (pied, pied), 104 from = 0, to = 360 }; 105 (case obsr of 106 [] => fillslice 0 0.0 107 | _ => (drawradius (obs1 * radscale); 108 loop 1 obs1 obsr; 109 fillslice 0 (obs1 / 2.0 * radscale))); 110 im 111 end 112 113(* Graphing several series of data, stacking the series on top of each 114 other. Time is implicit. Linear interpolation. Automatically 115 scale X and Y axis. 116 117 The input is a list of data series (rows). Each data series (row) 118 is a list of reals, and will be plotted with linear interpolation 119 between the data points. 120 *) 121 122fun accugraph (w, h) [] _ = raise Fail "accugraph: no data series" 123 | accugraph (w, h) (obss as obs1 :: obsr) itemnames = 124 let val noobs = length obs1 125 val _ = if noobs >= 2 then () 126 else raise Fail "accugraph: series must have at least two obs" 127 val _ = if List.all (fn xs => length xs = noobs) obsr then () 128 else raise Fail "accugraph: data series of unequal length" 129 130 (* The image and its color table *) 131 val im = image (w, h) (255, 255, 255) 132 val black = color im (0, 0, 0) 133 val color = makecolors im 134 135 (* Compute accumulated observations *) 136 fun loop [] sum = [sum] 137 | loop (xs :: xss) sum = 138 sum :: loop xss (ListPair.map op+ (xs, sum)) 139 val accumrows = loop obsr obs1 140 141 val legendw = addlegend im itemnames black color + 20 142 143 val maxsum = List.foldr Real.max 0.0 (List.last accumrows) 144 val lastsum = List.last (List.last accumrows) 145 val xoffset = 10 (* from left *) 146 val grfw = w - legendw - 2 * xoffset 147 (* The height will be at most 2/3 of the width: *) 148 val grfh = Int.min(h - 2 * xoffset, grfw * 2 div 3) 149 val yoffset = (h + grfh) div 2 (* from top *) 150 val xscale = real grfw / real (noobs - 1) 151 val yscale = real grfh / (maxsum + 2.0) 152 153 fun pos i y = (round (real i * xscale) + xoffset, 154 yoffset - round (y * yscale)) 155 156 fun drawobs i last [] = () 157 | drawobs i last (obs1 :: obsr) = 158 (drawLine im (Color black) (pos i last, pos (i+1) obs1); 159 drawobs (i+1) obs1 obsr) 160 161 fun drawseries (obs1 :: obsr) = drawobs 0 obs1 obsr; 162 163 fun fillsection ser last [] = () 164 | fillsection ser last ((_ :: obs12 :: _) :: obsr) = 165 (fill im (color ser) (pos 1 ((last+obs12) / 2.0)); 166 fillsection (ser-1) obs12 obsr) 167 168 fun uparrowhead (xy as (x, y)) = 169 (drawLine im (Color black) (xy, (x-3, y+4)); 170 drawLine im (Color black) (xy, (x+3, y+4))) 171 fun rightarrowhead (xy as (x, y)) = 172 (drawLine im (Color black) (xy, (x-4, y-3)); 173 drawLine im (Color black) (xy, (x-4, y+3))) 174 in 175 (* Y axis, left *) 176 drawLine im (Color black) ((xoffset, yoffset-grfh-5), 177 (xoffset, yoffset+5)); 178 uparrowhead (xoffset, yoffset-grfh-5); 179 (* Y axis, left *) 180 drawLine im (Color black) ((xoffset+grfw, 181 yoffset - round (lastsum * yscale)), 182 (xoffset+grfw, yoffset)); 183 (* X axis *) 184 drawLine im (Color black) ((xoffset-5, yoffset), 185 (xoffset+grfw+10, yoffset)); 186 rightarrowhead (xoffset+grfw+10, yoffset); 187 188 List.app drawseries accumrows; 189 fillsection (length obss - 1) 0.0 accumrows; 190 im 191 end 192 193