www.gcmsite.ru

Новости Программы PHP-скрипты Статьи Числа
Услуги Резюме Игры Автомобили Поиск

СИСТЕМНОЕ И ВЕБ-ПРОГРАММИРОВАНИЕ
компьютерная техника, игры

Сравнение двух графов на равенство

Предлагаю Вам программу чисто теоретического характера. Язык: Borland Pascal 7.0 Сравниваем два графа на равенство.

{Version 1.0}
{Курсовая работа по курсу "Структуры данных и их обработка"}
{Шарова Е.Н.}
{Тема работы : "Сравнение двух графов на равенство"}
Program Kursovik;
  Uses
    Crt;
  Const
    n = 170;
  Type
    stack = array [1..n] of byte;
    mas   = array [1..n,1..n] of shortint;
                                   {Значения ячеек массива :
                                    1 - существует дуга из вершины i В j
                                   -1 - существует дуга из вершины j В i
                                    0 - вершины i и j  не соединены дугой.}
    mm    = array [1..n,1..2] of byte;
            {Значения ячеек массива : [i,N] и [i,N] , где N=1,2
             В ячейке 1 хранится кол-во выходящих дуг из i-той вершины.
             В ячейке 2 хранится кол-во входящих дуг в i-тую вершину.}
  Var
    f                     : text;  {Файл с графом}
    key                   : char;  {Сканирует клавиатуру}
    i,j,k,x,count1,count2 : integer;
    m1,m2                 : mas;   {Матрицы инциндентности графов}
    stop                  : boolean;
    t1,t2                 : mm;    {Вспомогательные массивы второго уровня}
 
Procedure Ramka ;
  begin
    TextColor(0);
    TextBackGround(0);
    window(23,8,61,18);
    clrscr;
    TextColor(11);
    TextColor(3);
    TextBackGround(3);
    window(21,7,59,17);
    clrscr;
    TextColor(11);
 
  end;
Procedure Menu;       {Основное меню программы.}
  begin
    textcolor(1);
    textbackground(1);
    clrscr;
    Ramka;
    textcolor(11);
    gotoxy(13,2);
    write('Курсовая работа');
    textcolor(10);
    gotoxy(5,3);
    write('"Сравнение графов на равенство"');
    textcolor(White);
    gotoxy(4,5);
    write('Создать граф "A"................1');
    gotoxy(4,6);
    write('Создать граф "B"................2');
    gotoxy(4,7);
    write('Посмотреть на графы.............3');
    gotoxy(4,8);
    write('Сравнить графы..................4');
    gotoxy(4,9);
    write('О программе.....................5');
    gotoxy(3,10);
    write('Завершение работы программы.....ESC');
    TextColor(1);
    TextBackGround(1);
    window(1,1,80,25)
  end;
 
{Инициализация матриц инциндентности для графов и вспомогательных массивов,}
{где zz - номер графа (1 или 2).}
Procedure Clr(zz:byte);
  begin
    for i:=1 to n do
      for j:=1 to n do
        if zz=1
          then m1[i,j]:=0
          else m2[i,j]:=0;
    for i:=1 to n do
      if zz=1
       then begin t1[i,1]:=0; t1[i,2]:=0 end
       else begin t2[i,1]:=0; t2[i,2]:=0 end
  end;
 
