Даулеткулов А.Б. Олимпиады по информатике: Учебно-методическое пособие
Подождите немного. Документ загружается.
81
Txy[2].N:=Xy.N;Txy[2].M:=xy.M+1;
Txy[3].N:=Xy.N-1;Txy[3].M:=xy.M;
Txy[4].N:=Xy.N;Txy[4].M:=xy.M-1;
Txy[5].N:=Xy.N+1;Txy[5].M:=xy.M+1;
Txy[6].N:=Xy.N-1;Txy[6].M:=xy.M+1;
Txy[7].N:=Xy.N-1;Txy[7].M:=xy.M-1;
Txy[8].N:=Xy.N+1;Txy[8].M:=xy.M-1;
for it:=1 to 8 do
if (Txy[it].N<0) or (Txy[it].M<0) or
(Txy[it].N>N) or (Txy[it].M>M) then
Begin
Txy[it].N:=-1;
Txy[it].M:=-1;
End;
End;
Begin
Xy.N:=Nman;
Xy.M:=MmaN;
OpenList(Top);
Mat[xy.M,Xy.N].Status:=3;
Mat[Xy.M,Xy.N].Sum:=1;
for i:=0 to M do
for j:=0 to N do
Begin
gotoxy(i+1,j+1);
write(Mat[i,j].Status);
end;
for i1:=1 to K do
Begin
for i:=0 to M do
for j:=0 to N do
Begin
gotoxy(i+1+M+2,j+1);
write(Mat1[i1,i,j]);
end;
delay(100);
End;
Start:
TestHod(Xy,Txy);
For i:=1 to 4 do
if (Txy[i].N>=0) and (Txy[i].M>=0) then
Begin
Flag:=1;
for i1:=1 to K do
if Mat1[i1,Txy[i].M,Txy[i].N]>0 then Flag:=0;
if (Flag=1) and (Mat[Txy[i].M,Txy[i].N].Status=0) then
Begin
Mat[Txy[i].M,Txy[i].N].Mo:=Xy.M;
Mat[Txy[i].M,Txy[i].N].No:=Xy.N;
82
Mat[txy[i].M,Txy[i].N].Sum:=Mat[xy.M,xy.N].Sum+1;
Mat[txy[i].M,Txy[i].N].Status:=3;
PushRight(Top,Txy[i],Ok);
gotoxy(txy[i].M+1,Txy[i].N+1);
textcolor(blue);
write(chr(1));
End;
End;
For i:=1 to 4 do Txy1[i]:=Txy[i];
txy1[5]:=Txy1[1];
for i:=1 to 4 do
if (Txy[i+4].N>=0) and (Txy[i+4].M>=0) then
Begin
flag:=1;
for i1:=1 to K do
Begin
if (Txy1[i+1].N>-1) and
(Txy1[i].M>-1) and
(Mat1[i1,txy1[i].M,Txy1[i].N]=Mat1[i1,txy1[i+1].M,Txy1[i+1].N]) and
(Mat1[i1,txy1[i].M,Txy1[i].N]>0) then Flag:=0;
End;
if (Mat[txy[i+4].M,Txy[i+4].N].Status=0) and (Flag=1) then
Begin
Mat[Txy[i+4].M,Txy[i+4].N].Mo:=Xy.M;
Mat[Txy[i+4].M,Txy[i+4].N].No:=Xy.N;
Mat[txy[i+4].M,Txy[i+4].N].Sum:=Mat[xy.M,xy.N].Sum+1;
Mat[txy[i+4].M,Txy[i+4].N].Status:=3;
PushRight(Top,Txy[i+4],Ok);
textcolor(red);
gotoxy(txy[i+4].M+1,Txy[i+4].N+1);
write(chr(1));
End;
End;
PopLeft(top,Xy,Ok);
if Ok=true then goto Start;
End;
Procedure BacKTrace;
Var
i,j:Integer;
SumF:Integer;
Flag:Integer;
Back,Back1:TypeInfo;
Top:TypeTop;
Txy:typeTxy;
ok:Boolean;
Name:String;
F:text;
Procedure TestHod( xy : TypeInfo;
var Txy:typeTxy);
83
Var
It:integer;
Begin
Txy[1].N:=Xy.N+1;Txy[1].M:=xy.M;
Txy[2].N:=Xy.N-1;Txy[2].M:=xy.M;
Txy[3].N:=Xy.N;Txy[3].M:=xy.M+1;
Txy[4].N:=Xy.N;Txy[4].M:=xy.M-1;
Txy[5].N:=Xy.N+1;Txy[5].M:=xy.M-1;
Txy[6].N:=Xy.N-1;Txy[6].M:=xy.M-1;
Txy[7].N:=Xy.N+1;Txy[7].M:=xy.M+1;
Txy[8].N:=Xy.N-1;Txy[8].M:=xy.M+1;
for it:=1 to 8 do
if (Txy[it].N<0) or (Txy[it].M<0) or
(Txy[it].N>N) or (Txy[it].M>M) then
Begin
Txy[it].N:=-1;
Txy[it].M:=-1;
End;
End;
Begin
SumF:=1000;
Flag:=0;
for i:=0 to M do
Begin
If (Mat[i,0].Sum<SumF) and (Mat[i,0].Sum<>0) then
Begin
flag:=1;
SumF:=Mat[i,0].Sum;
Back.M:=I;
Back.N:=0;
End;
If (Mat[i,N].Sum<SumF) and (Mat[i,n].Sum<>0)then
Begin
flag:=1;
SumF:=Mat[i,N].Sum;
Back.M:=I;
Back.N:=N;
End;
End;
for i:=0 to N do
Begin
If (Mat[0,i].Sum<SumF) and (MAt[0,i].Sum<>0) then
Begin
flag:=1;
SumF:=Mat[0,i].Sum;
Back.M:=0;
Back.N:=i;
End;
If (Mat[M,i].Sum<SumF) and (mat[M,I].SUm<>0) then
84
Begin
flag:=1;
SumF:=Mat[M,i].Sum;
Back.M:=M;
Back.N:=I;
End;
End;
Name:=’3ANS’+NumFile+’.Txt’;
Assign(F,Name);
Rewrite(F);
if Flag=0 then
Begin
write(Нет решения’);
Close(F);
Halt;
End;
Writeln(F,Mat[Back.M,Back.N].Sum-1);
OpenList(top);
PushRight(Top,Back,ok);
Back1:=Back;
textcolor(Green);
gotoxy(Back.M+1,Back.N+1);
write(chr(3));
repeat
Back.N:=Mat[Back1.M,Back1.N].No;
Back.M:=Mat[Back1.M,Back1.N].Mo;
Back1:=Back;
PushRight(top,Back,ok);
gotoxy(Back.M+1,Back.N+1);
write(chr(3));
Until (Back1.N=Nman) and (Back1.M=Mman);
for i:=Top.Heap-1 Downto 1 do
Begin
write(F,Top.List[i].N);
Write(F,’,’);
writeln(f,Top.List[i].M);
End;
close(F);
End;
Begin
LoadFile;
Test;
BacKTrace;
End.
15. Головоломка Уитикера
85
Program Zad15;
var
hod:byte;
vyh:boolean;
z:string;
n,m:byte;
otv:array [0..100,1..3] of byte;
a,b:array [1..10,1..10] of byte;
procedure init;
var
s:string;
q,code:integer;
f:text;
i,j:byte;
c:char;
begin
write(“Введите номер теста:”);
readln(z);
assign(f,’test’+z+’.txt’);
reset(f);
readln(f,s);
q:=pos(“,”,s);
val(copy(s,1,q-1),n,code);
val(copy(s,q+1,length(s)-q),m,code);
for i:=1 to n do begin
for j:=1 to m do begin
read(f,c);
s:=c;
val(s,a[i,j],code);
if a[i,j]=3 then a[i,j]:=99;
if a[i,j]=2 then begin
otv[0,2]:=i;
otv[0,3]:=j;
end;
end;
read(f,c);
read(f,c);
end;
close(f);
end;
procedure run;
label lb1;
var
i1,j1,q,i,j:byte;
function change:boolean;
label lb;
var
86
w:boolean;
i,j:byte;
begin
w:=false;
for i:=1 to n do begin
for j:=1 to m do begin
if a[i,j]<>b[i,j] then begin
w:=true;
goto lb;
end;
end;
end;
lb:
change:=w;
end;
begin
vyh:=false;
q:=2;
b:=a;
b[1,1]:=23;
while ((not vyh) and (change)) do begin
b:=a;
for i:=1 to n do begin
for j:=1 to m do begin
if a[i,j]=q then begin
for i1:=i+1 to n do begin
if a[i1,j]<>0 then begin
if a[i1,j]=99 then begin
vyh:=true;
goto lb1;
end else
if a[i1,j]=1 then begin
if ((i1<>i+1) and (a[i1-1,j]=0)) then a[i1-1,j]:=q+1;
i1:=n;
end;
end;
end;
for i1:=i-1 downto 1 do begin
if a[i1,j]<>0 then begin
if a[i1,j]=99 then begin
vyh:=true;
goto lb1;
end else
if a[i1,j]=1 then begin
if ((i1<>i-1) and (a[i1+1,j]=0)) thena[i1+1,j]:=q+1;
i1:=1;
end;
end;
end;
87
for j1:=j+1 to m do begin
if a[i,j1]<>0 then begin
if a[i,j1]=99 then begin
vyh:=true;
goto lb1;
end else
if a[i,j1]=1 then begin
if ((j1<>j+1) and (a[i,j1-1]=0)) then a[i,j1-1]:=q+1;
j1:=m;
end;
end;
end;
for j1:=j-1 downto 1 do begin
if a[i,j1]<>0 then begin
if a[i,j1]=99 then begin
vyh:=true;
goto lb1;
end else
if a[i,j1]=1 then begin
if ((j1<>j-1) and (a[i,j1+1]=0)) then a[i,j1+1]:=q+1;
j1:=1;
end;
end;
end;
end;
end;
end;
lb1:
inc(q);
end;
hod:=q;
end;
procedure done;
label lb2,lb3;
var
w:boolean;
q,i,j,i1,j1:byte;
f:text;
begin
assign(f,’ans’+z+’.txt’);
rewrite(f);
if not vyh then begin
writeln(f,’Нет решения’);
close(f);
halt(1);
end;
for i:=1 to n do begin
for j:=1 to m do begin
if a[i,j]=hod then a[i,j]:=0;
88
end;
end;
for i:=1 to n do begin
for j:=1 to m do begin
if a[i,j]=99 then a[i,j]:=hod;
end;
end;
q:=hod-1;
while q>=3 do begin
w:=false;
for i:=1 to n do begin
for j:=1 to m do begin
if a[i,j]=q then begin
if w then begin
a[i,j]:=0;
goto lb2;
end;
for i1:=i+1 to n do begin
if a[i1,j]<>0 then begin
if a[i1,j]=q+1 then begin
w:=true;
end;
i1:=n;
end;
end;
for i1:=i-1 downto 1 do begin
if a[i1,j]<>0 then begin
if a[i1,j]=q+1 then begin
w:=true;
end;
i1:=1;
end;
end;
for j1:=j+1 to m do begin
if a[i,j1]<>0 then begin
if a[i,j1]=q+1 then begin
w:=true;
end;
j1:=m;
end;
end;
for j1:=j-1 downto 1 do begin
if a[i,j1]<>0 then begin
if a[i,j1]=q+1 then begin
w:=true;
end;
j1:=1;
end;
end;
89
if not w then a[i,j]:=0;
end;
lb2:
end;
end;
dec(q);
end;
writeln(f,hod-2);
for q:=1 to hod-2 do begin
for i:=1 to n do begin
for j:=1 to m do begin
if a[i,j]=q+2 then begin
otv[q,2]:=i;
otv[q,3]:=j;
goto lb3;
end;
end;
end;
lb3:
end;
for q:=1 to hod-2 do begin
if otv[q,2]<otv[q-1,2] then otv[q,1]:=1;
if otv[q,2]>otv[q-1,2] then otv[q,1]:=3;
if otv[q,3]<otv[q-1,3] then otv[q,1]:=4;
if otv[q,3]>otv[q-1,3] then otv[q,1]:=2;
end;
for q:=1 to hod-2 do begin
writeln(f,otv[q,1],’,’,otv[q,2],’,’,otv[q,3]);
end;
close(f);
end;
BEGIN
init;
run;
done;
END.
16. Ловись рыбка большая и маленькая
{$N+}
program fish;
type restrict = record
x,y,lx,ly:single;
end;
NetPoint = record
x,y:single;
IsGoodPoint:boolean;
end;
90
var M,N,S1,S2,BigS: single;
K,i,num,BytesRead: integer;
KA: array[1..100] of restrict;
f: text;
f1,f2: file;
TempStr: array[1..1000] of char;
numstr: string;
NetArr: array[1..202,1..202] of boolean;
INetArr,JNetArr: array[1..202] of single;
MaxI,MaxJ: integer;
function FindS1:single;
var
i,j: integer;
x: single;
begin
x:=0;
for i:=1 to MaxI-1 do
for j:=1 to MaxJ-1 do
if NetArr[i,j]=true then
x:=x+(INetArr[i+1]-INetArr[i])*(JNetArr[j+1]-JNetArr[j]);
FindS1:=x;
end;
procedure CheckPoint(i,j:integer);
begin
NetArr[i,j]:=false;
BigS:=BigS+(INetArr[i+1]-INetArr[i])*(JNetArr[j+1]-JNetArr[j]);
if ((j-1) in [1..MaxJ-1]) and NetArr[i,j-1] then
CheckPoint(i,j-1);
if ((i+1) in [1..MaxI-1]) and NetArr[i+1,j] then
CheckPoint(i+1,j);
if ((j+1) in [1..MaxJ-1]) and NetArr[i,j+1] then
CheckPoint(i,j+1);
if ((i-1) in [1..MaxI-1]) and NetArr[i-1,j] then
CheckPoint(i-1,j);
end;
function FindS2:single;
begin
BigS:=0;
if NetArr[1,1] then
CheckPoint(1,1);
FindS2:=BigS;
end;
procedure InsertVerLine(x:single;a:integer);
var i,j: integer;
begin
for i:=MaxI downto a do
INetArr[i+1]:=INetArr[i];
INetArr[a]:=x;
for i:=MaxI-1 downto a-1 do