Лаба Лаб 1-4; ПЗ 1-4 Все лабы по дисциплине Условия - в методе из ЭУМК (Пешков АТ) [Вариант 10] / Архив указанных лаб / PR4_10

program pr4_10;

uses
crt,graph;

type
windowtr=array[1..4,1..3] of real;

const
prism : array[1..8,1..3] of real = ((300,170,0),
(300,170,100),
(500,170,100),
(500,170,0),
(300,320,0),
(300,320,100),
(500,320,100),
(500,320,0));
edge : array [1..12,1..2] of byte = ((1,2),
(1,4),
(1,5),
(2,3),
(2,6),
(3,4),
(3,7),
(4,8),
(5,8),
(5,6),
(6,7),
(7,8));
sk1 : array [1..6,1..4] of byte = ((1,2,6,4),
(1,5,10,3),
(4,7,11,5),
(6,8,12,7),
(2,3,9,8),
(9,10,11,12));
skeleton : array [1..6,1..4] of byte =((1,4,3,2),
(1,2,6,5),
(6,2,3,7),
(7,3,4,8),
(8,4,1,5),
(6,7,8,5));
TransMatr : array[1..4,1..4] of real =((1,0,0,0),
(0,1,0,0),
(0.70710678,0.70710678,0,0),
(0,0,0,1));
piece : array [1..2,1..3] of real = ((250,120,0),(500,300,120));
var
gd,gm:integer; f:text;
seeedge:array[1..6] of boolean;
Matr2D:array[1..8,1..2] of real;
chk:byte;
Piece2D:array[1..2,1..2] of real;

procedure ConvTo2D;
var
i:byte;
begin
for i:=1 to 8 do
begin
Matr2D[i,1]:=prism[i,1]+prism[i,3]*sqrt(0.5);
Matr2D[i,2]:=prism[i,2]+prism[i,3]*sqrt(0.5);
end;
for i:=1 to 2 do
begin
Piece2D[i,1]:=piece[i,1]+piece[i,3]*sqrt(0.5);
Piece2D[i,2]:=piece[i,2]+piece[i,3]*sqrt(0.5);
end
end;

function scmul3D(x1,y1,z1,x2,y2,z2:real):real;
var tmp:real;
begin
tmp:=x1*x2+y1*y2+z1*z2;
scmul3D:=tmp
end;

procedure check;
var
c:boolean;
cnt:byte;
ax,bx,cx,ay,by,cy:real;
begin
for cnt:=1 to 6 do
begin
ax:=Matr2D[skeleton[cnt,1],1];
ay:=Matr2D[skeleton[cnt,1],2];
bx:=Matr2D[skeleton[cnt,2],1];
by:=Matr2D[skeleton[cnt,2],2];
cx:=Matr2D[skeleton[cnt,3],1];
cy:=Matr2D[skeleton[cnt,3],2];
seeedge[cnt]:=((ax*by+ay*cx+bx*cy-by*cx-ay*bx-cy*ax)>0)
end
end;

procedure retsc(r:byte; var e1,e2:byte);
var
i,j:byte;
begin
e1:=0;
e2:=0;
for i:=1 to 6 do
for j:=1 to 4 do
if r=sk1[i,j] then
if e1<>0 then e2:=i else e1:=i;
end;