{Открытие файла с графом, где z - номер графа (1 или 2).}
Procedure OpenFile(z:byte);
  var
    ss,s1,s2,fn: string[40];
    count: integer;
  begin
    clrscr;
    textcolor(11);
    if z=1
      then clr(1)
      else clr(2);
    count:=0;
    write('Введите имя файла : ');
    textcolor(10);
    readln(fn);
    assign(f,fn);
    {$i-}
    reset(f);
    {$i+}
    if ioresult<>0
      then
        begin
          textcolor(15);
          writeln('Ошибка...');
          key:=readkey;
          menu;
          exit
        end;
    readln(f,ss);
    val(ss,count,i);
    while not eof (f) do
      begin
        readln(f,ss);
        s1:='';
        s2:='';
        i:=1;
        while ss[i]<>'-' do
          begin
            s1:=s1+ss[i];
            inc(i)
          end;
        inc(i);
        while i<=length(ss) do
          begin
            s2:=s2+ss[i];
            inc(i)
          end;
        val(s1,i,x);
        val(s2,j,x);
        if z=1
          then
            begin
              m1[i,j]:=1;
              m1[j,i]:=-1;
              inc(t1[i,1]);
              inc(t1[j,2])
            end
          else
            begin
              m2[i,j]:=1;
              m2[j,i]:=-1;
              inc(t2[i,1]);
              inc(t2[j,2])
            end
      end;
    close (f);
    if z=1
      then count1:=count
      else count2:=count;
    textcolor(15);
    writeln('Загрузка графа из файла завершена !');
    key:=readkey;
    menu
  end;
{Ввод графа с клавиатуры, где z - номер графа (1 или 2).}
Procedure NewGr(z:byte);
  var ss : string[30];
      count: integer;
  begin
    clrscr;
    textcolor(11);
    if z=1
      then clr(1)
      else clr(2);
    count:=0;
    write('Введите количество вершин : ');
    textcolor(10);
    readln(count);
    if (count <=0) OR (count>n)
      then
        begin
          write('Ошибочный ввод !!');
          if z=1
            then count1:=0
            else count2:=0;
          key:=readkey;
          menu;
          exit
        end;
    i:=1;
    j:=1;
    while (j<>0) and (i<>0) do
      begin
        readln(i,j);
        if (i>0) and(j>0)  and (j<=n) and (i<=n)
          then
            begin
              if i<>j
                then
                  begin
                    if z=1
                      then
                        begin
                          m1[i,j]:=1;
                          m1[j,i]:=-1;
                          inc(t1[i,1]);
                          inc(t1[j,2])
                        end
                      else
                        begin
                          m2[i,j]:=1;
                          m2[j,i]:=-1;
                          inc(t2[i,1]);
                          inc(t2[j,2])
                        end
                  end
                else
                  writeln('Ошибка...');
            end
      end;
    textcolor(15);
    writeln('Граф введен !');
    if z=1
      then count1:=count
      else count2:=count;
    key:=readkey;
    menu
  end;
{Показать граф, где z - номер графа (1 или 2).}
Procedure LookGr(z:byte);
  var
    count: integer;
  begin
    if z=1
      then count:=count1
      else count:=count2;
    if count<>0
      then
        begin
          textcolor(10);
          write('Граф ');
          if z=1
            then writeln('"A" ')
            else writeln('"B" ');
          textcolor(11);
          write('Количество вершин : ');
          textcolor(15);
          writeln(count);
          textcolor(11);
          writeln('Дуги :');
          textcolor(10);
          write('');
          for i:=1 to count do
            begin
              write('');
              j:=1;
              while j<=count do
                begin
                  if z=1
                    then
                      begin
                        if m1[i,j]=1
                          then
                            if wherex>70
                              then
                                begin
                                  writeln;
                                  write('(',i,',',j,') ')
                                end
                              else
                                write('(',i,',',j,') ')
                      end
                    else
                      begin
                        if m2[i,j]=1
                          then
                            if wherex>70
                              then
                                begin
                                  writeln;
                                  write('(',i,',',j,') ')
                                end
                              else
                                write('(',i,',',j,') ')
                      end;
                  inc(j)
                end
            end;
          writeln;
          textcolor(14);
          write('Изолированные вершины : ');
          textcolor(10);
          for i:=1 to count do
           begin
             k:=0;
             for j:=1 to count do
               if z=1
                 then
                   begin
                     if m1[i,j]<>0 then inc(k)
                   end
                 else
                   begin
                     if m2[i,j]<>0 then inc(k)
                   end;
             if k = 0
               then
                 if wherexv
                   then
                     begin
                       writeln;
                       write(i,' ')
                     end
                   else
                     write(i,' ')
           end;
         writeln;
         writeln
        end
      else
        begin
          textcolor(10);
          write('Граф ');
          if z=1
            then write('"A" ')
            else write('"B" ');
          writeln('не найден...')
        end;
  end;
{Впомогательное меню.}
Procedure menu1;
  var
    sig   : boolean;
    i     : byte;
  begin
    clrscr;
    textbackground(0);
    window(25,10,59,16);
    clrscr;
    TextColor(3);
    TextBackGround(3);
    window(23,9,57,15);
    clrscr;
    textcolor(11);
    gotoxy(14,2);
    write('Граф "');
    if key='1'
      then write('A"')
      else write('B"');
    textcolor(15);
    gotoxy(4,4);
    write('1..........Загрузить из файла');
    gotoxy(4,5);
    write('2.........Ввести с клавиатуры');
    gotoxy(4,6);
    write('ESC......Выход в главное меню');
    TextBackGround(1);
    window(1,1,80,25);
    sig:ъlse;
    i:=ord(key)-48;
    while not sig do
      begin
        key:=readkey;
        if key =#0 then key:=readkey
          else
            case key of
              '1': begin Openfile(i); sig:=true end;
              '2': begin Newgr(i); sig:=true end;
              #27: sig:=true
            end;
      end;
    Menu
  end;
 
Function OutNet(r:byte;var m:mas;var t:mm;level:integer):integer;
  var
    e1,e2,e3:byte; Res : integer;
  begin
    res:=0;
    if level>0
      then
        begin
          e1:=t[r,1];
          e2:=0;
          e3:=1;
          while e2<>e1 do
            begin
              if m[r,e3]= 1
                then
                  begin
                    res:=resКz(e3,m,t,level-1)+1;
                    inc(e2)
                  end;
              inc(e3)
            end
        end;
    OutNet:=res
  end;
 
