Курсовая работа: Создание программы для определения вершин пирамиды с выпуклым основанием по данным точкам
Procedure
BeginOfPoints(var P:P_Descriptor);
Procedure
ReadPoint(var P:P_Descriptor;var a:Coordinates);
Procedure
MovePtrOfPoints(var P:P_Descriptor);
Procedure
MoveToPoints(var P:P_Descriptor; n:word);
Procedure
ClearMem(var P:P_Descriptor;var V:V_Descriptor);
Implementation
Procedure
InitListOfVectors;
Begin
If
MaxAvail<sizeOf(Vector) Then
ListError:=ListNotMem
else
begin
ListError:=ListOk;
V.V_Number:=0;
New(V.V_start);
V.V_Ptr:=V.V_Start;
end;
End;
Procedure
PutVector;
var
buf:P_Vectors;
Begin
If
MaxAvail<sizeOf(Vector) Then
ListError:=ListNotMem
else
begin
ListError:=ListOk;
V.V_Ptr:=V.V_start;
New(Buf);
buf^.data:=c;
buf^.next:=V.V_Ptr^.next;
V.V_Ptr^.next:=buf;
V.V_Number:=V.V_number+1;
end;
end;
procedure
createVector;
begin
with
c do
begin
x:=a.x-b.x;
y:=a.y-b.y;
z:=a.z-b.z;
end;
end;
Procedure
WriteVectors;
var
index:word;
begin
If
V.V_Number=0 then
ListError:=ListUnder
else
index:=1;
beginOfVectors(V);
while
(V.V_Ptr^.next<>V.V_Start)and(index<=V.V_number) do
begin
writeln('Vector
',index,'= (',V.V_Ptr^.data.x:5:2,' , ',V.V_Ptr^.data.y:5:2,', ',V.V_Ptr^.data.z:5:2,')
');
V.V_Ptr:=V.V_Ptr^.next;
inc(index);
end;
end;
Procedure
BeginOfVectors;
begin
V.V_Ptr:=V.V_start^.next;
end;
{Процедуры на
свойства векторов}
Procedure
AdditionVectors;
begin
with
c do
begin
x:=a.x+b.x;
y:=a.y+b.y;
z:=a.z+b.z;
end;
end;
Procedure
MultOnNumber;
begin
with
c do
begin
x:=number*a.x;
y:=number*a.y;
z:=number*a.z;
end;
end;
Function
lengthOfVector;
begin
lengthOfVector:=sqrt(sqr(a.x)+sqr(a.y)+sqr(a.z));
end;
Function
Scalar;
begin
Scalar:=a.x*b.x+a.y*b.y+a.z*b.z;
end;
Function
angle;
begin
Angle:=
arccos(scalar(a,b))/(lengthOf Vector(a)*lengthOfVector(b));
end;
Function
projection;
begin
projection:=(lengthOfVector(a)*lengthOfVector(b)*angle(a,b));
end;
Procedure
VECTMult;
begin
with
c do
begin
x:=a.y*b.z-b.y*a.z;
y:=a.z*b.x-b.z*a.z;
z:=a.x*b.y-b.x*a.y;
end;
end;
Function
collinearity;
begin
if
((a.x/b.x)=(a.y/b.y))and((a.y/b.y)=(a.z/b.z)) then
collinearity:=true
else
collinearity:=false;
end;
Function
MixeMult;
begin
MixeMult:=a.x*b.y*c.z+a.y*b.z*a.x+a.z*b.x*c.z-a.z*b.y*c.x-a.y*b.x*c.z-a.x*b.z*c.y;
end;
Function
coplanarity;
begin
if
MixeMult(a,b,c)=0 then
coplanarity:=true
else
coplanarity:=false;
end;
{Подпрограммы
для нахождения пирамиды}
Procedure ploskost;
var
j:word;
Begin
Ax:=(1*b.y*c.z)+(1*c.y*a.z)+(a.y*b.z*1)-(a.z*b.y*1)-(1*a.y*c.z)-(c.y*b.z*1);
Bx:=(a.x*1*c.z)+(1*b.z*c.x)+(b.x*1*a.z)-(a.z*1*c.x)-(b.x*1*c.z)-(1*b.z*a.x);
Cx:=(a.x*b.y*1)+(b.x*c.y*1)+(a.y*1*c.x)-(1*b.y*c.x)-(c.y*1*a.x)-(b.x*a.y*1);
Dx:=-((a.x*b.y*c.z)+(b.x*c.y*a.z)+(a.y*b.z*c.x)-(c.y*b.z*a.x)-(a.z*b.y*c.x)-(b.x*a.y*c.z));
if
(ax=0)and(bx=0)and(cx=0) then
writeln('lejat
na odnoi pr9mou');
end;
Procedure
FindaPyramid;
var
i,k:word;
f,fl:boolean;
a:coordinates;
begin
mno:=[];
for
i:=1 to p.number do
mno:=mno+[i];
f:=proverka_na_ploskost(p,mno,p.number);
if
f then writeln('resheni9 net..vse to4ki lejat v ploskosti')
else
begin
i:=1;
fl:=false;
while
(not fl)and(i<=p.number) do
begin
mno:=mno-[i];
writeln;
if
proverka_na_ploskost(p,mno,p.number-1) then
fl:=Vypuklost(p,mno,p.number-1)
else
fl:=false;
mno:=mno+[i];
i:=i+1;
end;
if
fl then
begin
writeln('pyramida''s
top are= ');
for
i:=1 to p.number do
begin
movetopoints(p,i);
readpoint(p,a);
Writeln('(
',a.x:6:2,' ',a.y:6:2,' ',a.z:6:2,') ');
end;
end
else
writeln('pyramida is not found ');
end;
end;
function
proverka_na_ploskost;
var
ax,bx,cx,dx:real;
i:word;
a,t1,t2,t3:coordinates;
f:boolean;
begin
i:=1;
while
not( i in mno) do i:=i+1;
movetopoints(p,i);
readpoint(p,t1);
i:=i+1;
while
not( i in mno) do i:=i+1;
movetopoints(p,i);
readpoint(p,t2);
i:=i+1;
while
not( i in mno) do i:=i+1;
movetopoints(p,i);
readpoint(p,t3);
ploskost(p,t1,t2,t3,ax,bx,cx,dx);
f:=true;
while
(i<=n)and f do
begin
i:=i+1;
while
not( i in mno) do i:=i+1;
movetopoints(p,i);
readpoint(p,a);
if
ax*a.x+bx*a.y+cx*a.z+dx=0 then
begin
f:=true;
end
else
begin
f:=false;
end;
end;
proverka_na_ploskost:=f;
end;
Function
Vypuklost;
var
i,j,k:byte;
Q:boolean;
T,Z,Px:real;
a,b,v1,v2:coordinates;
begin
i:=1;
while
not( i in mno) do i:=i+1;
movetopoints(p,i);
readpoint(p,a);
k:=0;
while
(k<>n) do
begin
if
(i in mno) then inc(k);
inc(i);
end;
movetopoints(p,i);
readpoint(p,b);
inc(i);
createVector(a,b,V1);
createVector(a,b,V2);
T:=(v1.y*v2.z-v2.y*v1.z)-(v1.x*v2.z-v2.y*v1.z)+(v1.x*v2.y-v2.x*v1.y);
Z:=Sign(T);
Px:=1.0;
j:=1;
Q:=true;
While
(Q and (j<n))do
begin
while
not( j in mno) do j:=j+1;
movetopoints(p,j);
readpoint(p,a);
inc(j);
while
not( j in mno) do j:=j+1;
movetopoints(p,j);
readpoint(p,b);
createVector(a,b,V1);
createVector(a,b,V2);
T:=(v1.y*v2.z-v2.y*v1.z)-(v1.x*v2.z-v2.y*v1.z)+(v1.x*v2.y-v2.x*v1.y);
Px:=Px*Z*Sign(T);
if
(Px<0) then Q:=false;
inc(i);
end;
Vypuklost:=Q;
end;
function
Sign;
begin
if
t=0 then
Sign:=1
else
sign:=round(t/abs(t));
end;
{Подпрограммы
для обрабоки списка точек}
Procedure
InitListOfPoint;
Begin
If
MaxAvail<sizeOf(point) Then
ListError:=ListNotMem
else
begin
ListError:=ListOk;
P.Number:=0;
New(P.start);
P.Ptr:=P.Start;
end;
End;
Procedure
PutPoint;
var
buf:P_Points;
Begin
If
MaxAvail<sizeOf(point) Then
ListError:=ListNotMem
else
begin
ListError:=ListOk;
P.ptr:=P.start;
New(Buf);
write('Input
point = ');
readln(buf^.data.x,buf^.data.y,buf^.data.z);
buf^.next:=P.Ptr^.next;
P.Ptr^.next:=buf;
P.Number:=P.number+1;
end;
end;
Procedure
WritePoints;
var
index:word;
begin
If
P.Number=0 then
ListError:=ListUnder
else
index:=1;
beginOfPoints(P);
while
(P.Ptr^.next<>P.Start)and(index<=P.number) do
begin
writeln('point
',index,'= (',P.Ptr^.data.x:5:2,' , ',P.Ptr^.data.y:5:2,', ',P.Ptr^.data.z:5:2,')
');
P.Ptr:=P.Ptr^.next;
inc(index);
end;
end;
Procedure
BeginOfPoints;
begin
P.Ptr:=P.start^.next;
end;
Procedure
ReadPoint;
begin
if
P.Number=0 then
ListError:=ListUnder
else
begin
ListError:=ListOk;
a:=P.Ptr^.data;
end;
end;
procedure
MovePtrOfPoints;
begin
P.Ptr:=P.Ptr^.next;
end;
Procedure
MoveToPoints;
var
i:word;
begin
IF
n>P.Number then
ListError:=ListUnder
else
begin
ListError:=ListOk;
P.Ptr:=P.start;
Страницы: 1, 2, 3, 4, 5 |
