Задачка с шестеренками Опции

[straight edge]

Такая вот задачка: Дана система шестеренок, т.е. для каждой шестеренки указано с какими она соединена. Необходимо определить будет ли она крутиться.

[trminator]

Проверьте!!!
========================================

Код

program shesterenka;
var A: array[1..100,1..100] of Integer;  {Матрица смежности}
   B: array[0..100] of Integer;{В какую сторону крутится  i-я шестеренка}
   New: array[1..100]of boolean;  {Проходили ли уже эту шестеренку}
   i, j, n : integer;        {Всякие разные переменые}
   prev    : integer;        {В как сторону вертелась предыдущая}

procedure Stop(v:integer);
begin
 WriteLn('Противоречие на шестеренке #',v);
 halt
end;

function test(v:integer):boolean;
var i  :integer;
   pr :boolean;
begin pr:=true;
 for i:=1 to N do if A[v,i]=1 then
      if (B[i]<>B[prev])and(B[i]<>0) then pr:=false;
 test:=pr
end;

procedure Use(v:integer);
begin
 if test(v) then
    B[v]:=-B[prev]
 else Stop(v);
 prev:=v;
end;

procedure walk(v:integer);
var w:integer;
begin
 Use(v);
 New[v]:=false;
 for w:=1 to N do if (A[v,w]=1)and(New[w])then walk(w)
end;

begin
 Write('Input N: ');ReadLn(N);
 WriteLn('Input matrix');
 for i:=1 to N do
   for j:=1 to N do Read(A[i,j]);
 for i:=1 to n do begin
   B[i]:=0;{ничего не крутится}
   New[i]:=true
 end;

 prev:=0; B[prev]:=1;

 walk(1);  {Запускаем обход с 1-й шестеренки}

 j:=0;
 for i:=1 to N do if not new[i] then inc(j);
 if j=N then
    WriteLn('All Okay')
 else
    WriteLn('Что-то не соединено')
end.

====================================
Это если размеры одинаковые. Если разные, то вместо направления вращения надо записывать в массив B угловые скорости.
====================================
Вводить матрицу смежности для системы: если i соединена с j, то A[i,j]=1 иначе A[i,j]=-1

Сообщение отредактировано: volvo - 17.12.2004 15:40