Author: Vimil Saju
A component for creating graphs
Answer:
Here is a component that draws graphs. You can zoom in and out of the graph. The
code is shown below. Copy the code to .pas file and install the component. I will
add a demo to show how to use this component soon.
1 unit UGraph;
2
3 interface
4
5 uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Math;
7
8 type
9 TOnMouseMove = procedure(Shift: TShiftState; x, y: integer) of object;
10 TOnMouseDown = procedure(Button: TMouseButton; Shift: TShiftState; x, y: integer)
11 of
12 object;
13 TOnMouseUp = procedure(Button: TMouseButton; Shift: TShiftState; x, y: integer) of
14 object;
15
16 TState = (fplotted, fjoined);
17 TGraph = class;
18 TPlots = class;
19
20 TPoints = class(Tlist)
21 private
22 fplots: TPlots;
23 fptcolor, fcrvcolor: TColor;
24 fstate: set of Tstate;
25 procedure fPlot;
26 procedure fJoin;
27 protected
28 function Get(index: integer): PPoint;
29 public
30 procedure Plot;
31 procedure Join;
32 constructor Create(aplots: TPlots);
33 function Add(x, y: integer): PPoint;
34 procedure HideDots;
35 procedure HideJoins;
36 procedure Clear; override;
37 property CurveColor: Tcolor read fcrvcolor write fcrvColor;
38 property DotColor: Tcolor read fptcolor write fptColor;
39 property Items[index: integer]: PPoint read Get; default;
40 end;
41
42 TPlots = class(Tlist)
43 private
44 fgraph: TGraph;
45 protected
46 function Get(index: integer): TPoints;
47 public
48 constructor Create(agraph: TGraph);
49 function Add: TPoints;
50 procedure Clear; override;
51 procedure PlotAllDots;
52 procedure PlotAllJoins;
53 procedure HideAllDots;
54 procedure HideAllJoins;
55 property Items[index: integer]: TPoints read Get; default;
56 end;
57
58 TGraph = class(TGraphicControl)
59 private
60 faxcolor, fbkcolor, fgridcolor: Tcolor;
61 fMouseDown: TOnMouseDown;
62 fMouseMove: TOnMouseMove;
63 fMouseUp: TOnMouseUp;
64 fspc: extended;
65 ldiv, sdiv: integer;
66 xaxis, yaxis: integer;
67 xlc, ylc: integer;
68 fmag: integer;
69 fplots: TPlots;
70 function Translate(x, y: integer): Tpoint;
71 function GetScale: Extended;
72 procedure DrawGrid;
73 procedure DrawAxes;
74 procedure GetXLineRect(y: integer; var arect: trect);
75 procedure GetYLineRect(x: integer; var arect: trect);
76 procedure SetGridColor(acolor: Tcolor);
77 procedure SetBackColor(acolor: Tcolor);
78 procedure SetAxisColor(acolor: TColor);
79 protected
80 procedure loaded; override;
81 procedure Paint; override;
82 {procedure MsgHandler(var msg:TMessage);}
83 procedure MouseDown(Button: TMouseButton; shift: TShiftState; x, y: integer);
84 override;
85 procedure MouseMove(shift: TShiftState; x, y: integer); override;
86 procedure MouseUp(Button: TMouseButton; shift: TShiftState; x, y: integer);
87 override;
88 public
89 constructor Create(AComponent: TComponent); override;
90 destructor Destroy; override;
91 procedure OffSetAxes(x, y: integer);
92 procedure ResetAxes;
93 procedure Zoom(mag: integer);
94 property Plots: TPlots read fplots;
95 published
96 property OnMouseDown: TOnMouseDown read fMouseDown write fMouseDown;
97 property OnMouseMove: TOnMouseMove read fMouseMove write fMouseMove;
98 property OnMouseUp: TOnMouseUp read fMouseUp write fMouseUp;
99 property GridColor: Tcolor read fgridcolor write SetGridColor;
100 property BackColor: Tcolor read fbkcolor write SetBackColor;
101 property AxisColor: Tcolor read faxcolor write SetAxisColor;
102 property Scale: extended read GetScale;
103 property ZoomFactor: integer read fmag;
104 end;
105
106 procedure register;
107
108 implementation
109
110 procedure TGraph.MouseDown(Button: TMouseButton; shift: TShiftState; x, y: integer);
111 var
112 tp: Tpoint;
113 begin
114 tp.x := x - left;
115 tp.y := y - top;
116 tp.x := trunc(tp.x / fspc - yaxis);
117 tp.y := trunc(xaxis - tp.y / fspc);
118 if (assigned(fMouseDown)) then
119 fMouseDown(button, shift, tp.x, tp.y);
120 inherited;
121 end;
122
123 procedure TGraph.MouseMove(shift: TShiftState; x, y: integer);
124 var
125 tp: Tpoint;
126 begin
127 tp.x := x - left;
128 tp.y := y - top;
129 tp.x := trunc(tp.x / fspc - yaxis);
130 tp.y := trunc(xaxis - tp.y / fspc);
131 if (assigned(fMousemove)) then
132 fMousemove(shift, tp.x, tp.y);
133 inherited;
134 end;
135
136 procedure TGraph.MouseUp(Button: TMouseButton; shift: TShiftState; x, y: integer);
137 var
138 tp: Tpoint;
139 begin
140 tp.x := x - left;
141 tp.y := y - top;
142 tp.x := trunc(tp.x / fspc - yaxis);
143 tp.y := trunc(xaxis - tp.y / fspc);
144 if (assigned(fMouseUp)) then
145 fMouseup(button, shift, tp.x, tp.y);
146 inherited;
147 end;
148
149 constructor TPoints.Create(aplots: TPlots);
150 begin
151 if aplots = nil then
152 raise Exception.Create('Not a valid Graph object.');
153 fplots := aplots;
154 end;
155
156 constructor TPlots.Create(agraph: Tgraph);
157 begin
158 if agraph = nil then
159 raise Exception.Create('Not a valid Graph object.');
160 fgraph := agraph;
161 end;
162
163 procedure TPoints.HideDots;
164 begin
165 fstate := fstate - [fplotted];
166 end;
167
168 procedure TPoints.HideJoins;
169 begin
170 fstate := fstate - [fjoined];
171 end;
172
173 procedure TPoints.Plot;
174 begin
175 fstate := fstate + [fplotted];
176 fplots.fgraph.invalidate;
177 end;
178
179 procedure TPoints.fPlot;
180 var
181 i: integer;
182 tmp: tpoint;
183 begin
184 if count <= 0 then
185 exit;
186 with fplots.fgraph do
187 begin
188 canvas.pen.color := fptcolor;
189 canvas.pen.width := 1;
190 for i := 0 to count - 1 do
191 begin
192 tmp := Translate(items[i].x, items[i].y);
193 canvas.Ellipse(rect(tmp.x - 1, tmp.y - 1, tmp.x + 1, tmp.y + 1));
194 end;
195 end;
196 end;
197
198 procedure TPoints.Join;
199 begin
200 fstate := fstate + [fjoined];
201 fplots.fgraph.invalidate;
202 end;
203
204 procedure TPoints.fJoin;
205 var
206 i: integer;
207 tmp: tpoint;
208 begin
209 if count <= 0 then
210 exit;
211 with fplots.fgraph do
212 begin
213 canvas.pen.color := fcrvcolor;
214 canvas.pen.width := 1;
215 tmp := Translate(items[0].x, items[0].y);
216 canvas.moveto(tmp.x, tmp.y);
217 for i := 1 to count - 1 do
218 begin
219 tmp := Translate(items[i].x, items[i].y);
220 canvas.lineto(tmp.x, tmp.y);
221 end;
222 end;
223 end;
224
225 procedure TPlots.PlotAllDots;
226 var
227 i: integer;
228 begin
229 for i := 0 to count - 1 do
230 items[i].Plot;
231 end;
232
233 procedure TPlots.PlotAllJoins;
234 var
235 i: integer;
236 begin
237 for i := 0 to count - 1 do
238 items[i].join
239 end;
240
241 procedure TPlots.HideAllDots;
242 var
243 i: integer;
244 inv: boolean;
245 begin
246 inv := false;
247 for i := 0 to count - 1 do
248 if (fplotted in items[i].fstate) then
249 begin
250 items[i].fstate := items[i].fstate - [fplotted];
251 inv := true;
252 end;
253 if inv then
254 fgraph.invalidate;
255 end;
256
257 procedure TPlots.HideAllJoins;
258 var
259 i: integer;
260 inv: boolean;
261 begin
262 inv := false;
263 for i := 0 to count - 1 do
264 if (fjoined in items[i].fstate) then
265 begin
266 items[i].fstate := items[i].fstate - [fjoined];
267 inv := true;
268 end;
269 if inv then
270 fgraph.invalidate;
271 end;
272
273 function TPlots.Get(index: integer): TPoints;
274 begin
275 result := TPoints(inherited Get(index));
276 end;
277
278 function TPlots.Add: TPoints;
279 begin
280 result := TPoints.create(self);
281 inherited Add(result);
282 end;
283
284 procedure TPlots.Clear;
285 var
286 i: integer;
287 tmp: Tpoints;
288 begin
289 for i := 0 to count - 1 do
290 begin
291 tmp := items[i];
292 freeandnil(tmp);
293 end;
294 inherited;
295 end;
296
297 procedure TPoints.Clear;
298 var
299 i: integer;
300 begin
301 for i := 0 to count - 1 do
302 dispose(items[i]);
303 inherited;
304 end;
305
306 function TPoints.Get(index: integer): PPoint;
307 begin
308 result := PPoint(inherited Get(index));
309 end;
310
311 function TPoints.Add(x, y: integer): PPoint;
312 begin
313 new(result);
314 result.x := x;
315 result.y := y;
316 inherited Add(result);
317 end;
318
319 function TGraph.GetScale: extended;
320 begin
321 if fspc result := sdiv / fspc
322 else
323 result := 1;
324 end;
325
326 destructor TGraph.Destroy;
327 begin
328 freeandnil(fplots);
329 inherited;
330 end;
331
332 constructor TGraph.Create(AComponent: TComponent);
333 begin
334 fplots := TPlots.create(self);
335 fmag := 100;
336 fbkcolor := clwhite;
337 faxcolor := clnavy;
338 fgridcolor := RGB(214, 244, 254);
339 ldiv := 10;
340 sdiv := 5;
341 fspc := 1;
342 inherited;
343 end;
344
345 procedure TGraph.GetXLineRect(y: integer; var arect: trect);
346 begin
347 arect.left := left;
348 arect.right := arect.left + width;
349 arect.top := top + trunc(y * fspc);
350 arect.bottom := arect.top + 2;
351 end;
352
353 procedure TGraph.GetYLineRect(x: integer; var arect: trect);
354 begin
355 arect.top := top;
356 arect.bottom := arect.top + height;
357 arect.left := left + trunc(x * fspc);
358 arect.right := arect.left + 2;
359 end;
360
361 procedure TGraph.SetGridColor(acolor: Tcolor);
362 begin
363 fgridcolor := acolor;
364 Invalidate;
365 end;
366
367 procedure TGraph.SetBackColor(acolor: Tcolor);
368 begin
369 fbkcolor := acolor;
370 Invalidate;
371 end;
372
373 procedure TGraph.SetAxisColor(acolor: TColor);
374 begin
375 faxcolor := acolor;
376 Invalidate;
377 end;
378
379 procedure TGraph.Zoom(mag: integer);
380 begin
381 if mag <= 0 then
382 mag := 1;
383 if mag > 100000 then
384 mag := 100000;
385 fspc := (mag / 20);
386 if fspc > 1 then
387 fspc := trunc(fspc);
388 fmag := mag;
389 xlc := Trunc(width / fspc);
390 ylc := Trunc(height / fspc);
391 xaxis := Trunc(ylc / 2);
392 yaxis := Trunc(xlc / 2);
393 Invalidate;
394 end;
395
396 function TGraph.Translate(x, y: integer): Tpoint;
397 begin
398 result.x := trunc((x + yaxis) * fspc);
399 result.y := trunc((xaxis - y) * fspc);
400 end;
401
402 procedure TGraph.loaded;
403 begin
404 Zoom(fmag);
405 end;
406
407 procedure TGraph.ResetAxes;
408 begin
409 Zoom(fmag);
410 end;
411
412 procedure TGraph.OffSetAxes(x, y: integer);
413 var
414 tmp: trect;
415 tmpx, tmpy: integer;
416 begin
417 canvas.Pen.color := faxcolor;
418 canvas.Pen.Width := 1;
419 tmpx := xaxis;
420 tmpy := yaxis;
421 xaxis := xaxis - y;
422 yaxis := yaxis + x;
423 if (tmpx = xaxis) and (tmpy = yaxis) then
424 exit;
425 GetXlineRect(tmpx, tmp);
426 InvalidateRect(parent.handle, @tmp, false);
427 GetYlineRect(tmpy, tmp);
428 InvalidateRect(parent.handle, @tmp, false);
429
430 GetXlineRect(xaxis, tmp);
431 InvalidateRect(parent.handle, @tmp, false);
432 GetYlineRect(yaxis, tmp);
433 InvalidateRect(parent.handle, @tmp, false);
434 end;
435
436 procedure TGraph.DrawAxes;
437 begin
438 canvas.Pen.color := faxcolor;
439 canvas.Pen.Width := 1;
440 canvas.MoveTo(0, trunc(fspc * xaxis));
441 canvas.lineto(width, trunc(fspc * xaxis));
442 canvas.MoveTo(trunc(fspc * yaxis), 0);
443 canvas.lineto(trunc(fspc * yaxis), height);
444 end;
445
446 procedure TGraph.DrawGrid;
447 var
448 i, t: integer;
449 t1, t2: Tpoint;
450 begin
451 i := 0;
452 t := 0;
453 canvas.pen.color := fbkcolor;
454 canvas.Brush.color := fbkcolor;
455 canvas.rectangle(0, 0, width, height);
456 canvas.Pen.color := fgridcolor;
457 canvas.Pen.Width := 1;
458 while i <= width do
459 begin
460 if (t mod ldiv) = 0 then
461 canvas.pen.width := 2
462 else
463 canvas.pen.width := 1;
464 t1.x := i;
465 t1.y := 0;
466 canvas.moveto(t1.x, t1.y);
467 t2.x := i;
468 t2.y := height;
469 canvas.lineto(t2.x, t2.y);
470 i := i + max(trunc(fspc), sdiv);
471 t := t + 1;
472 end;
473 i := 0;
474 t := 0;
475 while i <= height do
476 begin
477 if (t mod ldiv) = 0 then
478 canvas.pen.width := 2
479 else
480 canvas.pen.width := 1;
481 t1.x := 0;
482 t1.y := i;
483 canvas.moveto(t1.x, t1.y);
484 t2.x := width;
485 t2.y := i;
486 canvas.lineto(t2.x, t2.y);
487 i := i + max(trunc(fspc), sdiv);
488 t := t + 1;
489 end;
490 end;
491
492 procedure TGraph.Paint;
493 var
494 i: integer;
495 begin
496 DrawGrid;
497 for i := 0 to fplots.count - 1 do
498 begin
499 if (fplotted in fplots[i].fstate) then
500 fplots[i].fplot;
501 if fjoined in fplots[i].fstate then
502 fplots[i].fjoin;
503 end;
504 DrawAxes;
505 end;
506
507 procedure register;
508 begin
509 RegisterComponents('My Components', [TGraph]);
510 end;
511
512 end.
|
