[Lazarus] Object detection

[Leonardo M. Ramé]

On 2011-11-02 15:26:11 -0300, Leonardo M. Ramé wrote:
> Hi, I'm looking for a library/routine for object detection in bitmaps.
> 
> I need to process a black and white image (1bit) in low resolution and
> detect all white objects over a black background, as the attached image
> shows.
> 
> Apart from OpenCV, do you know anything similar but simplier?.
> Preferably in Pascal?.
> 
> Thanks in advance,
> -- 
> Leonardo M. Ramé
> http://leonardorame.blogspot.com

Well, it turned out to be a wrong decision to choose OpenCV. To make a
long story short, it worked on Linux but failed on Windows.

Here's a post I made on StackOverflow hoping for help:

http://stackoverflow.com/questions/8015084/opencv-pointer-to-bitmap-processing

Also asked in OpenCV chat room, on FreeNode, but nobody faced the same
issue as me.

So, I've started to google for a Blob Detection library and found this:
http://www.labbookpages.co.uk/software/imgProc/blobDetection.html

Took a look at the code, and it wasn't too complicated to migrate to
ObjectPascal, so, I did it.

I attached the resulting conversion for all those looking for it.

P.S.: The class uses TBGRABitmap, but it can be easily replaced by
TBitmap or similar.

-- 
Leonardo M. Ramé
http://leonardorame.blogspot.com
-------------- next part --------------
unit blobdetection;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,
  BGRABitmap,
  BGRABitmapTypes;

type

  { TBlob }
  TBlob = class
  private
    FxMin: Integer;
    FxMax: Integer;
    FyMin: Integer;
    FyMax: Integer;
    FMass: Integer;
  public
    constructor create( xMin, xMax, yMin, yMax, Mass: Integer);
    property xMin: Integer read FxMin;
    property yMin: Integer read FyMin;
    property xMax: Integer read FxMax;
    property yMax: Integer read FyMax;
    property Mass: Integer read FMass;
  end;

  { TBlobBoundaries }
  TBlobBoundaries = class
  private
    FBmp: TBGRABitmap;
    FX1: Integer;
    FX2: Integer;
    FY1: Integer;
    FY2: Integer;
    FBlobList: TBlobList;
    procedure DoCalcs;
    procedure GrayToBinary;
  public
    destructor Destroy; override;
    class procedure Execute(ABmp: TBGRABitmap; var AX1, AY1, AX2, AY2: Integer);
  end;


implementation

const
  cInitialColor = 0;

class procedure TBlobBoundaries.Execute(ABmp: TBGRABitmap; var AX1, AY1, AX2, AY2: Integer);
var
  lBlobBoundaries: TBlobBoundaries;
  lBlob: TBlob;
  I: Integer;
begin
  lBlobBoundaries := TBlobBoundaries.Create;
  try
    with lBlobBoundaries do
    begin
      FBlobList := TObjectList.create(True);
      FBmp := ABmp.FilterPixelate(5, False) as TBGRABitmap;
      GrayToBinary;
      FX1:= AX1;
      FX2:= AX2;
      FY1:= AY1;
      FY2:= AY2;
      DoCalcs;
      for I := 0 to FBlobList.Count - 1 do
      begin
        if I = 0 then
        begin
          lBlob := TBlob(FBlobList[0]);
        end
        else
        if TBlob(FBlobList[I]).Mass > lBlob.Mass then
          lBlob := TBlob(FBlobList[I]);
      end;
      AX1:= lBlob.xMin;
      AX2:= lBlob.xMax;
      AY1:= lBlob.yMin;
      AY2:= lBlob.yMax;
      ABmp.Assign(FBmp);
    end;
  finally
    lBlobBoundaries.Free;
  end;
end;

{ TBlob }

constructor TBlob.create(xMin, xMax, yMin, yMax, Mass: Integer);
begin
  FxMin := xMin;
  FxMax := xMax;
  FyMin := yMin;
  FyMax := yMax;
  FMass := Mass;
end;

procedure TBlobBoundaries.DoCalcs;
var
  X, Y: Integer;
  p: PBGRAPixel;
  tableSize: Integer;
  srcPtr: Integer;
  lLabel: Integer;
  aLabel: Integer;
  bLabel: Integer;
  cLabel: Integer;
  dLabel: Integer;
  aPtr: Integer;
  bPtr: Integer;
  cPtr: Integer;
  dPtr: Integer;
  lMin: Integer;
  I: Integer;
  L: Integer;
  LabelBuffer: array of Integer;
  labelTable: array of Integer;
  xMinTable: array of Integer;
  xMaxTable: array of Integer;
  yMinTable: array of Integer;
  yMaxTable: array of Integer;
  massTable: array of Integer;
  lBlob: TBlob;

