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 (ложь). Пролог хорошо подходит для автоматического перебора вариантов решений с возвратами. Язык не требует написания большого объемного кода и позволяет получать отличные результаты.

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

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