IPB
ЛогинПароль:

> 

Начальные контакты ТОЛЬКО через личку!!

 
 Ответить  Открыть новую тему 
> Две задачи по дискретной математике, поиск пути и проверка на двудольность.
сообщение
Сообщение #1





Группа: Пользователи
Сообщений: 9
Пол: Мужской

Репутация: -  0  +


приветствую, требуется срочное выполнение двух заданий по дискретной математике.

задание:
1)В заданном графе найти кратчайший путь от одной вершины к другой и найти все пути между этими вершинами, не пересекающиеся по вершинам.

вот исходник:
Код
{Bellman-Ford algorithm}
var a : array [1..20,1..20] of word;
    c, pred : array [1..20] of word;
    i, j, k, n, first, last : byte;
    f, g : text;
begin
     assign(f,'in.txt');
     reset(f);
     readln(f, n);
     for i := 1 to n do
     begin
          for j := 1 to n do
          read(f, a[i,j]);
          readln(f);
     end;
     readln(f, first, last);
     close(f);


     for j := 1 to n do
     begin
          c[j] := a[first,j];if a[first,j] < 32767 then pred[j] := first;
     end;

     for i := 3 to n do
         for j := 1 to n do
             if j <> first then
             for k := 1 to n do
                 if (c[k] < 32767) and (c[k] + a[k,j] < c[j]) then begin c[j] := c[k] + a[k,j];pred[j] := k;end;

     assign(g,'out.txt');
     rewrite(g);
     if c[last] = 32767 then writeln(g,'N') else
     begin
          writeln(g,'Y');
          write(g,first,' ');
          i := last;k := 1;
          while i <> first do
          begin
               a[1,k] := i;
               k := k + 1;
               i := pred[i];
          end;
          for i := k - 1 downto 1 do
          write(g,a[1,i],' ');
          writeln(g);
          writeln(g,c[last]);
     end;
     close(g);
end.


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

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

вот, что есть у меня
Код
{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.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 11.10.2024 13:37
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name