unit1.pas

最接近点对问题的源码。使用dephi编写而成。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Edit1: TEdit;
    procedure createdata;
    function distance(x1,y1,x2,y2:integer):real;
    procedure sortx(l1,l2:integer);
    procedure sorty(l1,l2:integer);
    procedure nearest(a,b:integer;var nearestd:real;var newt1,newt2:integer);
    procedure output;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
  point=record
    x,y,no:integer;
  end;

//const n=10;

var
  Form1: TForm1;
  points:array of point;
  nearestd:real;
  newt1,newt2:integer;
  n:integer;

implementation

{$R *.dfm}
uses math;

procedure TForm1.createdata;
var
i:integer;
begin
setlength(points,n);
for i:=0 to n-1 do
begin
points[i].x:=random(10000);
points[i].y:=random(10000);
points[i].no:=i;
end;
for i:=0 to n-1 do
memo1.Lines.Add(inttostr(points[i].no)+'('
               +inttostr(points[i].x)+','+inttostr(points[i].y)+')');
end;

function TForm1.distance(x1,y1,x2,y2:integer):real;
begin
distance:=sqrt(sqr(x1-x2)+sqr(y1-y2));
end;

procedure TForm1.sortx(l1,l2:integer);
var
  temp:point;
  i,j:integer;
  flag:boolean;
begin
  i:=1;
  repeat
    flag:=true;
    for j:=l1 to l2-i do
      if points[j].x>points[j+1].x
      then begin
             temp:=points[j];
             points[j]:=points[j+1];
             points[j+1]:=temp;
             flag:=false;
           end;
      i:=i+1;
    until flag;
end;

procedure TForm1.sorty(l1,l2:integer);
var
  temp:point;
  i,j:integer;
  flag:boolean;
begin
  i:=1;
  repeat
    flag:=true;
    for j:=l1 to l2-i do
      if points[j].y>points[j+1].y
      then begin
             temp:=points[j];
             points[j]:=points[j+1];
             points[j+1]:=temp;
             flag:=false;
           end;
      i:=i+1;
    until flag;
end;

procedure TForm1.nearest(a,b:integer;var nearestd:real;var newt1,newt2:integer);
var
d1,d2,dm,d3,dl:real;
t11,t12,t21,t22,tl1,tl2:integer;
middle:real;
mid:integer;
bound1,bound2:integer;
i,j:integer;
begin
middle:=0;
for i:=a to b do
middle:=middle+points[i].x;
middle:=middle/(b-a+1);
i:=a;
repeat
mid:=i;
i:=i+1;
until (middle<points[i].x)or(i>b-a+1);
if mid-a=0 then d1:=1000001
else if mid-a=1 then begin
d1:=distance(points[a].x,points[a].y,points[mid].x,points[mid].y);
t11:=a;t12:=mid;
end
else begin
nearest(a,mid,nearestd,newt1,newt2);
d1:=nearestd;
t11:=newt1;t12:=newt2;
end;
if b-mid-1=0 then d2:=1000001
else if b-mid-1=1 then begin
d2:=distance(points[mid+1].x,points[mid+1].y,points[b].x,points[b].y);
t21:=mid+1;t22:=b;
end
else begin
nearest(mid+1,b,nearestd,newt1,newt2);
d2:=nearestd;
t21:=newt1;t22:=newt2;
end;
if d1<d2 then begin
dm:=d1;newt1:=t11;newt2:=t12;
end
else begin
dm:=d2;newt1:=t21;newt2:=t22;
end;
i:=mid;
repeat
bound1:=i;
i:=i-1;
until (middle-points[i].x>dm)or(i<0);
i:=mid+1;
repeat
bound2:=i;
i:=i+1;
until (points[i].x-middle>dm)or(i>n-1);
sorty(bound1,bound2);
dl:=1000001;
for i:=bound1 to mid do
for j:=mid+1 to bound2 do
begin
if abs(points[i].y-points[j].y)<=dm
then begin
d3:=distance(points[i].x,points[i].y,points[j].x,points[j].y);
if d3<dl then begin
dl:=d3;tl1:=points[i].no;tl2:=points[j].no;
end;
end;
end;
if dm<dl then nearestd:=dm
else begin
nearestd:=dl;newt1:=tl1;newt2:=tl2;
end;
end;

procedure TForm1.output;
begin
memo1.Lines.Add('最近点对是：');
memo1.Lines.Add(inttostr(points[newt1].no)+'('
               +inttostr(points[newt1].x)+','+inttostr(points[newt1].y)+')'
               +'和'+inttostr(points[newt2].no)+'('
               +inttostr(points[newt2].x)+','+inttostr(points[newt2].y)+')');
memo1.Lines.Add('最近距离是：');
memo1.Lines.Add(inttostr(round(nearestd)));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
memo1.Clear;
n:=strtoint(edit1.Text);
if (n=0)or(n=1) then begin
showmessage('请保证点的数量在一对以上！');
edit1.Clear;
end else begin
createdata;
sortx(0,n-1);
nearest(0,n-1,nearestd,newt1,newt2);
output;
end;
end;

end.