{$mode fpc}
{$RANGECHECKS ON}
uses
sysutils,ptcGraph,ptcCrt,math;
Type PointF=object
x,y:double;
End;
type aop=array of PointF;
function rgb(r,g,b:smallint) :longword;
begin
exit(((r Shl 16) Or ((g) Shl 8) Or (b) Or $FF000000)- $FF000000)
end;
Function inpolygon(const p1:aop;const mx,my:double):boolean;
function Winder(L1,L2,p:PointF):integer;
begin
exit (-Sign((L1.x-L2.x)*(p.y-L2.y)-(p.x-L2.x)*(L1.y-L2.y)));
end;
var
index,nextindex,wn,k,n:integer;
const p2:pointf=(x:0;y:0);
begin
p2.x:=mx;p2.y:=my;
k:=length(p1);
wn:=0;
For n :=0 To high(p1) do
begin
index:=n Mod k;nextindex:=(n+1) Mod k;
If (p1[index].y<=p2.y) Then
If (p1[nextindex].y>p2.y) And (Winder(p1[index],p1[nextindex],p2)>0) Then wn:=wn+1;
If (p1[index].y>p2.y) Then
If (p1[nextindex].y<=p2.y) And (Winder(p1[index],p1[nextindex],p2)<0) Then wn:=wn-1;
end;
exit( boolean(wn));
End;
procedure swap(var a, b: longword);
var temp: longword;
begin
temp := a; a := b; b := temp;
end;
function circulate(var p:aop):pointF;
procedure swap(var a, b: pointF);
var temp: pointF;
begin
temp := a; a := b; b := temp;
end;
var
p1,p2,i:integer;
c:pointF;
begin
c.x:=0;c.y:=0;
for i:=0 to high(p) do
begin
c.x:=c.x+p[i].x;
c.y:=c.y+p[i].y;
end;
c.x:=c.x/length(p);
c.y:=c.y/length(p);
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;
exit(c);
end;
function range(mymin:int64;mymax:int64):int64;
begin
exit(trunc(int((Random*(Mymax-mymin+1)))+MyMin));
end;
procedure drawpolygon(ret:aop;linecol:longword);
var
n:integer;
getc:longword;
begin
getc:=getcolor;
setcolor(linecol);
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));
setcolor(getc);
end;
function rainbow( x:single):longword;
const pi=4*arctan(1);
var
r,g,b:single;
begin
r := sin( ( x*pi/180 ) ) * 127 + 128;
g := sin(( x - 120 )*pi/180 ) * 127 + 128;
b := sin( ( x + 120 )*pi/180 ) * 127 + 128;
exit( rgb( trunc(r) and 255 , trunc(g) and 255 ,trunc( b) and 255));
end;
var
a:aop=nil;
gd, gm: SmallInt;
ch:char;
i,j:integer;
col1,col2:longword;
dv,sv:integer;
begin
{========== set up graph =========}
gd := D24bit;
gm := m1024x768;
InitGraph(gd, gm, '');
if GraphResult <> grok then halt;
settextstyle(BoldFont,HorizDir,2);
{=================================}
randomize;
repeat
setlength(a,range(3,15));
for i:=0 to high(a) do
begin
a[i].x:=(range(0,800));
a[i].y:=range(0,600);
end;
circulate(a);
dv:=range(100,2500);
sv:=range(0,100);
for i:=0 to 1024 do
begin
for j:= 0 to 768 do
begin
col1:=rgb(i,i xor j,j);
col2:=rainbow(((768-i)*j)/dv);
if (sv < 50) then swap(col1,col2);
if inpolygon(a,i,j) then putpixel(i,j,col1) else putpixel(i,j,col2); //<--- crunch line
end;
end;
setcolor(rgb(255,255,255));
outtextxy(10,10,'Pascal inpolygon demo');
outtextxy(10,40,'Press esc key to end.');
drawpolygon(a,rgb(255,255,255));
if KeyPressed then ch:=readkey;
sleep(1000);
until (ord(ch)= 27);
end.
Recent
