Факультет математики и компьютерных наук, история


Решения задач областного тура всероссийской олимпиады школьников по информатике.
г.Иваново, 6 февраля 2002 г.


Задача 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.

Условия задач

ИвГУ: Математический факультет. Главная страница