www.gcmsite.ru

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

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

Нужна программа, скрипт или сайт? Анализ сайта или оптимизация? Копирайт или рерайт текстов? Заявка на выполнение работ.

Операции над бинарным деревом AVL

Язык: Borland Pascal 7.0

Курс: Линейные динамические структуры данных

В данной статье рассматривается:

  • Задать граф
  • Просмотреть граф
  • Выполнить топологическую сортировку
  • Графическое описание массива А
  • Поиск изолированных вершин
Program Topolog_Sortirovka;           {    Make 06.11.1998    }
  Uses                                {  All rights reserved  }
    Crt;
  Const
    max = 26;     { КОЛИЧЕСТВО ЭЛЕМЕНТОВ ГРАФА }
  Type
    T_elem = Char;
    ref = ^elem;
    elem = record
             n    : 0..max;
             next : ref
           end;
    t = array [1..max+1] of record
                              name    : t_elem;
                              data    : elem
                            end;
  Var
    a,b              : t;
    key              : char;
    stop,sig         : Boolean;
    cur,q            : ref;
    c                : integer;
    count            : integer;
    cp               : array [1..4] of byte;
 
{--------------------------------------------------------------------------}
  procedure ramka;
    var
      i    : integer;
    begin
      textcolor(13);
      for i:=1 to 47 do
        begin
          gotoxy(15+i,9);
          write('Н');
          gotoxy(15+i,16);
          write('Н')
        end;
      for i:=1 to 6 do
        begin
          gotoxy(16,9+i);
          write('є');
          gotoxy(62,9+i);
          write('є')
        end;
      gotoxy(62,9);
      write('>');
      gotoxy(16,9);
      write('Й');
      gotoxy(62,16);
      write('_');
      gotoxy(16,16);
      write('И')
    end;
{--------------------------------------------------------------------------}
  procedure clear;
    var
      i     : integer;
    begin
      for i:=1 to max+1 do
        begin
          cur:=a[i].data.next;
          if cur <> nil
            then
              begin
                q:=cur;
                cur:=cur^.next;
                while cur <> nil do
                  begin
                    q^.next:=cur^.next;
                    dispose(cur);
                    cur:=q^.next
                  end
              end
        end;
      for i:=1 to max+1 do
        begin
          cur:=b[i].data.next;
          if cur <> nil
            then
              begin
                q:=cur;
                cur:=cur^.next;
                while cur <> nil do
                  begin
                    q^.next:=cur^.next;
                    dispose(cur);
                    cur:=q^.next
                  end
              end
        end;
    end;
{--------------------------------------------------------------------------}
  procedure Konstructor_Graph;
    var
      i,j,k       : integer;
      name1,name2 : string[10];
      stop2       : boolean;
      key         : char;
    begin
      textcolor(1);
      clrscr;
      textcolor(15);
      clear;
      sig:=false;
      for i:=1 to max+1 do
        begin
          a[i].name:=upcase(chr(i+96));
          a[i].data.next:=nil;
          a[i].data.n:=0
        end;
      stop2:=false;
      writeln('Сколько вершин в графе ?');
      write('[N] : ');
      readln(count);
      if (count > max) or (count<1)
        then
          begin
            writeln('Ошибка !  В графе должно быть не более ',max,
                    ' и не менее одной вершины.');
            readkey;
            textcolor(1);
            cp[2]:=7;
            cp[3]:=7;
            sig:=false;
            clrscr;
            exit
          end;
      if count > 1
        then
          begin
            writeln('Введите данные для графа ( вершины графа : ',
                     a[1].name,'..',a[count].name,' ).');
            writeln('ЕNTER - завершение ввода.')
          end;
      if count = 1
        then
          stop2:=true;
      while not stop2 do
        begin
          key:=readkey;
          if key = #13
            then
              begin
                stop2:=true;
                name1:=''
              end
            else
              name1:=UpCase(key);
          if not stop2
            then
              write(name1,' -',#26,' ');
          if not stop2
            then
              begin
                key:=readkey;
                if key = #13
                  then
                    begin
                      stop2:=true;
                      name2:=''
                    end
                  else
                    name2:=UpCase(key);
              end ;
          if (name1<>'') or (name2<>'')
            then
              begin
                if not stop2
                  then
                    writeln(name2);
                for i:=1 to max do
                  if a[i].name = name2
                    then
                      for j:=1 to max do
                        if a[j].name = name1
                            then
                              begin
                                cur:=a[j].data.next;
                                if cur <> nil
                                  then
                                    begin
                                      while cur <> nil do
                                        begin
                                          q:=cur;
                                          cur:=cur^.next
                                        end;
                                      new(cur);
                                      q^.next:=cur
                                    end
                                  else
                                    begin
                                      new(cur);
                                      a[j].data.next:=cur
                                    end;
                                cur^.n:=i;
                                cur^.next:=nil
                              end
              end
            else
              stop2:=not stop2
        end;
      for i:=1 to count  do
        begin
          k:=0;
          for j:=1 to max do
            begin
              cur:=a[j].data.next;
              while cur <> nil do
                begin
                  if cur^.n = i
                    then
                      k:=k+1;
                  cur:=cur^.next
                end
            end;
          a[i].data.n:=k
        end;
      j:=0;
      for i:=1 to count do
        if (a[i].data.n = 0) and (a[i].data.next = nil)
          then
            j:=j+1;
      if j = 0
        then
          write('Изолированных вершин нет.')
        else
          begin
            write('Изолированные вершины : ');
            for i:=1 to count do
              if (a[i].data.n = 0) and (a[i].data.next = nil)
                then
                  write(a[i].name,' ')
          end;
      b:=a;
      sig:=true;
      cp[2]:=15;
      cp[3]:=15;
      readkey;
      textcolor(1);
      clrscr
    end;
{--------------------------------------------------------------------------}
  procedure Go_sort;
    var
      r,i,j,k,l     : integer;
      ok            : boolean;
    begin
      textcolor(1);
      clrscr;
      textcolor(15);
      i:=1;
      r:=0;
      {-------------------- Основной цикл ----------------------}
      while i <> 0 do
        begin
          i:=0;
          for j:=1 to count do
            if a[j].data.n = 0
              then
                begin
                  k:=0;
                  cur:=a[max+1].data.next;
                  while cur <> nil do
                    begin
                      if cur^.n = j
                        then
                          k:=k+1;
                      cur:=cur^.next
                    end;
                  if k = 0
                    then
                      begin
                        r:=r+1;
                        i:=i+1;
                        cur:=a[max+1].data.next;
                        if cur = nil
                          then
                            begin
                              new(a[max+1].data.next);
                              cur:=a[max+1].data.next
                            end
                          else
                            begin
                              while cur <> nil do
                                begin
                                  q:=cur;
                                  cur:=cur^.next
                                 end;
                              new(cur);
                              q^.next:=cur
                            end;
                        cur^.next:=nil;
                        cur^.n:=j;
                        cur:=a[j].data.next;
                        while cur <> nil do
                          begin
                            if a[cur^.n].data.n > 0
                              then
                                dec(a[cur^.n].data.n);
                            cur:=cur^.next
                          end
                      end
                end
        end;
      {-------------- Завершение основного цикла ---------------}
      cur:=a[max+1].data.next;
      while cur <> nil do
        begin
          write(a[cur^.n].name,'  ');
          cur:=cur^.next
        end;
      writeln;
      textcolor(11);
      if r <> count
        then
          ok:=false
        else
          ok:=true;
      if not ok
        then
          write('Полное решение не существует...')
        else
          write('Полное решение существует...');
      a:=b;
      readkey;
      textcolor(1);
      clrscr
    end;
{--------------------------------------------------------------------------}
  procedure Look_to_Graph;
    var
      i,j   : integer;
    begin
      textcolor(1);
      clrscr;
      textcolor(11);
      b:=a;
      writeln(' ':17,'Графическое описание массива А :');
      writeln;
      textcolor(15);
      for i:=1 to count do
        begin
          write('A[',i:2,'] : ',a[i].name:3,' | ',a[i].data.n);
          cur:=a[i].data.next;
          while cur<>nil do
            begin
              write('  -',#26,'  ',a[cur^.n].name);
              cur:=cur^.next
            end;
          writeln('  -',#26,' nil')
        end;
      for i:=1 to count do
        if (a[i].data.n = 0) and (a[i].data.next = nil)
          then
            j:=j+1;
      if j = 0
        then
          write('Изолированных вершин нет.')
        else
          begin
            write('Изолированные вершины : ');
            for i:=1 to count do
              if (a[i].data.n = 0) and (a[i].data.next = nil)
                then
                  write(a[i].name,' ')
          end;
      a:=b;
      readkey;
      textcolor(1);
      clrscr
    end;
{--------------------------------------------------------------------------}
BEGIN
  textcolor(1);
  textbackground(1);
  clrscr;
  cp[1]:=15;
  cp[2]:=7;
  cp[3]:=7;
  cp[4]:=15;
  stop:=false;
  sig:=false;
  while not stop do
    begin
      textcolor(11);
      gotoxy(17,2);
      writeln('Программа студента гр. ПА-97  Шарова Евгения');
      gotoxy(30,23);
      writeln('All rights reserved.');
      textcolor(10);
      gotoxy(20,7);
      writeln('Линейные динамические структуры данных.');
      writeln(' ':25,'Топологическая сортировка.');
      ramka;
      textcolor(15);
      gotoxy(20,11);
      textcolor(cp[1]);
      write('Задать граф...........................1');
      gotoxy(20,12);
      textcolor(cp[2]);
      write('Просмотреть граф......................2');
      gotoxy(20,13);
      textcolor(cp[3]);
      write('Выполнить топологическую сортировку...3');
      gotoxy(20,14);
      textcolor(cp[4]);
      write('Выход в ДОС...........................4');
      key:=readkey;
      case key of
        '1' : Konstructor_Graph;
        '2' : if sig
                then
                  Look_to_Graph;
        '3' : if sig
                then
                  Go_sort;
        '4' : stop:= not stop;
        else
          begin
            Sound(35+random(160));
            Delay(37);
            NoSound
          end
      end
    end;
  clear;
  textmode(3)
END.




Delphi — это объектно-ориентированный язык программирования со строгой типизацией переменных. Он используется в основном для написания прикладных, пользовательских программ. Простота использования позволяет рекомендовать его в качестве языка для начального обучения программированию. Хотя, если смотреть на перспективу, работодатели мало интересуются работниками, программирующими на Delphi.

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

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