{procedure cirus2D(x1,y1,z1,x2,y2,z2:real)}
procedure cirus3D(x1,y1,z1,x2,y2,z2:real);
var
i,j,k,l:byte;
dx,dy,dz,wx,wy,wz,nx,ny,nz:real;
opt:array[1..3,1..2] of real;
tin,tout,t:real;
dsc,wsc:real;
tc:array[1..6] of real;
wc:windowtr;
x1t,x2t,y1t,y2t,z1t,z2t:real;
begin
k:=6;
tin:=0;
tout:=1;
dx:=x2-x1;
dy:=y2-y1;
dz:=z2-z1;
for i:=1 to 6 do
begin
for j:=1 to 4 do
for l:=1 to 3 do
wc[j,l]:=prism[skeleton[i,j],l];
nx:=(wc[2,2]-wc[1,2])*(wc[3,3]-wc[1,3])-(wc[3,2]-wc[1,2])*(wc[2,3]-wc[1,3]);
ny:=-(wc[2,1]-wc[1,1])*(wc[3,3]-wc[1,3])-(wc[3,1]-wc[1,1])*(wc[2,3]-wc[1,3]);
nz:=(wc[2,1]-wc[1,1])*(wc[3,2]-wc[1,2])-(wc[3,1]-wc[1,1])*(wc[2,2]-wc[1,2]);
{if (not seeedge[i]) then
begin
nx:=-nx; ny:=-ny; nz:=-nz;
end;}
wx:=x1-wc[1,1];
wy:=y1-wc[1,2];
wz:=z1-wc[1,3];
dsc:=scmul3D(dx,dy,dz,nx,ny,nz);
wsc:=scmul3D(wx,wy,wz,nx,ny,nz);if (dsc<>0) then t:=-wsc/dsc else t:=0;
tc[i]:=t;
write(f,t:5:3,';');
{ if dsc=0 then
begin
if wsc<0 then begin
Line(round(Piece2D[1,1]),round(Piece2D[1,2]),round(Piece2D[2,1]),round(Piece2D[2,2]));
exit
end
end
else
begin
t:=-wsc/dsc;
tc[i]:=t;
if dsc<0 then
begin
if t>1 then
begin
Line(round(Piece2D[1,1]),round(Piece2D[1,2]),round(Piece2D[2,1]),round(Piece2D[2,2]));
exit;
end;
if tin<t then tin:=t;
end
else
begin
if t<0 then
begin
Line(round(Piece2D[1,1]),round(Piece2D[1,2]),round(Piece2D[2,1]),round(Piece2D[2,2]));
exit;
end;
if tout>t then tout:=t;
end;
end; }
x1t:=x1+(x2-x1)*tc[i];
y1t:=y1+(y2-y1)*tc[i];
z1t:=z1+(z2-z1)*tc[i];
for k:=1 to 3 do
begin
opt[k,1]:=wc[1,k];
opt[k,2]:=wc[1,k];
for l:=2 to 4 do
begin
if wc[l,k]>opt[k,2] then opt[k,2]:=wc[l,k];
if wc[l,k]<opt[k,1] then opt[k,1]:=wc[l,k];
end;
end;
if ((x1t<=opt[1,2]) and (x1t>=opt[1,1]) and (y1t<=opt[2,2])
and (y1t>=opt[2,1]) and (z1t<=opt[3,2]) and (z1t>=opt[3,1])) then
tc[i]:=tc[i] else tc[i]:=0;
end;
tin:=1; tout:=0;
for k:=1 to 6 do
begin
{ write(f,tc[k]:5:3,';');}
if ((tc[k]<>0) and (tc[k]<tin)) then if (tc[k]>0) then tin:=tc[k];
if ((tc[k]<>0) and (tc[k]>tout)) then if (tc[k]>0) then tout:=tc[k];
{ write(f,tc[k]:5:3,';')}
{tin:=0.27777;tout:=0.62531;}
end;
if (((tin=1) and (tout=0)) or (abs(tin-tout)<=0.001)) then
Line(round(Piece2D[1,1]),round(Piece2D[1,2]),round(Piece2D[2,1]),round(Piece2D[2,2]));
writeln(f,tin:5:3,';',tout:5:3);
if tin<tout then
begin
x1t:=x1+(x2-x1)*tin;
y1t:=y1+(y2-y1)*tin;
z1t:=z1+(z2-z1)*tin;
x2t:=x1+(x2-x1)*tout;
y2t:=y1+(y2-y1)*tout;
z2t:=z1+(z2-z1)*tout;
Piece2D[1,1]:=x1t+z1t*sqrt(0.5);
Piece2D[1,2]:=y1t+z1t*sqrt(0.5);
Piece2D[2,1]:=x2t+z2t*sqrt(0.5);
Piece2D[2,2]:=y2t+z2t*sqrt(0.5);
if (tin<>0) then
Line(round(x1+z1*sqrt(0.5)),round(y1+z1*sqrt(0.5)),round(Piece2D[1,1]),round(Piece2D[1,2]));
if (tout<>1) then
Line(round(Piece2D[2,1]),round(Piece2D[2,2]),round(x2+z2*sqrt(0.5)),round(y2+z2*sqrt(0.5)));
end
end;


