A Component that plots graphs

Problem/Question/Abstract:

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.

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 <= 0 then
    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 <= 0 then
    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 <= 0 then
    mag := 1;
  if mag > 100000 then
    mag := 100000;
  fspc := (mag / 20);
  if fspc > 1 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 <= width do
  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 <= height do
  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.