Даулеткулов А.Б. Олимпиады по информатике: Учебно-методическое пособие
Подождите немного. Документ загружается.
61
Pole[Y+1,X].St:=’0';
Pole[Y+1,X].Num:=255;
End;
End;
Man[i].X:=X;
Man[i].Y:=Y;
End;
End;
Begin
clrscr;
Load;
Clrscr;
Test(0);
ClrScr;
Pole:=PoleS;
TextColor(Red);
Print;
End.
8. Ручей Моно
Program Ruchei_Mono;
Uses Crt,Dos;
Const
MaxN=50;
MaxM=15;
Type
TypeM=Array[1..MaxM+1,1..3,1..2] of Byte;
TypeN=Array[1..MaxN] of Record
M:TypeM;
NumM:Byte;
End;
Var
N:TypeN;
NumN:Byte;
S:Integer;
SavH1,
SavH:Array[1..MaxM,1..2] of Byte;
L,LS:Byte;
T,TMin:Real;
Victory:Boolean;
Found:Boolean;
NumU,NumMinU:Byte;
Procedure Test(K:Byte);
Var
i,j:Byte;
T0:real;
Begin
for i:=1 to 3 do
62
Begin
Inc(NumMinU);
for j:=N[L].M[K,i,1] downto 1 do
if ((S-J+1)>0) then
Begin
S:=S-J;T0:=J/N[L].M[K,i,2];
T:=T+T0;
SavH[K,1]:=J;
SavH[K,2]:=N[L].M[K,i,2];
if (S=0) and (T<Tmin) then
Begin
Sound(500);
Tmin:=T;
SavH1:=SavH;
Found:=True;
Delay(100);
NoSound;
NumMinU:=NumU;
End else if (S>0) and (K<N[L].NumM) and (T<Tmin) and (NumU<NumMinU) then Test(K+1);
T:=T-T0;
FillChar(SavH[K],2,0);
S:=S+j;
End;
Dec(NumU);
SavH[K][1]:=0;
SavH[K][2]:=0;
if (K<N[L].NumM) then Test(K+1);
End;
End;
Procedure Test1(K:Byte);
var
T0:Real;
i:Byte;
Begin
for i:=1 to 3 do
Begin
if (N[L].M[K,i,1]>S) then
Begin
T0:=S/N[L].M[K,I,2];
SavH[K][1]:=S;
SavH[K][2]:=N[L].M[K,i,2];
if (TMin>T+T0) then
Begin
Found:=True;
Sound(500);
Tmin:=T+T0;
SavH1:=SavH;
Delay(100);
NoSound;
63
End;
FillChar(SavH[K],2,0);
End
else
Begin
S:=S-N[L].M[K,i,1];
T0:=N[L].M[K,i,1]/N[L].M[K,I,2];
T:=T+T0;
SavH[K][1]:=N[L].M[K,i,1];
SavH[K][2]:=N[L].M[K,i,2];
if (K<N[L].NumM) and (T<Tmin) then Test1(K+1);
T:=T-T0;
FillChar(SavH[K],2,0);
S:=S+N[L].M[K,i,1];
End;
End;
End;
Procedure TestStart;
Var
i,j,k,l:Byte;
Obmen:Array[1..2] of Byte;
Begin
for i:=1 to NumN do
for J:=1 to N[i].NumM do
Begin
for L:=1 to 2 do
for K:=L+1 to 3 do
if N[i].M[j,l,2]<N[i].M[j,k,2] then
Begin
Obmen[2]:=N[i].M[j,k,2];
Obmen[1]:=N[i].M[j,k,1];
N[i].M[j,k]:=N[i].M[j,l];
N[i].M[j,l,1]:=Obmen[1];
N[i].M[j,l,2]:=Obmen[2];
End;
End;
for i:=1 to NumN do
Begin
for L:=1 to N[i].NumM-1 do
for K:=L+1 to N[i].NumM do
if N[i].M[L,1,2]<N[i].M[K,1,2] then
Begin
N[i].M[N[i].NumM+1]:=N[i].M[l];
N[i].M[L]:=N[i].M[K];
N[i].M[K]:=N[i].M[N[i].NumM+1];
End;
End;
End;
64
Procedure Load;
Var
F:Text;
Name:String;
i,j:Byte;
Buf:String;
IOs:Integer;
Begin
clrscr;
write(“Enter FileName:”);Readln(Name);
write(“File Read -”);
Assign(F,Name);
Reset(F);
Readln(F,NumN);
for i:=1 to NumN do
Begin
Readln(F,N[i].NumM);
for j:=1 to N[i].NumM do
Begin
Readln(F,Buf);
Val(Copy(Buf,1,Pos(“,”,Buf)-1),N[i].M[J,1,1],IOs);
Delete(Buf,1,Pos(“,”,Buf));
Val(Copy(Buf,1,Pos(“,”,Buf)-1),N[i].M[j,1,2],IOs);
Delete(Buf,1,Pos(“,”,Buf));
Val(Copy(Buf,1,Pos(“,”,Buf)-1),N[i].M[j,2,1],IOs);
Delete(Buf,1,Pos(“,”,Buf));
Val(Copy(Buf,1,Pos(“,”,Buf)-1),N[i].M[j,2,2],IOs);
Delete(Buf,1,Pos(“,”,Buf));
Val(Copy(Buf,1,Pos(“,”,Buf)-1),N[i].M[j,3,1],IOs);
Delete(Buf,1,Pos(“,”,Buf));
Val(Buf,N[i].M[j,3,2],IOs);
End;
End;
Readln(F,S);
Close(F);
TestStart;
Writeln(“Ok”);
End;
Procedure Save;
Var
I:Byte;
F:Text;
Name:String;
Begin
clrscr;
write(“Enter FileName:”);Readln(Name);
Assign(F,Name);
Rewrite(F);
if Victory then
65
Begin
writeln(F,LS);
For I:=1 to N[LS].NumM do
writeln(F,I,’,’,SavH1[i][1],’,’,SavH1[i][2]);
End else write(F,’Net Reshenia’);
Close(F);
end;
Begin
Load;
L:=1;
Ls:=0;
Tmin:=999;
Victory:=False;
for L:=1 to NumN do
Begin
NumMinU:=30;
NumU:=0;
writeln(“NumL=”,L);
FillChar(SavH,SizeOF(SavH),0);
T:=0;
Found:=False;
Test1(1);
if Found then
Begin
lS:=L;
Victory:=True;
End;
End;
Save;
End.
9. Приключения в королевстве Ном
program doroty;
uses crt;
const
Wall = -1;
var
Lab: array[1..50,0..21,0..31] of shortint;
Lines,Columns,LabNum,L0,C0: byte;
procedure Init;
var
MyLab: array[1..5,0..21,0..31] of shortint;
LabOrder: array[1..10] of byte;
f: text;
infile,tempstr: string;
IOError,i,j,l: integer;
begin
66
clrscr;
FillChar(MyLab,SizeOf(MyLab),$FF);
readln(infile);
assign(f,infile);
reset(f);
readln(f,tempstr);
Val(Copy(tempstr,1,Pos(“,”,tempstr)-1),Lines,IOError);
Delete(tempstr,1,Pos(“,”,tempstr));
Val(Copy(tempstr,1,Pos(“,”,tempstr)-1),Columns,IOError);
Delete(tempstr,1,Pos(“,”,tempstr));
Val(tempstr,LabNum,IOError);
for i:=1 to LabNum do
for j:=1 to Lines do
begin
readln(f,tempstr);
for l:=1 to Columns do
if tempstr[l]=’1' then
MyLab[i,j,l]:=Wall
else
MyLab[i,j,l]:=0;
end;
readln(f,tempstr);
Val(Copy(tempstr,1,Pos(“,”,tempstr)-1),L0,IOError);
Delete(tempstr,1,Pos(“,”,tempstr));
Val(tempstr,C0,IOError);
readln(f,tempstr);
for i:=1 to 9 do
begin
Val(Copy(tempstr,1,Pos(“,”,tempstr)-1),LabOrder[i],IOError);
Delete(tempstr,1,Pos(“,”,tempstr));
end;
Val(tempstr,LabOrder[10],IOError);
close(f);
for i:=1 to 10 do
for j:=1 to 5 do
Move(MyLab[LabOrder[i]],Lab[(i-1)*5+j],SizeOf(Lab) div 50);
end;
procedure Run;
const
Turn: array[1..5,1..2] of shortint =
((-1,0),(0,1),(1,0),(0,-1),(0,0));
type TQueuePointer = ^TQueueMember;
TQueueMember = record
l,c,s: byte;
Next: TQueuePointer;
end;
TPoint = record
l,c: byte;
67
end;
var
ReadIndex,WriteIndex: TQueuePointer;
l,c,s,i,StepNum: byte;
FoundExit: boolean;
ExitArr: array[1..50] of TPoint;
procedure WriteToQueue(s,l,c:byte);
var
x: TQueuePointer;
begin
New(x);
Lab[s,l,c]:=1;
x^.l:=l;
x^.c:=c;
x^.s:=s;
x^.Next:=nil;
if WriteIndex<>nil then
WriteIndex^.Next:=x
else
ReadIndex:=x;
WriteIndex:=x;
end;
procedure ReadFromQueue(var s,l,c:byte);
var
x: TQueuePointer;
begin
l:=ReadIndex^.l;
c:=ReadIndex^.c;
s:=ReadIndex^.s;
x:=ReadIndex;
ReadIndex:=ReadIndex^.Next;
if ReadIndex=nil then
WriteIndex:=nil;
Dispose(x);
end;
procedure DrawLab(s:byte);
var
i,j: byte;
begin
clrscr;
for i:=1 to Lines do
for j:=1 to Columns do
if Lab[s,i,j]=Wall then
begin
gotoxy(j*2,i);
write(“*”);
end;
end;
68
begin (* procedure Run *)
DrawLab(1);
gotoxy(C0*2,L0);
write(“X”);
New(WriteIndex);
WriteIndex^.s:=0;
WriteIndex^.l:=L0;
WriteIndex^.c:=C0;
WriteIndex^.Next:=nil;
ReadIndex:=WriteIndex;
while ReadIndex<>nil do
begin
ReadFromQueue(s,l,c);
if (l in [1,Lines]) or (c in [1,Columns]) then
begin
(* save exit and quit *)
FoundExit:=true;
StepNum:=s;
while s>=1 do
begin
ExitArr[s].l:=l;
ExitArr[s].c:=c;
s:=s-1;
for i:=1 to 5 do
if Lab[s,l+Turn[i,1],c+Turn[i,2]]=1 then
begin
l:=l+Turn[i,1];
c:=c+Turn[i,2];
break;
end;
end;
for i:=1 to StepNum do
begin
if ((i mod 5)=1) and (i<>1) then
DrawLab(i);
gotoxy(ExitArr[i].c*2,ExitArr[i].l);
write(i);
Delay(2000);
end;
halt;
end;
if s<>50 then
for i:=1 to 5 do
if Lab[s+1,l+Turn[i,1],c+Turn[i,2]]=0 then
WriteToQueue(s+1,l+Turn[i,1],c+Turn[i,2]);
end;
end; (* procedure Run *)
69
begin
Init;
Run;
end.
10. Сфера
Program Sfer;
var
k,r:extended;
procedure init;
begin
write(“Введите радиус:”);
readln(r);
end;
procedure run;
label qqq;
var
rk,xk,yk,zk,x1,y1,z:extended;
x,y:integer;
begin
k:=0;
rk:=r*r;
for x:=1 to round(r) do begin
for y:=1 to round(r) do begin
x1:=x;y1:=y;
xk:=x1*x1;yk:=y1*y1;
if (rk-xk-yk<0) then goto qqq;
z:=sqrt(rk-xk-yk);
z:=round(int(z));
zk:=z*z;
if (xk+yk+zk)<=rk then k:=k+z;
qqq:
end;
end;
end;
procedure done;
begin
writeln(“Кол-во кубиков=”,k*8:0:0);
end;
BEGIN
init;
run;
done;
END.
11. Треугольник
Program treugoln;
70
var
n,m:integer;
number:string;
otv:array [1..4] of real;
a,b:array [1..10000,1..2] of shortint;
procedure init;
var
i,j:integer;
k,l:shortint;
f:text;
begin
write(“Введите номер теста:”);
readln(number);
assign(f,’test’+number+’.txt’);
reset(f);
n:=1;
while not eof(f) do begin
readln(f,a[n,1],a[n,2]);
inc(n);
end;
dec(n);
close(f);
for i:=1 to n-1 do begin
for j:=i+1 to n do begin
if a[i,2]>a[j,2] then begin
k:=a[i,1];
l:=a[i,2];
a[i,1]:=a[j,1];
a[i,2]:=a[j,2];
a[j,1]:=k;
a[j,2]:=l;
end;
end;
end;
end;
procedure postroenie;
label lb,lb1;
var
mnog:boolean;
znak1,znak:integer;
a1,b1,c1:integer;
num,max:shortint;
i1,i,j:integer;
begin
num:=1;
max:=a[1,1];
for i:=2 to n do if max<a[i,1] then begin
max:=a[i,1];
num:=i;