{************************************************************}
{                   Delphi VCL Extensions                    }
{                                                            }
{                 Selecting entity by matrix                 }
{                                                            }
{      Copyright (c) 2002-2013 SoftGold software company     }
{                                                            }
{************************************************************}

unit sgSelection;
{$I SGDXF.INC}
interface

uses
  SysUtils, Windows, Dialogs, Graphics, Classes, Math, sgConsts, sgFunction,
  sgLists
  {$IFDEF SGFPC}
  , JwaWinGDI
  {$ENDIF}
  {$IFDEF SGDEL_XE3}
  , System.Types, System.UITypes
  {$ENDIF}
  ;

type
  TsgSelectionMode = (smDisabled, smEnabled, smMatrixOnly);
  TsgSearchMode = (smPoint, smSnail, smFillability);
  TsgTypeElement = (teEntity, teMarker);
  TsgTypeElements = set of TsgTypeElement;
  TsgViewPortMode = (vmEdge, vmFill);

  TsgSimpleGraphicsObject = class;
  TsgSimplePen = class;
  TsgSimpleBrush = class;

  TsgSelectionMatrix = class
  private
    FPointByEntity: TPoint;
    FPrecision: Integer;
    FBitMap: Graphics.TBitMap;
    FLinkPen: TsgSimplePen;
    FLinkBrush: TsgSimpleBrush;
    FRegions: TsgStackRegions;
    FSearchMode: TsgSearchMode;
    FViewPortMode: TsgViewPortMode;
    FEntities: TList;
    FMarkers: TList;
    function FindElementOfFillabilityMode(const X, Y: Integer): Integer;
    function FindElementOfSnailMode(const X, Y: Integer): Integer;
    function FindPointOfIndexInSnailMode(const X, Y: Integer; const AIndex: Integer; var APt: TPoint): Boolean;
    function GetCanvas: TCanvas;
    function GetCurrColor: TColor;
    function GetElementInMatrix(const X, Y: Integer): Pointer;
    function GetFontColor: TColor;
    function GetHandle: THandle;
    function GetSize: TPoint;
    procedure SetPrecision(const AVal: Integer);
    procedure SetSize(const APoint: TPoint);
    procedure SetFontColor(const Value: TColor);
  protected
    function IsCorrectIndex(const AIndex: Integer): Boolean;
    function GetElement(const AIndex: Integer): Pointer;
    function GetList(const AType: TsgTypeElement): TList;
    function ProcessSnailMode(const AX, AY: Integer; const AWaitIndex: Integer;
      var APoint: TPoint): Integer;
    property Canvas: TCanvas read GetCanvas;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddElement(const AVal: Pointer;
      const AType: TsgTypeElement = teEntity);
    procedure Assign(Source: TsgSelectionMatrix);
    procedure Changed;
    procedure ClearFull;
    procedure ClearRect(const ARect: TRect);
    procedure ClearElements(const AType: TsgTypeElement);
    function FindNearestPoint(const AStartPoint: TPoint;
      var AFindedPoint: TPoint): Boolean;
{$IFDEF SG_BTI_TEST}
    procedure GetBoundaryByPoint(const APoint: TPoint; const AList: TList);
{$ENDIF}
    procedure GetElements(const X, Y: Integer; const AList: TObject;
      const AUniq: Boolean);
    procedure GetElementsVis(const AList: TList; const AFull: Boolean;
      const AType: TsgTypeElement = teEntity);
    function IsOverflow: Boolean;
    procedure RemoveElement(const AElement: Pointer;
      const AType: TsgTypeElement = teEntity);
    procedure RemoveElements(const AElements: TList;
     const AType: TsgTypeElement = teEntity);
    function RestoreClipRGN: Integer;
    function SaveClipRGN: Integer;
    property Bitmap: Graphics.TBitmap read FBitMap;
    property Brush: TsgSimpleBrush read FLinkBrush;
    property FontColor: TColor read GetFontColor write SetFontColor;
    property Handle: THandle read GetHandle;
    property CurrColor: TColor read GetCurrColor;
    property Matrix[const X, Y: Integer]: Pointer read GetElementInMatrix;
    property Pen: TsgSimplePen read FLinkPen;
    property PointByEntity: TPoint read FPointByEntity;
    property Precision: Integer read FPrecision write SetPrecision;
    property SearchMode: TsgSearchMode read FSearchMode write FSearchMode;
    property Size: TPoint read GetSize write SetSize;
    property ViewPortMode: TsgViewPortMode read FViewPortMode write FViewPortMode;
  end;

  TsgSimpleGraphicsObject = class
  private
    FHandle: THandle;
    FLinkCanvas: TCanvas;
    FValid: Boolean;
  protected
    procedure Changed; virtual;
    procedure FreeObjectHandle;
    function CanUseExStockObjects: Boolean; virtual;
    function GetCurrentStockObject: THandle; virtual;
    function HandleAllocated: Boolean;
    procedure SetObjectHandle(const Value: THandle);
    procedure SelectDefaultObject; virtual;
    procedure SetLinkCanvas(const Value: TCanvas);
    procedure NoValid;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    property Handle: THandle read FHandle write SetObjectHandle;
    property LinkCanvas: TCanvas read FLinkCanvas write SetLinkCanvas;
    property Valid: Boolean read FValid;
  end;

  TsgSimpleBrush = class(TsgSimpleGraphicsObject)
  private
    FBrushData: TBrushData;
  protected
    procedure Changed; override;
    function GetColor: TColor;
    function GetCurrentStockObject: THandle; override;
    function GetStyle: TBrushStyle;
    procedure SetColor(const Value: TColor);
    procedure SetStyle(const Value: TBrushStyle);
  public
    constructor Create; override;
    property Color: TColor read GetColor write SetColor default clWhite;
    property Style: TBrushStyle read GetStyle write SetStyle default bsSolid;
  end;

  TsgSimplePen = class(TsgSimpleGraphicsObject)
  private
    FPenData: TPenData;
  protected
    procedure Changed; override;
    function GetColor: TColor;
    function GetCurrentStockObject: THandle; override;
    function GetStyle: TPenStyle;
    function GetWidth: Integer;
    procedure SetColor(const Value: TColor);
    procedure SetStyle(const Value: TPenStyle);
    procedure SetWidth(const Value: Integer);
  public
    constructor Create; override;
    property Color: TColor read GetColor write SetColor;
    property Style: TPenStyle read GetStyle write SetStyle;
    property Width: Integer read GetWidth write SetWidth;
  end;

  TsgSnapMatrix = class
  private
    FBackColor: TColor;
    FRowsCount: Integer;
    FColsCount: Integer;
    // Dim pointer cells
    FCells: Pointer;
    //evg:
    FMemoryCash: TList;
    FCount: Integer;
    FCurrentPSnapData: PSnapData;

    function GetCell(ACol, ARow: Integer): PSnapData;
    procedure SetCell(ACol, ARow: Integer; const Value: PSnapData);
  protected
    procedure FreeMatrix;
    function GetDataPtr(const ACol, ARow: Integer): PPSnapData;
    function ReleaseCellPtr(const APtr: PPSnapData): PSnapData;
    procedure GrowMemory;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure ClearCell(const ACol, ARow: Integer);
    procedure ClearData(const APtr: PPSnapData);
    procedure ClearRect(const ARect: TRect);
    function CreateNewData: PSnapData;
    function IndexOf(const AData: PSnapData): TPoint;
    function IsCellValid(const ACol, ARow: Integer): Boolean;
    function ReleaseCell(const ACol, ARow: Integer): PSnapData;
    function RemoveData(const AData: PSnapData): TPoint;
    procedure Resize(const AColsCount, ARowsCount: Integer);
    property BackColor: TColor read FBackColor write FBackColor;
    property Cells[ACol, ARow: Integer]: PSnapData read GetCell write SetCell; default;
    property ColsCount: Integer read FColsCount;
    property RowsCount: Integer read FRowsCount;
  end;

  PContour = ^TContour;
  TContour = record
    Entities: TList;
    Pixels: TList; // list of TPixelData
    Box: TRect;
  end;

  TPixelOrient = (poLeft, poTop, poRight, poBottom);
  TPixelSide = (ps4, s1, s2, ps3, psIn, psOut, psEnt); // don't change order

  PPixelData = ^TPixelData;
  TPixelData = record
    Pt: TPoint;
    Orients: array [TPixelOrient] of set of TPixelSide;
    Contour: PContour;
    LowerPixel: PPixelData;
  end;

  TInputBitmapType = (ibtBitmap, ibtSelMatrix);
  TsgTraversalMode = (tmSnapToNearest, tmFindOneContour);
  TsgTraversalModes = set of TsgTraversalMode;

  TBmpTraversal = class
  private
    FBitMap: Graphics.TBitmap;
    FDataBmp: TsgSelectionMatrix;
    FContours: TList;
    FIslandsContours: TList;
    FInputType: TInputBitmapType;
    FContour: PContour;
    FBmpRect: TRect;
    FPoint: TPoint;
    FBackColor: TColor;
    FSelMatrix: TsgSelectionMatrix;
    FIterationsLast: Cardinal;
    FStartPoint: TPoint;
    FOrient: TPixelOrient;
    FMode: TsgTraversalModes;
  protected
    procedure AddEnt(const APt: TPoint; AList: TList);
    procedure CalcExtensionPoint(const APt: TPoint; const APtData: PPixelData;
      var ExtensionPt: TPoint);
    function DeltaFromOrient(AOrient: TPixelOrient): TPoint;
    procedure DeletePixel(APixel: PPixelData);
    procedure DeleteContour(AContour: PContour);
    function GetContourEnts: TList;
    function GetData(const APt: TPoint): PPixelData;
    function GetEnt(const APt: TPoint): Pointer;
    function GetNewPixel(const APoint: TPoint; const AOrient: TPixelOrient;
      AContour: PContour): PPixelData;
    function GetNewContour: PContour;
    function GetNearestPoint(const APoint: TPoint; var AOrient: TPixelOrient): TPoint;
    function GetNextPixel(APixel: PPixelData; AEntList: TList;
      AContour: PContour): PPixelData;
    function HasEnt(const APt: TPoint): Boolean;
    function IsPointInContour(const APoint: TPoint; const ACountour: PContour): Boolean;
    procedure SetBitMap(const Value: Graphics.TBitmap);
    procedure SetData(const APoint: TPoint; const AData: PPixelData);
    procedure SetDataSize(AWidth, AHeight: Integer);
    procedure SetSelMatrix(const Value: TsgSelectionMatrix);
    function OrientFromDelta(dPt: TPoint): TPixelOrient;
    function OffsetPoint(const APt: TPoint; const AOrient: TPixelOrient): TPoint;
    function ScanLine(const Pt: TPoint; var OutPt: TPoint): Boolean;
    function ScanContour(const APt: TPoint; var ExtensionPt: TPoint): PContour;
    property Orient: TPixelOrient read FOrient write FOrient;
    property StartPoint: TPoint read FStartPoint write FStartPoint;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure CalcContours;
    property BackColor: TColor read FBackColor write FBackColor;
    property Bitmap: Graphics.TBitmap read FBitMap write SetBitMap;
    property Contour: PContour read FContour;
    property ContourEnts: TList read GetContourEnts;
    property IslandsContours: TList read FIslandsContours;
    property InputType: TInputBitmapType read FInputType write FInputType;
    property UserPoint: TPoint read FPoint write FPoint;
    property SelMatrix: TsgSelectionMatrix read FSelMatrix write SetSelMatrix;
    property Mode: TsgTraversalModes read FMode write FMode;
  end;

