Выводы
Как видно из результатов тестов, быстрый метод с данной задачей справляется неудовлетворительно.
Теперь можно подвести итоги. В большинстве случаев самыми быстрыми являются алгоритмы Грэхема и быстрый алгоритм. С учетом того, что они просты для реализации, они вполне приемлемы для многих задач.
Но быстрый метод имеет существенный недостаток. Если нас интересует поведение алгоритма в худшем случае, он неприемлем.
Алгоритм типа “разделяй и властвуй” не показал очень быстрых результатов и не является очень простым в реализации, но он в худшем случае все равно имеет оптимальную оценку. Так же он может быть очень эффективно распараллелен.
Динамический способ стоит реализовывать только в случае, если требуется открытый алгоритм, так как он не является очень быстрым и его реализация связана с различными трудностями.
Заключение
В этой работе были показаны основные алгоритмы построения выпуклых оболочек на плоскости. Так же были проведены сравнения на конкретных реализациях алгоритмов и тестах. Все задачи, поставленные перед этой работой, на мой взгляд, решены.
Приложение Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, Spin;
const timew=10/24/60/60;
type
tp=extended;
pr=^rr;
rr=record
x,y:tp;
n:pr;
end;
TForm1 = class(TForm)
Panel1: TPanel;
ResetButton: TButton;
PaintBox1: TPaintBox;
RandomButton: TButton;
Label2: TLabel;
Label1: TLabel;
Label3: TLabel;
QRandom: TSpinEdit;
Range: TSpinEdit;
GrahamButton: TButton;
TimeL: TLabel;
QButton: TButton;
DiveRule: TButton;
Circle: TButton;
Button1: TButton;
Button2: TButton;
Button3: TButton;
procedure PaintBox1Paint(Sender: TObject);
procedure RandomButtonClick(Sender: TObject);
procedure ResetButtonClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure GrahamButtonClick(Sender: TObject);
procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure QButtonClick(Sender: TObject);
procedure DiveRuleClick(Sender: TObject);
procedure CircleClick(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
cn,sn:pr;
mx,my:tp;
strr:string;
x0,y0:integer;
time:double;
tt:pr;
kkk:integer;
implementation
{$R *.DFM}
procedure Writ(x,y:tp);
var t:pr;
begin
new(t);
t^.x:=x;
t^.y:=y;
t^.n:=sn;
sn:=t;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
var t:pr;
rect:TRect;
x,y:integer;
begin
with PaintBox1 do
begin
Canvas.Brush.Color :=clBtnFace;
rect.Left:=0;
rect.Top:=0;
rect.Bottom:=Height;
rect.Right:=Width;
Canvas.FillRect(rect);
Canvas.Pen.Color :=clGray;
x0:=Width div 2;
y0:=Height div 2;
Canvas.MoveTo(x0,y0);
Canvas.LineTo(x0,0);
Canvas.MoveTo(x0,y0);
Canvas.LineTo(x0,Height);
Canvas.MoveTo(x0,y0);
Canvas.LineTo(0,y0);
Canvas.MoveTo(x0,y0);
Canvas.LineTo(Width,y0);
Canvas.Pen.Color :=clGreen;
if sn<>nil then
begin
t:=sn;
x:=x0+Trunc(t^.x*mx);
y:=y0+Trunc(t^.y*my);
Canvas.MoveTo(x,y);
while t<>nil do
begin
x:=x0+Trunc(t^.x*mx);
y:=y0+Trunc(t^.y*my);
Canvas.LineTo(x,y);
t:=t^.n;
end;
x:=x0+Trunc(sn^.x*mx);
y:=y0+Trunc(sn^.y*my);
Canvas.LineTo(x,y);
end;
Canvas.Pen.Color :=clBlue;
t:=cn;
while t<>nil do
begin
x:=x0+Trunc(t^.x*mx);
y:=y0+Trunc(t^.y*my);
Canvas.Ellipse(x-1,y-1,x+1,y+1);
t:=t^.n;
end;
end;
end;
procedure TForm1.RandomButtonClick(Sender: TObject);
var
i:integer;
t:pr;
begin
randomize();
while cn<>nil do
begin
t:=cn^.n;
dispose(cn);
cn:=t;
end;
while sn<>nil do
begin
t:=sn^.n;
dispose(sn);
sn:=t;
end;
mx:=0;
my:=0;
for i:=1 to QRandom.Value do
begin
new(t);
t^.n:=cn;
cn:=t;
t^.x:=random(2*Range.Value+1)-Range.Value;
t^.y:=random(2*Range.Value+1)-Range.Value;
if mx
if my
end;
if mx<>0 then mx:=0.8*(Width div 2)/mx;
if my<>0 then my:=0.8*(Height div 2)/my;
PaintBox1.Refresh;
end;
procedure TForm1.ResetButtonClick(Sender: TObject);
var
t:pr;
begin
while cn<>nil do
begin
t:=cn^.n;
dispose(cn);
cn:=t;
end;
while sn<>nil do
begin
t:=sn^.n;
dispose(sn);
sn:=t;
end;
mx:=1;
my:=1;
PaintBox1.Refresh;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
cn:=nil;
sn:=nil;
mx:=1;
my:=1;
with PaintBox1 do
begin
x0:=Width div 2;
y0:=Height div 2;
end;
end;
procedure TForm1.GrahamButtonClick(Sender: TObject);
label repl;
type
prec=^rec;
rec=record
x,y:tp;
next,prev:prec;
end;
var st,t,s,l,r,p:prec;
procedure inss(var st:prec;t,d:prec);
begin
if st=nil then
begin
st:=t;
d^.next:=t;
st^.prev:=d;
end else
begin
st^.prev^.next:=t;
d^.next:=st;
t^.prev:=st^.prev;
st^.prev:=d;
end;
end;
procedure ins(var st,t:prec);
begin
if st=nil then
begin
st:=t;
st^.next:=t;
st^.prev:=t;
end else
begin
t^.next:=st;
t^.prev:=st^.prev;
st^.prev^.next:=t;
st^.prev:=t;
end;
end;
procedure cut(var st,t:prec);
begin
if st^.next=st then st:=nil else
begin
if t=st
then st:=t^.next;
t^.next^.prev:=t^.prev;
t^.prev^.next:=t^.next;
end;
end;
procedure sort(var b:prec;e:prec);
var p,q:prec;
x:tp;
begin
if b=e then exit;
if b^.next=e then
begin
if (b^.x>e^.x) or ((b^.x=e^.x)and(b^.y>e^.y)) then
begin
x:=b^.x;
b^.x:=e^.x;
e^.x:=x;
x:=b^.y;
b^.y:=e^.y;
e^.y:=x;
end;
exit;
end;
p:=b;
q:=e;
while (p<>q)and(p^.next<>q) do
begin
p:=p^.next;
q:=q^.prev;
end;
if p=q then q:=q.next;
p^.next:=b;
b^.prev:=p;
q^.prev:=e;
e^.next:=q;
sort(b,p);
sort(q,e);
p:=b;
b:=nil;
while (p<>nil)and(q<>nil) do
begin
if (p^.x>q^.x)or((p^.x=q^.x)and(p^.y>q^.y)) then
begin
e:=q;
cut(q,e);
ins(b,e);
end else
begin
e:=p;
cut(p,e);
ins(b,e);
end;
end;
if p<>nil then
begin
e:=p;
inss(b,e,e^.prev);
end;
if q<>nil then
begin
e:=q;
inss(b,e,e^.prev);
end;
end;
procedure sort2(var b:prec;e:prec);
var p,q:prec;
x:tp;
begin
if b=e then exit;
if b^.next=e then
begin
if (b^.x
begin
x:=b^.x;
b^.x:=e^.x;
e^.x:=x;
x:=b^.y;
b^.y:=e^.y;
e^.y:=x;
end;
exit;
end;
p:=b;
q:=e;
while (p<>q)and(p^.next<>q) do
begin
p:=p^.next;
q:=q^.prev;
end;
if p=q then q:=q.next;
p^.next:=b;
b^.prev:=p;
q^.prev:=e;
e^.next:=q;
sort2(b,p);
sort2(q,e);
p:=b;
b:=nil;
while (p<>nil)and(q<>nil) do
begin
if (p^.x
begin
e:=q;
cut(q,e);
ins(b,e);
end else
begin
e:=p;
cut(p,e);
ins(b,e);
end;
end;
if p<>nil then
begin
e:=p;
inss(b,e,e^.prev);
end;
if q<>nil then
begin
e:=q;
inss(b,e,e^.prev);
end;
end;
procedure grah(var st:prec);
var r,t,g:prec;
f:integer;
begin
if st^.next=st^.prev then exit;
r:=st;
t:=st;
f:=0;
while (f<=0) or (t<>r) do
begin
if (t^.next^.x-t^.prev^.x)*(t^.y-t^.prev^.y)>=(t^.x-t^.prev^.x)*(t^.next^.y-t^.prev^.y) then
begin
if t=r then
begin
dec(f);
r:=t^.next;
end;
t:=t^.prev;
g:=t^.next;
cut(st,g);
dispose(g);
end else
begin
t:=t^.next;
if t=r then inc(f);
end;
end;
end;
begin
time:=now;
kkk:=0;
repeat
while sn<>nil do
begin
tt:=sn^.n;
dispose(sn);
sn:=tt;
end;
st:=nil;
s:=nil;
tt:=cn;
if tt=nil then exit;
while tt<>nil do
begin
new(t);
t^.x:=tt^.x;
t^.y:=tt^.y;
tt:=tt^.n;
ins(st,t);
end;
if st=nil then exit;
l:=st;
r:=st;
t:=st;
repeat
if (r^.x
if (l^.x>t^.x) or ((l^.y>t^.y)and(l^.x=t^.x)) then l:=t;
t:=t^.next;
until t=st;
if l^.x=r^.x then
begin
str((now-time)*24*60*60:0:2,strr);
TimeL.Caption:=strr+'s';
writ(l^.x,l^.y);
if not((r^.x=l^.x)and(r^.y=l^.y)) then writ(r^.x,r^.y);
t:=l;
while l<>nil do
begin
t:=l;
cut(l,t);
dispose(t);
end;
exit;
end;
t:=l;
t:=st;
repeat
repl:
if st=nil then break;
p:=t;
t:=t^.next;
if (p^.x-l^.x)*(r^.y-l^.y)<=(p^.y-l^.y)*(r^.x-l^.x) then
begin
cut(st,p);
ins(s,p);
goto repl;
end;
until t=st;
sort2(s,s^.prev);
if st <> nil then
begin
sort(st,st^.prev);
t:=st^.prev;
st^.prev^.next:=s;
st^.prev:=s^.prev;
s^.prev^.next:=st;
s^.prev:=t;
st:=st^.prev;
grah(s);
end;
t:=s;
repeat
writ(t^.x,t^.y);
t:=t^.next;
until t=s;
while s<>nil do
begin
t:=s;
cut(s,t);
dispose(t);
end;
inc(kkk);
until now-time>timew;
str((now-time)/kkk*24*60*60:0:6,strr);
TimeL.Caption:=strr+'s';
PaintBox1.Refresh;
end;
{ end graham}
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
t:pr;
begin
new(t);
t^.x:=(x-x0)/mx;
t^.y:=(y-y0)/my;
t^.n:=cn;
cn:=t;
Canvas.Pen.Color :=clBlue;
Canvas.Ellipse(x-1,y-1,x+1,y+1);
end;
{-------------------------------------}
procedure TForm1.QButtonClick(Sender: TObject);
type prec=^rec;
rec=record
x,y:tp;
p,n:prec;
end;
list=record
b,e:prec;
end;
var t,bb,ee:prec;
ll,gr,ls:list;
procedure cut(var l:list;t:prec);
begin
if t^.p<>nil then t^.p^.n:=t^.n
else l.b:=t^.n;
if t^.n<>nil then t^.n^.p:=t^.p
else l.e:=t^.p;
end;
procedure clr(var l:list);
begin
l.b:=nil;
l.e:=nil;
end;
procedure add(var l:list;var t:prec);
begin
t^.n:=nil;
if l.e<>nil then l.e^.n:=t;
t^.p:=l.e;
l.e:=t;
if l.b=nil then l.b:=t;
end;
procedure con(var l1,l2:list);
begin
if l2.b<>nil then l2.b^.p:=l1.e else exit;
if l1.b<>nil then l1.e^.n:=l2.b else
begin
l1:=l2;
exit;
end;
l1.e:=l2.e;
end;
procedure proc(var ls:list;b,e:prec);
var l1,l2:list;
r,t,m:prec;
begin
if ls.b=nil then exit;
t:=ls.b;
m:=t;
while t<>nil do
begin
if (b^.x-m^.x)*(b^.y+m^.y)+(m^.x-e^.x)*(e^.y+m^.y)<(b^.x-t^.x)*(b^.y+t^.y)+(t^.x-e^.x)*(e^.y+t^.y) then
m:=t;
t:=t^.n;
end;
cut(ls,m);
clr(l1);
t:=ls.b;
while t<>nil do
begin
r:=t^.n;
if (t^.x-b^.x)*(m^.y-b^.y)>(m^.x-b^.x)*(t^.y-b^.y) then
begin
cut(ls,t);
add(l1,t)
end;
t:=r;
end;
clr(l2);
t:=ls.b;
while t<>nil do
begin
r:=t^.n;
if (t^.x-e^.x)*(m^.y-e^.y)<(m^.x-e^.x)*(t^.y-e^.y) then
begin
cut(ls,t);
add(l2,t)
end;
t:=r;
end;
con(gr,ls);
proc(l1,b,m);
proc(l2,m,e);
ls:=l1;
add(ls,m);
con(ls,l2);
end;
begin
time:=now;
kkk:=0;
repeat
while sn<>nil do
begin
tt:=sn^.n;
dispose(sn);
sn:=tt;
end;
clr(ls);
clr(gr);
tt:=cn;
if tt=nil then exit;
while tt<>nil do
begin
new(t);
t^.x:=tt^.x;
t^.y:=tt^.y;
tt:=tt^.n;
add(ls,t);
end;
bb:=ls.b;
t:=ls.b;
while t<>nil do
begin
if (t^.x
then bb:=t;
t:=t^.n;
end;
cut(ls,bb);
t:=ls.b;
while (t<>nil) and ((t^.x=bb^.x)and(t^.y=bb^.y)) do
t:=t^.n;
ee:=t;
while t<>nil do
begin
if ((t^.x<>bb^.x)or(t^.y<>bb^.y)) and
(((t^.x-bb^.x)*(ee^.y-bb^.y)<(ee^.x-bb^.x)*(t^.y-bb^.y)) or
(((t^.x-bb^.x)*(ee^.y-bb^.y)=(ee^.x-bb^.x)*(t^.y-bb^.y))and(abs(ee^.x-bb^.x)+abs(ee^.y-bb^.y)
then ee:=t;
t:=t^.n;
end;
if (ee<>nil) and ((ee^.x<>bb^.x) or (ee^.y<>bb^.y)) then
begin
cut(ls,ee);
proc(ls,bb,ee);
clr(ll);
add(ll,bb);
con(ll,ls);
add(ll,ee);
ls:=ll;
end else
begin
clr(ls);
add(ls,bb);
dispose(ee);
end;
t:=ls.b;
while ls.b<>nil do
begin
if (t=ls.b)or(t=ls.e)or
((t^.x-t^.p^.x)*(t^.n^.y-t^.p^.y)<>(t^.n^.x-t^.p^.x)*(t^.y-t^.p^.y)) then writ(t^.x,t^.y);
t:=t^.n;
dispose(ls.b);
ls.b:=t;
end;
t:=gr.b;
while t<>gr.e do
begin
t:=t^.n;
dispose(t^.p);
end;
if t<>nil then dispose(t);
inc(kkk);
until now-time>timew;
str((now-time)/kkk*24*60*60:0:6,strr);
TimeL.Caption:=strr+'s';
PaintBox1.Refresh;
end;
{------------------------------}
procedure TForm1.DiveRuleClick(Sender: TObject);
type
prec=^rec;
rec=record
a,x,y:tp;
p,n:prec;
end;
var r,t,ls,gs:prec;
procedure add(var l:prec;t:prec);
begin
if l=nil then
begin
l:=t;
t^.n:=l;
t^.p:=l
end else
begin
t^.n:=l;
t^.p:=l^.p;
l^.p^.n:=t;
l^.p:=t;
end;
end;
function arc(x,y:extended):extended;
begin
if abs(x)>abs(y) then
begin
if x>0 then
arc:=1+y/x
else
arc:=5+y/x;
end
else
begin
if y>0 then
arc:=3-x/y
else
begin
if abs(y)=0 then
arc:=0
else
arc:=7-x/y;
end;
end;
end;
procedure con(var l1,l2:prec);
var t:prec;
begin
if l2=nil then exit;
if l1=nil then
begin
l1:=l2;
exit;
end;
l1^.p^.n:=l2;
l2^.p^.n:=l1;
t:=l1^.p;
l1^.p:=l2^.p;
l2^.p:=t;
end;
procedure cut(l1,l2:prec);
var t:prec;
begin
l1^.p^.n:=l2;
l2^.p^.n:=l1;
t:=l1^.p;
l1^.p:=l2^.p;
l2^.p:=t;
end;
procedure grah(var st:prec);
var r,t,d:prec;
f:integer;
begin
if st^.n=st^.p then exit;
r:=st;
t:=st;
f:=0;
while (f<=0) or (t<>r) do
begin
if t^.n=t^.p then break;
if ((t^.n^.x-t^.p^.x)*(t^.y-t^.p^.y)>(t^.x-t^.p^.x)*(t^.n^.y-t^.p^.y))
or (((t^.n^.x-t^.p^.x)*(t^.y-t^.p^.y)=(t^.x-t^.p^.x)*(t^.n^.y-t^.p^.y))
and (abs(t^.y-t^.p^.y)+abs(t^.y-t^.n^.y)=abs(t^.p^.y-t^.n^.y)) and(abs(t^.x-t^.p^.x)+abs(t^.x-t^.n^.x)=abs(t^.p^.x-t^.n^.x)))
then
begin
if t=r then
begin
dec(f);
r:=t^.n;
end;
d:=t;
t:=t^.n;
cut(t,d);
t:=t^.p;
con(gs,d);
end else
begin
t:=t^.n;
if t=r then inc(f);
end;
end;
st:=t;
end;
procedure proc(var ls:prec);
var t,l1,l2,r,l:prec;
x,y:tp;
f:boolean;
begin
if ls^.n=ls
then exit;
l1:=ls;
l2:=ls;
repeat
l1:=l1^.n;
l2:=l2^.p;
until (l1=l2) or (l1^.p=l2);
l1:=ls;
cut(l1,l2);
proc(l1);
proc(l2);
if l1^.n=l1 then
if l2^.n<>l2 then begin
t:=l1;
l1:=l2;
l2:=t;
end else
begin
l1^.n:=l2;
l1^.p:=l2;
l2^.n:=l1;
l2^.p:=l1;
ls:=l1;
exit;
end;
x:=(l1^.x+l1^.n^.x+l1^.n^.n^.x)/3;
y:=(l1^.y+l1^.n^.y+l1^.n^.n^.y)/3;
r:=l1;
r^.a:=arc((r^.x-x),(r^.y-y));
t:=l1;
repeat
t^.a:=arc((t^.x-x),(t^.y-y));
if (r^.a>t^.a) or ((r^.a=t^.a) and (abs(r^.x-x)+abs(r^.y-y)>abs(t^.x-x)+abs(t^.y-y))) then r:=t;
t:=t^.n;
until t=l1;
l1:=r;
l:=l2;
r:=l;
t:=r;
f:=false;
repeat
if (t.x-x)*(r^.y-y)>(r^.x-x)*(t.y-y) then r:=t;
if (t.x-x)*(l^.y-y)<(l^.x-x)*(t.y-y) then l:=t;
f:=f or((x-t^.p^.x)*(t^.y-t^.p^.y)>(t^.x-t^.p^.x)*(y-t^.p^.y));
t:=t^.n;
until (t=l2);
if (l^.x=x) and (l^.y=y) then r:=r^.n
else l:=l^.n;
if f then
begin
cut(l,r);
if l<>r then con(gs,l);
end;
l2:=r;
r:=l2;
r^.a:=arc((r^.x-x),(r^.y-y));
t:=l2;
repeat
t^.a:=arc((t^.x-x),(t^.y-y));
if (r^.a>t^.a) or ((r^.a=t^.a) and (abs(r^.x-x)+abs(r^.y-y)>abs(t^.x-x)+abs(t^.y-y))) then r:=t;
t:=t^.n;
until t=l2;
l2:=r;
l1^.p^.n:=nil;
l2^.p^.n:=nil;
r:=l1;
l:=l2;
ls:=nil;
while (r<>nil) and (l<>nil) do
begin
if (r^.a
begin
t:=r;
r:=r^.n;
if r<>nil then r^.p:=t^.p;
add(ls,t);
end else
begin
t:=l;
l:=l^.n;
if l<>nil then l^.p:=t^.p;
add(ls,t);
end;
end;
if r<>nil then
begin
r^.p^.n:=r;
con(ls,r);
end;
if l<>nil then
begin
l^.p^.n:=l;
con(ls,l);
end;
grah(ls);
end;
begin
time:=now;
kkk:=0;
repeat
while sn<>nil do
begin
tt:=sn^.n;
dispose(sn);
sn:=tt;
end;
ls:=nil;
gs:=nil;
tt:=cn;
if tt=nil then exit;
while tt<>nil do
begin
new(t);
t^.x:=tt^.x;
t^.y:=tt^.y;
tt:=tt^.n;
add(ls,t);
end;
proc(ls);
t:=ls;
if t<>nil then
repeat
r:=t;
writ(t^.x,t^.y);
t:=t^.n;
dispose(r);
until t=ls;
t:=gs;
if t<>nil then
repeat
r:=t;
t:=t^.n;
dispose(r);
until t=gs;
inc(kkk);
until now-time>timew;
str((now-time)/kkk*24*60*60:0:6,strr);
TimeL.Caption:=strr+'s';
PaintBox1.Refresh;
end;
{Div end}
procedure TForm1.CircleClick(Sender: TObject);
var
i:integer;
t:pr;
begin
while cn<>nil do
begin
t:=cn^.n;
dispose(cn);
cn:=t;
end;
while sn<>nil do
begin
t:=sn^.n;
dispose(sn);
sn:=t;
end;
mx:=0;
my:=0;
for i:=1 to QRandom.Value do
begin
new(t);
t^.n:=cn;
cn:=t;
t^.x:=Range.Value*sin(i);
t^.y:=Range.Value*cos(i);
if mx
if my
end;
if mx<>0 then mx:=0.8*(Width div 2)/mx;
if my<>0 then my:=0.8*(Height div 2)/my;
PaintBox1.Refresh;
end;
{ online}
procedure TForm1.Button2Click(Sender: TObject);
label onend;
type
prec=^TTree;
TTree=record
x,y:tp;
l,r,u,n,p,gr:prec;
kl,kr:integer;
end;
var ls,t,p,n,gr:prec;
procedure disp(t:prec);
begin
if t=nil then exit;
disp(t^.l);
disp(t^.r);
dispose(t);
end;
function max(a,b:integer):integer;
begin
if a>b then max:=a
else max:=b;
end;
procedure getleft(m,n:prec;var l:prec);
var fm,fn,f:boolean;
begin
l:=nil;
if ((p^.x=m^.x) and (p^.y=m^.y)) or ((p^.x=n^.x) and (p^.y=n^.y)) then exit;
if ((p^.x=m^.n^.x) and (p^.y=m^.n^.y)) or ((p^.x=n^.n^.x) and (p^.y=n^.n^.y)) then exit;
if (m^.n=m) or
(((m^.n^.x-p^.x)*(m^.y-p^.y)=(m^.x-p^.x)*(m^.n^.y-p^.y)) and (abs(m^.x-p^.x)=abs(m^.n^.x-p^.x)+abs(m^.n^.x-m^.x)) and (abs(m^.y-p^.y)=abs(m^.n^.y-p^.y)+abs(m^.n^.y-m^.y))) or
(((m^.p^.x-p^.x)*(m^.y-p^.y)>(m^.x-p^.x)*(m^.p^.y-p^.y)) and ((m^.n^.x-p^.x)*(m^.y-p^.y)>(m^.x-p^.x)*(m^.n^.y-p^.y)))
then
begin
l:=m;
exit;
end;
if (n^.n=n) or
(((n^.n^.x-p^.x)*(n^.y-p^.y)=(n^.x-p^.x)*(n^.n^.y-p^.y)) and (abs(n^.x-p^.x)=abs(n^.n^.x-p^.x)+abs(n^.n^.x-n^.x)) and (abs(n^.y-p^.y)=abs(n^.n^.y-p^.y)+abs(n^.n^.y-n^.y))) or
(((n^.p^.x-p^.x)*(n^.y-p^.y)>(n^.x-p^.x)*(n^.p^.y-p^.y)) and ((n^.n^.x-p^.x)*(n^.y-p^.y)>(n^.x-p^.x)*(n^.n^.y-p^.y)))
then
begin
l:=n;
exit;
end;
if m^.n<>m then
begin
fm:=((m^.n^.x-p^.x)*(m^.y-p^.y)>(m^.x-p^.x)*(m^.n^.y-p^.y)) or
((m^.p^.x-p^.x)*(m^.y-p^.y)<(m^.x-p^.x)*(m^.p^.y-p^.y));
fn:=((n^.n^.x-p^.x)*(n^.y-p^.y)>(n^.x-p^.x)*(n^.n^.y-p^.y)) or
((n^.p^.x-p^.x)*(n^.y-p^.y)<(n^.x-p^.x)*(n^.p^.y-p^.y));
f:=(m^.x-p^.x)*(n^.y-p^.y)>(n^.x-p^.x)*(m^.y-p^.y);
if (m^.l<>nil) and ((f and not(fn)) or (not(f) and fm)) then
getleft(m^.l,n,l)
else if m^.r<>nil then
getleft(m^.r,m^.n,l);
end;
end;
procedure getright(m,n:prec;var l:prec);
var fm,fn,f:boolean;
begin
l:=nil;
if ((p^.x=m^.x) and (p^.y=m^.y)) or ((p^.x=n^.x) and (p^.y=n^.y)) then exit;
if ((p^.x=m^.p^.x) and (p^.y=m^.p^.y)) or ((p^.x=n^.p^.x) and (p^.y=n^.p^.y)) then exit;
if (m^.n=m) or
(((m^.p^.x-p^.x)*(m^.y-p^.y)=(m^.x-p^.x)*(m^.p^.y-p^.y)) and (abs(m^.x-p^.x)=abs(m^.p^.x-p^.x)+abs(m^.p^.x-m^.x)) and (abs(m^.y-p^.y)=abs(m^.p^.y-p^.y)+abs(m^.p^.y-m^.y))) or
(((m^.p^.x-p^.x)*(m^.y-p^.y)<(m^.x-p^.x)*(m^.p^.y-p^.y)) and ((m^.n^.x-p^.x)*(m^.y-p^.y)<(m^.x-p^.x)*(m^.n^.y-p^.y)))
then
begin
l:=m;
exit;
end;
if (n^.n=n) or
(((n^.p^.x-p^.x)*(n^.y-p^.y)=(n^.x-p^.x)*(n^.p^.y-p^.y)) and (abs(n^.x-p^.x)=abs(n^.p^.x-p^.x)+abs(n^.p^.x-n^.x)) and (abs(n^.y-p^.y)=abs(n^.p^.y-p^.y)+abs(n^.p^.y-n^.y))) or
(((n^.p^.x-p^.x)*(n^.y-p^.y)<(n^.x-p^.x)*(n^.p^.y-p^.y)) and ((n^.n^.x-p^.x)*(n^.y-p^.y)<(n^.x-p^.x)*(n^.n^.y-p^.y)))
then
begin
l:=n;
exit;
end;
if m^.n<>m then
begin
fm:=((m^.n^.x-p^.x)*(m^.y-p^.y)>(m^.x-p^.x)*(m^.n^.y-p^.y)) or
((m^.p^.x-p^.x)*(m^.y-p^.y)<(m^.x-p^.x)*(m^.p^.y-p^.y));
fn:=((n^.n^.x-p^.x)*(n^.y-p^.y)>(n^.x-p^.x)*(n^.n^.y-p^.y)) or
((n^.p^.x-p^.x)*(n^.y-p^.y)<(n^.x-p^.x)*(n^.p^.y-p^.y)); f:=(m^.x-p^.x)*(n^.y-p^.y)>(n^.x-p^.x)*(m^.y-p^.y);
if (m^.l<>nil) and ((f and not(fm)) or (not(f) and fn)) then
getright(m^.l,n,l)
else if m^.r<>nil then
getright(m^.r,m^.n,l);
end;
end;
procedure balance(m:prec;var t:prec;f:boolean);
var u,r,k,l:prec;
kr:integer;
begin
if m=nil then exit;
if m^.l<>nil then m^.kl:=max(m^.l^.kl,m^.l^.kr)+1 else m^.kl:=0;
if m^.r<>nil then m^.kr:=max(m^.r^.kl,m^.r^.kr)+1 else m^.kr:=0;
u:=m^.u;
k:=m;
if m^.kl>m^.kr+1 then
begin
k:=m^.l;
if k^.kr>k^.kl then
k:=k^.r;
if k^.u^.l=k then
k^.u^.l:=k^.l
else
k^.u^.r:=k^.l;
if k^.u^.l=k then
k^.u^.kl:=k^.kl
else
k^.u^.kr:=k^.kl;
if k^.l<>nil then k^.l^.u:=k^.u;
r:=m^.l;
kr:=m^.kl;
m^.l:=k^.r;
m^.kl:=k^.kr;
if k^.r<>nil then k^.r^.u:=m;
k^.l:=r;
k^.kl:=kr;
r^.u:=k;
k^.r:=m;
m^.u:=k;
if u<>nil then
begin
if u^.l=m then
u^.l:=k
else
u^.r:=k;
end
else t:=k;
k^.u:=u;
balance(m,t,false);
{ balance(r,t);}
end else
if m^.kr>m^.kl+1 then
begin
k:=m^.r;
if k^.kl>k^.kr then
k:=k^.l;
if k^.u^.r=k then
k^.u^.r:=k^.r
else
k^.u^.l:=k^.r;
if k^.u^.r=k then
k^.u^.kr:=k^.kr
else
k^.u^.kl:=k^.kr;
if k^.r<>nil then k^.r^.u:=k^.u;
r:=m^.r;
kr:=m^.kr;
m^.r:=k^.l;
m^.kr:=k^.kl;
if k^.l<>nil then k^.l^.u:=m;
k^.r:=r;
k^.kr:=kr;
r^.u:=k;
k^.l:=m;
m^.u:=k;
if u<>nil then
begin
if u^.l=m then
u^.l:=k
else
u^.r:=k;
end
else t:=k;
k^.u:=u;
balance(m,t,false);
end;
if f then balance(u,t,true);
end;
procedure ins(m,d:prec);
begin
if m^.r<>nil then m^.r^.u:=d;
d^.r:=m^.r;
d^.l:=nil;
d^.u:=m;
m^.r:=d;
balance(d,t,true);
end;
procedure cutl(l:prec;var dl,dr:prec);
var
r,c:prec;
begin
r:=l;
dl:=nil;
if r^.l<>nil then
begin
dl:=r^.l;
dl^.u:=nil;
r^.l:=nil;
r^.kl:=0;
end;
while r<>nil do
begin
c:=r^.u;
if c<>nil then
begin
if c^.r=r then
begin
if c^.u<>nil then
begin
if c^.u^.l=c then
begin
c^.u^.l:=r;
r^.u:=c^.u;
end
else
begin
c^.u^.r:=r;
r^.u:=c^.u;
end;
end else
begin
dr:=r;
r^.u:=nil;
end;
c^.r:=dl;
if dl<>nil then dl^.u:=c;
dl:=c;
dl^.u:=nil;
continue;
end;
end;
r:=r^.u;
end;
balance(l,dr,true);
end;
procedure cutr(r:prec;var dl,dr:prec);
var
l,c:prec;
begin
l:=r;
dr:=nil;
if l^.r<>nil then
begin
dr:=l^.r;
dr^.u:=nil;
l^.r:=nil;
end;
while l<>nil do
begin
c:=l^.u;
if c<>nil then
begin
if c^.l=l then
begin
if c^.u<>nil then
begin
if c^.u^.l=c then
begin
c^.u^.l:=l;
l^.u:=c^.u;
end
else
begin
c^.u^.r:=l;
l^.u:=c^.u;
end;
end else
begin
dl:=l;
l^.u:=nil;
end;
c^.l:=dr;
if dr<>nil then dr^.u:=c;
dr:=c;
dr^.u:=nil;
continue;
end;
end;
l:=l^.u;
end;
balance(r,dl,true);
end;
procedure add(p:prec);
var l,r,d:prec;
begin
getleft(t,n,l);
if l<>nil then
begin
getright(t,n,r);
if (n=r) or ((n^.x-r^.x)*(l^.y-r^.y)<(l^.x-r^.x)*(n^.y-r^.y)) then
begin
cutl(r,d,t);
n:=r;
cutr(l,t,d);
ins(l,p);
end else
begin
cutr(l,t,d);
balance(l^.n,d,true);
p^.l:=t;
t^.u:=p;
t:=d;
cutl(r,d,t);
p^.r:=t;
t^.u:=p;
t:=p;
p^.u:=nil;
balance(p,t,true);
end;
l^.n:=p;
p^.p:=l;
r^.p:=p;
p^.n:=r;
end;
end;
begin
kkk:=0;
time:=now;
repeat
while sn<>nil do
begin
tt:=sn^.n;
dispose(sn);
sn:=tt;
end;
ls:=nil;
gr:=nil;
tt:=cn;
if tt=nil then goto onend;
while tt<>nil do
begin
new(t);
t^.gr:=gr;
gr:=t;
t^.x:=tt^.x;
t^.y:=tt^.y;
t^.n:=ls;
ls:=t;
tt:=tt^.n;
end;
t:=ls;
ls:=ls^.n;
t^.u:=nil;
t^.l:=nil;
t^.r:=nil;
t^.n:=t;
t^.p:=t;
t^.kl:=0;
t^.kr:=0;
n:=t;
while ls<>nil do
begin
p:=ls;
ls:=ls^.n;
add(p);
end;
p:=n;
repeat
writ(p^.x,p^.y);
t:=p;
p:=p^.n;
until p=n;
while gr<>nil do
begin
p:=gr;
gr:=gr^.gr;
dispose(p);
end;
onend:
inc(kkk);
until now-time>timew;
str((now-time)/kkk*24*60*60:0:6,strr);
TimeL.Caption:=strr+'s';
PaintBox1.Refresh;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
while sn<>nil do
begin
tt:=sn^.n;
dispose(sn);
sn:=tt;
end;
while cn<>nil do
begin
tt:=cn^.n;
dispose(cn);
cn:=tt;
end;
halt;
end;
procedure TForm1.Button3Click(Sender: TObject);
var
i:integer;
t:pr;
begin
randomize();
while cn<>nil do
begin
t:=cn^.n;
dispose(cn);
cn:=t;
end;
while sn<>nil do
begin
t:=sn^.n;
dispose(sn);
sn:=t;
end;
mx:=0;
my:=0;
new(t);
t^.n:=cn;
cn:=t;
t^.x:=0;
t^.y:=10;
if mx
if my
for i:=2 to QRandom.Value do
begin
new(t);
t^.n:=cn;
cn:=t;
t^.x:=i-2;
t^.y:=exp(i-2)/Range.Value;
if mx
if my
end;
if mx<>0 then mx:=0.8*(Width div 2)/mx;
if my<>0 then my:=0.8*(Height div 2)/my;
PaintBox1.Refresh;
end;
end.
1 F. P. Preparata, M. I. Shamos, Computational geometry, Ph. D. Thesis, Dept. Of Comput. Sci., Yale Univ., 1985.
S. G. Akl and G. T. Toussaint, Efficient convex hull algorithm for pattern recognition aplications, Proc. 4th Int’l Joint Conf. On Pattern Recognition, Kyoto, Japan, pp. 483-487 (1978).
2 A. Rosenfeld, Picture Processing by Computers, Academic Press, New York, 1969.
3 H. Freeman, Computer processing of line-drawing images, Comput. Surveys 6, 57-97 (1974).
4 P. McMullen and G. C. Shephard, Convex Polytopes and the Upper Bound Conjecture, Cambridge University Press, Cambridge, England, 1971
5 R. L. Graham, An efficient algorithm for determining the convex hull of a finite planar set, Info, Proc. Lett. 1, 132-133 (1972).
6 A. M. Andrew, Another efficient algorithm for convex hulls in two dimension, Info. Proc. Lett. 9, 216-219 (1979).
7 M. I. Shamos, Computational geometry, Ph. D. Thesis, Dept. Of Comput. Sci., Yale Univ., 1978.
8 F. P. Preparata, An optimal real time algorithm for planar convex hulls, Comm. ACM 22, 402-405 (1979).
|
