Delphi - histogram

Use it as :

histimage:TImage;  // is setup somewhere

myhist:=TIntHistogram.create(101,0,100,histimage);   // 101 slots from 0..100, onto histimage

for i:=.. to .. do begin 	// loop over samples
  
  myhist.addvalue(q);		// q is the parameter of the histogram
 end;

myhist.display;
myhist.movetomemo(memo1);	// get the numbers as list
myhist.destroy;

the unit

unit Histogramm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,ExtCtrls,VArrays;

type
  TIntHistogramm = class(tobject)
  private
    { Private declarations }
   hv:intarray;
   fslots:integer;
   fmin,fmax:integer;
   fover,funder:integer;
   fdx:double;
   ft:TImage;
   finclude:boolean;
  protected
    { Protected declarations }
   function getvalue(index:integer):integer;
   function getpeak:integer;
   function getsum:integer;
  public
    { Public declarations }
    property values[index:integer]:integer read getvalue;  default;
    constructor create(slots:integer;min,max:integer;T:TImage);
    destructor destroy; override;
    procedure addvalue(q:integer);
    procedure addvalues(x,y:integer);
    procedure display;
    procedure MoveToMemo(m:TMemo);
    procedure clear;
  published
    { Published declarations }
   property peak:integer read getpeak;
   property sum:integer read getsum;
   property includebound:boolean read finclude write finclude;
   property under:integer read funder;
   property over:integer read fover;
  end;

procedure Register;

implementation


//............................................................................
function TIntHistogramm.getvalue(index:integer):integer;
begin
 result:=hv[index];
end;

constructor TIntHistogramm.create(slots:integer;min,max:integer;T:TImage);
begin
 inherited create;
 fslots:=slots;
 hv:=IntArray.create(slots);
 hv.clear;
 fmin:=min; fmax:=max;
 fdx:=(fmax-fmin+1)/fslots;
 ft:=t;
 finclude:=true;
end;

destructor TIntHistogramm.destroy;
begin
 hv.destroy;
end;

procedure TIntHistogramm.addvalue(q:integer);
var i:integer;
begin
 if (q>fmax) then inc(fover);
 if (q=fmin)and(q<=fmax) then begin
  i:=round(fslots*(q-fmin)/(fmax-fmin+1));
  hv[i]:=hv[i]+1;
 end;
end;
procedure TIntHistogramm.addvalues(x,y:integer);
var i:integer;
begin
 if (x>fmax) then inc(fover);
 if (x=fmin)and(x<=fmax) then begin
  i:=round(fslots*(x-fmin)/(fmax-fmin+1));
  hv[i]:=hv[i]+round(y);
 end;
end;

function TIntHistogramm.getpeak:integer;
var i,j:integer;
begin
 j:=0;
 for i:=0 to fslots-1 do begin
  if (hv[i]>j) then j:=hv[i];
 end;
 if (finclude)and(fover>j) then j:=fover;
 if (finclude)and(funder>j) then j:=funder;
 result:=j;
end;

function TIntHistogramm.getsum:integer;
var i,j:integer;
begin
 j:=0;
 for i:=0 to fslots-1 do begin
  j:=j+hv[i];
 end;
 if (finclude)then j:=j+fover;
 if (finclude)then j:=j+funder;
 result:=j;
end;

procedure TIntHistogramm.display;
var x,y,i,j:integer;
dx,dy:single;
begin
 ft.canvas.pen.color:=clwhite;
 ft.canvas.brush.color:=clwhite;
 ft.canvas.rectangle(0,0,ft.width-1,ft.height-1);
 ft.canvas.brush.color:=clblack;
 ft.canvas.pen.color:=clblack;
 j:=getpeak;
 if j>0 then begin
  dy:=ft.height/j;
  if (finclude) then dx:=ft.width/(fslots+2)
  else dx:=ft.width/fslots;
  if (finclude) then begin
   for x:=0 to fslots-1 do begin
    y:=round(hv[x]*dy);
    ft.canvas.rectangle(round((x+1)*dx),ft.height-y-1,round((x+2)*dx),ft.height-1);
   end;
   ft.canvas.brush.color:=clred;
   ft.canvas.pen.color:=clred;
   y:=round(funder*dy);
   ft.canvas.rectangle(0,ft.height-y-1,round(dx),ft.height-1);
   y:=round(fover*dy);
   ft.canvas.rectangle(round(ft.width-dx-1),ft.height-y-1,ft.width-1,ft.height-1);
  end
  else begin
   for x:=0 to fslots-1 do begin
    y:=round(hv[x]*dy);
    ft.canvas.rectangle(round(x*dx),ft.height-y,round((x+1)*dx),ft.height-1);
   end;
  end; // else
 end;
end;

procedure TIntHistogramm.MoveToMemo(m:TMemo);
var i:integer;
 s:string;
begin
 m.clear;
 m.lines.add(' ');
 for i:=0 to fslots-1 do begin
  s:=format('slot %4d  %6d  %6d  %4d',[i,round(fmin+i*fdx),round(fmin+(i+1)*fdx),hv[i]]);
  m.lines.add(s);
 end;
end;

procedure TIntHistogramm.clear;
begin
 hv.clear;
 fover:=0;funder:=0;
end;


procedure Register;
begin
 //RegisterComponents('Samples', [THistogramm]);
end;

end.

improvements