procedure DrawPrism(an:integer);
var
i,j,e1,e2: byte;
begin
for i:=1 to 12 do
begin
retsc(i,e1,e2);
case chk of
1:
Line(round(Matr2D[edge[i,1],1]),round(Matr2D[edge[i,1],2]),round(Matr2D[edge[i,2],1]),round(Matr2D[edge[i,2],2]));
2:
begin
if ((seeedge[e1]) or (seeedge[e2])) then
SetLineStyle(SolidLn,0,NormWidth)
else SetLineStyle(DashedLn,0,NormWidth);
Line(round(Matr2D[edge[i,1],1]),round(Matr2D[edge[i,1],2]),round(Matr2D[edge[i,2],1]),round(Matr2D[edge[i,2],2]));
end;
3:
if ((seeedge[e1]) or (seeedge[e2])) then
Line(round(Matr2D[edge[i,1],1]),round(Matr2D[edge[i,1],2]),round(Matr2D[edge[i,2],1]),round(Matr2D[edge[i,2],2]));
end;
end;
end;

procedure Turn;
var
phi,an:integer;
rvec:real;
i:byte;
zt,xt:real;
begin
an:=0;
for phi:=1 to 360 do
begin
for i:=1 to 8 do
if ((i<>1) and (i<>5)) then begin
zt:=prism[i,3];
xt:=prism[i,1];
prism[i,3]:=(zt-prism[1,3])*cos(pi*1/180)-(xt-prism[1,1])*sin(pi*1/180)+prism[1,3];
prism[i,1]:=(zt-prism[1,3])*sin(pi*1/180)+(xt-prism[1,1])*cos(pi*1/180)+prism[1,1];
end; ConvTo2D;
check;
Setcolor(Magenta);
DrawPrism(an);
Cirus3D(piece[1,1],piece[1,2],piece[1,3],piece[2,1],piece[2,2],piece[2,3]);
Delay(5000);
{Readkey; }
Setcolor(White); DrawPrism(an);
Cirus3D(piece[1,1],piece[1,2],piece[1,3],piece[2,1],piece[2,2],piece[2,3]);
for i:=1 to 3 do
if (i<>1) then begin
zt:=piece[i,2];
xt:=piece[i,3];
piece[i,2]:=(zt-piece[1,2])*cos(pi*1/180)-(xt-piece[1,3])*sin(pi*1/180)+piece[1,2];
piece[i,3]:=(zt-piece[1,2])*sin(pi*1/180)+(xt-piece[1,3])*cos(pi*1/180)+piece[1,3];
end;
end
end;

begin
assign(f,'file.txt');
rewrite(f);
writeln('Choose the kind of the model:');
writeln('1-wire frame model;');
writeln('2-dashed unvisible lines;');
writeln('3-opaque model.');
readln(chk);
gd:=detect;
gm:=0;
initgraph(GD,gm,'');
ConvTo2D;
check;
SetBkColor(White);
SetColor(Magenta);
DrawPrism(0);
Cirus3D(piece[1,1],piece[1,2],piece[1,3],piece[2,1],piece[2,2],piece[2,3]);
ReadKey;
Setcolor(White); DrawPrism(0);
Turn;
Setcolor(Magenta); DrawPrism(0);
ReadKey; close(f);
closegraph;
end.