Реферат: Сравнительный анализ алгоритмов построения выпуклой оболочки на плоскости

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. 4^th 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).