{ сортировка пузырьковым методом}
       procedure Bubble(var item: DataArray; count:integer);
       var
         i,j: integer;
         x: DataItem;
       begin
         for i := 2 to count do
         begin
           for j := count downto i do
             if item[j-1]>item[j] then
             begin
               x := item[j-1];
               item[j-1] := item[j];
               item[j] := x;
             end;
          end;
       end; {конец сортировки пузырьковым методом}
     program SortDriver;

----------------------------------------------------------------------
    {эта  программа  будет  считывать 80 или меньше символов с
     дискового файла "test.dat",  отсортирует их и выдаст
     pезультат на экран дисплея }

     type
       DataItem = char;
       DataArray = array [1..80] of char;
     var
       test: DataArray;
       t, t2: integer;
       testfile: file of char;

   { сортировка пузырьковым методом}
     procedure Bubble(var item: DataArray; count:integer);
     var
       i,j: integer;
       x: DataItem;
     begin
       for i := 2 to count do
       begin
         for j := count downto i do
           if item[j-1]>item[j] then
           begin
             x := item[j-1];
             item[j-1] := item[j];
             item[j] := x;
           end;
       end;
     end;

     begin
       Assign(testfile, 'test.dat');
       Reset(testfile);
       t := 1;

     { считывание символов,которые будут сортироваться.}

      while not Eof(testfile) do begin
         read(testfile, test[t]);
         t := t+1;
       end;
     t := t-2; {скорректировать число считанных элементов }

     Bubble(test, t); { сортировать массив }

     { выдать отсортированный массив символов }
     for t2 := 1 to t do write(test[t2]);
     WriteLn;
   end.
---------------------------------------------------------------
   { челночная сортировка является улучшенной версией сортиров-
                  ки пузырьковым методом }
       procedure Shaker(var item: DataArray; count:integer);
       var
         j, k, l, r: integer;
         x: DataItem;
       begin
         l := 2; r := count; k := count;
         repeat
           for j := r downto l do
             if item[j-1] then
             begin    { обмен }
               x := item[j-1];
               item[j-1] := item[j];
               item[j] := x;
               k := j;
             end;

           l := k+1;

           for j := l to r do
             if item[j-1]>item[j] then
             begin   { обмен }
               x := item[j-1];
               item[j-1] := item[j];
               item[j] := x;
               k := j;
             end;

           r := k-1;
         until l>r
     end; { конец челночной сортировки  }
------------------------------------------------------------------
       { сортировка выбором }
       procedure Selekt(var item: DataArray; count:integer);
       var
         i, j, k: integer;
         x: DataItem;
       begin
         for i := i to count-1 do
         begin
           k := i;
           x := item[i];
           for j := i+1 to count do { найти элемент с наименьшим
                     значением }
           if item[j]<x then
           begin
               k := j;
               x := item[j];
             end;
           item[k] := item[i];  { обмен }
           item[i] := x;
         end;
     end; { конец сортировки выбором  }
------------------------------------------------------------------

       { сортировка вставкой }
       procedure Inser(var item: DataArray; count:integer);
       var
         i, l: integer;
         x: DataItem;
       begin
         for i := 2 to count do
         begin
           x := item[i];
           j := i-1;
           while (x<item[j]) and (j>0) do
           begin
             item[j+1] := item[j];
             j := j-1;
           end;
           item[j+1] := x;

         end;
     end;  { конец сортировки вставкой }
-----------------------------------------------------------------

       { сортировка Шелла }
       procedure Shell(var item: DataArray; count:integer);
       const
         t = 5;
       var
         i, j, k, s, m: integer;
         h: array[1..t] of integer;
         x: DataItem;
       begin
         h[1]:=9; h[2]:=5; h[3]:=3; h[4]:=2; h[5]:=1;
         for m := 1 to t do
           begin

         k:=h[m];
         s:=-k;
         for i := k+1 to count do
         begin
           x := item[i];
           j := i-k;
           if s=0 then
           begin
             s := -k;
             s := s+1;
             item[s] := x;
           end;
           while (x<item[j]) and (j<count) do
             begin
               item[j+k] := item[j];
               j := j-k;
             end;
             item[j+k] := x;
           end;
         end;
     end; { конец сортировки Шелла }
