Аналитическое дифференцирование / 116_INST

Uses Crt,grafx,Timer;

const
MaxRows = 50;
Maxcols = 50;

type

Fig = record
Sort : Integer;
squares : array [1..5] of integer
end;

CellInf = record
FigNum, SqNum : Integer
end;
Area = record
HorSize,VertSize:Integer;
Place : array [1..MaxRows] of array [1..MaxCols] of ^CellInf
end;

pArea = ^Area;


var
Mo,ti,Exit:Boolean;


procedure MakeFig(var Ar:Fig);
begin

If Ar.Sort = 1 then
begin
Ar.Squares[1]:=31;
Ar.Squares[2]:=32;
Ar.Squares[3]:=33;
Ar.Squares[4]:=34;
Ar.Squares[5]:=22;
end;

If Ar.Sort = 2 then
begin
Ar.Squares[5]:=13;
Ar.Squares[2]:=23;
Ar.Squares[3]:=33;
Ar.Squares[4]:=43;
Ar.Squares[1]:=32;
end;

If Ar.Sort = 3 then
begin
Ar.Squares[1]:=21;
Ar.Squares[2]:=22;
Ar.Squares[3]:=23;
Ar.Squares[4]:=24;
Ar.Squares[5]:=33;
end;

If Ar.Sort = 4 then
begin
Ar.Squares[1]:=12;
Ar.Squares[2]:=22;
Ar.Squares[3]:=32;
Ar.Squares[4]:=42;
Ar.Squares[5]:=23;
end;

If Ar.Sort = 5 then
begin
Ar.Squares[1]:=31;
Ar.Squares[2]:=32;
Ar.Squares[3]:=33;
Ar.Squares[4]:=34;
Ar.Squares[5]:=23;
end;

If Ar.Sort = 6 then
begin
Ar.Squares[5]:=13;
Ar.Squares[2]:=23;
Ar.Squares[3]:=33;
Ar.Squares[4]:=43;
Ar.Squares[1]:=22;
end;

If Ar.Sort = 7 then
begin
Ar.Squares[1]:=21;
Ar.Squares[2]:=22;
Ar.Squares[3]:=23;
Ar.Squares[4]:=24;
Ar.Squares[5]:=32;
end;

If Ar.Sort = 8 then
begin
Ar.Squares[1]:=12;
Ar.Squares[2]:=22;
Ar.Squares[3]:=32;
Ar.Squares[4]:=42;
Ar.Squares[5]:=33;
end;

end;

Function Placible(var A:Area; S,C,T:Integer):Boolean;
var
F:Fig;
I,P,Q:Integer;
Ans:Boolean;
begin
F.Sort := T;
MakeFig(F);
Ans := true;
I := 1;
while (I <= 5)and(Ans) do
begin
P := S + (F.Squares[I] div 10 - F.Squares[1] div 10);
Q := C + (F.Squares[I] mod 10 - F.Squares[1] mod 10);
If (A.Place[P,Q] <> Nil) then
Ans := false;
If (P <= 0) or (P > A.Vertsize) then
Ans := false;
If (Q <= 0) or (Q > A.Horsize) then
Ans := false;
I := I+1
end;
Placible := Ans
end;

Function FindNext(var A:Area; var S,C,P,Q:Integer):Boolean;
var
Ans,More:Boolean;
begin

Ans := false;
More := false;
P := S;
Q := C;
while not(Ans) and not(More) do
begin
If P = A.Vertsize then
If Q<A.HorSize then
begin
P := 1;
Q:=Q+1
end
else
more := true
else
P := P+1;
If not (more) and (A.Place[P,Q] = Nil) then
Ans := true
end;
FindNext := Ans

end;

procedure Put(var A:area; S,C,T,Num:Integer);
var
F:Fig;
I,X,Y:Integer;
begin
F.Sort := T;
MakeFig(F);
For I := 1 to 5 do
begin
X := S + (F.squares[I] div 10 - F.squares[1] div 10);
Y := C + (F.squares[I] mod 10 - F.squares[1] mod 10);
new(A.Place[X,Y]);
A.Place[X,Y]^.FigNum := Num;
A.Place[X,Y]^.SqNum := I
end
end;


