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

program lab3_10;

uses crt,graph;
type
windowtr=array [1..3,1..2] of integer;
const
M1 : array[1..4,1..2] of real =((20,20),
(250,20),
(250,180),
(20,180));
M2: array[1..3,1..2] of real =((500,300),
(600,400),
(400,400));
w1:windowtr=((130,450),(300,50),(470,450));
w2:windowtr=((200,400),(300,150),(400,400));

D:integer=1;
var
X,xc1,xc2,xc3,xc4,yc1,yc2,yc3,yc4: real;
check:boolean;
gd,gm:integer;
DXY: array[1..4,1..2] of real;
M,MM: array[1..4] of integer;
Y, Q, P: array[1..4] of real;
i:byte;

procedure drawwindow;
begin
MoveTo(w1[1,1],w1[1,2]);
LineTo(w1[2,1],w1[2,2]);
LineTo(w1[3,1],w1[3,2]);
LineTo(w1[1,1],w1[1,2]);
MoveTo(w2[1,1],w2[1,2]);
LineTo(w2[2,1],w2[2,2]);
LineTo(w2[3,1],w2[3,2]);
LineTo(w2[1,1],w2[1,2]);
end;

function scmul(x1,y1,x2,y2:longint):longint;
begin
scmul:=x1*x2+y1*y2
end;

procedure cirus(x1,y1,x2,y2:integer;cnt:byte);
var
i,k:byte;
tin,tout,t:real;
dx,dy,nx,ny,wx,wy:longint;
dsc,wsc:longint;
wc:windowtr;
begin
if cnt=1 then wc:=w1 else wc:=w2;
k:=3;
tin:=0;
tout:=1;
dx:=x2-x1;
dy:=y2-y1;
for i:=1 to k do
begin
if i<>k then
begin
nx:=-(wc[i+1,2]-wc[i,2]);
ny:=(wc[i+1,1]-wc[i,1]);
end
else
begin
nx:=(wc[k,2]-wc[1,2]);
ny:=-(wc[k,1]-wc[1,1]);
end;
wx:=x1-wc[i,1];
wy:=y1-wc[i,2];
dsc:=scmul(dx,dy,nx,ny);
wsc:=scmul(wx,wy,nx,ny);
if dsc=0 then begin
if wsc<0 then exit end
else {else 2}
begin
t:=-wsc/dsc; {if dsc>0 then 1}
if dsc>0 then
begin
if t>1 then begin if cnt=1 then Line(x1,y1,x2,y2); exit; end;
if tin<t then tin:=t;
end
else
begin
if t<0 then begin if cnt=1 then Line(x1,y1,x2,y2); exit; end; {then 4}
if tout>t then tout:=t;
end;
end;
end;

if tin<tout then
if cnt=2 then
Line(round(x1+(x2-x1)*tin),round(y1+(y2-y1)*tin),round(x1+(x2-x1)*tout),round(y1+(y2-y1)*tout))
else
begin
if (tin<>0) then Line(x1,y1,round(x1+(x2-x1)*tin),round(y1+(y2-y1)*tin));
if (tout<>1) then Line(round(x1+(x2-x1)*tout),round(y1+(y2-y1)*tout),x2,y2)
end;
end;


procedure Dr(x1,x2,x3,x4,y1,y2,y3,y4:real);
var
minx,maxx,miny,maxy:integer;
ic:byte;
begin
for ic:=1 to 2 do
begin
cirus(round(x1),round(y1),round(x2),round(y2),ic);
cirus(round(x2),round(y2),round(x3),round(y3),ic);
cirus(round(x3),round(y3),round(x4),round(y4),ic);
cirus(round(x4),round(y4),round(x1),round(y1),ic);
end
end;

procedure filling;
var
counter,J,K : integer;
begin
MoveTo(round(M1[1,1]), round(M1[1,2]));
xc1:= M1[1,1];
xc2:=M1[2,1];
xc3:=M1[3,1];
xc4:=M1[4,1];
yc1:=M1[1,2];
yc2:=M1[2,2];
yc3:=M1[3,2];
yc4:=M1[4,2];
Dr(xc1, xc2, xc3, xc4, yc1, yc2, yc3, yc4);
ReadKey;

for counter:=1 to 15 do
begin
Delay(20000);
if not check then
begin
setcolor(white);
Dr(xc1, xc2, xc3, xc4, yc1, yc2, yc3, yc4);
setcolor(magenta);
end;
xc1:= xc1+dxy[1,1];
xc2:= xc2+dxy[2,1];
xc3:= xc3+dxy[3,1];
xc4:= xc4+dxy[4,1];
yc1:= (M2[M[1],2]- M1[1,2])/(M2[M[1],1]- M1[1,1])*(xc1-M1[1,1])+M1[1,2];
yc2:= (M2[M[2],2]- M1[2,2])/(M2[M[2],1]- M1[2,1])*(xc2-M1[2,1])+M1[2,2];
yc3:= (M2[M[3],2]- M1[3,2])/(M2[M[3],1]- M1[3,1])*(xc3-M1[3,1])+M1[3,2];
yc4:= (M2[M[4],2]- M1[4,2])/(M2[M[4],1]- M1[4,1])*(xc4-M1[4,1])+M1[4,2];