Function InNet(r:byte;var m:mas;var t:mm;level:integer):integer;
  var
    e1,e2,e3:byte; Res : integer;
  begin
    res:=0;
    if level>0
      then
        begin
          e1:=t[r,2];
          e2:=0;
          e3:=1;
          while e2<>e1 do
            begin
              if m[r,e3]= -1
                then
                  begin
                    res:=ress(e3,m,t,level-1)+1;
                    inc(e2)
                  end;
              inc(e3)
            end
        end;
    InNet:=res
  end;
 
Function Present (r:byte;var st:stack):boolean;
  var
    e1: integer;
    res : boolean;
  begin
    res:ъlse;
    e1:=1;
    while e1<=count1 do
      begin
        if st[e1]= r then
          begin
            res:=true;
            e1:=count1
          end;
        inc(e1)
      end;
    Present:=Res
  end;
 
{Главная процедура : Сравнение двух графов.}
Procedure Compare;
  var
    i,j,k,l,x,x1,x2  : integer; {Впомогательные переменные}
    ok,stop2         : boolean; {Ok-признак корректности сравнения}
                                {Как только Okъlse, так сразу же
                                 произойдет преостановка дальнейшего
                                 сравнения графов}
    st1,st2,st3      : stack;   {Вспомогательные массивы}
 
  begin
    ok:=true;
    clrscr;
    textcolor(14);
    If (count1=0) and (count2=0)
      then
        begin
          Writeln('Графы не созданы.');
          key:=readkey;
          Menu;
          Exit
        end;
    If (count1=0) or (count2=0)
      then
        begin
          Write('Граф "');
          if count1=0 then write('A')
                      else write('B');
          writeln('" не создан.');
          key:=readkey;
          Menu;
          Exit
        end;
    writeln('Пожалуйста, подождите...');
    textcolor(11);
    writeln('Сравниваются графы...');
    textcolor(15);
    for i:=1 to n do
      begin
        st1[i]:=0;
        st2[i]:=0;
        st3[i]:=0
      end;
    if (count1<>count2) or (count1=0) or (count2=0)
      then
        ok:ъlse;
    x:=t1[1,1]+t1[1,2];
    for i:=1 to count1 do
      if (t1[i,1]+t1[i,2])>x
        then
          x:=t1[i,1]+t1[i,2];
    i:=0;
    while (i<=x) and ok do
      begin
        x1:=0;
        for j:=1 to count1 do
          if i = (t1[j,1]+t1[j,2])
            then
              begin
                inc(x1);
                st1[x1]:=j
              end;
        x2:=0;
        for j:=1 to count1 do
          if i = (t2[j,1]+t2[j,2])
            then
              begin
                inc(x2);
                st2[x2]:=j
              end;
        inc(i);
        if x1<>x2
          then
            ok:ъlse
          else
            begin
              j:=x1;
              l:=x1;
              while (j>0) and ok do
                begin
                  k:=x2;
                  while k>0 do
                    if (InNet(st1[j],m1,t1,Count1)=InNet(st2[k],m2,t2,Count1))
                       and
                       (OutNet(st1[j],m1,t1,Count1)=OutNet(st2[k],m2,t2,Count1))
                      then
                        begin
                          st3[st1[j]]:=st2[k];
                          st2[k]:=st2[x2];
                          dec(x2);
                          dec(l);
                          k:=0
                        end
                      else
                        dec(k);
                  dec(j);
                  if j<>l
                    then
                      ok:ъlse
                end
            end
      end;
    if ok
      then
       { Каркасные структуры графов равны.
         Проводим переименование вершин.}
        begin
          for i:=1 to n do
            begin
              st1[i]:=0;
              st2[i]:=0;
              st3[i]:=0
            end;
          { Проверка соответствия статуса вершин с одинаковыми полями }
          For i:=1 to count1 do
            begin              if (InNet(i,m1,t1,Count1)=InNet(i,m2,t2,Count2))
               and
                (OutNet(i,m1,t1,Count1)=OutNet(i,m2,t2,Count2))
               then st3[i]:=i;
 
            end;
          i:=0;
          while i<=x do
            begin
              x1:=0;
              for j:=1 to Count1 do
                if i = (t1[j,1]+t1[j,2])
                  then
                    begin
                      inc(x1); St1[x1]:=j
                    end;
              x2:=0;
              for j:=1 to Count1 do
                if i = (t2[j,1]+t2[j,2])
                  then
                    begin
                      inc(x2); St2[x2]:=j
                    end;
              for j:=1 to x1 do
                if st3[st1[j]]<>0 then st1[j]:=0;
              for j:=1 to x1 do
                if Present(st2[j],st3) then st2[j]:=0;
              {Подсчитываем новое количество элементов в списках St1 и St2.}
              j:=0;
              for k:=1 to x1 do
                if st1[k]<>0
                  then inc(j);
              x1:=j;
              j:=0;
              for k:=1 to x2 do
                if st2[k]<>0
                  then inc(j);
              x2:=j;
              j:=0;
              k:=0;
              while k<>x1 do
                begin
                  inc(j);
                  if st1[j]<>0
                    then
                      begin
                        inc(k);
                        st1[k]:=st1[j];
                        if k<>j
                          then st1[j]:=0;
                      end;
                end;
              j:=0;
              k:=0;
              while k<>x2 do
                begin
                  inc(j);
                  if st2[j]<>0
                    then
                      begin
                        inc(k);
                        st2[k]:=st2[j];
                        if k<>j
                          then st2[j]:=0;
                      end;
                end;
              if (x1=1) and (x2=1)
                then
                  st3[st1[1]]:=st2[1]
                else
                  begin
                    j:=x1;
                    while j>0 do
                      begin
                        k:=x2;
                        while k>0 do
                          if (InNet(st1[j],m1,t1,Count1)=InNet(st2[k],m2,t2,Count1))
                             and
                             (OutNet(st1[j],m1,t1,Count1)=OutNet(st2[k],m2,t2,Count1))
                            then
                              begin
                                st3[st1[j]]:=st2[k];
                                st2[k]:=st2[x2];
                                dec(x2);
                                k:=0
                              end
                            else
                              dec(k);
                        dec(j)
                      end;
                  end;
              inc(i)
            end;
          j:=0;
          for i:=1 to count1 do
            if st3[i]<>i then inc(j);
          if j=0
            then
              writeln('Графы равны !')
            else
              begin
                j:=1;
                writeln('Чтобы свести граф "А" к графу "В",'+
                        ' надо переименовать вершины в графе "А":');
                for i:=1 to count1 do
                  begin
                    if i <> st3[i]
                      then writeln(i:3,' -> ',st3[i]);
{                    inc(j);
                    if j# then
                      begin
                        textcolor(13);
                        gotoxy(10,25);
                        write('<<<   Нажмите любую клавишу для продолжения   >>>');
                        gotoxy(10,25);
                        key:=readkey;
                        if key = #0
                          then
                            key:=readkey;
                        textcolor(15);
                        write('                                                 ');
                        gotoxy(1,25);
                        j:=1
                      end;  }
                  end;
              end;
          textcolor(13);
          writeln('Процесс окончен !')
        end
      else
        begin
          textcolor(15);
          writeln('Графы не могут быть сведены друг к другу.')
        end;
    key:=readkey;
    if key= #0
      then
        key:=readkey;
    menu
  end;
 
