Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате
Форум программистов > Центр помощи > [Pascal] Проверка графа на двудольность


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

Ув. тов. 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.


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

Автор: comtat 18.7.2006, 16:14
Код

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


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

Автор: Kubus 18.7.2006, 16:21
нужно, чтоб в блокноте вбивалась матрица 15*15, и оттуда читалась.
этот код
Код

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

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

Автор: comtat 18.7.2006, 16:29
Вот пример входного файла
Цитата

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  

Автор: Kubus 19.7.2006, 19:30
а как можно сделать, чтоб матрица задавалась единицами и нулями? 

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

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

Автор: Kubus 25.7.2006, 06:24
 :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.


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

Автор: comtat 25.7.2006, 07:23
Это батенька Pascal, а че компилятор говорит ?? 

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

Автор: comtat 25.7.2006, 09:02
Чета странный он какой-то у тебя  smile  

Автор: Nora 25.4.2010, 15:41
[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

Powered by Invision Power Board (http://www.invisionboard.com)
© Invision Power Services (http://www.invisionpower.com)