implementation

const
  cnstPointZero: TPoint = ();
  cnstPrecisionDef: Integer = 3;
  cLeftVector: TPoint = (X: -1; Y: 0);
  cTopVector: TPoint = (X: 0; Y: -1);
  cRightVector: TPoint = (X: 1; Y: 0);
  cBottomVector: TPoint = (X: 0; Y: 1);
  cInvertVector: TPoint = (X: -1; Y: -1);

type
  TSetDCPenColorFunc = function(DC: HDC; Color: COLORREF): COLORREF; stdcall;
  TSetDCBrushColorFunc = function(DC: HDC; Color: COLORREF): COLORREF; stdcall;

var
  Gdi32HModule: HModule;
  SetDCPenColorFunc: TSetDCPenColorFunc = nil;
  SetDCBrushColorFunc: TSetDCBrushColorFunc = nil;

function GetScreenResolution: TPoint;
var
  vDC: HDC;
begin
  vDC := GetDC(0);
  //vDC := CreateCompatibleDC(0);
  try
    try
      Result.X := GetDeviceCaps(vDC, HORZRES);
      Result.Y := GetDeviceCaps(vDC, VERTRES);
    except
      Result := cnstPointZero;
    end;
  finally
    //DeleteDC(vDC);
    ReleaseDC(0, vDC);
  end;
end;

procedure NormRect(var R: TRect);
begin
  if R.Left > R.Right then
    SwapInts(R.Left, R.Right);
  if R.Top > R.Bottom then
    SwapInts(R.Top, R.Bottom);
end;

  {TsgSelectionMatrix}

constructor TsgSelectionMatrix.Create;
begin
  inherited Create;
  FSearchMode := smFillability;
  FEntities := TList.Create;
  FMarkers := nil;
  FBitMap := Graphics.TBitmap.Create;
  FBitMap.PixelFormat := pf32bit;
  FBitMap.Width := 1;
  FBitMap.Height := 1;
  FLinkPen := TsgSimplePen.Create;
  FLinkPen.LinkCanvas := FBitMap.Canvas;
  FLinkBrush := TsgSimpleBrush.Create;
  FLinkBrush.LinkCanvas := FBitMap.Canvas;
  FRegions := TsgStackRegions.Create;
  Size := GetScreenResolution;
  FPrecision := cnstPrecisionDef;
  FViewPortMode := vmEdge;
end;

destructor TsgSelectionMatrix.Destroy;
begin
  FEntities.Free;
  if FMarkers <> nil then
    FMarkers.Free;
  FLinkPen.Free;
  FLinkBrush.Free;
  FBitMap.Free;
  FRegions.Free;
  inherited Destroy;
end;

procedure TsgSelectionMatrix.AddElement(const AVal: Pointer;
  const AType: TsgTypeElement = teEntity);
var
  vColor: Integer;
begin
  if AVal <> nil then
  begin
    case AType of
      teMarker:
        begin
          if FMarkers = nil then
          begin
            FMarkers := TList.Create;
            FMarkers.Count := FEntities.Count;
            LoadListNils(FMarkers);
          end;
          FMarkers.Add(AVal);
          FEntities.Add(nil);
        end;
    else//teEntity
      if FMarkers <> nil then
        FMarkers.Add(nil);
      FEntities.Add(AVal);
    end;
  end;
  vColor := FEntities.Count - 1;
  Pen.Color := vColor;
  Brush.Color := vColor;
end;

