{$mode fpc}
uses
ptcGraph, ptcCrt,
SysUtils,math;
Type Point=object
x,y:double;
End;
Type _Line=object
s,f:point;
End;
type aol=array of _Line;
type aop=array of point;
function equals(a,b:point;tol:double):boolean;
var
z:boolean=false;
begin
if (abs(a.x-b.x)<tol) and (abs(a.y-b.y)<tol) then z:=true;// -1
exit(z);
end;
procedure draw(L:_Line);
begin
line(trunc(L.s.x),trunc(L.s.y),trunc(L.f.x),trunc(L.f.y));
end;
Function isleft(L:_Line;p:point):integer;
begin
exit (-sign((L.s.x-L.f.x)*(p.y-L.f.y)-(p.x-L.f.x)*(L.s.y-L.f.y)));
End;
Function intersects(L1:_Line;L2:_Line):boolean;
begin
If (isleft(L2,L1.s) = isleft(L2,L1.f)) Then exit (false);
If (isleft(L1,L2.s) = isleft(L1,L2.f)) Then exit (false);
exit(true);
End;
function intersections(l1:_Line;l2:_Line;var _out:point):boolean;
var
p1,p2,p3,p4:point;
x12,x34,y12,y34:single;
c:single;
a,b,x,y:single;
begin
p1:=l1.s;p2:=l1.f;p3:=l2.s;p4:=l2.f;
x12:=p1.x-p2.x;x34:=p3.x-p4.x;y12:=p1.y-p2.y;y34:=p3.y-p4.y;
c:=x12 * y34 - y12 * x34;
if (abs(c) < 0.01) then exit(false);
a := p1.x * p2.y - p1.y * p2.x;
b := p3.x * p4.y - p3.y * p4.x;
x := (a * x34 - b * x12) / c;
y := (a * y34 - b * y12) / c;
_out.x:=x;
_out.y:=y;
exit(true)
end;
procedure ellipse(x,y:integer;rx:double;ry:double;var a:aop);
const pi=4*arctan(1);
var
counter:int32;
z:double=0;
xp,yp:double;
begin
counter:=0;
repeat
xp:=x+rx*cos(z);
yp:=y+ry*sin(z);
counter:=counter+1;
setlength(a,counter);
a[counter-1].x:=xp;
a[counter-1].y:=yp;
putpixel(trunc(xp), trunc(yp),white);
z:=z+0.05;
until (z>2*pi);
end;
procedure setlines(a:aop;var ret:aop);
var
k,n,n1,n2,flag,m:integer;
b:aop=nil;
l:aol=nil;
_out:point;
centre:point;
begin
setcolor(blue);
centre.x:=400;
centre.y:=300;
_out.x:=0;
_out.y:=0;
setlength(b,6);
k:=10;
for n :=0 to 5 do
begin
b[n]:=a[k];
fillellipse(trunc(a[k].x),trunc(a[k].y),4,4);
k:=k+high(a) div 6;
end;
k:=0;
for n1 :=0 to 4 do
begin
for n2 :=n1+1 to 5 do
begin
k:=k+1;
setlength(l,k);
L[k-1].s:=b[n1];
L[k-1].f:=b[n2];
end;
end;
k:=0;
for n1 :=0 to high(l)-1 do
begin
for n2 :=n1+1 to high(l) do
begin
flag:=0;
if (intersects(L[n1],L[n2])) then
begin
intersections(L[n1],L[n2],_out);
flag:=1;
for m :=0 to high(b) do
begin
if equals(_out,b[m],2) then
begin
flag:=0;
break;
end;
end;
end;
if (flag=1) then
begin
draw(L[n1]);
draw(l[n2]);
if equals(_out,centre,40)=false then
begin
k:=k+1;
setlength(ret,k);
ret[k-1]:=_out;
setcolor(white);
fillellipse(trunc(_out.x), trunc(_out.y),2,2);
setcolor(blue);
end;
end;
end;
end;
end;
procedure circulate(var p:aop);
procedure swap(var a, b: point);
var temp: point;
begin
temp := a; a := b; b := temp;
end;
var
p1,p2:integer;
c:point;
begin
c.x:=400;
c.y:=300;
For p1 := 0 To high(p)-1 do
begin
For p2 := p1 + 1 To high(p) do
begin
if arctan2(p[p1].y-c.y,p[p1].x-c.x)< arctan2(p[p2].y-c.y,p[p2].x-c.x) then
begin
swap (p[p1],p[p2]);
end;
end;
end;
end;
procedure drawpascallines(ret:aop);
var
n:integer;
begin
circulate(ret);
for n:=0 to high(ret)-1 do
line(trunc(ret[n].x),trunc(ret[n].y),trunc(ret[n+1].x),trunc(ret[n+1].y));
line(trunc(ret[high(ret)].x),trunc(ret[high(ret)].y),trunc(ret[0].x),trunc(ret[0].y));
end;
//main//
var
a:aop=nil;
ret:aop=nil;
gd, gm: SmallInt;
ch:char;
begin
{========== set up graph =========}
gd := D8bit;
gm := m800x600;
InitGraph(gd, gm, '');
if GraphResult <> grok then halt;
setbkcolor(black);
settextstyle(BoldFont,HorizDir,1);
setwritemode(copyput);
repeat
ClearViewPort;
setcolor(white);
outtextxy(10,10,'Pascal hexagon demo');
outtextxy(10,40,'Space key to refresh -- esc key to end.');
ellipse(400,300,randomrange(100,300),randomrange(100,300),a);
setlines(a,ret);
setcolor(red);
drawpascallines(ret);
ch:=readkey;
sleep(10);
until (ord(ch)= 27);
closegraph;
end.