边缘追踪(100分)

对图像中的物体能够利用鼠标绘出边缘起始段，然后程序能够自动搜寻
图像边缘的等色值点，最后绘出待测物的边缘。当然不需鼠标定义起始段
就能够自动绘出边缘更好，希望彩色图也适用。
欢迎johnsonGuo兄来回答，最好给出程序。

大虾们：
请发言，有分送。

呵呵，计算机图形学，扫描线算法，好久没用了。

你等一下，我先去试试。

下面的程序暂时只能检测单色位图，彩色位图要等一阵子。

procedure Calc(Bmp, Res: TBitmap; x, y: Integer);
var
Value: Integer;

function Pixels(x, y: Integer): Integer;
begin
if (x < 0) or (x >= Bmp.Width) or
(y < 0) or (y >= Bmp.Height) then
Result := 0
else
Result := Integer(PByteArray(Bmp.ScanLine[y])[x]);
end;

procedure SetPixels(Value: Byte);
begin
PByteArray(Res.ScanLine[y])[x] := Value;
end;

begin
//对图象边缘化
Value := 20 * Pixels(x, y)
- 2 * (Pixels(x - 1, y - 1) + Pixels(x + 1, y - 1)
+ Pixels(x - 1, y + 1) + Pixels(x + 1, y + 1))
- 3 * (Pixels(x, y - 1) + Pixels(x - 1, y)
+ Pixels(x + 1, y) + Pixels(x, y + 1));
if Value < 57 then SetPixels(0)
else SetPixels(1);
end;

function GetBorder(Bmp: TBitmap; x, y: Integer): String;
const
dx: array [1..8] of Integer = ( 0, 0, 1,-1, 1,-1,-1, 1);
dy: array [1..8] of Integer = (-1, 1, 0, 0, 1, 1,-1,-1);
var
Ptr: PByteArray;
nx, ny, i: Integer;
begin
//采用递归跟踪方式获得边缘点序列
Result := Format('(%d,%d) ', [x, y]);
Ptr := Bmp.ScanLine[y];
Ptr[x] := 0;
for i := 1 to 8 do begin
nx := x + dx;
ny := y + dy;
if (nx >= 0) and (nx < Bmp.Width) and
(ny >= 0) and (ny < Bmp.Height) then begin
Ptr := Bmp.ScanLine[ny];
if Ptr[nx] = 1 then begin
AppendStr(Result, GetBorder(Bmp, nx, ny));
Break;
end;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
Res, Bmp: TBitmap;
i, j: Integer;
Ptr: PByteArray;
begin
if OpenPictureDialog1.Execute then begin
Bmp := TBitmap.Create;
Res := TBitmap.Create;
try
Bmp.LoadFromFile(OpenPictureDialog1.FileName);
if Bmp.PixelFormat <> pf1Bit then begin
ShowMessage('此位图不是单色位图！');
Exit;
end;
Bmp.PixelFormat := pf8Bit;
//首先把图形边缘化
Res.Width := Bmp.Width;
Res.Height := Bmp.Height;
Res.PixelFormat := pf8Bit;
for j := 0 to Bmp.Height - 1 do
for i := 0 to Bmp.Width - 1 do
Calc(Bmp, Res, i, j);
//保存文件以观察边缘化结果
Res.SaveToFile('c:/a.bmp');
//跟踪边缘获得各颗粒边缘序列
Memo1.Clear;
for j := 0 to Res.Height - 1 do begin
Ptr := Res.ScanLine[j];
for i := 0 to Res.Width - 1 do
if Ptr <> 0 then begin
Memo1.Lines.Add(GetBorder(Res, i, j));
Memo1.Lines.Add('');
end;
end;
finally
Res.Free;
Bmp.Free;
end;
end;
end;

johnsonGuo兄：
多谢，我的要求有两层意思：
1、自动或手动求出所有物体的边缘；
2、鼠标点到那里后（比如某一物体的边缘附近处），则可求出该点附近的物体边缘，
而不需其它物体的边缘。

那么上面的是你的第一个要求，第二个迟点给你。

function GetRect(Bmp: TBitmap; X, Y: Integer): TRect;
//获得所在点的矩形框（与上次的程序几乎相同）
const
dx: array [1..8] of Integer = (-1, 0, 1, 0,-1,-1, 1, 1);
dy: array [1..8] of Integer = ( 0,-1, 0, 1, 1,-1, 1,-1);
var
Ptr: PByteArray;
Rt: TRect;
i, nx, ny: Integer;
begin
Ptr := Bmp.ScanLine[y];
Ptr[x] := 0;
with Result do begin
Left := x;
Right := x;
Top := y;
Bottom := y;
end;
for i := 1 to 8 do begin
nx := x + dx;
ny := y + dy;
if (nx >= 0) and (nx < Bmp.Width) and
(ny >= 0) and (ny < Bmp.Height) then begin
Ptr := Bmp.ScanLine[ny];
if Ptr[nx] <> 0 then begin
Rt := GetRect(Bmp, nx, ny);
with Result do begin
if Rt.Left < Left then Left := Rt.Left;
if Rt.Right > Right then Right := Rt.Right;
if Rt.Top < Top then Top := Rt.Top;
if Rt.Bottom > Bottom then Bottom := Rt.Bottom;
end;
end;
end;
end;
end;

procedure TForm1.Image1MouseDown(...);
var
Res, Bmp: TBitmap;
Rt: TRect;
i, j: Integer;
Ptr: PByteArray;
begin
if Image1.Canvas.Pixels[X, Y] = 0 then Exit; //所点位置没有颗粒，退出
Bmp := TBitmap.Create;
Res := TBitmap.Create;
try
Bmp.LoadFromFile(FileName); //为保证原来图象不变，在这里重新载入
Bmp.PixelFormat := pf8Bit;
Res.Width := Bmp.Width;
Res.Height := Bmp.Height;
Res.PixelFormat := pf8Bit;
Res.Assign(Bmp); //保留备份，因为后面操作将破坏原图象
Rt := GetRect(Bmp, X, Y); //获得点中颗粒所在矩形
Bmp.Assign(Res); //恢复已破坏图象
for j := Rt.Top to Rt.Bottom do //对矩形框进行边缘化
for i := Rt.Left to Rt.Right do
Calc(Bmp, Res, i, j);
Res.SaveToFile('c:/a.bmp'); //保存一个备份以观察边緣化结果
Memo1.Clear;
for j := Rt.Top to Rt.Bottom do begin //对矩形框內的边缘进行跟踪获得边缘点序列
Ptr := Res.ScanLine[j];
for i := Rt.Left to Rt.Right do
if Ptr <> 0 then begin
Memo1.Lines.Add(GetBorder(Res, i, j));
Memo1.Lines.Add('');
end;
end;
finally
Res.Free;
Bmp.Free;
end;
end;

johnsonGuo兄：
多谢，请查邮件

>>

>>

接受答案了.