procedure TsgSelectionMatrix.Assign(Source: TsgSelectionMatrix);
begin
  FPointByEntity := Source.FPointByEntity;
  FPrecision := Source.FPrecision;
  if FBitMap <> nil then
    FBitMap.Assign(Source.FBitMap);
  FSearchMode := Source.FSearchMode;
  FViewPortMode := Source.FViewPortMode;
  CopyLists(FEntities, Source.FEntities);
  Brush.Color := Source.Brush.Color;
  Pen.Color := Source.Pen.Color;
end;

procedure TsgSelectionMatrix.Changed;
begin
  if not Pen.Valid then
    Pen.Changed;
  if not Brush.Valid then
    Brush.Changed;
//  FBitMap.SaveToFile('d:\1.bmp');
end;

procedure TsgSelectionMatrix.ClearElements(const AType: TsgTypeElement);
begin
  case AType of
    teMarker: FreeAndNil(FMarkers);
  else
    if (FMarkers <> nil) and (FMarkers.Count > 0) then
      LoadListNils(FEntities)
    else
      FEntities.Count := 0;
  end;
end;

procedure TsgSelectionMatrix.ClearFull;
begin
  FEntities.Count := 0;
  FreeAndNil(FMarkers);
  ClearRect(FBitMap.Canvas.ClipRect);
end;

procedure TsgSelectionMatrix.ClearRect(const ARect: TRect);
begin
  Pen.Color := cnstDefColor;
  Brush.Color := cnstDefColor;
  FBitMap.Canvas.FillRect(ARect);
end;

procedure TsgSelectionMatrix.GetElements(const X, Y: Integer; const AList: TObject; const AUniq: Boolean);
var
  vX, vY, EX, EY, vIndex: Integer;
  vElement: Pointer;
  vList: TList;
  vPointerList: TsgList;
begin
  if SetObjLists(AList, vList, vPointerList) > 0 then
  begin
    if vList <> nil then
      vList.Count := 0;
    if vPointerList <> nil then
      vPointerList.Count := 0;
    EX := X + FPrecision;
    EY := Y + FPrecision;
    for vX := X - FPrecision to EX do
    begin
      for vY := Y - FPrecision to EY do
      begin
        vIndex := FBitMap.Canvas.Pixels[vX, vY];
        if IsCorrectIndex(vIndex) then
        begin
          vElement := GetElement(vIndex);
          if vPointerList <> nil then
            vPointerList.Add(vElement)
          else
          begin
            if (not AUniq) or (vList.IndexOf(vElement) < 0) then
              vList.Add(vElement);
          end;
        end;
      end;
    end;
  end;
end;

procedure TsgSelectionMatrix.GetElementsVis(const AList: TList;
  const AFull: Boolean; const AType: TsgTypeElement = teEntity);
var
  I, vX, vY, vIndex: Integer;
  vData: PInteger;
  vSortList: TsgList;
  vList: TList;
begin
  vList := GetList(AType);
  if vList <> nil then
  begin
    vSortList := TsgList.Create;
    try
      vSortList.Capacity := FEntities.Count;
      vSortList.Duplicates := dupIgnore;
      vSortList.Sorted := True;
      if AFull then
      begin
        for I := 0 to vList.Count - 1 do
          if vList.List[I] <> nil then
            vSortList.Add(vList.List[I]);
      end
      else
      begin
        vData := FBitMap.ScanLine[FBitMap.Height - 1];
        for vY := 1 to FBitMap.Height do
        begin
          for vX := 1 to FBitMap.Width do
          begin
            vIndex := SwapWords(vData^) shr 8;
            Inc(vData);
            if IsCorrectIndex(vIndex) and (vList.List[vIndex] <> nil) then
              vSortList.Add(vList.List[vIndex]);
          end;
        end;
      end;
      vSortList.CopyTo(AList);
    finally
      vSortList.Free;
    end;
  end;
end;

function TsgSelectionMatrix.FindElementOfFillabilityMode(const X, Y: Integer): Integer;
var
  vLPointer, vLCounter: TList;
  I, J, vIndex, Val, vMax1, vInd1, vInd2: Integer;
  P: Pointer;
  V: Integer absolute P;
begin
  Result := -1;
  vLPointer := TList.Create;
  vLPointer.Capacity := Sqr(FPrecision shl 1);
  vLCounter := TList.Create;
  vLCounter.Capacity := vLPointer.Capacity;
  try
    for I := -FPrecision to FPrecision do
    begin
      for J := - FPrecision to FPrecision do
      begin
        V := FBitMap.Canvas.Pixels[X + I, Y + J];
        if (V > -1) and (V < cnstDefColor) then
        begin
          vIndex := vLPointer.IndexOf(P);
          if vIndex > -1 then
            vLCounter[vIndex] := Pointer(TsgNativeUInt(vLCounter[vIndex]) + 1)
          else
          begin
            vLPointer.Add(P);
            vLCounter.Add(Pointer(1));
          end;
        end;
      end;
    end;
    case vLPointer.Count of
      0:  Result := -1;
      1:  Result := TsgNativeUInt(vLPointer[0]);
    else
      vMax1 := -1;
      vInd1 := -1;
      vInd2 := -1;
      for I := vLCounter.Count - 1 downto 0 do
      begin
        Val := TsgNativeUInt(vLCounter[I]);
        if Val > vMax1 then
        begin
          vInd2 := vInd1;
          vMax1 := Val;
          vInd1 := I;
        end;
      end;
      if vInd2 < 0 then
        Result := TsgNativeUInt(vLPointer[vInd1])
      else
        Result := TsgNativeUInt(vLPointer[vInd2]);
    end;
  finally
    if (Result < 0) or (not FindPointOfIndexInSnailMode(X, Y, Result, FPointByEntity)) then
      FPointByEntity := cnstPointZero;
    vLPointer.Free;
    vLCounter.Free;
  end;
end;

function TsgSelectionMatrix.FindElementOfSnailMode(const X, Y: Integer): Integer;
begin
  Result := ProcessSnailMode(X, Y, MaxInt, FPointByEntity);
end;

function TsgSelectionMatrix.FindNearestPoint(const AStartPoint: TPoint;
  var AFindedPoint: TPoint): Boolean;
begin
  Result := IsCorrectIndex(ProcessSnailMode(AStartPoint.X, AStartPoint.Y,
    MaxInt, AFindedPoint));
end;

function TsgSelectionMatrix.FindPointOfIndexInSnailMode(const X, Y: Integer; const AIndex: Integer; var APt: TPoint): Boolean;
begin
  Result := IsCorrectIndex(ProcessSnailMode(X, Y, AIndex, APt));
end;

function TsgSelectionMatrix.ProcessSnailMode(const AX, AY: Integer; const AWaitIndex: Integer;
  var APoint: TPoint): Integer;

  function CheckPoint(const AX, AY: Integer; var AIndex: Integer): Boolean;
  begin
    AIndex := Integer(FBitMap.Canvas.Pixels[AX, AY]);
    if AWaitIndex = MaxInt then
      Result := IsCorrectIndex(AIndex)
    else
      Result := AIndex = AWaitIndex;
  end;

var
  I, vDeltaX, vDeltaY: Integer;
  vClosedPeriod: Boolean;