-----------------------------------------------------------------

     { быстрая сортировка }
     procedure QuickSort(var item: DataArray; count:integer);
       procedure qs(l, r: integer; var it: DataArray);
         var
         i, j: integer;
         x, y: DataItem;
       begin
         i:=l; j:=r;
         x:=it[(l+r) div 2];
         repeat
           while it[i]<x do i := i+1;
           while x<it[j] do j := j-1;
           if y<=j then
           begin
             y := it[i];
             it[i] := it[j];
             it[j] := y;
             i := i+1; j := j-1;
           end;
         until i>j;
         if l<j then qs(l, j, it);
         if l<r then qs(i, r, it)
       end;
     begin
       qs(1, count, item);
     end; { конец быстрой сортировки }
-----------------------------------------------------------------

     type
       DataItem = string[80];
       DataArray = array [1..80] of DataItem;

    { алгоритм быстрой сортировки для символьных строк }
     procedure QsString(var item: DataArray; count:integer);
       procedure qs(l, r: integer; var it:DataArray);
         var
         i, l: integer;
         x, y: DataItem;
       begin
         i := l; j := r;
         x := it[(l+r) div 2];
         repeat
           while it[i] < x do i := i+1;
           while x < it[j] do j := j-1;
           if i<=j then
           begin
             y := it[i];
             it[i] := it[j];
             it[j] := y;
             i := i+1; j := j-1;
           end;
         until i>j;
         if l<j then qs(l, j, it);
         if l<r then qs(i, r, it);
       end;
     begin
       qs(1, count, item);
     end; { конец быстрой сортировки }
-----------------------------------------------------------------

       { быстрая сортировка записей с почтовым адресом }
       procedure QsRecord(var item: DataArray; count:integer);
         procedure qs(l, r:integer; var it:DataArray);
           var
             i, j: integer;
             x, y: DataItem;
           begin
             i := l; j := r;
             x := it[(l+r) div 2];
             repeat
               while it[i].name < x.name do i := i+1;
               while x.name < it[j].name do j := j-1;
             if i<=j then
             begin
               y := it[i];
               it[i] := it[j];
               it[j] := y;
               i := i+1; j := j-1;
             end;
           until i>j;
           if l<j then qs(l, j, it);
           if l<r then qs(i, r, it)
         end;
     begin
          qs(1, count, item);
     end; {конец быстрой сортировки записей}
-----------------------------------------------------------------

    { пример программы сортировки списка почтовых адресов }
           programm MlistSort;
           type
             address = record
               name: string[30];
               street: string[40];
               sity: string[20];
               state: string[2];
               zip: string[9];
             end;
             str80 = string[80];
             DataItem = addres;
             DataArray = array [1..80] of DataItem
             recfil = file of DataItem

             var
               test: DataItem;
               t, t2:integer;
               testfile: recfil;

                         { найти запись в файле }
           function Find(var fp:recfil; i:integer): str80
           var
             t:address;
           begin
             i := i-1;
             Seek(fp, i)
             Read(fp, t)
             Find := t.name;
           end;

           procedure QsRand(var var fp:recfil; count:integer)
             procedure Qs(l, r:integer)
               var
                 i, j, s:integer ;
                 x, y, z:DataItem;
                 begin
                   i := l; j := r;
                   s := (l+r) div 2;
                   Seek(fp,s-1); { получить запись }
                   Reed(fp,x);
                   repeat
                     while Find(fp, i) < x.name do i := i+1;
                     while x.name < Find(fp, j) do j := j-1;
                     if i<=j then
                     begin
                       Seek(fp,i-1);  Reed(fp,y);
                       Seek(fp,j-1);  Reed(fp,z);
                       Seek(fp,j-1);  Write(fp,y);
                       Seek(fp,i-1);  Write(fp,z);
                       i := i+1; j := j-1;
                     end;
                   until i>y;
                   if l<j then qs(l, j)
                   if l<r then qs(i, r)
             end;
           begin
             qs(1,count);
           end; {конец быстрой сортировки файла произвольного доступа}
           begin
             Assign(testfile, 'rectest.dat');
             Reset(testfile);
             t := 1;
             while not EOF(testfile) do begin
               Read(testfile,test); { подсчет числа записей в файле}
             t := t+1;
             end;
             t := t-1;

             QsRand(testfile,t)
           end.
