IMHO.WS - Нужен исходник по Pascal. Метаграммы

Yurij
Получите и распишитесь.
Код:
uses

  crt;



const

  n = 5;



type

  str_vector = array [1..n] of string;

  log_vector = array [1..n] of boolean;

  log_matrix = array [1..n, 1..n] of boolean;



const

  a: str_vector = ('vaz', 'sad', 'gad', 'gaz', 'par');



var

  b: log_matrix;



{

  ----------------------------------------------------------------------------

  Процедура составления двумерного массива.

    вход:  x - одномерный массив (вектор) слов

    выход: y - двумерный массив (матрица) логических величин

}

procedure Metagrams (x: str_vector; var y: log_matrix); far;

{

  Функция определения прямых метаграмм - слов отличающихся друг от друга не

  более чем на один символ.

    вход:  два слова s1 и s2

    выход: "истина" (если метаграммы) или "ложь"

}

function DirectMetagram (s1, s2: string): boolean; far;

var

  i, j: byte;

begin

  if length (s1) = length (s2) then begin

    j := 0;

    for i := 1 to length (s1) do if s1[i] = s2[i] then inc (j);

    DirectMetagram := ((length (s1) - j) <= 1);

  end else DirectMetagram := false;

end;

{

  Функция определения существования метаграммной цепочки между двумя словами.

    вход:  номера двух слов i и j, логический вектор p слов цепочки

    выход: "истина" (если есть метаграммная цепочка) или "ложь"

}

function ChainMetagram (i, j: byte; p: log_vector): boolean; far;

var

  k: byte;

  q: boolean;

begin

  p[i] := true;

  if p[j] then q := true else begin

    q := false;

    for k := 1 to n do begin

      if y[i, k] and not p[k] then q := q or ChainMetagram (k, j, p);

      if q then break;

    end;

  end;

  ChainMetagram := q;

end;



var

  i, j, k: byte;

  q: log_vector;

{

  Основная часть процедуры

}

begin

{

  Обозначаем два одинаковых слова - "true", находим пары слов-метаграмм, и

  копируем "трегульную" матрицу саму на себя относительно главной диагонали.

}

  for i := 1 to n do for j := i to n do if i = j then y[i, i] := true else begin

    y[i, j] := DirectMetagram(x[i], x[j]);

    y[j, i] := y[i, j];

  end;

{

  Находим пару слов, не являющихся метаграммами, и пробуем найти цепочку

  метаграмм, соединяющую их. Полученную "треугольную" матрицу копируем саму на

  себя относительно главной диагонали.

}

  for i := 1 to n - 1 do for j := i + 1 to n do if not y[i, j] then begin

    for k := 1 to n do q[k] := false;

    y[i, j] := ChainMetagram (i, j, q);

    y[j, i] := y[i, j];

  end;

end;

{ ---------------------------------------------------------------------------- }



var

  i, j: byte;



begin

  clrscr;

  writeln ('strings:');

  for i := 1 to n do write (a[i]:4);

  writeln;

  writeln ('boolean:');

  Metagrams (a, b);

  for i := 1 to n do begin

    for j := 1 to n do if b[i, j] then write ('+':4) else write ('-':4);

    writeln;

  end;

  readkey;

end.
Вроде работает. Думаю, разберешься - здесь все достаточно просто.