begin
  APoint := Point(AX, AY);
  Result := -1;
  vDeltaX := 1;
  vDeltaY := 1;
  while True do
  begin
    I := APoint.X + vDeltaX;
    while APoint.X <> I do
    begin
      Inc(APoint.X, Sign(vDeltaX));
      if CheckPoint(APoint.X, APoint.Y, Result) then
        Exit;
    end;
    vDeltaX := (Abs(vDeltaX) + 1) * Sign(-vDeltaX);
    vClosedPeriod := (Abs(vDeltaX) > 2) and (Abs(vDeltaX) mod 2 = 1);
    if vClosedPeriod and (FPrecision <= Abs(APoint.X - AX)) then
      Exit;
    I := APoint.Y + vDeltaY;
    while APoint.Y <> I do
    begin
      Inc(APoint.Y, Sign(vDeltaY));
      if CheckPoint(APoint.X, APoint.Y, Result) then
        Exit;
    end;
    vDeltaY := (Abs(vDeltaY) + 1) * Sign(-vDeltaY);
  end;
end;

{$IFDEF SG_BTI_TEST}
procedure TsgSelectionMatrix.GetBoundaryByPoint(const APoint: TPoint; const AList: TList);
type
  TsgDirection = (drUndefined, drRight, drTop, drLeft, drBottom);

const
  cnstNewDirection: array [drRight..drBottom] of TsgDirection = (drBottom, drRight, drTop, drLeft);
  cnstNextDirection: array [drRight..drBottom] of TsgDirection = (drTop, drLeft, drBottom, drRight);

  function GetData(const AP: TPoint): Integer;
  begin
    Result := FBitMap.Canvas.Pixels[AP.X, AP.Y];
  end;

  procedure ClearData(const AP: TPoint);
  begin
    FBitMap.Canvas.Pixels[AP.X, AP.Y] := cnstDefColor;
  end;

  function CheckData(const AData: Integer): Boolean;
  begin
    Result := (AData > -1) and (AData < cnstDefColor);
  end;

  function SetNextPos(var ACurPos: TPoint; var ACurDirection: TsgDirection; var AData: Integer): Integer;
  var
    vPos: TPoint;
//    vOldDirection: TsgDirection;
    vData: Integer;
  begin
    AData := -1;
    Result := 0;
    vPos := ACurPos;
//    vOldDirection := ACurDirection;
    ACurDirection := cnstNewDirection[ACurDirection];
    while Result < 4 do
    begin
      Inc(Result);
      case ACurDirection of
        drRight:    Inc(ACurPos.X);
        drBottom:   Inc(ACurPos.Y);
        drLeft:     Dec(ACurPos.X);
        drTop:      Dec(ACurPos.Y);
      else
        Exit;
      end;
      vData := GetData(ACurPos);
      if CheckData(vData) then
      begin
        AData := vData;
        Break;
      end
      else
        ACurPos := vPos;
      ACurDirection := cnstNextDirection[ACurDirection];
    end;
  end;

  function FindToRight(var AP: TPoint; var AIndex: Integer): Boolean;
  var
    vSize: Integer;
  begin
    Result := False;
    AP := APoint;
    vSize := Size.X;
    while AP.X < vSize do
    begin
      AIndex := GetData(AP);
      if CheckData(AIndex) then
      begin
        Result := True;
        Break;
      end
      else
        Inc(AP.X);
    end;
  end;

  function FindToLeft(var AP: TPoint; var AIndex: Integer): Boolean;
  begin
    Result := False;
    AP := APoint;
    while AP.X > -1 do
    begin
      AIndex := GetData(AP);
      if CheckData(AIndex) then
      begin
        Result := True;
        Break;
      end
      else
        Dec(AP.X);
    end;
  end;

  function FindToTop(var AP: TPoint; var AIndex: Integer): Boolean;
  begin
    Result := False;
    AP := APoint;
    while AP.Y > -1 do
    begin
      AIndex := GetData(AP);
      if CheckData(AIndex) then
      begin
        Result := True;
        Break;
      end
      else
        Dec(AP.Y);
    end;
  end;

  function FindToBottom(var AP: TPoint; var AIndex: Integer): Boolean;
  var
    vSize: Integer;
  begin
    Result := False;
    AP := APoint;
    vSize := Size.Y;
    while AP.Y < vSize do
    begin
      AIndex := GetData(AP);
      if CheckData(AIndex) then
      begin
        Result := True;
        Break;
      end
      else
        Inc(AP.Y);
    end;
  end;

var
  vIndex: Integer;
  vPoint: TPoint;
  vCurPos: TPoint;
  vCurDirection: TsgDirection;
  vList: TsgList;
begin
  vList := TsgList.Create;
  try
    vList.Sorted := True;
    vList.Duplicates := dupIgnore;
    vList.Capacity := FEntities.Count;
    if FindToTop(vPoint, vIndex) then
      vCurDirection := drTop
    else
      if FindToRight(vPoint, vIndex) then
        vCurDirection := drRight
      else
        if FindToBottom(vPoint, vIndex) then
          vCurDirection := drBottom
        else
          if FindToLeft(vPoint, vIndex) then
            vCurDirection := drLeft
          else
            vCurDirection := drUndefined;
    if vCurDirection <> drUndefined then
    begin
      //ClearData(vPoint);
      vList.Add(Pointer(vIndex));
      vCurPos := vPoint;
      repeat
        SetNextPos(vCurPos, vCurDirection, vIndex);
        if CheckData(vIndex) then
        begin
          //ClearData(vCurPos);
          vList.Add(Pointer(vIndex));
        end;
      until IsEqualPoints(vCurPos, vPoint);
    end;
    if vList.Count > 0 then
    begin
      AList.Count := vList.Count;
      for vIndex := 0 to vList.Count - 1 do
        AList.List[vIndex] := FEntities[TsgNativeUInt(vList[vIndex])];
    end;
  finally
    vList.Free;
  end;
end;
{$ENDIF}

function TsgSelectionMatrix.GetCanvas: TCanvas;
begin
  Result := FBitMap.Canvas;
end;

function TsgSelectionMatrix.GetCurrColor: TColor;
begin
  Result := FEntities.Count;
end;

function TsgSelectionMatrix.GetElement(const AIndex: Integer): Pointer;
begin
  Result := FEntities.List[AIndex];
  if (FMarkers <> nil) and (FMarkers.List[AIndex] <> nil) then
    Result := FMarkers.List[AIndex];
end;

function TsgSelectionMatrix.GetElementInMatrix(const X, Y: Integer): Pointer;
var
  vIndex: Integer;
begin
  if FPrecision > 1 then
  begin
    case FSearchMode of
      smSnail:        vIndex := FindElementOfSnailMode(X, Y);
      smFillability:  vIndex := FindElementOfFillabilityMode(X, Y);
    else
      vIndex := FBitMap.Canvas.Pixels[X, Y];
      FPointByEntity.X := X;
      FPointByEntity.Y := Y;
    end;
  end
  else
    vIndex := FBitMap.Canvas.Pixels[X, Y];
  if IsCorrectIndex(vIndex) then
    Result := GetElement(vIndex)   //evg - for tracersmatrix this is good place to breakpoint
  else
  begin
    Result := nil;
    FPointByEntity := cnstPointZero;
  end;
end;

function TsgSelectionMatrix.GetFontColor: TColor;
begin
  Result := Canvas.Font.Color;
end;

function TsgSelectionMatrix.GetHandle: THandle;
begin
  Result := Canvas.Handle;
end;

function TsgSelectionMatrix.GetList(const AType: TsgTypeElement): TList;
begin
  case AType of
    teMarker : Result := FMarkers;
  else
    Result := FEntities;
  end;
end;

procedure TsgSelectionMatrix.SetPrecision(const AVal: Integer);
begin
  if AVal < 0 then
    FPrecision := cnstPrecisionDef
  else
    FPrecision := AVal;
end;

function TsgSelectionMatrix.GetSize: TPoint;
begin
  Result := Point(FBitMap.Width, FBitMap.Height);
end;

