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