Задача 1. "Автобусные маршруты" (42 балла)
program BusWays;
uses
Crt;
{-------------------------------------------------------------------}
function IntToStr(a: Integer): string;
var
s: string;
begin
Str(a, s);
IntToStr := s;
end;
function StrToInt(s: string): Integer;
var
a, vc: Integer;
begin
Val(s, a, vc);
StrToInt := a;
end;
function FileDir(FullFileName: string): string;
var
i: Integer;
begin
i:=Length(FullFileName);
repeat
i:=i-1;
until FullFileName[i]='\';
FileDir := Copy(FullFileName,1,i)
end;
{------------------------- Bits routines ---------------------------------}
procedure SetBit(var b: Byte; i: Byte; Value: Byte); { count from left to right }
var
k, p: Byte;
begin
p := 128 shr (i - 1);
if Value = 1 then b := b or p
else b := b and (255 - p);
end;
function GetBit(b, i: Byte): Byte; { count from left to right }
var
k, p: Byte;
begin
p := 128 shr (i - 1);
GetBit := Ord(b and p = p);
end;
function Min(a, b: LongInt): Integer;
begin
if a <= b then Min := a
else Min := b;
end;
{-------------------------------------------------------------------}
const
MaxN = 100; { Bus ways max. count }
MaxM = 200; { Squares max. count }
MaxK = 1000; { Bus way max. length }
GrafSize = MaxM div 8 + 1;
MaxLinesCount = MaxM * (MaxM - 1);
type
TByteCell = array [1..8] of Byte;
TGraf = array [1..GrafSize, 1..GrafSize] of TByteCell; { Graf matrix }
TDots = array [1..GrafSize] of Byte;
TPath = array [1..MaxLinesCount] of Byte;
var
Graf: TGraf;
Path: TPath;
N, M: Integer;
PathLength: LongInt;
{------------------------------ Graf rotines --------------------------------}
procedure SetVal(var Graf: TGraf; i, j: Integer; Value: Byte);
var
a, b, a1, b1: Integer;
v: Byte;
Cell: TByteCell;
begin
a := i div 8 + 1; a1 := i mod 8;
b := j div 8 + 1; b1 := j mod 8;
if a1 = 0 then begin
a1 := 8; Dec(a);
end;
if b1 = 0 then begin
b1 := 8; Dec(b);
end;
Cell := Graf[a, b];
SetBit(Cell[a1], b1, Value);
Graf[a, b] := Cell;
end;
function GetVal(var Graf: TGraf; i, j: Integer): Byte;
var
a, b, a1, b1: Integer;
v: Byte;
Cell: TByteCell;
begin
a := i div 8 + 1; a1 := i mod 8;
b := j div 8 + 1; b1 := j mod 8;
if a1 = 0 then begin
a1 := 8; Dec(a);
end;
if b1 = 0 then begin
b1 := 8; Dec(b);
end;
Cell := Graf[a, b];
GetVal := GetBit(Cell[a1], b1);
end;
procedure SetDotVal(var Dots: TDots; i: Integer; Value: Byte);
var
a, a1: Integer;
begin
a := i div 8 + 1; a1 := i mod 8;
if a1 = 0 then begin
a1 := 8; Dec(a);
end;
SetBit(Dots[a], a1, Value);
end;
function GetDotVal(var Dots: TDots; i: Integer): Byte;
var
a, a1: Integer;
begin
a := i div 8 + 1; a1 := i mod 8;
if a1 = 0 then begin
a1 := 8; Dec(a);
end;
GetDotVal := GetBit(Dots[a], a1);
end;
function IsEmpty: Boolean;
var
i, j, k, m1: Integer;
Cell: TByteCell;
begin
IsEmpty := False;
m1 := M div 8 + 1;
for i := 1 to m1 do
for j := 1 to m1 do begin
Cell := Graf[i, j];
for k := 1 to 8 do
if Cell[k] <> 0 then Exit;
end;
IsEmpty := True;
end;
procedure ClearDots(var Dots: TDots);
var
i: Integer;
begin
for i := 1 to M div 8 + 1 do
Dots[i] := 0;
end;
procedure ClearGraf;
var
i, j, k: Integer;
Cell: TByteCell;
begin
for i := 1 to M div 8 + 1 do
for j := 1 to M div 8 + 1 do begin
Cell := Graf[i, j];
for k := 1 to 8 do
Cell[k] := 0;
Graf[i, j] := Cell;
end;
end;
procedure FillGraf(FileName: string);
var
f: Text;
i, j, a, a1, k: Integer;
begin
Assign(f, FileName);
ReSet(f);
M := 0;
ReadLn(f, N);
for i := 1 to N do begin
Read(f, k);
a1 := 0;
for j := 1 to k + 1 do begin
Read(f, a);
if M < a then M := a;
if a1 <> 0 then SetVal(Graf, a1, a, 1);
a1 := a;
end;
ReadLn(f);
end;
Close(f);
end;
function Pow(i: Integer): Integer;
var
p, j: Integer;
begin
P := 0;
for j := 1 to M do
P := P + GetVal(Graf, i, j) - GetVal(Graf, j, i);
Pow := p;
end;
function Check: Boolean;
var
i, p: Integer;
begin
Check := False;
for i := 1 to M do
if Pow(i) <> 0 then Exit;
Check := True;
end;
{--------------------------- debug routines ------------------------------}
procedure LoadGraf(FileName: string);
var
f: Text;
a: Byte;
i, j: Integer;
begin
Assign(f, FileName);
ReSet(f);
i := 0;
while not EoF(f) do begin
Inc(i);
j := 0;
while not EoLn(f) do begin
Read(f, a);
Inc(j);
SetVal(Graf, i, j, a);
end;
ReadLn(f);
end;
Close(f);
M := i;
end;
procedure SaveGraf(FileName: string);
var
f: Text;
a: Byte;
i, j: Integer;
begin
if FileName <> '' then begin
Assign(f, FileName);
ReWrite(f);
for i := 1 to M do begin
for j := 1 to M do
Write(f, GetVal(Graf, i, j));
WriteLn(f);
end;
Close(f);
end
else
for i := 1 to M do
for j := 1 to M do begin
GotoXY(j, i);
Write(GetVal(Graf, i, j));
end;
end;
procedure SaveDots(var Dots: TDots; FileName: string);
var
f: Text;
a: Byte;
i, j: Integer;
begin
if FileName <> '' then begin
Assign(f, FileName);
ReWrite(f);
for i := 1 to M do
Write(f, GetDotVal(Dots, i));
Close(f);
end
else
for i := 1 to M do begin
GotoXY(i, 1);
Write(GetDotVal(Dots, i));
end;
end;
{----------------------------- process -----------------------------}
function WideSearchStep(var Dots: TDots): Boolean;
var
i, j: Integer;
StartDots: TDots;
begin
WideSearchStep := False;
StartDots := Dots;
for i := 1 to M do
if GetDotVal(StartDots, i) = 1 then
for j := 1 to M do
if (GetVal(Graf, i, j) = 1) or (GetVal(Graf, j, i) = 1) then
if GetDotVal(Dots, j) = 0 then begin
WideSearchStep := True;
SetDotVal(Dots, j, 1);
end;
end;
function DotsAreLinked(i, j: Integer): Boolean;
var
Dots1, Dots2: TDots;
c1, c2: Boolean;
function EqualDotsExists: Boolean;
var
i: Integer;
begin
EqualDotsExists := True;
for i := 1 to M div 8 + 1 do
if Dots1[i] and Dots2[i] <> 0 then Exit;
EqualDotsExists := False;
end;
function IsIsol(i: Integer): Boolean;
var
j, k, a, a1: Integer;
Cell1, Cell2: TByteCell;
begin
IsIsol := False;
a := i div 8 + 1; a1 := i mod 8;
if a1 = 0 then Dec(a);
for j := 1 to M div 8 + 1 do begin
Cell1 := Graf[a, j];
Cell2 := Graf[j, a];
for k := 1 to 8 do
if (Cell1[k] <> 0) or (Cell2[k] <> 0) then Exit;
end;
IsIsol := True;
end;
begin
DotsAreLinked := False;
if IsIsol(i) or IsIsol(j) then Exit;
ClearDots(Dots1);
ClearDots(Dots2);
SetDotVal(Dots1, i, 1);
SetDotVal(Dots2, j, 1);
repeat
c1 := WideSearchStep(Dots1);
c2 := WideSearchStep(Dots2);
if c1 and c2 and EqualDotsExists then begin
DotsAreLinked := True;
Break;
end;
until not c1 or not c2;
end;
procedure BuildEulerCycle;
var
i, j, k, k0, l: Integer;
Found: Boolean;
Result: string;
begin
Result := '';
PathLength := 0;
{ Search non-isolar dot }
Found := False;
for i := 1 to M do begin
for j := 1 to M do
if GetVal(Graf, i, j) = 1 then begin
Found := True; Break;
end;
if Found then Break;
end;
if not Found then Exit;
k0 := i;
k := i;
repeat
Inc(PathLength);
Path[PathLength] := k;
WriteLn(PathLength, '-', k);
{ Search dot to go }
Found := False;
l := 0;
for i := 1 to M do
if GetVal(Graf, k, i) = 1 then begin
SetVal(Graf, k, i, 0);
if not DotsAreLinked(k, i) then begin { "bridge" }
SetVal(Graf, k, i, 1);
l := i;
end
else begin
Found := True;
Break;
end;
end;
if Found then k := i
else begin { go throught last found bridge }
if (k <> 0) and (l <> 0) then SetVal(Graf, k, l, 0);
k := l;
end;
until k = 0;
Dec(PathLength);
end;
procedure SetResult(FileName: string; Empty: Boolean);
var
f: Text;
i: LongInt;
begin
Assign(f, FileName);
ReWrite(f);
if not Empty then begin
Write(f, PathLength, ' ');
for i := 1 to PathLength + 1 do
Write(f, Path[i], ' ');
end
else Write(f, 0);
Close(f);
end;
{****************************** Main ***************************************}
begin
ClrScr;
FillGraf('input.txt');
{SaveGraf(SelfPath + '1');}
if not Check then begin { нc
Задача 2. "Новобранцы" (28 баллов)
Program tsk_2; { "Новобранцы"
Заметим, что процесс исполнения команды "налево" не может быть
бесконечным. Для решения задачи назовем условно пару солдат
"неправильной", если первый солдат стоит левее второго, но при этом
первый смотрит направо, а второй - налево. Легко видеть, что каждый
разворот уменьшает число неправильных пар на 1 . Кроме того, пока есть
неправильные пары, развороты солдат будут продолжаться. Таким образом,
задача сводится к тому, чтобы посчитать число
"неправильных" пар в начальной позиции.
Обозначим через e[k] количество солдат среди 1..k, которые смотрят вправо.
Обозначим через w[k] количество неправильных пар среди первых k солдат.
Имеем:
Если k-й солдат смотрит вправо, то
w[k] = w[k-1],
e[k] = e[k-1]+1
иначе
w[k] = w[k-1]+e[k-1],
e[k] = e[k-1]
все.
}
{--------------------------------------------------------------------}
procedure Onestep( var e, w: longint; sk: char );
begin
if sk = '>' then inc(e) else inc(w,e);
end;
{--------------------------------------------------------------------}
var s:string[60];
e, w: longint;
l, i: longint;
fin, fout: text;
begin
{s:='>><<><';}
Assign( fin, 'input.txt' );
{Assign( fin, ParamStr(1) );}
Reset( fin );
Readln( fin, l );
e:=0; w:=0; l:=0;
while not eof( fin ) do begin
Read( fin, s );
l := length(s);
if l=0 then break;
for i:=1 to length(s) do Onestep( e, w, s[i] );
end;
Assign( fout,'output.txt' ); Rewrite( fout );
{WriteLn( w );}
WriteLn( fout, w );
Close( fout );
end.
Задача 3. "Ломаная" (35 баллов)
Program tsk_3; { "Ломаная" }
const NMax = 20; MMax = 70;
var N, M: integer;
PX, PY: array[0..NMax, 0..NMax, 0..MMax] of byte;
{ Если на 8-м шаге есть линия от (x7,y7) до (x8,y8), то
PX[x8,y8] = x7;
PY[x8,y8] = y7;
}
{------------------------------------------------------------------}
procedure Set1( k, x0, y0, x1, y1: integer );
begin
if (x1>=0) and (x1<=N) and (y1>=0) and (y1<=N) then
begin PX[ x1, y1, k ] := x0; PY[ x1, y1, k ] := y0; end;
end;
{------------------------------------------------------------------}
procedure Set8( k, x, y, d1, d2: byte );
begin
Set1( k, x, y, x+d1, y+d2 );
Set1( k, x, y, x+d1, y-d2 );
Set1( k, x, y, x-d1, y+d2 );
Set1( k, x, y, x-d1, y-d2 );
Set1( k, x, y, x+d2, y+d1 );
Set1( k, x, y, x+d2, y-d1 );
Set1( k, x, y, x-d2, y+d1 );
Set1( k, x, y, x-d2, y-d1 );
end;
{------------------------------------------------------------------}
procedure PP_a( k, d1, d2: integer );
{ Для допустимых точек (x,y) на k-м шаге ( PX[x,y,k] < 255 )
установить в (x,y) значения (PX[*,*,k+1],PY[*,*,k+1]),
отстоящие от (x,y) на d1, d2 по осям координат
}
var x,y: integer;
begin
for x:=0 to N do for y:= 0 to N do
if PX[x,y,k] < 255 then Set8( k+1, x, y, d1, d2 );
end;
{------------------------------------------------------------------}
procedure PP_b( k, l: integer );
{ По уже готовым значениям (PX[*,*,k],PY[*,*,k])
расчитать значения (PX[*,*,k+1],PY[*,*,k+1])
}
var t, dx, dy: integer;
begin
dx := 0;
repeat
{ для выбранного dx проверяем будет ли dy=sqrt(l-dx^2) целым }
t := l-sqr(dx);
dy := trunc( sqrt(t));
if sqr( trunc( sqrt(t))) = t then
PP_a( k, dx, dy );
inc( dx );
until 2*sqr(dx) > l;
end;
{------------------------------------------------------------------}
var z : array [ 1..MMax ] of integer;
rx, ry: array [ 0..MMax ] of byte;
k, x, y, xx, yy: byte;
fin, fout: text;
begin
{ данные из условия:
N := 8; M:= 4; z[1] := 13; z[2] := 29; z[3] := 37; z[4] := 5;
данные из файла input.txt: }
Assign( fin, 'input.txt' ); Reset( fin );
Readln( fin, N, M );
for k:=1 to M do
read( fin, z[k] );
Close( fin );
for x:=0 to (N div 2) do for y:=0 to x do begin
{WriteLn( x:4, y:4);}
for k:=0 to M do for xx:=0 to N do for yy:=0 to N do
begin PX[xx,yy,k]:=255; PY[xx,yy,k]:=255; end;
PX[x,y,0] := x;
PY[x,y,0] := y;
for k:= 1 to M do begin
PP_b( k-1, z[k] );
end;
if PX[x,y,M] < 255 then begin { выведем решение }
rx[M] := x; ry[M] := y;
for k:=M downto 1 do begin
rx[k-1] := PX[ rx[k], ry[k], k ];
ry[k-1] := PY[ rx[k], ry[k], k ];
end;
Assign( fout,'output.txt' ); Rewrite( fout );
for k:=0 to M-1 do WriteLn( fout, rx[k]:4, ry[k]:4 );
Close( fout );
exit;
end;
end;
Assign( fout,'output.txt' ); Rewrite( fout );
WriteLn( fout, 'Нет решения' );
Close( fout );
end.
Задача 4. "Театр" (21 балл)
Program tsk_4; { "Театр" }
const NMax = 30000;
var N, k, k0, count: integer;
su: array[1..NMax] of integer;
{ su[i] - номер человека, сидящего на i-м месте }
f: text;
begin
Assign( f, 'input.txt' );
Reset ( f );
ReadLn( f, N );
for k:= 1 to N do Read( f, su[k] );
ReadLn( f );
ReadLn( f, k );
Close ( f );
k0:=k;
if su[k] = k then count := 0
else begin
count := 1;
while (su[k] <> 0) and (su[k] <> k0) do begin
{ на k-м месте сидит человек номер su[k] }
inc(count);
k := su[k];
end;
end;
Assign( f, 'output.txt' );
Rewrite( f );
WriteLn( f, count );
Close( f );
end.
Задача 5. "Последовательность чисел" (28 баллов)
Program tsk_5; { "Фибоначчи"
Пусть g[k] - числа Фибоначчи:
k -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8
g[k] 5 -3 2 -1 1 0 1 1 2 3 4 8 13 21
Тогда последовательность чисел F[i] удовлетворяет соотношению:
F[i+k] = g[k-1]*F[i] + g[k]*F[i+1]
Решаем задачу в 2 шага.
1. Найдем x=F[i+1]. Пусть j = i+k. Тогда
F[j] = g[k-1]*F[i] + g[k]*x.
Отсюда находим x.
2. По формуле
F[i+k] = g[k-1]*F[i] + g[k]*F[i+1]
найдем F[n]
------------------------------------------------------------------}
Function g( k: integer ): comp;
var i : integer;
t, Fi, Fi1: comp;
begin
if k<0 then begin
Fi:=0; Fi1:=1;
for i:= -1 downto k do begin t:=Fi; Fi:=Fi1-Fi; Fi1:=t; end;
g := Fi;
Exit;
end;
if k = 0 then begin g:= 0; Exit; end;
if k = 1 then begin g:= 1; Exit; end;
if k = 2 then begin g:= 1; Exit; end;
Fi:=1; Fi1:=1;
for i:= 3 to k do begin t:=Fi1; Fi1:=Fi+Fi1; Fi:=t; end;
g := Fi1;
end;
{------------------------------------------------------------------}
var fin, fout: text;
i, j, n, k: integer;
Fi, Fj, Fi1, Fn: comp;
begin
{ данные из условия:
i := 3; j := -1; n:=5; Fi:= 5; Fj:= 4;
данные из файла input.txt: }
Assign( fin, 'input.txt' );
Reset( fin );
read( fin, i, Fi, j, Fj, n );
Close( fin );
k := j-i;
Fi1 := (Fj - g(k-1)*Fi) / g(k);
k := n-i;
Fn := g(k-1)*Fi + g(k)*Fi1;
Assign( fout,'output.txt' ); Rewrite( fout );
WriteLn( fout, Fn:10:0 );
Close( fout );
end.
Условия задач
ИвГУ: Математический факультет. Главная страница