function TsgSelectionMatrix.IsCorrectIndex(const AIndex: Integer): Boolean;
begin
  Result := (AIndex > -1) and (AIndex < FEntities.Count);
end;

function TsgSelectionMatrix.IsOverflow: Boolean;
begin
  Result := FEntities.Count >= clWhite;
end;

procedure TsgSelectionMatrix.RemoveElement(const AElement: Pointer;
  const AType: TsgTypeElement = teEntity);
var
  I: Integer;
  vList: TList;
begin
  vList := GetList(AType);
  if vList <> nil
  then
  begin
    for I := vList.Count - 1 downto 0 do
      if vList.List[I] = AElement then
        vList.List[I] := nil;
  end;
end;

procedure TsgSelectionMatrix.RemoveElements(const AElements: TList;
  const AType: TsgTypeElement = teEntity);
var
  I, vIndex: Integer;
  vSortList: TsgList;
  vList: TList;
  vItem: Pointer;
begin
  vList := GetList(AType);
  if vList <> nil then
  begin
    case AElements.Count of
      0:  begin end;
      1:  RemoveElement(AElements.List[0], AType);
    else
      vSortList := TsgList.Create;
      try
        vSortList.CopyFrom(AElements);
        if not vSortList.Sorted then
          vSortList.Sort{$IFNDEF SGDEL_5}(0, vSortList.Count - 1){$ENDIF};
        for I := vList.Count - 1 downto 0 do
        begin
          vItem := vList[I];
          if vItem <> nil then
          begin
            vIndex := vSortList.IndexOf(vItem);
            if vIndex > -1 then
              vList[I] := nil;
          end;
        end;
      finally
        vSortList.Free;
      end;
    end;
  end;
end;

function TsgSelectionMatrix.RestoreClipRGN: Integer;
var
  vRGN: HRGN;
begin
  Result := -1;
  if FRegions.Count > 0 then
  begin
    vRGN := FRegions.Pop;
    SelectClipRgn(Handle, vRGN);
    if vRGN <> 0 then
      DeleteObject(vRGN);
    Result := FRegions.Count - 1;
  end;
end;

procedure TsgSelectionMatrix.SetSize(const APoint: TPoint);
begin
  if APoint.X > 0 then
    FBitMap.Width := APoint.X;
  if APoint.Y > 0 then
    FBitMap.Height := APoint.Y;
//  ClearFull;
end;

function TsgSelectionMatrix.SaveClipRGN: Integer;
var
  vRGN: HRGN;
begin
  vRGN := CreateRectRgn(0, 0, 0, 0);
  if GetClipRgn(Handle, vRGN) = 0 then
  begin
    DeleteObject(vRGN);
    vRGN := 0;
  end;
  FRegions.Push(vRGN);
  Result := FRegions.Count;
end;

procedure TsgSelectionMatrix.SetFontColor(const Value: TColor);
begin
  Canvas.Font.Color := Value;
end;

{ TsgSimpleGraphicsObject }

function TsgSimpleGraphicsObject.CanUseExStockObjects: Boolean;
begin
  Result := Win32Platform = VER_PLATFORM_WIN32_NT;
end;

procedure TsgSimpleGraphicsObject.Changed;
begin
  FValid := True;
end;

procedure TsgSimpleGraphicsObject.FreeObjectHandle;
begin
  Handle := 0;
end;

function TsgSimpleGraphicsObject.GetCurrentStockObject: THandle;
begin
  Result := 0;
end;

function TsgSimpleGraphicsObject.HandleAllocated: Boolean;
begin
  Result := Handle <> 0;
end;

procedure TsgSimpleGraphicsObject.NoValid;
begin
  FValid := False;
end;

procedure TsgSimpleGraphicsObject.SelectDefaultObject;
begin
  if LinkCanvas <> nil then
    SelectObject(LinkCanvas.Handle, GetCurrentStockObject)
end;

procedure TsgSimpleGraphicsObject.SetLinkCanvas(const Value: TCanvas);
begin
  FLinkCanvas := Value;
  NoValid;
end;

procedure TsgSimpleGraphicsObject.SetObjectHandle(const Value: THandle);
begin
  if (LinkCanvas = nil) {or (Value = FHandle)} then
    Exit;
  if HandleAllocated then
    DeleteObject(FHandle);
  FHandle := Value;
  if FHandle <> 0 then
    SelectObject(LinkCanvas.Handle, FHandle)
  else
    SelectDefaultObject;
end;

constructor TsgSimpleGraphicsObject.Create;
begin
  inherited Create;
  FHandle := 0;
  FLinkCanvas := nil;
  FValid := False;
end;

destructor TsgSimpleGraphicsObject.Destroy;
begin
  if HandleAllocated then
    FreeObjectHandle;
  inherited Destroy;
end;

{ TsgSimpleBrush }

procedure TsgSimpleBrush.Changed;
var
  vLogBrush: TLogBrush;
begin
  inherited Changed;
  if (FBrushData.Style = bsSolid) and (FBrushData.Bitmap = nil) and
    CanUseExStockObjects then
  begin
    Handle := GetCurrentStockObject;
    if LinkCanvas <> nil then
      SetDCBrushColorFunc(LinkCanvas.Handle, ColorToRGB(FBrushData.Color));
  end
  else
  begin
    vLogBrush.lbHatch := 0;
    vLogBrush.lbColor := ColorToRGB(FBrushData.Color);
    case FBrushData.Style of
      bsClear: vLogBrush.lbStyle := BS_HOLLOW;
    else
      vLogBrush.lbStyle := BS_SOLID;
    end;
    Handle := CreateBrushIndirect(vLogBrush);
  end;
end;

constructor TsgSimpleBrush.Create;
begin
  inherited Create;
  FBrushData.Color := clWhite;
  FBrushData.Style := bsClear;
end;

function TsgSimpleBrush.GetColor: TColor;
begin
  Result := FBrushData.Color;
end;

function TsgSimpleBrush.GetCurrentStockObject: THandle;
begin
  if CanUseExStockObjects then
    Result := GetStockObject(DC_BRUSH)
  else
    Result := GetStockObject(BLACK_BRUSH)
end;

function TsgSimpleBrush.GetStyle: TBrushStyle;
begin
  Result := FBrushData.Style;
end;

procedure TsgSimpleBrush.SetColor(const Value: TColor);
begin
  if Value = FBrushData.Color then
    Exit;
  FBrushData.Color := Value;
  if FBrushData.Style = bsClear then // as VCL
    FBrushData.Style := bsSolid;
  NoValid;
end;

procedure TsgSimpleBrush.SetStyle(const Value: TBrushStyle);
begin
  if Value = FBrushData.Style then
    Exit;
  FBrushData.Style := Value;
  NoValid;
end;

{ TsgSimplePen }

procedure TsgSimplePen.Changed;
const
  PenStyles: array[TPenStyle] of Word =
    (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,
     PS_INSIDEFRAME
{$IFDEF SGDEL_2006}
    ,PS_USERSTYLE, PS_ALTERNATE
{$ENDIF}
{$IFDEF SGFPC}
   ,PS_USERSTYLE
{$ENDIF}
    );
var
  vLogPen : TLogPen;
begin
  inherited Changed;
  if (FPenData.Style = psSolid) and (FPenData.Width = 1) and
    CanUseExStockObjects then
  begin
    Handle := GetCurrentStockObject;
    if LinkCanvas <> nil then
      SetDCPenColorFunc(LinkCanvas.Handle, ColorToRGB(FPenData.Color));
  end
  else
  begin
    vLogPen.lopnStyle := PenStyles[FPenData.Style];
    vLogPen.lopnWidth.X := FPenData.Width;
    vLogPen.lopnColor := ColorToRGB(FPenData.Color);
    Handle := CreatePenIndirect(vLogPen);
  end;
