Mega Code Archive
A Component that plots graphs
<![CDATA[
Title: A Component that plots graphs
Question: 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.
----------------------------code-----------------------------------------------
unit UGraph;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,Math;
type
TOnMouseMove=procedure(Shift:TShiftState;x,y:integer) of object;
TOnMouseDown=procedure(Button:TMouseButton;Shift:TShiftState;x,y:integer) of object;
TOnMouseUp=procedure(Button:TMouseButton;Shift:TShiftState;x,y:integer) of object;
TState=(fplotted,fjoined);
TGraph = class;
TPlots = class;
TPoints =class(Tlist)
private
fplots:TPlots;
fptcolor,fcrvcolor:TColor;
fstate:set of Tstate;
procedure fPlot;
procedure fJoin;
protected
function Get(index:integer):PPoint;
public
procedure Plot;
procedure Join;
constructor Create(aplots:TPlots);
function Add(x,y:integer):PPoint;
procedure HideDots;
procedure HideJoins;
procedure Clear;override;
property CurveColor:Tcolor read fcrvcolor write fcrvColor;
property DotColor:Tcolor read fptcolor write fptColor;
property Items[index:integer]:PPoint read Get;default;
end;
TPlots= class(Tlist)
private
fgraph:TGraph;
protected
function Get(index:integer):TPoints;
public
constructor Create(agraph:TGraph);
function Add:TPoints;
procedure Clear;override;
procedure PlotAllDots;
procedure PlotAllJoins;
procedure HideAllDots;
procedure HideAllJoins;
property Items[index:integer]:TPoints read Get;default;
end;
TGraph = class(TGraphicControl)
private
faxcolor,fbkcolor,fgridcolor:Tcolor;
fMouseDown:TOnMouseDown;
fMouseMove:TOnMouseMove;
fMouseUp:TOnMouseUp;
fspc:extended;
ldiv,sdiv:integer;
xaxis,yaxis:integer;
xlc,ylc:integer;
fmag:integer;
fplots:TPlots;
function Translate(x,y:integer):Tpoint;
function GetScale:Extended;
procedure DrawGrid;
procedure DrawAxes;
procedure GetXLineRect(y:integer;var arect:trect);
procedure GetYLineRect(x:integer;var arect:trect);
procedure SetGridColor(acolor:Tcolor);
procedure SetBackColor(acolor:Tcolor);
procedure SetAxisColor(acolor:TColor);
protected
procedure loaded;override;
procedure Paint; override;
{procedure MsgHandler(var msg:TMessage);}
procedure MouseDown(Button:TMouseButton;shift:TShiftState;x,y:integer);override;
procedure MouseMove(shift:TShiftState;x,y:integer);override;
procedure MouseUp(Button:TMouseButton;shift:TShiftState;x,y:integer);override;
public
constructor Create(AComponent:TComponent);override;
destructor Destroy;override;
procedure OffSetAxes(x,y:integer);
procedure ResetAxes;
procedure Zoom(mag:integer);
property Plots:TPlots read fplots;
published
property OnMouseDown:TOnMouseDown read fMouseDown write fMouseDown;
property OnMouseMove:TOnMouseMove read fMouseMove write fMouseMove;
property OnMouseUp:TOnMouseUp read fMouseUp write fMouseUp;
property GridColor:Tcolor read fgridcolor write SetGridColor;
property BackColor:Tcolor read fbkcolor write SetBackColor;
property AxisColor:Tcolor read faxcolor write SetAxisColor;
property Scale:extended read GetScale;
property ZoomFactor:integer read fmag;
end;
procedure Register;
implementation
procedure TGraph.MouseDown(Button:TMouseButton;shift:TShiftState;x,y:integer);
var
tp:Tpoint;
begin
tp.x:=x-left;
tp.y:=y-top;
tp.x:=trunc(tp.x/fspc-yaxis);
tp.y:=trunc(xaxis-tp.y/fspc);
if (assigned(fMouseDown)) then
fMouseDown(button,shift,tp.x,tp.y);
inherited;
end;
procedure TGraph.MouseMove(shift:TShiftState;x,y:integer);
var
tp:Tpoint;
begin
tp.x:=x-left;
tp.y:=y-top;
tp.x:=trunc(tp.x/fspc-yaxis);
tp.y:=trunc(xaxis-tp.y/fspc);
if (assigned(fMousemove)) then
fMousemove(shift,tp.x,tp.y);
inherited;
end;
procedure TGraph.MouseUp(Button:TMouseButton;shift:TShiftState;x,y:integer);
var
tp:Tpoint;
begin
tp.x:=x-left;
tp.y:=y-top;
tp.x:=trunc(tp.x/fspc-yaxis);
tp.y:=trunc(xaxis-tp.y/fspc);
if (assigned(fMouseUp)) then
fMouseup(button,shift,tp.x,tp.y);
inherited;
end;
constructor TPoints.Create(aplots:TPlots);
begin
if aplots=nil then
raise Exception.Create('Not a valid Graph object.');
fplots:=aplots;
end;
constructor TPlots.Create(agraph:Tgraph);
begin
if agraph=nil then
raise Exception.Create('Not a valid Graph object.');
fgraph:=agraph;
end;
procedure TPoints.HideDots;
begin
fstate:=fstate-[fplotted];
end;
procedure TPoints.HideJoins;
begin
fstate:=fstate-[fjoined];
end;
procedure TPoints.Plot;
begin
fstate:=fstate+[fplotted];
fplots.fgraph.invalidate;
end;
procedure TPoints.fPlot;
var
i:integer;
tmp:tpoint;
begin
if count exit;
with fplots.fgraph do
begin
canvas.pen.color:=fptcolor;
canvas.pen.width:=1;
for i:=0 to count-1 do
begin
tmp:=Translate(items[i].x,items[i].y);
canvas.Ellipse(rect(tmp.x-1,tmp.y-1,tmp.x+1,tmp.y+1));
end;
end;
end;
procedure TPoints.Join;
begin
fstate:=fstate+[fjoined];
fplots.fgraph.invalidate;
end;
procedure TPoints.fJoin;
var
i:integer;
tmp:tpoint;
begin
if count exit;
with fplots.fgraph do
begin
canvas.pen.color:=fcrvcolor;
canvas.pen.width:=1;
tmp:=Translate(items[0].x,items[0].y);
canvas.moveto(tmp.x,tmp.y);
for i:=1 to count-1 do
begin
tmp:=Translate(items[i].x,items[i].y);
canvas.lineto(tmp.x,tmp.y);
end;
end;
end;
procedure TPlots.PlotAllDots;
var
i:integer;
begin
for i:= 0 to count -1 do
items[i].Plot;
end;
procedure TPlots.PlotAllJoins;
var
i:integer;
begin
for i:= 0 to count -1 do
items[i].join
end;
procedure TPlots.HideAllDots;
var
i:integer;
inv:boolean;
begin
inv:=false;
for i:= 0 to count -1 do
if (fplotted in items[i].fstate) then
begin
items[i].fstate:=items[i].fstate-[fplotted];
inv:=true;
end;
if inv then
fgraph.invalidate;
end;
procedure TPlots.HideAllJoins;
var
i:integer;
inv:boolean;
begin
inv:=false;
for i:= 0 to count -1 do
if (fjoined in items[i].fstate) then
begin
items[i].fstate:=items[i].fstate-[fjoined];
inv:=true;
end;
if inv then
fgraph.invalidate;
end;
function TPlots.Get(index:integer):TPoints;
begin
result:=TPoints(inherited Get(index));
end;
function TPlots.Add:TPoints;
begin
result:=TPoints.create(self);
inherited Add(result);
end;
procedure TPlots.Clear;
var
i:integer;
tmp:Tpoints;
begin
for i:=0 to count-1 do
begin
tmp:=items[i];
freeandnil(tmp);
end;
inherited;
end;
procedure TPoints.Clear;
var
i:integer;
begin
for i:=0 to count-1 do
dispose(items[i]);
inherited;
end;
function TPoints.Get(index:integer):PPoint;
begin
result:=PPoint(inherited Get(index));
end;
function TPoints.Add(x,y:integer):PPoint;
begin
new(result);
result.x:=x;result.y:=y;
inherited Add(result);
end;
function TGraph.GetScale:extended;
begin
if fspc result:=sdiv/fspc
else
result:=1;
end;
destructor TGraph.Destroy;
begin
freeandnil(fplots);
inherited;
end;
constructor TGraph.Create(AComponent:TComponent);
begin
fplots:=TPlots.create(self);
fmag:=100;
fbkcolor:=clwhite;
faxcolor:=clnavy;
fgridcolor:=RGB(214,244,254);
ldiv:=10;sdiv:=5;fspc:=1;
inherited;
end;
procedure TGraph.GetXLineRect(y:integer;var arect:trect);
begin
arect.left:=left;arect.right:=arect.left+width;
arect.top:=top+trunc(y*fspc);
arect.bottom:=arect.top+2;
end;
procedure TGraph.GetYLineRect(x:integer;var arect:trect);
begin
arect.top:=top;arect.bottom:=arect.top+height;
arect.left:=left+trunc(x*fspc);
arect.right:=arect.left+2;
end;
procedure TGraph.SetGridColor(acolor:Tcolor);
begin
fgridcolor:=acolor;
Invalidate;
end;
procedure TGraph.SetBackColor(acolor:Tcolor);
begin
fbkcolor:=acolor;
Invalidate;
end;
procedure TGraph.SetAxisColor(acolor:TColor);
begin
faxcolor:=acolor;
Invalidate;
end;
procedure TGraph.Zoom(mag:integer);
begin
if mag mag:=1;
if mag100000 then
mag:=100000;
fspc:=(mag/20);
if fspc1 then
fspc:=trunc(fspc);
fmag:=mag;
xlc:=Trunc(width/fspc);
ylc:=Trunc(height/fspc);
xaxis:=Trunc(ylc/2); yaxis:=Trunc(xlc/2);
Invalidate;
end;
function TGraph.Translate(x,y:integer):Tpoint;
begin
result.x:=trunc((x+yaxis)*fspc);
result.y:=trunc((xaxis-y)*fspc);
end;
procedure TGraph.loaded;
begin
Zoom(fmag);
end;
procedure TGraph.ResetAxes;
begin
Zoom(fmag);
end;
procedure TGraph.OffSetAxes(x,y:integer);
var
tmp:trect;
tmpx,tmpy:integer;
begin
canvas.Pen.color:=faxcolor;
canvas.Pen.Width:=1;
tmpx:=xaxis;tmpy:=yaxis;
xaxis:=xaxis-y;yaxis:=yaxis+x;
if (tmpx=xaxis) and (tmpy=yaxis) then
exit;
GetXlineRect(tmpx,tmp);
InvalidateRect(parent.handle,@tmp,false);
GetYlineRect(tmpy,tmp);
InvalidateRect(parent.handle,@tmp,false);
GetXlineRect(xaxis,tmp);
InvalidateRect(parent.handle,@tmp,false);
GetYlineRect(yaxis,tmp);
InvalidateRect(parent.handle,@tmp,false);
end;
procedure TGraph.DrawAxes;
begin
canvas.Pen.color:=faxcolor;
canvas.Pen.Width:=1;
canvas.MoveTo(0,trunc(fspc*xaxis));
canvas.lineto(width,trunc(fspc*xaxis));
canvas.MoveTo(trunc(fspc*yaxis),0);
canvas.lineto(trunc(fspc*yaxis),height);
end;
procedure TGraph.DrawGrid;
var
i,t:integer;
t1,t2:Tpoint;
begin
i:=0;t:=0;
canvas.pen.color:=fbkcolor;
canvas.Brush.color:=fbkcolor;
canvas.rectangle(0,0,width,height);
canvas.Pen.color:=fgridcolor;
canvas.Pen.Width:=1;
while i begin
if (t mod ldiv)=0 then
canvas.pen.width:=2
else
canvas.pen.width:=1;
t1.x:=i; t1.y:=0;
canvas.moveto(t1.x,t1.y);
t2.x:=i;t2.y:=height;
canvas.lineto(t2.x,t2.y);
i:=i+max(trunc(fspc),sdiv);
t:=t+1;
end;
i:=0;t:=0;
while i begin
if (t mod ldiv)=0 then
canvas.pen.width:=2
else
canvas.pen.width:=1;
t1.x:=0; t1.y:=i;
canvas.moveto(t1.x,t1.y);
t2.x:=width;t2.y:=i;
canvas.lineto(t2.x,t2.y);
i:=i+max(trunc(fspc),sdiv);
t:=t+1;
end;
end;
procedure TGraph.Paint;
var
i:integer;
begin
DrawGrid;
for i:=0 to fplots.count-1 do
begin
if (fplotted in fplots[i].fstate) then
fplots[i].fplot;
if fjoined in fplots[i].fstate then
fplots[i].fjoin;
end;
DrawAxes;
end;
procedure Register;
begin
RegisterComponents('My Components', [TGraph]);
end;
end.
--------------------------------------------------------------------------------
Please report any bugs by adding comments to this article.
]]>