MoveTo(round(xc1), round(yc1));
Dr(xc1, xc2, xc3, xc4, yc1, yc2, yc3, yc4);
end;

MoveTo(round(x), round(yc1));
Dr(X, x, x, x, yc1, yc2, yc3, yc4);
DXY[1,1]:= (M2[1,1]-X)/15;
DXY[2,1]:= (M2[2,1]-X)/15;
DXY[3,1]:= (M2[3,1]-X)/15;
DXY[4,1]:= (M2[D,1]-X)/15;
P[1]:= X;
P[2]:=x;
P[3]:=x;
P[4]:=x;

for counter:=1 to 15 do
begin
if not check then
begin
setcolor(white);
Dr(x, x, x, x, yc1, yc2, yc3, yc4);
setcolor(magenta);
end;
P[1]:= P[1]+dxy[1,1];
P[2]:= P[2]+dxy[2,1];
P[3]:= P[3]+dxy[3,1];
P[4]:= P[4]+dxy[4,1];
Q[1]:= (M2[1,2]-M1[MM[1],2])/(M2[1,1]-M1[MM[1],1])*(P[1]-M1[MM[1],1])+M1[MM[1],2];
Q[2]:= (M2[2,2]- M1[MM[2],2])/(M2[2,1]- M1[MM[2],1])*(P[2]-M1[MM[2],1])+M1[MM[2],2];
Q[3]:= (M2[3,2]- M1[MM[3],2])/(M2[3,1]- M1[MM[3],1])*(P[3]-M1[MM[3],1])+M1[MM[3],2];
Q[4]:= (M2[D,2]- M1[MM[4],2])/(M2[D,1]- M1[MM[4],1])*(P[4]-M1[MM[4],1])+M1[MM[4],2];
Delay(20000);
if not check then begin ClearDevice; DrawWindow end;
MoveTo(round(P[1]), round(Q[1]));
Dr(P[1], P[2], P[3], P[4], Q[1], Q[2], Q[3], Q[4]);
end;
MoveTo(round(M2[1,1]), round(M2[1,2]));
Dr(M2[1,1], M2[2,1], M2[3,1], M2[D,1], M2[1,2], M2[2,2], M2[3,2], M2[D,2]);
end;

procedure corr;
var
I,B, J,K: integer;
bb: boolean;
begin
randomize;
for I:=1 to 4 do
begin
MM[I]:= 0;
M[I]:=0;
end;
for I:=1 to 4 do
begin
while true do
begin
bb:=false;
B:= random(4)+1;
for J:=1 to 4 do
if M[J]= B then
begin
bb:= true;
break;
end;
if not bb then
begin
M[I]:= B;
MM[B]:=I;
break;
end;
end;

end;
for I:=1 to 4 do
if M[I]=4 then
M[I]:= D;
X:= (M1[3,1]+M2[3,1])/2;
y[1]:=(M2[M[1],2]- M1[1,2])/(M2[M[1],1]- M1[1,1])*(xc1-M1[1,1])+M1[1,1];
y[2]:=(M2[M[2],2]- M1[2,2])/(M2[M[2],1]- M1[2,1])*(xc2-M1[2,1])+M1[2,1];
y[3]:=(M2[M[3],2]- M1[3,2])/(M2[M[3],1]- M1[3,1])*(xc3-M1[3,1])+M1[3,1];
y[4]:=(M2[M[4],2]- M1[4,2])/(M2[M[4],1]- M1[4,1])*(xc4-M1[4,1])+M1[4,1];
for I:=1 to 4 do
begin
DXY[I,1]:= (X-M1[I,1])/15;
DXY[I,2]:= (Y[I]-M1[I,2])/15;
end;
end;

procedure preparation;
var i:integer;
c:char;
begin
writeln('Points correspondence:');
for i:=1 to 4 do
writeln(MM[i],'-',M[i]);
writeln('Do you want to show all current figures (slave) (y/n)?');
readln(c);
if (c='y') or (c='Y') then check:=true else check:=false;
end;

begin
corr;
preparation;
gd:=detect;
gm:=0;
initgraph(GD,gm,'');
SetBkColor(White);
SetColor(Magenta);
Drawwindow;
Filling;
ReadKey;
closegraph;
end.