end;

constructor TsgSimplePen.Create;
begin
  inherited Create;
  FPenData.Color := clWhite;
  FPenData.Width := 1;
  FPenData.Style := psSolid;
end;

function TsgSimplePen.GetColor: TColor;
begin
  Result := FPenData.Color;
end;

function TsgSimplePen.GetCurrentStockObject: THandle;
begin
  if CanUseExStockObjects then
    Result := GetStockObject(DC_PEN)
  else
    Result := GetStockObject(BLACK_PEN);
end;

function TsgSimplePen.GetStyle: TPenStyle;
begin
  Result := FPenData.Style;
end;

function TsgSimplePen.GetWidth: Integer;
begin
  Result := FPenData.Width;
end;

procedure TsgSimplePen.SetColor(const Value: TColor);
begin
  if Value = FPenData.Color then
    Exit;
  FPenData.Color := Value;
  NoValid;
end;

procedure TsgSimplePen.SetStyle(const Value: TPenStyle);
begin
  if Value = FPenData.Style then
    Exit;
  FPenData.Style := Value;
  NoValid;
end;

procedure TsgSimplePen.SetWidth(const Value: Integer);
begin
  if Value = FPenData.Width then
    Exit;
  FPenData.Width := Value;
  NoValid;
end;

{ TsgSnapMatrix }

constructor TsgSnapMatrix.Create;
begin
  Inc(FColsCount);
  Inc(FRowsCount);
  GetMem(FCells, SizeOf(Pointer));
  PPsnapData(FCells)^ := nil;
  FMemoryCash := TList.Create;
  FCount := 0;
end;

destructor TsgSnapMatrix.Destroy;
var
  I: Integer;
begin
  Clear;
  FreeMatrix;
  for I := 0 to FMemoryCash.Count - 1 do
    FreeMem(FMemoryCash[I], cnstSnapMemoryCash * SizeOf(TSnapData));
  FMemoryCash.Free;
  inherited Destroy;
end;

procedure TsgSnapMatrix.Clear;
begin
  FillChar(FCells^, (FRowsCount * FColsCount) * SizeOf(Pointer), $00);
  FCount := 0;
  FCurrentPSnapData := nil;
end;

procedure TsgSnapMatrix.ClearRect(const ARect: TRect);
var
  Y, X: Integer;
  R: TRect;
begin
  if Assigned(FCells) then
  begin
    R := ARect;
    NormRect(R);
    IntersectRect(R, R, Rect(0, 0, FColsCount - 1, FRowsCount - 1));
    for X := R.Left to R.Right do
      for Y := R.Top to R.Bottom do
        ClearData(GetDataPtr(X, Y));
  end;
end;

function TsgSnapMatrix.CreateNewData: PSnapData;
begin
  if FCount = FMemoryCash.Count * cnstSnapMemoryCash then
  begin
    GrowMemory;
    FCurrentPSnapData := FMemoryCash.Last;
  end
  else
    if (FCount mod cnstSnapMemoryCash) = 0 then
      FCurrentPSnapData := FMemoryCash[FCount div cnstSnapMemoryCash];
  Result := FCurrentPSnapData;
  Inc(FCount);
  Inc(FCurrentPSnapData);
end;

function TsgSnapMatrix.RemoveData(const AData: PSnapData): TPoint;
begin
  Result := IndexOf(AData);
  if Result.X <> -1 then
    ClearData(GetDataPtr(Result.X, Result.Y));
end;

procedure TsgSnapMatrix.FreeMatrix;
var
  vPtr: PPSnapData;
  vSize: Integer;
begin
  vPtr := FCells;
  vSize := (FRowsCount * FColsCount) * SizeOf(Pointer);
  FRowsCount := 0;
  FColsCount := 0;
  FCells := nil;
  if Assigned(vPtr) then
    FreeMem(vPtr, vSize);
end;

function TsgSnapMatrix.GetCell(ACol, ARow: Integer): PSnapData;
begin
  Result := nil;
  if IsCellValid(ACol, ARow) then
    Result := GetDataPtr(ACol, ARow)^;
end;

function TsgSnapMatrix.GetDataPtr(const ACol, ARow: Integer): PPSnapData;
begin
  Result := PPSnapData(TsgNativeUInt(FCells) +
    Cardinal(ACol * FRowsCount + ARow) * SizeOf(Pointer));
end;

function TsgSnapMatrix.IsCellValid(const ACol, ARow: Integer): Boolean;
begin
  Result := (ACol >= 0) and (ACol < FColsCount) and (ARow >= 0)
    and (ARow < FRowsCount);
end;

function TsgSnapMatrix.ReleaseCell(const ACol, ARow: Integer): PSnapData;
var
  vPtr: PPSnapData;
begin
  Result := nil;
  if IsCellValid(ACol, ARow) then
  begin
    vPtr := GetDataPtr(ACol, ARow);
    Result := ReleaseCellPtr(vPtr);
  end;
end;

procedure TsgSnapMatrix.SetCell(ACol, ARow: Integer; const Value: PSnapData);
var
  vPtr: PPSnapData;
  vP: Pointer;
begin
  if IsCellValid(ACol, ARow) then
  begin
    vPtr := GetDataPtr(ACol, ARow);
    if vPtr^ <> nil then
    begin
      if Value.Entity <> vPtr^.Entity then
        vP := vPtr^.Entity
      else
        vP := vPtr^.EntityIntersected;
    end
    else
      vP := nil;
    ReleaseCellPtr(vPtr);
    vPtr^ := Value;
    if (Value.EntityIntersected = nil) and (vPtr^.Entity <> vP) then
      vPtr^.EntityIntersected := vP;
  end;
end;

procedure TsgSnapMatrix.Resize(const AColsCount, ARowsCount: Integer);
var
  vPtr: PPSnapData;
  vNewColsCount, vNewRowsCount: Integer;
  vSz: Integer;
begin
  vPtr := nil;
  vNewColsCount := AColsCount;
  vNewRowsCount := ARowsCount;
  if vNewColsCount <= 0 then vNewColsCount := 1;
  if vNewRowsCount <= 0 then vNewRowsCount := 1;
  try
    Clear;
    FreeMatrix;
    vSz := (vNewRowsCount * vNewColsCount) * SizeOf(Pointer);
    GetMem(vPtr, vSz);
    FillChar(vPtr^, vSz, $00);
  finally
    FCells := vPtr;
    FRowsCount := vNewRowsCount;
    FColsCount := vNewColsCount;
  end;
end;

procedure TsgSnapMatrix.ClearData(const APtr: PPSnapData);
//var
//  vData: PSnapData;
begin
  {vData := }ReleaseCellPtr(APtr);
end;

function TsgSnapMatrix.IndexOf(const AData: PSnapData): TPoint;
var
  I, C: Integer;
  vPtr: PPSnapData;
begin
  FillChar(Result, SizeOf(TPoint), $FF); // -1, -1
  if Assigned(FCells) and Assigned(AData) then
  begin
    I := 0;
    C := FColsCount * FRowsCount;
    vPtr := PPSnapData(FCells);
    while (I < C) and (AData <> vPtr^) do
    begin
      Inc(vPtr);
      Inc(I);
    end;
    if (I < C) and (AData = vPtr^) then
    begin
      Result.X := I div FRowsCount;
      Result.Y := I mod FRowsCount;
    end;
  end;
end;