procedure DrawCurArea(var A:Area; Col:Integer);
var
I,J,H,V,Size:Integer;
begin
Size := 600 div A.HorSize;
If (350 div A.VertSize) < Size then
Size := 350 div A.VertSize;
For J:=1 to A.Vertsize do
For I:=1 to A.HorSize do
If A.Place[J,I]<>Nil then
begin
If (A.Place[J,I]^.FigNum) mod 2 = 0 then
setfillstyle(1,trunc(7 + (240 / Col) * (A.Place[J,I]^.FigNum)))
else
setfillstyle(1,trunc(247 - (240 / Col) * (A.Place[J,I]^.FigNum)));
bar(20 + (I-1)*Size, 80 + (J-1)*Size, 20 + I*Size, 80 + J*Size )
end
end;

Procedure Remove(var A:Area; S,C,T:integer);
var
F:Fig;
I,P,Q:Integer;
begin
F.Sort := T;
makeFig(F);
P := F.squares[1] div 10;
Q := F.squares[1] mod 10;
For I:=1 to 5 do
begin
Dispose(A.Place[S + (F.Squares[I] div 10 - P),C + (F.Squares[I] mod 10 - Q)]);
A.Place[S + (F.Squares[I] div 10 - P),C + (F.Squares[I] mod 10 - Q)] := Nil
end
end;

procedure GetBounds(var A:Area;var S,C:Integer);
var
I,J:Integer;
Ans:Boolean;
begin
Ans:=true;
J := A.VertSize;
while (J>0)and(Ans) do
begin
I:=1;
while (I<=A.HorSize)and(Ans) do
begin
If A.Place[J,I]<>Nil then
begin
S := J;
Ans:=false
end;
I := I+1
end;
J := J-1
end;
I := A.HorSize;
Ans:=true;
while (I>0)and(Ans) do
begin
J:=1;
while (J<=A.VertSize)and(Ans) do
begin
If A.Place[J,I]<>Nil then
begin
C := I;
Ans:=false
end;
J := J+1
end;
I := I-1
end;
end;

Function AllPlacible(var A:Area; S,C,T:Integer):Boolean;
var
F:Fig;
I,J,P,Q:Integer;
Ans,Ans2:Boolean;
begin
F.Sort := T;
MakeFig(F);
Ans2 := false;
J := 1;
While (J<=5)and(not(Ans2)) do
begin
Ans := true;
I := 1;

while (I <= 5)and(Ans) do
begin
P := S + (F.Squares[I] div 10 - F.Squares[J] div 10);
Q := C + (F.Squares[I] mod 10 - F.Squares[J] mod 10);
If (A.Place[P,Q] <> Nil) then
Ans := false;
If (P <= 0) or (P > A.Vertsize) then
Ans := false;
If (Q <= 0) or (Q > A.Horsize) then
Ans := false;
I := I+1
end;
Ans2 := Ans;
J := J+1
end;
AllPlacible := Ans2
end;


Function Optim1(var A:Area; VertBound,HorBound:Integer):Boolean;
var
Ans,Flag:Boolean;
I,J,T:Integer;
begin
Ans := True;
J := 1;
While (J <= VertBound) and (Ans) do
begin
I := 1;
while (I <= HorBound) and (Ans) do
begin
T:=1;
Flag := false;
While (T <= 8) and not(Flag) do
begin
If (A.Place[J,I] <> Nil)or((AllPlacible(A,J,I,T))) then
Flag := true;
T := T+1
end;
Ans := Flag;
I := I+1
end;
J := J+1
end;
Optim1 := Ans
end;


Function Fill1(var A:Area; S,C,CurFig:Integer):Boolean;

var
Ft,P,K,Q,X,Y,I,Hun,Sec,M,H,Size:Integer;
F:Fig;
Ans:Boolean;
begin
K := 1;
Ans:=false;
ft := 1;
While (Ft < 8)and(not(Exit)) do
begin


If K <> 27 then
begin
F.Sort := Ft;
MakeFig(F);

If Placible(A,S,C,Ft) then
begin
Put(A,S,C,Ft,CurFig);


If Mo then
begin
clrscr;
Writeln('Press ESC to stop');
writeln;
Writeln('Press Space to continue in the Step-by-step mode');
writeln;
writeln;
write(A.Vertsize,'x',A.Horsize,' ');

