unit filterHistogram;
(* ***** BEGIN LICENSE BLOCK *****
* Copyright (C) 2004 Durand Emmanuel
* Copyright (C) 2004 Burgel Eric
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*
* Contact :
* filters@edurand.com
* filters@burgel.com
*
* ***** END LICENSE BLOCK ***** *)
{
edurand (filters@edurand.com)
}
interface
uses
filter, fparameters, image, SysUtils;
type
TFilterHistogram = class(TFilter)
public
constructor Create; override;
destructor Destroy; override;
procedure Run(); override;
private
parameterImageIn : TParameterImage;
parameterNormalize : TParameterString;
parameterPrecision : TParameterInteger;
parameterShow : TParameterString;
parameterFeature : TParameterInteger;
outputParameterImageOuts : TParameterImages;
imgIn : PBitmap32 ;
imageOuts : ArrayOfPBitmap32;
outputParameterHistogram : TParameterArraySingles;
histogramOuts : array[0..255] of Single;
procedure _run();
procedure destroyImageOuts();
end;
implementation
uses
imageIO, Math, divers;
constructor TFilterHistogram.Create;
begin
inherited;
parameterImageIn := addParameterImage('inImage','explication...');
parameterNormalize := addParameterString('normalize','TRUE/FALSE','TRUE');
parameterPrecision := addParameterInteger('precision','',1,15,1);
parameterShow := addParameterString('show','TRUE/FALSE','FALSE');
parameterFeature := addParameterInteger('feature', '0:Hue, 1:Luminosity, 2:Saturation', 0, 2, 1);
outputParameterImageOuts:=addOutputParameterImages('outImages','show histogram');
SetLength(imageOuts,1);
imageOuts[0]:=createImage(256,256);
setOutputParameterImages('outImages',imageOuts);
outputParameterHistogram:=addOutputParameterArraySingles('histogram','0->255');
end;
destructor TFilterHistogram.Destroy;
begin
inherited;
destroyImageOuts();
end;
procedure TFilterHistogram.destroyImageOuts();
var
i : Integer;
begin
for i:=Low(imageOuts) to High(imageOuts) do begin
image.freeImage(imageOuts[i]);
end;
end;
procedure TFilterHistogram.Run();
begin
imgIn := parameterImageIn.Image;
if (imgIn<>nil) then begin
_run();
end;
end;
procedure TFilterHistogram._run();
var
PSrc : PColor32Array;
maxX, maxY : Integer;
max : Cardinal;
x, y : Integer;
tLevel : Integer;
histogramme : array[0..255] of Integer;
histogrammeFull : array[0..255] of Integer;
histogrammenormed : array[0..255] of Integer;
histogrammepixelcountmax : Integer;
imgOut : PBitmap32 ;
i,j : Integer;
precision, pLeft, pRight, pCount : Integer;
feature : Integer ;
H, L, S : Single ;
color : TColor32 ;
begin
feature := parameterFeature.Value ;
FillChar(histogramOuts,SizeOf(histogramOuts),0);
imgOut := outputParameterImageOuts.Images[0];
maxX := scanWidth(imgIn)-1;
maxY := scanHeight(imgIn)-1;
if (maxX>0) and (maxY>0) then begin
FillChar(histogramme,SizeOf(histogramme),0);
for y:=0 to maxY do Begin
pSrc := scanLine(imgIn, y) ;
for x:=0 to maxX do Begin
image.RGBtoHSL(pSrc^[0], H, S, L) ;
case feature of
0 : tLevel := floor(H*255) ;
1 : tLevel := floor(L*255) ; //tLevel:=Intensity(pSrc^[0]);
2 : tLevel := floor(S*255) ;
else
tLevel := 0;
end ;
Inc(histogramme[tLevel]);
inc(pSrc);
end;
end;
// norm histo
FillChar(histogrammenormed,SizeOf(histogrammenormed),0);
histogrammepixelcountmax:=0;
if parameterNormalize.Value<>'FALSE' then begin
// To normalize, we only have to use directly the histogram on the ROI
for i:=0 to 255 do begin
if histogrammepixelcountmax < histogramme[i] then histogrammepixelcountmax:=histogramme[i];
end;
end else begin
// If we don't normalize,
// we have to calcul the Histogram on the full image size
FillChar(histogrammeFull,SizeOf(histogrammeFull),0);
max:=imgIn.Width*imgIn.Height-1 ;
pSrc:=imgIn.Bits;
for x:= 0 to max do Begin
//tLevel := Intensity(pSrc^[0]);
image.RGBtoHSL(pSrc^[0], H, S, L) ;
case feature of
0 : tLevel := floor(H*255) ;
1 : tLevel := floor(L*255) ; //tLevel:=Intensity(pSrc^[0]);
2 : tLevel := floor(S*255) ;
else
tLevel := 0;
end ;
Inc(histogrammeFull[tLevel]);
inc(pSrc);
end;
for i:=0 to 255 do begin
if histogrammepixelcountmax < histogrammeFull[i] then histogrammepixelcountmax:=histogrammeFull[i];
end;
end;
for i:=0 to 255 do begin
histogrammenormed[i]:=(histogramme[i] * 99) div histogrammepixelcountmax;
end;
(*
// Precision
precision:=parameterPrecision.Value;
pRight:=precision-1;
pLeft:=pRight-1; if pLeft<0 then pLeft:=0;
pCount:=1+pLeft+pRight;
for i:=pLeft to 255-pRight do begin
for j:=i-pLeft to i+pRight do begin
Inc(histogramOuts[i],histogrammenormed[j]);
end;
histogramOuts[i]:=histogramOuts[i] div pCount;
end;
*)
for i:=0 to 255 do begin
histogramOuts[i] := histogrammenormed[i] ;
end;
smoothIt(histogramOuts, parameterPrecision.Value) ;
// show
if parameterShow.Value='TRUE' then begin
eraseImage(imgOut);
for i:=0 to 255 do begin
case feature of
0 : color := HSLtoRGB(i / 255, 0.7, 0.7) ;
1 : color := clRed32 ;
2 : color := clAqua32 ;
else
color := clBlack32;
end ;
for j:=round(histogramOuts[i]) downto 0 do begin
setPixel(imgOut, i, 255-j, color);
end;
end;
end;
end;
setOutputParameterArraySingles('histogram',histogramOuts);
end;
end.