procedure TsgSnapMatrix.ClearCell(const ACol, ARow: Integer);
begin
  SetCell(ACol, ARow, nil);
end;

function TsgSnapMatrix.ReleaseCellPtr(const APtr: PPSnapData): PSnapData;
begin
  Result := APtr^;
  APtr^ := nil;
end;

procedure TsgSnapMatrix.GrowMemory;
var
  vPointer: Pointer;
begin
  GetMem(vPointer, cnstSnapMemoryCash * SizeOf(TSnapData));
  FMemoryCash.Add(vPointer);
end;

function SuccOrient(AOrient: TPixelOrient): TPixelOrient;
begin
  if AOrient = High(TPixelOrient) then
    Result := Low(TPixelOrient)
  else
    Result := Succ(AOrient);
end;

function PredOrient(AOrient: TPixelOrient): TPixelOrient;
begin
  if AOrient = Low(TPixelOrient) then
    Result := High(TPixelOrient)
  else
    Result := Pred(AOrient);
end;

function SuccOrient2(AOrient: TPixelOrient): TPixelOrient;
begin
  Result := SuccOrient(SuccOrient(AOrient));
end;

procedure SetOrient(APixel: PPixelData; const AOrient: TPixelOrient);
  // (AOrient = poRight => Orients = {[s3],[s4],[s1],[s2]} )
  // (AOrient = poTop => Orients = {[s4],[s1],[s2],[s3]} )
var
  I: TPixelOrient;
  vFlag: TPixelSide;
begin
  vFlag := ps4;
  I := AOrient;
  repeat
    APixel^.Orients[I] := APixel^.Orients[I] + [vFlag];
    I := PredOrient(I);
    vFlag := Succ(vFlag);
  until I = AOrient;
end;

 { TBmpTraversal }

procedure TBmpTraversal.Clear;
begin
  while FContours.Count > 0 do
    DeleteContour(PContour(FContours.Last));
end;

constructor TBmpTraversal.Create;
begin
  inherited Create;
  FPoint := Point(0, 0);
  FIslandsContours := TList.Create;
  FContours := TList.Create;
  FContour := nil;
  FBitMap := nil;
  FSelMatrix := nil;
  FDataBmp := nil;
  FInputType := ibtBitmap;
  FOrient := poLeft;
  FMode := [];
end;

destructor TBmpTraversal.Destroy;
begin
  Clear;
  FreeAndNil(FContours);
  FreeAndNil(FDataBmp);
  FreeAndNil(FIslandsContours);
  inherited Destroy;
end;

function TBmpTraversal.GetEnt(const APt: TPoint): Pointer;
var
  vColor: TColor absolute Result;
begin
  if InputType = ibtBitmap then
  begin
    Result := Pointer(Bitmap.Canvas.Pixels[APt.X, APt.Y]);
    if vColor = BackColor then
      Result := nil;
  end
  else // InputType = ibtSelMatrix
  begin
    Result := SelMatrix.Matrix[APt.X, APt.Y];
  end;
end;

function TBmpTraversal.GetData(const APt: TPoint): PPixelData;
begin
  Result := FDataBmp.Matrix[APt.X, APt.Y];
end;

procedure TBmpTraversal.SetBitMap(const Value: Graphics.TBitmap);
begin
  FBitMap := Value;
  InputType := ibtBitmap;
  SetDataSize(FBitMap.Width, FBitMap.Height);
end;

procedure TBmpTraversal.SetData(const APoint: TPoint; const AData: PPixelData);
var
  vPrevData: PPixelData;
begin
  vPrevData := GetData(APoint);
  if (vPrevData <> nil) and (AData <> nil) then
    AData^.LowerPixel := vPrevData;
  FDataBmp.AddElement(AData);
  FDataBmp.Canvas.Pixels[APoint.X, APoint.Y] := FDataBmp.CurrColor;
end;

procedure TBmpTraversal.SetDataSize(AWidth, AHeight: Integer);
begin
  FreeAndNil(FDataBmp);
  FDataBmp := TsgSelectionMatrix.Create;
  FDataBmp.SearchMode := smPoint;
  FDataBmp.Size := Point(AWidth, AHeight);
  FBmpRect := Rect(0, 0, AWidth - 1, AHeight - 1);
  FDataBmp.ClearFull;
end;

procedure TBmpTraversal.SetSelMatrix(const Value: TsgSelectionMatrix);
begin
  FSelMatrix := Value;
  InputType := ibtSelMatrix;
  SetDataSize(FSelMatrix.Size.X, FSelMatrix.Size.Y);
end;

function TBmpTraversal.DeltaFromOrient(AOrient: TPixelOrient): TPoint;
begin
  case AOrient of
    poLeft: Result := cLeftVector;
    poTop: Result := cTopVector;
    poRight: Result := cRightVector;
    poBottom: Result := cBottomVector;
  end;
end;

function TBmpTraversal.OrientFromDelta(dPt: TPoint): TPixelOrient;
begin
  if IsEqualPoints(dPt, cLeftVector) then
    Result := poLeft
  else if IsEqualPoints(dPt, cTopVector) then
    Result := poTop
  else if IsEqualPoints(dPt, cRightVector) then
    Result := poRight
  else if IsEqualPoints(dPt, cBottomVector) then
    Result := poBottom
  else
    Result := poLeft;
end;

function TBmpTraversal.OffsetPoint(const APt: TPoint; const AOrient: TPixelOrient): TPoint;
var
  dPt: TPoint;
begin
  dPt := DeltaFromOrient(AOrient);
  Result := AddPoint(APt, dPt);
end;

function TBmpTraversal.GetNewPixel(const APoint: TPoint;
  const AOrient: TPixelOrient; AContour: PContour): PPixelData;
begin
  New(Result);
  AContour.Pixels.Add(Result);
  Result^.Pt := APoint;
  Result^.Orients[poLeft] := [];
  Result^.Orients[poTop] := [];
  Result^.Orients[poRight] := [];
  Result^.Orients[poBottom] := [];
  SetOrient(Result, AOrient);
  Result^.Contour := nil;
end;

function TBmpTraversal.GetNearestPoint(const APoint: TPoint; var AOrient: TPixelOrient): TPoint;
var
  vSearchMode: TsgSearchMode;
  vPrecision: Integer;
  vDelta, vNearest: TPoint;
begin
  Result := APoint;
  vSearchMode := SelMatrix.SearchMode;
  vPrecision := SelMatrix.Precision;
  try
    SelMatrix.SearchMode := smFillability;
    SelMatrix.Precision := 150;
    if not SelMatrix.FindNearestPoint(APoint, vNearest) then
      Exit;
  finally
    SelMatrix.SearchMode := vSearchMode;
    SelMatrix.Precision := vPrecision;
  end;
  vDelta := Point(Sign(APoint.X - vNearest.X), Sign(APoint.Y - vNearest.Y));
  if not HasEnt(Point(vNearest.X + vDelta.X, vNearest.Y)) then
    vDelta.Y := 0
  else
    if not HasEnt(Point(vNearest.X, vNearest.Y + vDelta.Y)) then
      vDelta.X := 0
    else
      if not HasEnt(Point(vNearest.X, vNearest.Y + vDelta.Y)) then
        // nothing to do
      else
        Exit; // FindNearestPoint not work correct
   AOrient := OrientFromDelta(Point(-vDelta.X, -vDelta.Y));
   Result := AddPoint(vNearest, vDelta);
end;

function TBmpTraversal.GetNewContour: PContour;
begin
  New(Result);
  FContours.Add(Result);
  Result.Entities := TList.Create;
  Result.Pixels := TList.Create;
  Result.Box := cnstBad2DRect;
