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<bb^.x)or((t^.x=bb^.x)and(t^.y<bb^.y))
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)<abs(t^.x-bb^.x)+abs(t^.x-bb^.x))))
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<l^.a)or((r^.a=l^.a)and(abs(r^.x-x)+abs(r^.y-y)<abs(l^.x-x)+abs(l^.y-y)))then
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<abs(t^.x) then mx:=abs(t^.x);
if my<abs(t^.y) then my:=abs(t^.y);
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);