Procedure Autor;
  begin
    clrscr;
    textbackground(0);
    window(23,10,61,16);
    clrscr;
    TextColor(3);
    TextBackGround(3);
    window(21,9,59,15);
    clrscr;
    textcolor(11);
    gotoxy(3,2);
    writeln('Программа написана студентом группы ',' ':18,'ПА-97');
    gotoxy(6,4);
    textcolor(10);
    writeln('Шаровым Евгением Николаевичем');
    gotoxy(11,6);
    textcolor(14);
    writeln('All rights reserved');
    key:=readkey;
    if key = #0
      then
        key:=readkey;
    menu
  end;
 
begin
  stop:=false;
  menu;
  while not stop do
    begin
      key:=readkey;
      if key = #0 then begin Sound(60); Delay(20); NoSound; key:=readkey end
        else case key of
               '1':menu1;
               '2':menu1;
               '3': begin
                      textcolor(1);
                      clrscr;
                      lookgr(1);
                      key:=readkey;
                      if key= #0
                        then
                          key:=readkey;
                      lookgr(2);
                      key:=readkey;
                      if key =#0 then key:=readkey;
                      menu
                    end;
               '4': Compare;
               '5': Autor;
               #27: stop:=true
             end
    end;
  textmode(3)
end.

Prolog — это язык логического программирования. Он является декларативным языком: вся стуктура программы представлена в виде правил и фактов. На нем можно строить экспертные системы, генерирующие ответы вида true (истина) или false (ложь). Пролог хорошо подходит для автоматического перебора вариантов решений с возвратами. Язык не требует написания большого объемного кода и позволяет получать отличные результаты.

Интересные материалы на сайте:

Автор, разработчик: Шаров Евгений   (gcmsite@yandex.ru)
(c) 2000-2019 GCM-Site - системное и веб-программирование
Цитирование материалов сайта возможно только при наличии гиперссылки