begin
  SetLength(LabelBuffer, FBmp.Width * FBmp.Height);
  tableSize := FBmp.Width * FBmp.Height div 4;

  SetLength(labelTable, tableSize);
  SetLength(xMinTable, tableSize);
  SetLength(xMaxTable, tableSize);
  SetLength(yMinTable, tableSize);
  SetLength(yMaxTable, tableSize);
  SetLength(massTable, tableSize);

  srcPtr := 0;
  aPtr := -FBmp.Width - 1;
  bPtr := -FBmp.Width;
  cPtr := -FBmp.Width + 1;
  dPtr := -1;
  lLabel := 1;

  for Y := 0 to FBmp.Height - 1 do
  begin
    p := FBmp.ScanLine[Y];
    for X := 0 to FBmp.Width - 1 do
    begin
      LabelBuffer[srcPtr] := 0;
      if p^.red = 255 then
      begin
        // Find label for neighbours (0 if out of range)
        aLabel := 0;
        bLabel := 0;
        cLabel := 0;
        dLabel := 0;

        if (x > 0) and (y > 0) then
          aLabel := labelTable[LabelBuffer[aPtr]];

        if (y > 0) then
          bLabel := labelTable[LabelBuffer[bPtr]];

        if (x < FBmp.Width - 1) and (y > 0) then
          cLabel := labelTable[LabelBuffer[cPtr]];

        if (x > 0) then
          dLabel := labelTable[LabelBuffer[dPtr]];

        // Look for label with least value
        lMin := MaxInt;
        if (aLabel <> 0) and (aLabel < lmin) then
          lMin := aLabel;

        if (bLabel <> 0) and (bLabel < lmin) then
          lMin := bLabel;

        if (cLabel <> 0) and (cLabel < lmin) then
          lMin := cLabel;

        if (dLabel <> 0) and (dLabel < lmin) then
          lMin := dLabel;

        // If no neighbours in foreground
        if (lMin = MaxInt) then
        begin
          labelBuffer[srcPtr] := lLabel;
          labelTable[lLabel] := lLabel;

          // Initialise min/max x,y for label
          yMinTable[lLabel] := y;
          yMaxTable[lLabel] := y;
          xMinTable[lLabel] := x;
          xMaxTable[lLabel] := x;
          massTable[lLabel] := 1;

          inc(lLabel);
        end
        else
        // Neighbour found
        begin
          // Label pixel with lowest label from neighbours
          labelBuffer[srcPtr] := lMin;

          // Update min/max x,y for label
          yMaxTable[lMin] := y;
          inc(massTable[lMin]);

          if (x < xMinTable[lMin]) then
                   xMinTable[lMin] := x;

          if (x > xMaxTable[lMin]) then
                   xMaxTable[lMin] := x;

          if (aLabel <> 0) then
                   labelTable[aLabel] := lMin;

          if (bLabel <> 0) then
                   labelTable[bLabel] := lMin;

          if (cLabel <> 0) then
                   labelTable[cLabel] := lMin;

          if (dLabel <> 0) then
                   labelTable[dLabel] := lMin;
        end;
      end;
      inc(srcPtr);
      inc(aPtr);
      inc(bPtr);
      inc(cPtr);
      inc(dPtr);
      inc(p);
    end;
  end;

  for I := lLabel - 1 downto 0 do
  begin
    if (labelTable[i] <> i) then
    begin
      if (xMaxTable[i] > xMaxTable[labelTable[i]]) then
         xMaxTable[labelTable[i]] := xMaxTable[i];

      if (xMinTable[i] < xMinTable[labelTable[i]]) then
         xMinTable[labelTable[i]] := xMinTable[i];

      if (yMaxTable[i] > yMaxTable[labelTable[i]]) then
         yMaxTable[labelTable[i]] := yMaxTable[i];

      if (yMinTable[i] < yMinTable[labelTable[i]]) then
         yMinTable[labelTable[i]] := yMinTable[i];

      massTable[labelTable[i]] := massTable[labelTable[i]] + massTable[i];

      L := I;
      while (l <> labelTable[l]) do
        L := labelTable[l];

      labelTable[i] := L;
    end
    else
    begin
      lBlob := TBlob.create(xMinTable[i], xMaxTable[i], yMinTable[i], yMaxTable[i], massTable[i]);
      FBlobList.Add(lBlob);
    end;
  end;
end;

procedure TBlobBoundaries.GrayToBinary;
var
  I: Integer;
  A: Integer;
  n: Integer;
  psrc: PBGRAPixel;
  newintensity: single;
begin
  psrc := FBmp.Data;
  for n := 0 to FBmp.NbPixels-1 do
  begin
    if psrc^.red > 25 then
    begin
      psrc^.red := 255;
      psrc^.green := psrc^.red;
      psrc^.blue := psrc^.red;
    end
    else
    begin
      psrc^.red := 0;
      psrc^.green := psrc^.red;
      psrc^.blue := psrc^.red;
    end;

    inc(psrc);
  end;
end;

destructor TBlobBoundaries.Destroy;
begin
  FBlobList.Free;
  FBmp.Free;
  inherited Destroy;
end;

end.