VPF::[Pascal] Проверка графа на двудольность

Kubus

Дата 18.7.2006, 16:02 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 18
Регистрация: 13.7.2006

Репутация: нет
Всего: нет

Приветствую!
Прошу помочь в написании программы на Паскале или Фортране. Задание: написать программу, проверяющую заданный граф на двудольность.

Ув. тов. Pete по этому поводу высказывался следующим образом:
"Граф двудольный тогда и толко тогда, когда длина каждого его цикла четна. Надо несколько модифицировать алгоритм поиска в ширину."

Далее спасибо тов. Comtat'у за код

Код


{Proverka dvudolnosti grafa}
const nv = 20;
type pz = ^z;
     z = record
     v : byte;
     next : pz;
     end;
var a : array [1..nv,1..nv] of byte;
    cc : array [1..nv] of byte;
    i, j, n, c : byte;
    f, g : text;
    top, p : pz;
begin
     assign(f,'in.txt');
     assign(g,'out.txt');
     rewrite(g);
     reset(f);
     readln(f,n);
     for i := 1 to n do
     begin
          read(f,a[i,1]);
          j := 2;
          while a[i,j-1] > 0 do
          begin
               read(f,a[i,j]);
               j := j + 1;
          end;
     end;
     close(f);
     new(top);
     top^.next := nil;
     top^.v := 1;
     cc[1] := 1;
     c := 2;

     while top <> nil do
     begin
          j := 1;
          while (a[top^.v,j] > 0)and(cc[a[top^.v,j]] > 0) do
          begin
               if cc[a[top^.v,j]] <> c then begin writeln(g,'N');close(g);
               exit;end;
               j := j + 1;
          end;
          if a[top^.v,j] > 0 then
          begin
               cc[a[top^.v,j]] := c;c := c and 1 + 1;
               new(p);
               p^.v := a[top^.v,j];
               p^.next := top;
               top := p;
          end
          else begin p := top^.next;dispose(top);top := p;c := cc[top^.v] and 1 + 1;end;
     end;
     writeln(g,'Y');
     j := 1;
     while cc[j] > 0 do
     begin if cc[j] = cc[1] then write(g,j,' ');j := j + 1;end;
     write(g,'0');
     writeln(g);
     j := 1;
     while cc[j] > 0 do
     begin if cc[j] = cc[1] and 1 + 1 then write(g,j,' ');j := j + 1;end;


     close(g);
end.

вот только моих знаний не особо хватает, ну да ладно, придется учебники полистать с описанием процедур.
кроме того, от меня требуют, чтобы граф был задан в виде матрицы в тхт файле.
вечером попробую скинуть несколько исходников своих, буду очень признателен, если кто-нибудь поможет мне сдать эту программу в срок!

Это сообщение отредактировал(а) Alexeis - 22.4.2007, 11:24

comtat

Дата 18.7.2006, 16:14 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1310
Регистрация: 2.5.2006
Где: Россия, Казань

Репутация: 8
Всего: 71

Код


assign(f,'in.txt');
assign(g,'out.txt');

Вот этот код говорит что открываются файлы
один для чтения другой для записи

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

Рожденный в СССР !!!
ExtJS - мой фреймворк

Kubus

Дата 18.7.2006, 16:21 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 18
Регистрация: 13.7.2006

Репутация: нет
Всего: нет

нужно, чтоб в блокноте вбивалась матрица 15*15, и оттуда читалась.
этот код

Код


assign(f,'in.txt');
assign(g,'out.txt');

допускает такое условие?
Я сейчас в весьма неприятном положении, т.к. дома интернет умер по техническим причинам сейчас нахожусь в интернет кафе, времени на все про все 1 час, посему попробовать найти в учебнике что-либо не представляется возможным. А собственных знаний Паскаля ну никак не хватает. Давно с ним не встречался, да и встречи были весьма поверхностными.

comtat

Дата 18.7.2006, 16:29 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1310
Регистрация: 2.5.2006
Где: Россия, Казань

Репутация: 8
Всего: 71

Вот пример входного файла

Цитата

6
4 5 6 0
4 5 6 0
4 5 6 0
1 2 3 0
1 2 3 0
1 2 3 0

где 6 размер графа
если нужно 15*15 пиши вместо 6 - 15

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

Рожденный в СССР !!!
ExtJS - мой фреймворк

Kubus

Дата 19.7.2006, 19:30 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 18
Регистрация: 13.7.2006

Репутация: нет
Всего: нет

а как можно сделать, чтоб матрица задавалась единицами и нулями?

comtat

Дата 20.7.2006, 07:41 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1310
Регистрация: 2.5.2006
Где: Россия, Казань

Репутация: 8
Всего: 71

Т.е ты имеешь в виду если есть путь то 1, если нет то 0 ??
Если хочешь так то в этом нет проблем пиши так в матрицу
и все будет в норме smile

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

Рожденный в СССР !!!
ExtJS - мой фреймворк

Kubus

Дата 24.7.2006, 20:25 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 18
Регистрация: 13.7.2006

Репутация: нет
Всего: нет

да, в матрицу смежности нужно вбивать 1, если путь есть, 0, если нет.
кроме того, на чем написан код? на Паскале не работает что-то