If ti then
begin
Hun := trunc((CurMom mod 18) /18 *100);
Sec := (CurMom div 18) mod 60;
M := (CurMom div 1080) mod 60;
H := (CurMom div 64800);
write(H:3,':');
If (M mod 10) = M then
write('0');
write(M,':');
If (Sec mod 10) = Sec then
write('0');
write(Sec,':');
If (Hun mod 10) = Hun then
write('0');
writeln(Hun)
end;
writeln;
writeln;
write('Proceed');
For I := 1 to CurFig do
write('.');
If keypressed then
begin
K := ord(readkey);
If K = 27 then
Exit := true;
If K = 32 then
begin
Mo := false;
Ti := false;
setmode(640,480,8)
end
end
end
else
begin
settextjustify(lefttext,centertext);
outtextxy(10,30,'Press any key to continue');
outtextxy(10,50,'Press ESC to stop');
outtextxy(10,70,'Press Space to continue in the fast mode');


Size := 600 div A.HorSize;
If (350 div A.VertSize) < Size then
Size := 350 div A.VertSize;
setfillstyle(1,white);
bar(20,80,20 + A.horsize * Size,80 + A.vertsize * Size);
DrawCurArea(A,(A.HorSize * A.VertSize) div 5);
K := ord(readkey);
If K = 27 then
Exit := true;
If K = 32 then
begin
Mo := true;
closegraph
end
end;

GetBounds(A,Y,X);
If Optim1(A,Y,X) then

If FindNext(A,S,C,P,Q) then
If Fill1(A,P,Q,CurFig+1) then
Ans := true
else
Remove(A,S,C,Ft)
else
Ans := true
else
Remove(A,S,C,Ft)

end

end;

Ft := Ft + 1;

end;

Fill1 := Ans

end;



var
A:pArea;
S,C,State,St,I,J,E,Choice,H,M,Sec,Hun,Size:Integer;
Mode,Menu1,Menu2:Boolean;
way : Char;
SSS : String;
F,Fi : Text;
begin

setmode(640,480,8);
closegraph;

Menu1 := true;
State := 1;

New(A);

While Menu1 do
begin

For I:=1 to 4 do
begin

gotoXY(10,I * 2);
If I = State then
begin
Textbackground(blue);
Textcolor(white);
If I = 1 then
writeln('Input the area size');
If I = 2 then
writeln('Fast mode');
If I = 3 then
writeln('Step-by-Step mode');
If I = 4 then
writeln('Exit')
end
else
begin
Textbackground(black);
Textcolor(white);
If I = 1 then
writeln('Input the area size');
If I = 2 then
writeln('Fast mode');
If I = 3 then
writeln('Step-by-Step mode');
If I = 4 then
writeln('Exit')
end
end;
Textbackground(black);
Textcolor(white);

Choice := ord(readkey);
If Choice = 0 then
begin
Choice := ord(readkey);
If Choice = 72 then
If State = 1 then
State := 4
else State := State - 1
Else
If Choice = 80 then
If State = 4 then
State := 1
else State := State + 1
end
else
If Choice = 13 then
begin
case State of
1: begin
C := -1;
{$I-}

While (IOResult <> 0) or (C <= 0) or (S <= 0) or (C > MaxCols) or (S > MaxRows) or (C*S > 1000) do
begin
clrscr;
Writeln;
If (C > MaxCols) or (S > MaxRows) then
Writeln('Area size should be not more then ',MaxRows,'x',MaxCols);
Writeln;
If (C * S > 1000) then
Writeln('Area square size should be not more then 1000'); Writeln;
writeln('Input the area sizes.');
writeln;
writeln;
writeln;
write(' The first size: ');
ReadLn(S);
write('The second size: ');
ReadLn(C);
end;
{$I+}

If S < C then
begin
A^.Vertsize := S;
A^.HorSize := C
end
else
begin
A^.Vertsize := C;
A^.HorSize := S
end

end;

2: begin


If C <= 0 then
begin
clrscr;
writeln('You should input the sizes at first');
writeln;
writeln;
writeln('Press any key.');
readkey
end
else
begin

For State := 1 to 50 do
For St := 1 to 50 do
(A^.Place[State,St]) := Nil;

State := 1;

Mo := true;
Ti := true;
Exit := false;
startTimer;


