LCL: added a FloodFill algorithm. Because it uses Pixels it can only be used for very small canvas

git-svn-id: trunk@15404 -

ide/compileroptionsdlg.lfm

@@ -3,8 +3,6 @@ object frmCompilerOptions: TfrmCompilerOptions
   Height = 528
   Top = 186
   Width = 669
-  HorzScrollBar.Page = 668
-  VertScrollBar.Page = 527
   ActiveControl = MainNotebook
   BorderIcons = [biSystemMenu]
   Caption = 'frmCompilerOptions'

lcl/graphutil.pp

@@ -27,7 +27,7 @@ unit GraphUtil;
 interface
 
 uses
-  Types, Graphics, Math, LCLType;
+  Types, Graphics, GraphType, Math, LCLType;
 
 function ColorToGray(const AColor: TColor): Byte;
 procedure ColorToHLS(const AColor: TColor; out H, L, S: Byte);
@@ -59,6 +59,7 @@ procedure DrawArrow(Canvas:TCanvas;Direction:TScrollDirection; Location: TPoint;
 procedure DrawArrow(Canvas:TCanvas;p1,p2: TPoint; ArrowType: TArrowType=atSolid);
 procedure DrawArrow(Canvas:TCanvas;p1,p2: TPoint; ArrowLen: longint; ArrowAngleRad: float=NiceArrowAngle; ArrowType: TArrowType=atSolid);
 
+procedure FloodFill(Canvas: TCanvas; X, Y: Integer; lColor: TColor; FillStyle: TFillStyle);
 
 // delphi compatibility
 procedure ColorRGBToHLS(clrRGB: COLORREF; var Hue, Luminance, Saturation: Word);
@@ -248,6 +249,124 @@ begin
   end;
 end;
 
+type
+  ByteRA = array [1..1] of byte;
+  Bytep = ^ByteRA;
+  LongIntRA = array [1..1] of LongInt;
+  LongIntp = ^LongIntRA;
+
+procedure FloodFill(Canvas: TCanvas; X, Y: Integer; lColor: TColor;
+  FillStyle: TFillStyle);
+//Written by Chris Rorden
+// Very slow, because uses Canvas.Pixels.
+//A simple first-in-first-out circular buffer (the queue) for flood-filling contiguous voxels.
+//This algorithm avoids stack problems associated simple recursive algorithms
+//http://steve.hollasch.net/cgindex/polygons/floodfill.html [^]
+const
+  kFill = 0; //pixels we will want to flood fill
+  kFillable = 128; //voxels we might flood fill
+  kUnfillable = 255; //voxels we can not flood fill
+var
+  lWid,lHt,lQSz,lQHead,lQTail: integer;
+  lQRA: LongIntP;
+  lMaskRA: ByteP;
+  
+  procedure IncQra(var lVal, lQSz: integer);//nested inside FloodFill
+  begin
+      inc(lVal);
+      if lVal >= lQSz then
+         lVal := 1;
+  end; //nested Proc IncQra
+  
+  function Pos2XY (lPos: integer): TPoint;
+  begin
+      result.X := ((lPos-1) mod lWid)+1; //horizontal position
+      result.Y := ((lPos-1) div lWid)+1; //vertical position
+  end; //nested Proc Pos2XY
+  
+  procedure TestPixel(lPos: integer);
+  begin
+       if (lMaskRA^[lPos]=kFillable) then begin
+          lMaskRA^[lPos] := kFill;
+          lQra^[lQHead] := lPos;
+          incQra(lQHead,lQSz);
+       end;
+  end; //nested Proc TestPixel
+  
+  procedure RetirePixel; //nested inside FloodFill
+  var
+     lVal: integer;
+     lXY : TPoint;
+  begin
+     lVal := lQra^[lQTail];
+     lXY := Pos2XY(lVal);
+     if lXY.Y > 1 then
+          TestPixel (lVal-lWid);//pixel above
+     if lXY.Y < lHt then
+        TestPixel (lVal+lWid);//pixel below
+     if lXY.X > 1 then
+          TestPixel (lVal-1); //pixel to left
+     if lXY.X < lWid then
+        TestPixel (lVal+1); //pixel to right
+     incQra(lQTail,lQSz); //done with this pixel
+  end; //nested proc RetirePixel
+  
+var
+   lTargetColorVal,lDefaultVal: byte;
+   lX,lY,lPos: integer;
+   lBrushColor: TColor;
+begin //FloodFill
+  if FillStyle = fsSurface then begin
+     //fill only target color with brush - bounded by nontarget color.
+     if Canvas.Pixels[X,Y] <> lColor then exit;
+     lTargetColorVal := kFillable;
+     lDefaultVal := kUnfillable;
+  end else begin //fsBorder
+      //fill non-target color with brush - bounded by target-color
+     if Canvas.Pixels[X,Y] = lColor then exit;
+     lTargetColorVal := kUnfillable;
+     lDefaultVal := kFillable;
+  end;
+  //if (lPt < 1) or (lPt > lMaskSz) or (lMaskP[lPt] <> 128) then exit;
+  lHt := Canvas.Height;
+  lWid := Canvas.Width;
+  lQSz := lHt * lWid;
+  //Qsz should be more than the most possible simultaneously active pixels
+  //Worst case scenario is a click at the center of a 3x3 image: all 9 pixels will be active simultaneously
+  //for larger images, only a tiny fraction of pixels will be active at one instance.
+  //perhaps lQSz = ((lHt*lWid) div 4) + 32; would be safe and more memory efficient
+  if (lHt < 1) or (lWid < 1) then exit;
+  getmem(lQra,lQSz*sizeof(longint)); //very wasteful -
+  getmem(lMaskRA,lHt*lWid*sizeof(byte));
+  for lPos := 1 to (lHt*lWid) do
+      lMaskRA^[lPos] := lDefaultVal; //assume all voxels are non targets
+  lPos := 0;
+  // MG: it is very slow to access the whole (!) canvas with pixels
+  for lY := 0 to (lHt-1) do
+      for lX := 0 to (lWid-1) do begin
+          lPos := lPos + 1;
+          if Canvas.Pixels[lX,lY] = lColor then
+             lMaskRA^[lPos] := lTargetColorVal;
+      end;
+  lQHead := 2;
+  lQTail := 1;
+  lQra^[lQTail] := ((Y * lWid)+X+1); //NOTE: both X and Y start from 0 not 1
+  lMaskRA^[lQra^[lQTail]] := kFill;
+  RetirePixel;
+  while lQHead <> lQTail do
+        RetirePixel;
+  lBrushColor := Canvas.Brush.Color;
+  lPos := 0;
+  for lY := 0 to (lHt-1) do
+      for lX := 0 to (lWid-1) do begin
+          lPos := lPos + 1;
+          if lMaskRA^[lPos] = kFill then
+             Canvas.Pixels[lX,lY] := lBrushColor;
+      end;
+  freemem(lMaskRA);
+  freemem(lQra);
+end;
+
 procedure ColorRGBToHLS(clrRGB: COLORREF; var Hue, Luminance, Saturation: Word);
 var
   H, L, S: Byte;