Это сообщение отредактировал(а) Kubus - 24.7.2006, 21:00

Kubus

Дата 25.7.2006, 06:24 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 18
Регистрация: 13.7.2006

Репутация: нет
Всего: нет

:stena

люди добрые, подскажите, пожалуйста!
вот есть код программы проверки графа на двудольность.

Код


const
  maxn = 250;

var
  a: array [1..maxn, 1..maxn] of boolean;
  c, p: array [1..maxn] of word;
  n: longint;

procedure init;
var
  i, x, y, nn: longint;
begin
  fillchar(a, sizeof(a), false);
  fillchar(p, sizeof(p), 0);
  fillchar(c, sizeof(c), 0);

  assign(input, 'graph.in');
  reset(input);

  read(n);
  read(nn);

  for i := 1 to nn do
  begin
    read(x, y);
    a[x, y] := true;
    a[y, x] := true;                    { ¥á«¨ ¥®à¨¥â¨à®¢ ë© £à ä }
  end;
end;

procedure print;
var
  i, j: integer;
begin
  writeln;
  writeln('number of vertex : ', n);
  writeln('adjacency matrix');
  for i := 1 to n do
  begin
    for j := 1 to n do
      write(ord(a[i, j]));
    writeln;
  end;
end;

function dfs(v: longint; color: byte): boolean;
var
  i: integer;
begin
  if color = 1 then
    c[v] := 2
  else if color = 2 then
    c[v] := 1;

  for i := 1 to n do
    if a[v, i] then
      if c[i] = 0 then
      begin
        p[i] := v;
        dfs := dfs(i, c[v]);
      end
      else if (p[v] <> i) and (c[i] <> color) then            { not parent }
      begin
        dfs := false;
        exit;
      end;

  dfs := true;
end;

function is_bipartite: boolean;
var
  i: longint;
begin
  for i := 1 to n do
    if c[i] = 0 then
    begin
      if not dfs(i, 1) then
      begin
        is_bipartite := false;
        exit;
      end;
    end;

  is_bipartite := true;
end;


var
  i: word;
  b: boolean;

begin
  init;

  writeln('depth-first search (cycle)');

  b := is_bipartite;
  writeln('is bipartite : ', b);
  if b then
  begin
    write('parts : ');
    for i := 1 to n do
      write(c[i], ' ');
  end;

  print;
end.

как заставить его работать? и может кто-нибудь объяснить принцип работы?

Это сообщение отредактировал(а) Alexeis - 22.4.2007, 11:24

comtat

Дата 25.7.2006, 07:23 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1310
Регистрация: 2.5.2006
Где: Россия, Казань

Репутация: 8
Всего: 71

Это батенька Pascal, а че компилятор говорит ??

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

Рожденный в СССР !!!
ExtJS - мой фреймворк

Kubus

Дата 25.7.2006, 08:42 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 18
Регистрация: 13.7.2006

Репутация: нет
Всего: нет

да вот и мне кажется, что паскаль, а вот говорит, что рантайм еррор 002 at 0001:0047
компилятор Borland Pascal 7.0 for Windows

comtat

Дата 25.7.2006, 09:02 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1310
Регистрация: 2.5.2006
Где: Россия, Казань

Репутация: 8
Всего: 71

Чета странный он какой-то у тебя smile

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

Рожденный в СССР !!!
ExtJS - мой фреймворк

Nora

Дата 25.4.2010, 15:41 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 1
Регистрация: 12.12.2009

Репутация: нет
Всего: нет

[Delphi] Проверка графа на двудольность

Дан неориентированный граф G. Необходимо определить,
является ли данный граф двудольным.

Граф строится в процессе выполнения программы, данные автоматически записываются в матрицу смежности.
Пытаюсь воспользоваться процедурой поиска в глубину и красить вершины.
Только в любом случае, программа выдает мне результат, что граф двудольный, даже когда он не двудольный.

Код


  const
  maxn = 250;

var
  a: array [1..maxn, 1..maxn] of boolean;
  c, p: array [1..maxn] of word;
  n: longint;

function dfs(v: longint; color: byte): boolean;
var
  i: integer;
begin
  if color = 1 then
    c[v] := 2
  else if color = 2 then
    c[v] := 1;

  for i := 1 to n do
    if a[v, i] then
      if c[i] = 0 then
      begin
        p[i] := v;
        dfs := dfs(i, c[v]);
      end
      else if (p[v] <> i) and (c[i] <> color) then            //{ not parent}
      begin
        dfs := false;
        exit;
      end;

  dfs := true;
end;

function is_bipartite: boolean;
var
  i: longint;
begin
  for i := 1 to n do
    if c[i] = 0 then
    begin
      if not dfs(i, 1) then
      begin
        is_bipartite := false;
        exit;
      end;
    end;

  is_bipartite := true;
end;  



procedure TMainForm.BitBtn1Click(Sender: TObject);
begin
  if is_bipartite then

             showmessage('Граф двудолен')
  else   showmessage('Граф не двудолен') ;

Помогите, пожалуйста, найти мою ошибку! smile

Заранее спасибо smile

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Центр помощи \| Следующая тема »