end;

procedure TBmpTraversal.DeletePixel(APixel: PPixelData);
begin
  if APixel = nil then
    Exit;
  Dispose(APixel);
end;

procedure TBmpTraversal.DeleteContour(AContour: PContour);
var
  I: Integer;
begin
  if AContour = nil then
    Exit;
  for I := 0 to AContour.Pixels.Count - 1 do
    DeletePixel(AContour.Pixels[I]);
  AContour.Pixels.Free;
  AContour.Entities.Free;
  FContours.Delete(FContours.IndexOf(AContour));
  Dispose(AContour);
end;

function TBmpTraversal.ScanLine(const Pt: TPoint; var OutPt: TPoint): Boolean;
var
  vNextPt: TPoint;
begin
  Result := False;
  if (not PtInRect(FBmpRect, Pt)) or HasEnt(Pt) then
    Exit;
  vNextPt := Pt;
  while (not Result) and PtInRect(FBmpRect, vNextPt) do
  begin
    OutPt := vNextPt;
    vNextPt := OffsetPoint(vNextPt, Orient);
    Result := HasEnt(vNextPt);
  end;
end;

function TBmpTraversal.GetNextPixel(APixel: PPixelData; AEntList: TList;
  AContour: PContour): PPixelData;
var
  I, vStartI: TPixelOrient;
  vNextPt: TPoint;
begin
  Result := nil;
  for vStartI := Low(TPixelOrient) to High(TPixelOrient) do
    if s1 in APixel.Orients[vStartI] then
      Break;
  I := vStartI;
  repeat
    vNextPt := OffsetPoint(APixel^.Pt, I);
    if not PtInRect(FBmpRect, vNextPt) then
      Exit;
    if HasEnt(vNextPt) then
    begin
      APixel.Orients[I] := APixel.Orients[I] + [psEnt];
      AddEnt(vNextPt, AEntList);
    end
    else
    begin
      Result := GetNewPixel(vNextPt, SuccOrient2(I), AContour);
      APixel.Orients[I] := APixel.Orients[I] + [psOut];
      Break;
    end;
    I := PredOrient(I)
  until I = vStartI;
end;

function TBmpTraversal.HasEnt(const APt: TPoint): Boolean;
var
  vBackColor: Pointer;
begin
  if InputType = ibtBitmap then
    vBackColor := Pointer(BackColor)
  else
    vBackColor := nil;
  Result := GetEnt(APt) <> Pointer(vBackColor);
end;

function TBmpTraversal.ScanContour(const APt: TPoint; var ExtensionPt: TPoint): PContour;
var
  vPtData, vPtDataFirst: PPixelData;
  vNextEntPt: TPoint;
begin
  Result := nil;
  ExtensionPt := APt;
  vNextEntPt := OffsetPoint(APt, Orient);
  if not HasEnt(vNextEntPt) then
    Exit;
  Result := GetNewContour;
  try
    Result^.Box := Rect(APt.X, APt.Y, APt.X, APt.Y);
    AddEnt(vNextEntPt, Result^.Entities);
    vPtDataFirst := GetNewPixel(APt, SuccOrient2(PredOrient(Orient)), Result);
    vPtData := vPtDataFirst;
    repeat
      Dec(FIterationsLast);
      if FIterationsLast = 0 then // infinite cycle protection
      begin
        Result := nil;
        Exit;
      end;
      SetData(vPtData^.Pt, vPtData);
      vPtData^.Contour := Result;
      ExpandRect(Result^.Box, vPtData^.Pt);
      CalcExtensionPoint(APt, vPtData, ExtensionPt);

      vPtData := GetNextPixel(vPtData, Result^.Entities, Result);
      if vPtData = nil then // contour can't be calculated
      begin
        DeleteContour(Result);
        Result := nil;
        Exit;
      end;
    until IsEqualPoints(vPtDataFirst^.Pt, vPtData^.Pt);
  except
    DeleteContour(Result);
  end;
end;

procedure TBmpTraversal.AddEnt(const APt: TPoint; AList: TList);
var
  vEnt: Pointer;
begin
  if (AList = nil) or not HasEnt(APt) then
    Exit;
  vEnt := GetEnt(APt);
  if AList.IndexOf(vEnt) < 0 then
    AList.Add(vEnt)
end;

procedure TBmpTraversal.CalcContours;
var
  vOutPt, vExtPt: TPoint;
  vCont: PContour;
begin
  if tmSnapToNearest in Mode then
    StartPoint := GetNearestPoint(UserPoint, FOrient)
  else
    StartPoint := UserPoint;
  FIterationsLast := 100000;
  vOutPt := StartPoint;
  while True do
  begin
    if not ScanLine(vOutPt, vOutPt) then
      Break;
    vCont := ScanContour(vOutPt, vExtPt);
    if vCont = nil then
      Break;
    vOutPt := vExtPt;
    if (tmFindOneContour in Mode) or IsPointInContour(StartPoint, vCont) then
    begin
      FContour := vCont;
      Break;
    end
    else
      IslandsContours.Add(vCont);
  end;
end;

procedure TBmpTraversal.CalcExtensionPoint(const APt: TPoint; const APtData: PPixelData;
  var ExtensionPt: TPoint);
begin
  // calc box
  case Orient of
    poLeft:
      if APtData^.Pt.Y = APt.Y then
        ExtensionPt.X := Math.Min(APtData^.Pt.X, ExtensionPt.X);
    poTop:
      if APtData^.Pt.X = APt.X then
        ExtensionPt.Y := Math.Min(APtData^.Pt.Y, ExtensionPt.Y);
    poRight:
      if APtData^.Pt.Y = APt.Y then
        ExtensionPt.X := Math.Max(APtData^.Pt.X, ExtensionPt.X);
    poBottom:
      if APtData^.Pt.X = APt.X then
        ExtensionPt.Y := Math.Max(APtData^.Pt.Y, ExtensionPt.Y);
  end;
end;

function TBmpTraversal.IsPointInContour(const APoint: TPoint; const ACountour: PContour): Boolean;
var
  X: Integer;
  vPtData: PPixelData;

  function CheckPt(APt: TPoint): Boolean;
  var
    vEnt: Pointer;
  begin
    Result := HasEnt(APt);
    if not Result then
      Exit;
    vEnt := GetEnt(APt);
    Result := ACountour.Entities.IndexOf(vEnt) > -1;
  end;

begin
  Result := False;
  for X := ACountour^.Box.Left to ACountour^.Box.Right do
  begin
    vPtData := GetData(Point(X, StartPoint.Y));
    if vPtData <> nil then
    begin
      Result := CheckPt(Point(X - 1, APoint.Y));
      if Result then
        Break
      else
      begin
        if CheckPt(Point(X + 1, APoint.Y)) then
        begin
          Result := False;
          Break;
        end;
      end;
    end;
  end;
end;

function TBmpTraversal.GetContourEnts: TList;
begin
  if Contour <> nil then
    Result := Contour.Entities
  else
    Result := nil;
end;

initialization
  if Win32Platform = VER_PLATFORM_WIN32_NT then
    try
      Gdi32HModule := LoadLibrary(PChar(gdi32));
      if Gdi32HModule <> 0 then
      begin
        SetDCPenColorFunc := GetProcAddress(Gdi32HModule, 'SetDCPenColor');
        SetDCBrushColorFunc := GetProcAddress(Gdi32HModule, 'SetDCBrushColor');
      end;
    except
    end;

finalization
  if Gdi32HModule <> 0 then
    FreeLibrary(Gdi32HModule);

end.