If ((A^.HorSize mod 5 = 0)or(A^.VertSize mod 5 = 0))and(Fill1(A^,1,1,1)) then
begin
StopTimer;
If not(Mo) then
begin
setfillstyle(1,black);
bar(0,0,640,80);
outtextXY(40,40,'PRESS ANY KEY');
readkey;
closegraph
end;
clrscr;
If Ti then
begin
Hun := trunc((TimeRes mod 18) /18 *100);
Sec := (TimeRes div 18) mod 60;
M := (TimeRes div 1080) mod 60;
H := (TimeRes div 64800);
write(H:3,':');
If (M mod 10) = M then
write('0');
write(M,':');
If (Sec mod 10) = Sec then
write('0');
write(Sec,':');
If (Hun mod 10) = Hun then
write('0');
write(Hun);
writeln
end;
writeln('The filling is possible.');
writeln;
writeln;
writeln('Press any key.');
readkey;
Way := 'A';
while (Way <> 'y' ) and (Way <> 'Y' ) and (Way <> 'n' ) and (Way <> 'N' ) do
begin
clrscr;
writeln('Show the desigion? (y/n)');
writeln;
Way := readkey
end;
If (Way = 'y') or (Way = 'Y') then
begin
setmode(640,480,8);
settextjustify(lefttext,centertext);
outtextxy(30,30,'Press any key');

Size := 600 div A^.HorSize;
If (350 div A^.VertSize) < Size then
Size := 350 div A^.VertSize;
setfillstyle(1,white);
bar(20,80,20 + A^.horsize * Size,80 + A^.vertsize * Size);
DrawCurArea(A^,(A^.HorSize * A^.VertSize) div 5);
readkey;
closegraph;
end;

Way := 'A';
while (Way <> 'y' ) and (Way <> 'Y' ) and (Way <> 'n' ) and (Way <> 'N' ) do
begin
clrscr;
writeln('Write the result to file? (y/n)');
writeln;
Way := readkey
end;
If (Way = 'y') or (Way = 'Y') then
begin
assign(Fi,'in.txt');
rewrite(Fi);
write(Fi,A^.VertSIze,'x',A^.Horsize,'.txt');
reset(Fi);
read(Fi,SSS);
assign(F,SSS);
rewrite(F);
write(F,A^.VertSIze,'x',A^.Horsize,' ');
If Ti then
begin
Hun := trunc((TimeRes mod 18) /18 *100);
Sec := (TimeRes div 18) mod 60;
M := (TimeRes div 1080) mod 60;
H := (TimeRes div 64800);
write(F,H:3,':');
If (M mod 10) = M then
write(F,'0');
write(F,M,':');
If (Sec mod 10) = Sec then
write(F,'0');
write(F,Sec,':');
If (Hun mod 10) = Hun then
write(F,'0');
write(F,Hun);
writeln(F);
writeln(F)
end;
writeln(F,'The filling is possible.');
writeln(F);
writeln(F);
For J := 1 to A^.HorSize do
begin
For I := 1 to A^.Vertsize do
write(F,A^.Place[I,J]^.FigNum:4,' ');
writeln(F)
end;
close(F);
clrscr;
writeln('The result is put into ',SSS);
writeln;
writeln;
writeln('Press any key');
readkey
end;

end
else
begin
StopTimer;
closegraph;
clrscr;
If Exit then
begin
writeLn('The execution is stopped');
writeln;
writeln;
writeln('Press any key.');
readkey;
clrscr
end
else
begin
If Ti then
begin
Hun := trunc((TimeRes mod 18) /18 *100);
Sec := (TimeRes div 18) mod 60;
M := (TimeRes div 1080) mod 60;
H := (TimeRes div 64800);
write(H:3,':');
If (M mod 10) = M then
write('0');
write(M,':');
If (Sec mod 10) = Sec then
write('0');
write(Sec,':');
If (Hun mod 10) = Hun then
write('0');
write(Hun);
writeln
end;
writeln('The filling is impossible.');
writeln;
writeln;
writeln('Press any key.');
readkey;
Way := 'A';
while (Way <> 'y' ) and (Way <> 'Y' ) and (Way <> 'n' ) and (Way <> 'N' ) do
begin
clrscr;
writeln('Write the result to file? (y/n)');
writeln;
Way := readkey
end;
If (Way = 'y') or (Way = 'Y') then
begin
assign(Fi,'in.txt');
rewrite(Fi);
write(Fi,A^.VertSIze,'x',A^.Horsize,'.txt');
reset(Fi);
read(Fi,SSS);
assign(F,SSS);
rewrite(F);
write(F,A^.VertSIze,'x',A^.Horsize,' ');