-----------------------------------------------------------------

      { функция  "Find" используется в сортировке методом
        слияния для считывания из файла конкретной записи.}
       function Find(var fp:filtype; i:integer):DataItem;
       var
         t:DataItem;
       begin
         Seek(fp, i-1);
         Read(fp, t);
         Find := t;
       end;

       procedure Mergesort(var fp: filetype; count:integer);
          var
            i, j, k, l, t, h, m, p, q, r: integer;
           ch1, ch2:DataItem
           up: Boolean;
         begin
           up := TRUE;
           p := 1;
           repeat
             h := 1; m := count;
             if up then
             begin
               i := 1; j := count; k := count+1; l := 2*count;
             end else
             begin
               k := 1; l := count; i := count+1; j := 2*count;
             end;
             repeat
               if m>=p then q := p else q := m;
               m := m-q;
               if m>=p then r := p else r := m;
               m := m-r;
               while (q<>0) and (r<>0) do
               begin
                 if Find(fp,i) < Find(fp,j) then
                 begin
                   Seek(fp, i-1); Read(fp,ch2);
                   Seek(fp, k-1); Write(fp,ch2);
                   k := k+h; i := i+1; q := q-1;
                 end else
                 begin
                   Seek(fp, j-1); Read(fp,ch2);
                   Seek(fp, k-1); Write(fp,ch2);
                   k := k+h; j := j-1; r := r-1;
                 end;
               end;
               while r<>0 do
               begin
                   Seek(fp, j-1); Read(fp,ch2);
                   Seek(fp, k-1); Write(fp,ch2);
                   k := k+h; j := j-1; r := r-1;
               end;
               while q<>0 do
               begin
                   Seek(fp, i-1); Read(fp,ch2);
                   Seek(fp, k-1); Write(fp,ch2);
                   k := k+h; i := i+1; q := q-1;
               end;
                  h := -1; t := k;
                  k := l;
                  l := t;
              until m = 0:
              up := not up;
              p := p*2;
            until  p >= count;
            if not up then
              for i := 1 to count do
              begin
                Seek(fp, i-1+count); Read(fp,ch2);
                Seek(fp, i-1); Write(fp,ch2);
              end;
             end; { кoнец сортировки методом слияния }
-----------------------------------------------------------------

     function SeqSearch(item: DataArray; count:integer;
                              key:DataItem):integer;
     var
       t:integer;
     begin
       t:=1;
       while (key<>item[t]) and (t<=count) t:=t+1;
       if t>count then SeqSearch:=0
       else SeqSearch:=t;
     end; { конец последовательного поиска }
-----------------------------------------------------------------

     function BSearch (item: DataArray; count:integer;
                             key:DataItem):integer;
     var
       low, high, mid: integer;
       found:boolean;
     begin
       low:=1; high:=count;
       found:=false;         { не найден }
       while (low<=high) and (not found) do
       begin
         mid:=(low+high) div 2;
         if key<item[mid] then high:=mid-1
         else if key>item[mid] then low:=mid+1
         else found:=true;  { найден }
       end;
       if found then BSearch:=mid
       else BSearch:=0;  { не найден }
     end; { конец поиска }