writeln(F,'The filling is impossible.');
writeln(F);
writeln(F);
close(F);
clrscr;
writeln('The result is put into ',SSS);
writeln;
writeln;
writeln('Press any key');
readkey
end

end;



end
end

end;

3: begin


If C <= 0 then
begin
clrscr;
writeln('You should input the sizes at first');
writeln;
writeln;
writeln('Press any key.');
readkey
end
else
begin

For State := 1 to 50 do
For St := 1 to 50 do
(A^.Place[State,St]) := Nil;

State := 1;

Mo := false;
Exit := false;
setmode(640,480,8);
If ((A^.HorSize mod 5 = 0)or(A^.VertSize mod 5 = 0))and(Fill1(A^,1,1,1)) then
begin
If not(Mo) then
begin
setfillstyle(1,black);
bar(0,0,640,80);
outtextXY(40,40,'PRESS ANY KEY');
readkey;
closegraph
end;


clrscr;

writeln('The filling is possible.');
writeln;
writeln;
writeln('Press any key.');
readkey;
If Mo then
begin
Way := 'A';
while (Way <> 'y' ) and (Way <> 'Y' ) and (Way <> 'n' ) and (Way <> 'N' ) do
begin
clrscr;
writeln('Show the desigion? (y/n)');
writeln;
Way := readkey
end;
If (Way = 'y') or (Way = 'Y') then
begin
setmode(640,480,8);
settextjustify(lefttext,centertext);
outtextxy(30,30,'Press any key');

Size := 600 div A^.HorSize;
If (350 div A^.VertSize) < Size then
Size := 350 div A^.VertSize;
setfillstyle(1,white);
bar(20,80,20 + A^.horsize * Size,80 + A^.vertsize * Size);
DrawCurArea(A^,(A^.HorSize * A^.VertSize) div 5);
readkey;
closegraph;
end
end;
Way := 'A';
while (Way <> 'y' ) and (Way <> 'Y' ) and (Way <> 'n' ) and (Way <> 'N' ) do
begin
clrscr;
writeln('Write the result to file? (y/n)');
writeln;
Way := readkey
end;
If (Way = 'y') or (Way = 'Y') then
begin
assign(Fi,'in.txt');
rewrite(Fi);
write(Fi,A^.VertSIze,'x',A^.Horsize,'.txt');
reset(Fi);
read(Fi,SSS);
assign(F,SSS);
rewrite(F);
write(F,A^.VertSIze,'x',A^.Horsize,' ');

writeln(F,'The filling is possible.');
writeln(F);
writeln(F);
For J := 1 to A^.HorSize do
begin
For I := 1 to A^.Vertsize do
write(F,A^.Place[I,J]^.FigNum:4,' ');
writeln(F)
end;
close(F);
clrscr;
writeln('The result is put into ',SSS);
writeln;
writeln;
writeln('Press any key');
readkey
end;
end
else
begin
closegraph;
clrscr;
If Exit then
begin
writeLn('The execution is stopped');
writeln;
writeln;
writeln('Press any key.');
readkey;
clrscr
end
else
begin
writeln('The filling is impossible.');
writeln;
writeln;
writeln('Press any key.');
readkey;
Way := 'A';
while (Way <> 'y' ) and (Way <> 'Y' ) and (Way <> 'n' ) and (Way <> 'N' ) do
begin
clrscr;
writeln('Write the result to file? (y/n)');
writeln;
Way := readkey
end;
If (Way = 'y') or (Way = 'Y') then
begin
assign(Fi,'in.txt');
rewrite(Fi);
write(Fi,A^.VertSIze,'x',A^.Horsize,'.txt');
reset(Fi);
read(Fi,SSS);
assign(F,SSS);
rewrite(F);
write(F,A^.VertSIze,'x',A^.Horsize,' ');

writeln(F,'The filling is impossible.');
writeln(F);
writeln(F);
close(F);
clrscr;
writeln('The result is put into ',SSS);
writeln;
writeln;
writeln('Press any key');
readkey
end

end
end

end
end;


4: begin
Menu1:=false
end;
end
end;
clrscr
end

end.