Новости :

Множества


Материал подготовил(и): volvo

Множества

В математике под множеством понимается некоторый неупорядоченный набор элементов. Например, множество целых чисел или множество букв латинского алфавита. К множествам применимы следующие операции:
  • объединение множеств: A U B;
  • пересечение множеств: A П B;
  • разность (дополнение) двух множеств: A \ B.
Например:
{1, 2} U {3, 2, 4} = {1, 2, 3, 4}
{1, 2} П {3, 2, 4} = {2}
{1, 2} \ {3, 2, 4} = {1}

Понятие множествав языке Паскаль основывается на математическом представлении о конечных множествах: это ограниченная совокупность различных элементов. Для построения конкретного множественного типа используется перечисляемый или интервальный тип данных. Тип элементов, составляющих множество, называется базовым типом.

Множественный тип описывается с помощью служебных слов Set Of, например:
CODE

Type SetType = Set Of BaseType;

где SetType - множественный тип, ВaseType - базовый тип.

Пример описания переменной множественного типа:
CODE

Type SetType = Set Of 'A'..'D';
Var
 mySet: SetType;


Принадлежность переменных к множественному типу может быть определена прямо в разделе описания переменных:
CODE

Var otherSet: Set Of 0..7;


Константы множественного типа записываются в виде заключенной в квадратные скобки последовательности элементов или интервалов базового типа, разделенных запятыми, например:
['A', 'C'] [0, 2, 7] [3, 7, 11..14]

Константа вида [ ] означает пустое подмножество.

Количество базовых элементов не должно превышать 256.

Инициализация величин множественного типа может производиться с помощью типизированных констант:
CODE

Const seLit: Set Of 'A'..'D' = [];

Порядок перечисления элементов базового типа в константах безразличен.

Множество включает в себя набор элементов базового типа, все подмножества данного множества, а также пустое подмножество. Так, переменная Т множественного типа
CODE
Var T: Set Of 1..3;

может принимать восемь различных значений:
[ ] [1] [2] [3] [1,2] [1,3] [2,3] [1,2,3]

К переменным и константам множественного типа применимы операции присваивания(:=), объединения(+), пересечения(*) и вычитания(-). Результат выполнения этих операций есть величина множественного типа.

Примеры операций над множествами
Пусть заданы 3 множества с одинаковым базовым типом: A, B и C...
  • 1. Объединение множеств (C := A + B).
    Результат - множество, которое состоит из элементов, принадлежащих хотя бы одному из множеств.
    A = ['A', 'B'] и B = ['A', 'D']
    C = ['A', 'B', 'D']
  • 2. Пересечение множеств (C := A * B)
    Результат - множество, состоящее из элементов, принадлежащих каждому из множеств
    A = ['A','D'] и B = ['A','B','C']
    C = ['A']
  • 3. Разность множеств (C := A - B)
    Результат - множество, состоящее из тех элементов первого множества, которые не принадлежат второму
    A = ['A','B','C'] и B = ['A','B']
    C = ['C']
К множественным величинам применимы операции:
  • тождественность (=): проверка на эквивалентность двух множеств
    ['A','B'] = ['A','C'] вернет False
  • нетождественность (<>): проверка на неэквивалентность двух множеств
    ['A','B'] <> ['A','C'] вернет True
  • содержится в (<=): проверка того, является ли левое множество подмножеством правого
    ['B'] <= ['B','C'] вернет True
  • содержит (=>): проверка того, является ли правое множество подмножеством левого
    ['C','D'] >= ['A'] вернет False
  • In: проверка принадлежности элемента базового типа, стоящего слева от знака операции, множеству, стоящему справа от знака операции. Результат выполнения этой операции - булевский.
    Операция проверки принадлежности элемента множеству часто используется вместо операций отношения, например:
    'A' In ['A', 'B'] вернет True,
    2 In [1, 3, 6] вернет False.
В качестве примера работы с множествами можно рассмотреть моделирование “лототрона (5 из 36)” т.е. случайную выборку 5 шаров из контейнера, содержащего 36 шаров, пронумерованных от единицы до 36. Множество шаров в этом случае удобно представить описаниями вида:
CODE

Type
 Number = 1 .. 36;
 Container = Set Of Number;
Var
 Selection: Container;
 Ball: Number;


Решение задачи сводится к генерации случайного числа (номера шара) в интервале от 1 до 36 с проверкой условия принадлежности очередного шара множеству ранее выбранных, причем на первом шаге это множество пустое. Выбору шара соответствует вывод его номера на экран. Для генерации случайных чисел используется стандартная функция Random(n).
CODE

Uses Crt;
Const
 n = 36; { общее количество шаров }
 m = 5; { количество шаров в выборке }
Type
 Number = 1 .. 36;
 Container = Set Of Number;
Var
 Selection: Container;
 i, Ball : Number;
Begin
 ClrScr;
 Selection := [];
 Randomize;

 For i := 1 To m Do
   Begin
     Repeat
       Ball := Random(36)+1;
     Until not (Ball in Selection);
     Selection := Selection + [Ball];
     Write(Ball: 3)
   End;
 ReadLn
End.


Структура данных типа set оказывается безусловно полезной в случаях, когда задача легко формулируется в терминах множеств и, кроме того, позволяет существенно упростить программирование “длинных” условных выражений, связанных с проверкой на принадлежность. К последним, например, относятся, задачи анализа текстов и, в частности задача сканирования текстов программ с целью выделения лексем и других конструкций языка при трансляции.

В качестве еще одного примера использования типа set рассмотрим задачу поиска простых чисел в диапазоне 2, ... , 255.

Из-за простоты решения (не используются операции умножения и деления) в основу поиска положен метод, известный под названием ”решето Эратосфена”. Тогда алгоритм поиска простых чисел сводится к следующему.
  • Поместить все числа заданного диапазона в решето (Sieve).
  • Изъять из решета наименьшее среди оставшихся в нем чисел и поместить его среди простых (Primes).
  • Удалить из решета все числа, кратные данному.
  • Если решето не пустое, то вернуться к пункту 2, иначе вычисления прекратить.
Решето и множество простых чисел можно описать как:
CODE

Var Sieve, Primes : Set Of 2 .. 255;


и, учитывая, что простые числа (кроме двойки) есть нечетные числа, представить фрагмент программы их поиска в виде:
CODE

Uses Crt;
Const n = 255;
Type
 number = 2 .. n;
Var
 Sieve, Primes : Set Of number;
 i, n1, next: Word;
Begin
 ClrScr;
 Sieve := [2 .. n];
 Primes := [ ];
 next := 2;

 While Sieve <> [] Do
   Begin
     n1 := next;
     While n1 <= n Do
       Begin
         Sieve := Sieve - [n1];
         Inc(n1, next)
       End;
     Primes := Primes + [next];

     Repeat
       Inc(next)
     Until (next in Sieve) or (next > n)

   End;

 For i := 2 To 255 Do
   If i In Primes Then Write(i:5);
 ReadLn;
End.

Материал взят с сайта Всё о Паскале

Комментарии: (0) | Pascal & Delphi | 2006-06-01

Комбинаторика


Материал подготовил(и): Altair

CODE
Function Accomodations(N,K:Longint):Longint;
var i,Result:longint;
begin
Result:=1;
For i:=n downto (n-k+1) do result:=result*i;
Accomodations:=result
end;

Function Transpositions(N:longint):Longint;
begin
Transpositions:=Accomodations(N,N)
end;

Function Combination(N,K:Longint):Longint;
var numerator,denominator,i:longint;
begin
numerator:=1; denominator:=1;
for i:=N downto (N-K+1) do numerator:=numerator*i;
for i:=1 to K do denominator:=denominator*i;
Combination:=numerator div denominator
end;

procedure BinomialTheorum(N:longint);
var K,T,SA,SB:Longint;
begin
writeln;
for K:=0 to n do
begin
SA:=n-k; SB:=k;
T:=Combination(N,K);
If T>1 then write(T);
If SA=1 then write('A');
If SA>1 then write('A^',SA);
If SB=1 then write('B');
If SB>1 then write('B^',SB);
If k<>n then write(' + ');
end;
writeln
end;

begin
BinomialTheorum(3);
writeln(Combination(14,7));
writeln(Accomodations(14,5));
writeln(Transpositions(3));
end.

Function Accomodations(N,K:Longint):Longint;
Вычисление размещений из N по К.
(число размещений из N по K есть число к элементных упорядоченных подмножеств множества, содержащего N элементов.)
Function Transpositions(N:longint):Longint;
Вычисление числа перестановок. (A из n по n)
Function Combination(N,K:Longint):Longint;
Вычисление сочетаний из N по K. (k элементные подмножества множетсва содержащего N элементов.)
procedure BinomialTheorum(N:longint);
Выводит на экран разложение (a+b)^n.по формуле Ньютона.
Входной паарметр - N.

Материал подготовил(и): volvo

При решении задач на практике часто приходится выбирать из некоторого множества объектов какие-либо подмножества, обладающие заданными свойствами, размещать элементы в определенном порядке и т.д. Такие задачи называются комбинаторными. Классическими задачами комбинаторики являются задачи о перестановках, выборках, сочетаниях.

Перестановки
Перестановки описывают, сколькими способами можно расставить N различных предметов на N различных позиций.

Число перестановок принято обозначать Pn. N различных элементов можно расставить на N различных мест N! способами. Следовательно, Pn = N! = 1*2*… *(N-1)*N.

Также важной задачей является не только подсчет количества перестановок, но и их генерация, при этом больший интерес представляет генерация перестановок в определенном порядке, например, лексикографическом (отсортированном по возрастанию).

Рассмотрим задачу генерации всех перестановок N-элементного множества в лексикографическом порядке. В качестве примера рассмотрим перестановку для N=3

            
            1 2 3
1 3 2
2 1 3
2 3 1
3 1 2
3 2 1

Алгоритм генерации следующей перестановки таков: начиная с конца перестановки находим такой элемент a[i]: a[i-1]
CODE
{ программа генерации перестановок N элементного
множества в лексикографическом порядке }

Program perms;
var
i, j, h, n, k: integer;
a:array[0 .. 100] of integer; { массив для хранения перестановки }

{процедура вывода полученной перестановки}
procedure output;
var i: integer;
begin
writeln;
for i:=1 to n do write(a[i],' ');
end;

begin
write('количество элементов перестановки: '); readln(n);
fillchar(a, sizeof(a), 0);

{ ввод элементов начальной перестановки }
for i:=1 to n do a[i]:=i;

repeat
output; { вывод текущей перестановки }
i:=n;
while a[i-1]>a[i] do dec(i); { поиск скачка }
j:=i-1;
h:=a[j];
while a[i+1]>h do inc(i); { поиск первого меньшего элемента }
a[j]:=a[i]; a[i]:=h;
i:=j+1; k:=n;
while i h:=a[i]; a[i]:=a[k]; a[k]:=h;
inc(i); dec(k)
end
until j=0;
end.

Для получения всех n! перестановок необходимо, чтобы начальная перестановка образовывала возрастающую последовательность (то есть была первой в лексикографическом порядке). Следует прокомментировать следующие два момента: почему условием окончания работы программы является выполнение равенства j=0 и почему для упорядочивания хвоста перестановки используется простой цикл без всяких сравнений.

  1. Следуя логике алгоритма, последняя перестановка представляет собой убывающую последовательность. Следовательно, позиция скачка будет равна 1 и соответственно j=0. Ни в каком другом случае равенство j=0 не выполняется, так как тогда перестановка не будет убывающей последовательностью, то есть не является последней.

  2. Об упорядочивании хвоста следует сказать только одно: хвост всегда представляет убывающую последовательность, поэтому требуется его только инвертировать.


Сочетания
Задачи о сочетаниях решают вопрос о том, сколькими способами можно выбрать M элементов из заданного N элементного множества и генерации всех возможных выборок. Число выборок вычисляется следующей формулой С=n!/(m!(n - m)!).

Рассмотрим задачу о генерации сочетаний в лексикографическом порядке.
Для примера рассмотрим начальные данные N=6 и M=4. Тогда число сочетаний равно 15. Начальное сочетание образует последовательность 1, 2, .. m, а последнее n-m+1, … , n.

            
            1234 1256 2345
1235 1345 2346
1236 1346 2356
1245 1356 2456
1246 1456 3456

Переход к следующему сочетанию осуществляется по следующему правилу: требуется просмотреть текущее сочетание с конца и найти элемент, который можно увеличить. То есть такой элемент что a[i] <> n-k+i. Далее увеличиваем этот элемент на 1, а оставшуюся часть сочетания заполняем числами натурального ряда большими измененного элемента в порядке их следования.

CODE
program sochets;
var
i, j, n, m: integer;
a: array[0 .. 100] of integer;

{ процедура вывода текущего сочетания }
procedure use;
var i: integer;
begin
writeln;
for i:=1 to m do write(a[i]:3)
end;

begin
write('ввод N и M: '); read(n, m);

{ формирование первого сочетания }
for i:=0 to m do a[i]:=i;

repeat
use;
i:=m;
while a[i]=n-m+i do dec(i); { поиск элемента для изменения }
inc(a[i]);
for j:=i+1 to m do a[j]:=a[j-1]+1; { изменение правой части сочетания }
until i=0;
end.

Рекурсивный алгоритм генерации сочетаний (с повторениями):
const
n = 3;
k = 2;

Код
procedure s_pov(s: string);
var i: integer;
begin
if length(s) = n then begin
for i := 1 to length(s) do
write(s[i] + ' ');
writeln;
end
else
for i := k downto 1 do
s_pov(s+chr(ord('0') + i));
end;

begin
s_pov('');
end.


Подмножества
Для генерации всех подмножеств N-элементного множества: введем массив b[1..n] такой, что если b[i]=1 то i-й элемент входит в подмножество и если b[i]=0, то иначе. Тогда пустому подмножеству будет соответствовать набор из 0, а n-элементному подмножеству набор из 1. Поэтому здесь явно заметна связь с двоичным представление чисел в интервале 0 … 2N–1.

Будем находить двоичное представление числа и формировать характеристические вектора подмножеств. Изначально положим b[i]=0 для всех I, что соответствует пустому подмножеству. Введем массив a[1..n] соответствующий двоичному представлению числа. Будем моделировать операцию сложения этого числа с 1. Для этого просмотрим число справа налево, заменяя единичные биты на нулевые до тех пор, пока не найдем нулевой бит, который заменим на 1.

CODE
program subsets;
var
i, n: integer;
a, b: array[0..100] of integer;

procedure output;
var i : integer;
begin
{ вывод двоичного числа }
for i:=1 to n do write(' ',a[i]);
write(' ');

{ вывод характеристического вектора подмножества }
for i:=1 to n do write(' ',b[i]);
write(' ');

{ вывод подмножества }
for i:=1 to n do
if(b[i]=1) then write(' ',i);
end;

begin
readln(n);
fillchar(a,sizeof(a),0);
fillchar(b,sizeof(b),0);
repeat
output;
i:=n;
while a[i]=1 do begin
a[i]:=0; dec(i); { перенос в следующий разряд }
end;
a[i]:=1;
b[i]:=1-b[i] { b[i] = (1+b[i]) mod 2 }
until i=0;
end.

Материал взят с сайта Всё о Паскале

Комментарии: (0) | Pascal & Delphi | 2006-06-01

Графы


Материал подготовил(и): virt

Графы можно представлять в виде множества вершин и множества соединяющих их ребер. (Города и дороги их соединяющие)

1. Просмотр вершин графа в некотором фиксированном порядке.

общие структуры данных :
Код
const Maxn=100;
var a:array[1..Maxn,1..Maxn]of integer;
Nnew:array[1..Maxn]of boolean;
n,i,j:integer;


поиск в глубину :
Код

{ рекурсивный вариант }
procedure Pg(v:integer);
var i:integer;
begin
Nnew[v]:=false;
write(v:2);
for i:=1 to n do
if (a[v,i]<>0) and Nnew[i] then Pg(i);
end;

{ нерекурсивный вариант }
procedure Pg_nonrec(v:integer);
var St:array[1..Maxn]of integer;
yk:integer;
t,j:integer;
pp:boolean;
begin
fillchar(St,sizeof(St),0);
yk:=1;
St[yk]:=v;Nnew[v]:=false;
write(v:2);
while yk <> 0 do
begin
t:=St[yk];j:=0;pp:=false;
repeat
if (a[t,j+1] <> 0) and Nnew[j+1] then pp:=true
else inc(j);
until pp or (j >= n);
if pp then
begin
inc(yk);St[yk]:=j+1;Nnew[j+1]:=false;
write(j+1:2);
end else
dec(yk);
end;
end;


Поиск в ширину:
Код
procedure Pw(v:integer);
var Og:array[1..Maxn]of 0..Maxn;
yk1,yk2:integer;
j:integer;
begin
fillchar(Og,sizeof(Og),0);yk2:=0;
yk1:=1;Og[yk1]:=v;Nnew[v]:=false;
while yk2 < yk1 do
begin
inc(yk2);v:=Og[yk2];
write(v:2);
for j:=1 to n do
if (a[v,j] <> 0) and Nnew[j] then
begin
inc(yk1);Og[yk1]:=j;Nnew[j]:=false;
end;
end;
end;



2. Каркасы (стягивающие деревья)

Код
const Maxn=100;
var a:array[1..Maxn,1..Maxn]of byte;
Nnew:array[1..Maxn]of boolean;
Tree:array[1..2,1..Maxn]of integer;
n,i,j:integer;
yk:integer;


Построение стягивающего дерева поиском в глубину:
Код
procedure Tree_Depth(v:integer);
var i:integer;
begin
Nnew[v]:=false;
for i:=1 to n do
if (a[v,i] <> 0) and Nnew[i] then
begin
inc(yk);Tree[1,yk]:=v;Tree[2,yk]:=i;
Tree_Depth(i);
end;
end;


Построение стягивающего дерева поиском в ширину:
Код
procedure Tree_Width(v:integer);
var Turn:array[1..Maxn]of integer;
yr,yw,i:integer;
begin
fillchar(Turn,sizeof(Turn),0);yr:=0;
yw:=1;Turn[yw]:=v;Nnew[v]:=false;
while yw <> yr do
begin
inc(yr);v:=Turn[yr];
for i:=1 to n do
if (a[i,j] <> 0) and Nnew[i] then
begin
inc(yw);Turn[yw]:=i;Nnew[i]:=false;
inc(yk);Tree[1,yk]:=v;Tree[2,yk]:=i;
end;
end;
end;


Построение всех каркасов графа:
Код
const Maxn=100;
var a:array[1..Maxn,1..Maxn]of byte;
Nnew:array[1..Maxn]of boolean;
Tree:array[1..2,1..Maxn]of integer;
Turn:array[1..maxn]of integer;
n,i,j:integer;
numb:integer;
down,up:integer;

..............

procedure solve(v,q:integer);
var j:integer;
begin
if down >= up then exit;
j:=q;
while (j <= n) and (numb < n-1) do
begin
if (a[v,j] <> 0) and Nnew[j] then
begin
Nnew[j]:=false;
inc(numb);
Tree[1,numb]:=v;Tree[2,numb]:=j;
Turn[up]:=j;inc(up);
solve(v,j+1);
dec(up);Nnew[j]:=true;dec(numb);
end;
inc(j);
end;
if numb = n-1 then
begin
writeln;
for i:=1 to numb do
write(Tree[1,i],' ',Tree[2,i],' ');
exit;
end;
if j = n+1 then
begin
inc(down);
solve(Turn[down],1);
dec(down);
end;
end;


Построение минимального каркаса методом Краскала:

Граф задан списком ребер с указанием их весов:
Код
program minim_tree_kraskal;
const maxn=100;
var p:array[1..3,1..maxn*(maxn-1) div 2]of integer;
Mark:array[1..maxn]of integer;
k,i,t:integer;
m,n:integer;{m - rebra;n - vershini }

procedure Change_Mark(l,m:integer);
var i,t:integer;
begin
if m < l then
begin
t:=l;l:=m;m:=t;
end;
for i:=1 to n do
if Mark[i]=m then Mark[i]:=l;
end;

begin
readln(n,m);
for i:=1 to m do
read(p[1,i],p[2,i],p[3,i]);
for i:=1 to m-1 do
for t:=i+1 to m do
if p[3,i] > p[3,t] then
begin
k:=p[1,i];p[1,i]:=p[1,t];p[1,t]:=k;
k:=p[2,i];p[2,i]:=p[2,t];p[2,t]:=k;
k:=p[3,i];p[3,i]:=p[3,t];p[3,t]:=k;
end;
for i:=1 to n do mark[i]:=i;
k:=0;t:=m;
while k < n-1 do
begin
i:=1;
while (i <= t) and (Mark[p[1,i]] = Mark[p[2,i]]) and (p[1,i] <> 0) do inc(i);
inc(k);
write(p[1,i],' ',p[2,i],' ');
change_Mark(Mark[p[1,i]],Mark[p[2,i]]);
end;
end.


Построение минимального каркаса методом Прима:
Код
procedure solve;
var sm,sp:set of 1..maxn;
min,i,j,l,t:integer;
begin
min:=maxint;
sm:=[1..n];sp:=[];
for i:=1 to n-1 do
for j:=i+1 to n do
if (a[i,j] < min) and (a[i,j] <> 0) then
begin
min:=a[i,j];
l:=i;t:=j;
end;
sp:=[l,t];sm:=sm-[l,t];
write(l,' ',t ,' ');
while sm <> [] do
begin
min:=maxint;
l:=0;t:=0;
for i:=1 to n do
if not (i in sp) then
for j:=1 to n do
if (j in sp) and (a[i,j] < min) and (a[i,j] <> 0) then
begin
min:=a[i,j];
l:=i;t:=j;
end;
sp:=sp+[l];sm:=sm-[l];
write(l,' ',t,' ');
end;
end;


Материал подготовил(и): Altair

Поиск кратчайших путей.

Алгоритм Флойда

Описание алгоритма:
Над матрицей A (NxN) выполняется n итераций. После k-ой итерации, A[i,j] содержит значение наименьшей длинны путей из вершины i в вершину j, которые не проходят через вершины с номером, большим k.
На k-ой итерации для вычисления матрицы A, используется слудующая формула:
[CODEfaq]Ak[i,j] = min (Ak-1[i,j], Ak-1[i,k]+ Ak-1[k,j]).[/CODEfaq]
Графическая интерпретация формулы:
[attachmentid=726]

Сложность алгоритма
Время выполнения программы, имеетпорядок O(n3), так как в ней нет практически ничего, кроче 3 вложенных друг в друга циклов.

Сохранение маршрутов.
Что бы сохранять маршруты, от одной вершины кдругой, следует, ввести еще одну матрицу, в которой каждому элементу P[I,j]присваивать вершину K (номер), полученную при нахождении наименьшего значения a[I,j].


Код
Const
NN=100;
Type
Graph = array[1..nn,1..nn] of longint; {граф задан матрицей смежности}
Var
n:integer;
Procedure Floyd (var a:graph; c:graph; var p:graph);
var i,j,k:integer;
begin
for i:=1 to n do
for j:=1 to n do begin a[i,j]:=c[i,j]; p[i,j]:=0; end;
for i:=1 to n do a[i,i]:=0;
for k:=1 to n do
for i:=1 to n do
for j:=1 to n do
If (a[i,k]+a[k,j] begin
a[i,j]:=a[i,k]+a[k,j];
p[i,j]:=k;
end;
end;

procedure ReadGraph(var a:graph);
var
i,j:integer;
begin
write('n= ');readln(n);
For i:=1 to n do for j:=1 to n do
begin write('G',i,',',j,'= ');readln(a[i,j]); end;
writeln;
end;

procedure ReadFileGraph(var a:graph);
var
i,j:integer; filename:string; f:text;
begin
Write('Enter file name:'); readln(filename);
Assign (f,filename); reset(f);
Readln(f,N);
For i:=1 to n do for j:=1 to n do read(f,a[i,j]); close(f);
end;

var
a,c,p:graph;
i,j:integer;
begin
{ ReadGraph( c );}
ReadFileGraph( c );
floyd(a,c,p);
writeln('---------------------------');
for i:=1 to n do {
begin
for j:=1 to n do write(a[i,j]:3);
writeln
end;
writeln('---------------------------');
for i:=1 to n do
begin
for j:=1 to n do write(p[i,j]:3);
writeln
end;
readln;
end.[/PASCODE]

В программе C-граф, заданный матрицей смежности.
A- матрица содержащая кратчайшие пути.
P - матрица, сохраняющая маршруты.

Материал подготовил(и): Altair

Поиск кратчайшего пути. Алгоритм Дейкстры
Процедура
Код

procedure Deikstr(n:integer; W:graph; u1,u2:integer;
var length:integer; var Weight:real; var Path: array of integer);

находит путь минимального веса в графе G, заданном весовой матрицей (матрица смежности) -W.
При этом предполагается, что все элементы Wij неотрицательны.
Путь ищется из вершины номер u1 к вершине номер u2 .
Для представления веса, равного бесконечности (машинная бесконечность), используется число GM,
передаваемое в алгоритм.
Это число можно задавать в зависимости от конкретной задачи...
модуль
Код

UNIT Dijkstra;
Interface
Const
NN=30;
Type
graph=array [1..nn,1..nn] of integer;

procedure Deikstr(n:integer; W:graph; u1,u2:integer;
var length:integer; var Weight:real; var Path: array of integer);
Implementation
procedure Deikstr(n:integer; W:graph; u1,u2:integer;
var length:integer; var Weight:real; var Path: array of integer);
var
i,k,j:integer;
GM:real;
d,m:array[1..nn] of real;
p:array[1..nn] of integer;
t:integer;
dd,min:real;
begin
GM:=10000;{бесконечность}
length:=0;
if u1<>u2 then
begin
i:=1;
repeat
d[i]:=GM; p[i]:=0; m[i]:=0; i:=i+1
until not(i<=n);
d[u1]:=0; t:=u1;
while length=0 do
begin
i:=1;
repeat
if w[t,i] begin
dd:=d[t]+w[t,i];
if d[i]>dd then begin d[i]:=dd; p[i]:=t end;
end;
i:=i+1
until not(i<=n);
Min:=GM; i:=1; k:=0;
repeat
if m[i]=0 then
begin
if d[i] end;
i:=i+1
until not(i<=n);
if k<>0 then begin
m[k]:=1; t:=k;
if t=u2 then begin length:=1; end;
end else begin length:=-1 end;
end;
if length=1 then
begin
Path[1]:=u2; length:=2; j:=u2;
repeat
Path[length]:=P[j]; j:=P[j]; length:=length+1
until not(j<>u1);
i:=1; k:=trunc(length/2);
repeat
t:=Path[i]; Path[i]:=Path[length-i]; Path[length-i]:=t; i:=i+1
until not(i<=k);
length:=length-1
end;
Weight:=d[u2]
end;
end;
end.



демонстрационная программа
компилятор BP7 (target windows)
Код

uses wincrt,dijkstra;
var
i,u1,u2,n,l:integer;
G:Graph;
w:real;
path:array[0..100] of integer;

procedure ReadFileGraph(var a:graph);
var
i,j:integer; filename:string; f:text;
begin
Write('Enter file name:'); readln(filename);
Assign (f,filename); reset(f);
Readln(f,N);
For i:=1 to n do for j:=1 to n do read(f,a[i,j]); close(f);
end;

begin
readfilegraph(G); {читаем из файла граф.}
write('u1 = '); readln(u1); {вводим первую вершину}
write('u2 = '); readln(u2); {...и конечную..}
Deikstr(n,G,u1,u2, L,w,path);
writeln('w=',w:1:2); {выводим минимальный путь (вес)}
writeln('path'); {выводим путь ....}
for i:=1 to l do write(path[i],' - ');
readkey;
end.

В программе,граф считывается из файла. Вот для такого графа:
[attachmentid=878]
файл должен иметь вид (за машинную бесконечность берется 10000):
CODE

20
0 3 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
3 0 10000 10000 10000 3 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 0 2 10000 5 1 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 2 0 3 10000 10000 5 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 3 0 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 3 5 10000 10000 0 10000 10000 3 10000 10000 4 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 1 10000 10000 10000 0 10000 2 2 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 5 10000 10000 10000 0 10000 10000 4 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 10000 10000 3 2 10000 0 2 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 10000 10000 10000 2 10000 2 0 3 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 10000 10000 10000 10000 4 10000 3 0 10000 4 10000 10000 5 10000 10000 10000 10000
10000 10000 10000 10000 10000 4 10000 10000 10000 10000 10000 0 4 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 4 4 0 4 3 10000 10000 10000 10000 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 4 0 10000 10000 3 10000 10000 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 3 10000 0 10000 10000 3 10000 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 5 10000 10000 10000 10000 0 10000 4 7 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 3 10000 10000 0 10000 10000 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 3 4 10000 0 10000 6
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 7 10000 10000 0 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 6 10000 0



Материал подготовил(и): Altair

Эйлеров цикл.

Дадим теперь строгое определение эйлерову циклу и эйлерову графу. Если граф имеет цикл (не обязательно простой), содержащий все ребра графа по одному разу, то такой цикл называется эйлеровым циклом, а граф называется эйлеровым графом. Если граф имеет цепь (не обязательно простую), содержащую все вершины по одному разу, то такая цепь называется эйлеровой цепью, а граф называется полу-эйлеровым графом.
Ясно, что эйлеров цикл содержит не только все ребра по одному разу, но и все вершины графа (возможно, по несколько раз). Очевидно также, что эйлеровым может быть только связный граф.


Программа, строящая Эйлеров цикл, представленна ниже. (граф задается матрицей смежности, причем 0ставим если ребра нет, и один если есть).

Код

Uses CRT;

var
N :integer;
M: array [1..20, 1..20] of boolean ;

Type
list = ^node;
node = record
i: integer;
next: list;
end;
Var
stack1, stack2: list;
v, u, x, i, j: integer;
count: array [1..20] of byte;
procedure readfile;
var
filename:string;
f:text; i,j:integer;
b:byte;
begin
writeln('Введите имя файла:');
readln( filename );
assign(f, filename);
reset(F);
readln(f , n );
for i:=1 to n do for j:=1 to n do begin
read( f , B );
if b=1 then m[i,j]:=true else m[i,j]:=false;
end;
close(F);
end;

Procedure Push(x: integer; var stack: list);
Var
temp: list;
Begin
New(temp);
temp^.i:=x;
temp^.next:=stack;
stack:=temp;
End;
Procedure Pop(var x: integer; var stack: list);
Begin
x:=stack^.i;
stack:=stack^.next
End;
Function Peek(stack: list): integer;
Begin
Peek:=stack^.i
End;
Procedure PrintList(l: list);
Begin
If l=nil then
begin
writeln('Ошибка!');
exit;
end;
write('Эйлеров цикл: ');
While l<>nil do
Begin
Write(l^.i,'-');
l:=l^.next;
End;
End;
Begin
readfile;
for i:=1 to N do
begin
count[i]:=0;
for j:=1 to N do if m[i,j] = True then inc(count[i]);
if (count[i] mod 2)<>0 then
begin
writeln('Нет цикла');
readkey;
halt;
end;
end;
stack1:=nil;
stack2:=nil;
Write('Начальная вершина: '); readln(v);
if (v<=N) then Push(v, stack1);
While stack1<>NIL do
Begin
v:=peek(stack1);
i:=1;
While (i<=n) and not m[v,i] do inc(i);
If i<=n then
Begin
u:=i;
Push(u, stack1);
m[v,u]:=False;
m[u,v]:=False;
End
else
Begin
pop(x,stack1);
push(x,stack2)
End;
End;
PrintList(stack2);
readkey;
End.


Материал взят с сайта Всё о Паскале

Комментарии: (0) | Pascal & Delphi | 2006-06-02

Задачи связанные с календарем


Материал подготовил(и): klem4

1) Как вычислить конечную дату ?
Задача: У Васи Пупкина неожиданно сломался компьютер. Из-за отсутствия нужных материалов на ремонт понадобится N дней. Определите дату окончания ремонта, если известно, что компьютер сломался в текущем году, и ремонт должен закончиться тоже в этом году...
Код
Function GetInteger(s: String): Integer;
Var i, Err: Integer;
Begin
If s[1] = '0' Then Delete(s, 1, 1);
Val(s, i, Err); GetInteger := i
End;

Const
CurrYear = 2004;
DayInMonth: Array[1 .. 12] Of Byte =
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);

(*
{ Тестировалось с этими данными }
Const
Repair: Integer = 50;
st: String = '21.06';
*)
Var
Day, Month, DaysBefore: Integer;
p, i: Byte;
Var
Repair: Integer;
st: String;
begin
Inc(DayInMonth[2], Byte((CurrYear mod 4) = 0));
Write('Дата поломки > '); ReadLn(st);
Write('Длительность ремонта > '); ReadLn(Repair);

p := Pos('.', st);
Day := GetInteger( Copy(st, 1, Pred(p)) );
Month := GetInteger( Copy(st, Succ(p), Length(st)-p) );

For i := 1 To Pred(Month) Do
Inc(DaysBefore, DayInMonth[i]);
Inc(DaysBefore, Day);

Inc(DaysBefore, Repair);
i := 1;
While DaysBefore > DayInMonth[i] Do
Begin
Dec(DaysBefore, DayInMonth[i]); Inc(i)
End;
WriteLn('Ремонт закончится: ', DaysBefore, '.', i);
end.

by Volvo

Еще один вариант
Код
program Lab8_02_2;
uses crt,dos;
var
q:char;
data:record
day,year,months:word;
end;
j:integer;
week:word;
m:integer;
g:word;

const
month:array[1..12] of string[7] =
('января','февраля','марта','апреля','мая','июня','июля',
'августа','сентябя','октября','ноября','декабря');
a:array[1..12] of integer =
(31,29,31,30,31,30,31,31,30,31,30,31);

begin
repeat
clrscr;
getdate(data.year,data.months,data.day,week);
g:=data.months;
writeln('Сегодняшняя дата: ',data.day,' ',month[g]);
writeln('введите число m через которое вы хотите узнать дату:');
read(m);
j:=m;
while j<>0 do begin
if j>a[data.months]-data.day then begin
j:=j-(a[data.months]-data.day);
inc(data.months);
data.day:=0;
end

else begin
data.day:=data.day+j; break;
end;
end;

g:=data.months;
writeln('Дата дня и месяц: ',data.day,' ',month[g] );
write('Вычислить еще ?(Y/N)');
q:=ReadKey;
until not (q in ['Y','y']);
end.

by Amro

Материал подготовил(и): klem4

2) Задача про старокитайский календарь
В старокитайском календаре был принят 60-летний цикл состоящий из 5 двенадцатилетних подциклов. Подциклы обозначались названиями цвета:
• Зеленый
• Красный
• Желтый
• Белый
• Черный
Внутри каждого подцикла годы получили название животных:
• Крыса
• Корова
• Тигр
• Заяц
• Дракон
• Змея
• Лошадь
• Овца
• Обезьяна
• Курица
• Собака
• Свинья
(К примеру 1984–год зеленой крысы - был началом очередного цикла). Написать программу, которая вводит номер некоторого года нашей эры и печатает его название по старояпонскому календарю.

var

y : array [0..11] of string =

(
'Rat',
'Cow',
'Tiger',
'Rabbit',
'Dragon',
'Snake',
'Horse',
'Sheep',
'Monkey',
'Chicken',
'Dog',
'Pig'
);

d : array[0..4] of string =

(
'Green',
'Red',
'Yellow',
'White',
'Black'
);


year:Integer;

begin

writeln('Input year'); readln(year);

year := (year mod 60)-4;

If year<0 then year := year+60;

writeln(d[year div 12],' ',y[year mod 12]);

end.

by Idea

Материал подготовил(и): klem4

Модуль для работы с календарем

{
Calendar.pas

Набор функций для работы с датами и вычислений по календарю.
Автор: Виктор Осташев
Fido: 2:5020/1194
E-mail: v_ostashev@chat.ru
WWW: _http://ostashev.newmail.ru
}

function datein(low, high, dt : tdate) : boolean;
{ Проверяет нахождение даты в промежутке между low и high }

procedure stringtodate(st : string; var dt : tdate);
{ Преобразует строку в дату }

procedure datetostring(dt : tdate; var st : string);
{ Преобразует дату в строку }

function compdate(d1, d2 : tdate) : integer;
{
Сравнивает две даты. Возвращает:
0, если даты равны;
-1, если первая дата меньше второй;
1, если вторая дата меньше первой
}

function numofday(dat : tdate; style : tstyle) : longint;
{ Вычисляет условный номер дня для даты dat
с учетом нового стиля при style=true }

function dayofweek(dat : tdate; style : tstyle) : byte;
{ Вычисляет день недели для даты dat с
учетом нового стиля при style=true }

function numinyear(dat : tdate; style : tstyle) : word;
{ Вычисляет номер дня от начала года с учетом стиля }

function lenofmonth(month: byte; year: word; style: tstyle): byte;
{ Вычисляет длину месяца с учетом стиля }

procedure numtodate(num: longint; style: tstyle; var dat: tdate);
{ Вычисляет дату по данному номеру дня }

function isleap(year : integer):boolean;
{ Является ли год високосным }
Комментарии: (0) | Pascal & Delphi | 2006-06-03

Алгоритмы сортировок

Сравнительная скорость работы некоторых нижеприведенных алгоритмов сортировки:


Примечание:
size: размер сортируемой последовательности
n: количество сортировок для замера времени
*: RadixSort в последнем тесте прогонялся при параметрах:
size=21000; n=100

----- ----- ----- ----- ----- -----


1. Пузырьковая сортировка(простым выбором, линейная)

Скачать: [attachmentid=987]
Код
Type
arrType = Array[1 .. n] Of Integer;

Procedure Bubble(Var ar: arrType; n: integer);
Var i, j, T: Integer;
Begin
For i := 1 To n Do
For j := n DownTo i+1 Do
If ar[Pred(j)] > ar[j] Then { < }
Begin
T := ar[Pred(j)]; ar[Pred(j)] := ar[j]; ar[j] := T
End
End;


Реализация пузырьковой сортировки на ассемблере:
Код
procedure BubbleSort(Mas: Pointer; Len: LongWord);
asm
dec Len
@CycleExt:
xor ebx,ebx
mov ecx,Len
mov esi,0
@CycleIn:
mov edi,Mas[esi]
cmp edi,Mas[esi+4]
jg @Exchange
add esi,4
loop @CycleIn
jmp @Check
@Exchange:
mov ebx,Mas[esi+4]
mov Mas[esi+4],edi
mov Mas[esi],ebx
add esi,4
loop @CycleIn
@Check:
cmp ebx,0
je @Exit
jmp @CycleExt
@Exit:

end;


Сложность этого метода сортировки составляет О(n^2)


2. Сортировка простой вставкой

Скачать: [attachmentid=988]
Код
Type
arrType = Array[1 .. n] Of Integer;

Procedure Insert(Var ar: arrType; n: Integer);
Var i, j, T: Integer;
Begin
For i := 1 To n do
Begin
T := ar[i];
j := Pred(i);
While (T < ar[j]) and (j > 0) Do
Begin
ar[Succ(j)] := ar[j]; Dec(j);
End;
ar[Succ(j)] := T;
End;
End;

Сложность О(n^2)


3. Сортировка слияниями
Код
Type
arrType = Array[1 .. n] Of Integer;

Procedure merge(Var ar: arrType; n: Integer);

Procedure Slit( k, q: Integer );
Var
m: Integer;
i, j, T: Integer;
d: arrType;
Begin
m := k + (q-k) div 2;
i := k; j := Succ(m); t := 1;
While (i <= m) and (j <= q) Do
Begin
If ar[i] <= ar[j] Then
Begin
d[T] := ar[i]; Inc(i)
End
Else
Begin
d[T] := ar[j]; Inc(j)
End;
Inc(T)
End;

While i <= m Do
Begin
d[T] := ar[i]; Inc(i); Inc(T)
End;

While j <= q Do
Begin
d[T] := ar[j]; Inc(j); Inc(T)
End;

For i := 1 to Pred(T) Do
ar[Pred(k+i)] := d[i]
End;

Procedure Sort(i, j: Integer);
Var
T: integer;
Begin
If i >= j Then Exit;

If j-i = 1 Then
Begin
If ar[j] < ar[i] Then
Begin
T := ar[i]; ar[i] := ar[j]; ar[j] := T
End
End
Else
Begin
Sort(i, i + (j-i) div 2);
Sort(i + (j-i) div 2 + 1, j);
Slit(i, j)
End;
End;

Begin
Sort(1, n);
End;

Сложность О(n*logn), самая быстрая из сортировок ,но использует в 2 раза больше оперативной памяти.


4. Быстрая сортировка Хоара
Это улучшенный метод, основанный на обмене. При "пузырьковой" сортировке производятся обмены элементов в соседних позициях. При пирамидальной сортировке такой обмен совершается между элементами в позициях, жестко связанных друг с другом бинарным деревом. Ниже будет рассмотрен алгоритм сортировки К. Хоара, использующий несколько иной механизм выбора значений для обменов. Этот алгоритм называется сортировкой с разделением или быстрой сортировкой. Она основана на том факте, что для достижения наибольшей эффективности желательно производить обмены элементов на больших расстояниях.

Предположим, что даны N элементов массива, расположенные в обратном порядке. Их можно рассортировать, выполнив всего N/2 обменов, если сначала поменять местами самый левый и самый правый элементы и так далее, постепенно продвигаясь с двух сторон к середине. Это возможно только, если мы знаем, что элементы расположены строго в обратном порядке.

Рассмотрим следующий алгоритм: выберем случайным образом какой-то элемент массива (назовем его x). Просмотрим массив, двигаясь слева направо, пока не найдем элемент a[i]>x (сортируем по возрастанию), а затем просмотрим массив справа налево, пока не найдем элемент a[j]<x. Далее, поменяем местами эти два элемента a[i] и a[j] и продолжим этот процесс "просмотра с обменом", пока два просмотра не встретятся где-то в середине массива.

После такого просмотра массив разделится на две части: левую - с элементами меньшими (или равными) x, и правую - с элементами большими (или равными) x. Итак, пусть a[k] (k=1,...,N) - одномерный массив, и x - какой-либо элемент из a. Надо разбить "a" на две непустые непересекающиеся части а1 и а2 так, чтобы в a1 оказались элементы, не превосходящие x, а в а2 - не меньшие x.

Рассмотрим пример. Пусть в массиве a: <6, 23, 17, 8, 14, 25, 6, 3, 30, 7> зафиксирован элемент x=14. Просматриваем массив a слева направо, пока не найдем a[i]>x. Получаем a[2]=23. Далее, просматриваем a справа налево, пока не найдем a[j]<x. Получаем a[10]=7. Меняем местами a[2] и a[10]. Продолжая этот процесс, придем к массиву <6, 7, 3, 8, 6> <25, 14, 17, 30, 23>, разделенному на две требуемые части a1, a2. Последние значения индексов таковы: i=6, j=5. Элементы a[1],....,a[i-1] меньше или равны x=14, а элементы a[j+1],...,a[n] больше или равны x. Следовательно,разделение массива произошло. Описанный алгоритм прост и эффективен, так как сравниваемые переменные i, j и x можно хранить во время просмотра в быстрых регистрах процессора. Наша конечная цель - не только провести разделение на указанные части исходного массива элементов, но и отсортировать его. Для этого нужно применить процесс разделения к получившимся двум частям, затем к частям частей, и так далее до тех пор, пока каждая из частей не будет состоять из одного единственного элемента. Эти действия описываются следующей программой. Процедура Sort реализует разделение массива на две части, и рекурсивно обращается сама к себе...


Код
Type
arrType = Array[1 .. n] Of Integer;

{ первый вариант : }
Procedure HoarFirst(Var ar: arrType; n: integer);

Procedure sort(m, l: Integer);
Var i, j, x, w: Integer;
Begin

i := m; j := l;
x := ar[(m+l) div 2];
Repeat

While ar[i] < x Do Inc(i);
While ar[j] > x Do Dec(j);
If i <= j Then
Begin
w := ar[i]; ar[i] := ar[j]; ar[j] := w;
Inc(i); Dec(j)
End

Until i > j;
If m < j Then Sort(m, j);
If i < l Then Sort(i, l)

End;

Begin
sort(1, n)
End;

{ второй вариант : }
Procedure HoarSecond(Var ar: arrType; n: Integer);

Procedure Sort(m, l: Integer);
Var i, j, x, w: Integer;
Begin
If m >= l Then Exit;
i := m; j := l;
x := ar[(m+l) div 2];

While i < j Do
If ar[i] < x Then Inc(i)
Else If ar[j] > x Then Dec(j)
Else
Begin
w := ar[i]; ar[i] := ar[j]; ar[j] := w;
End;
Sort(m, Pred(j));
Sort(Succ(i),l);
End;

Begin
Sort(1, n)
End;

Сложность O(n*logn), на некоторых тестах работает быстрее сортировки слияниями ,но на некоторых специально подобранных работает за O(n^2).


5. Пирамидальная - турнирная- HeapSort сортировка

Код
Type
arrType = Array[1 .. n] Of Integer;

Procedure HeapSort(Var ar: arrType; n: Integer);
Var
i, Left, Right: integer;
x: Integer;

Procedure sift;
Var
i, j: Integer;
Begin
i := Left; j := 2*i; x := ar[i];
While j <= Right Do
Begin
If j < Right Then
If ar[j] < ar[Succ(j)] Then Inc(j);

If x >= ar[j] Then Break;
ar[i] := ar[j];
i := j; j := 2 * i
End;

ar[i] := x
end;

Var T: Integer;
Begin
Left := Succ(n div 2); Right := n;
While Left > 1 Do
Begin
Dec(Left); sift
End;

While Right > 1 Do
Begin
T := ar[ Left ]; ar[ Left ] := ar[ Right ]; ar[ Right ] := T;
Dec(Right); sift
End
End;

Сложность O(n*logn), самая стабильная сортировка, на любых входных данных работает за одинаковое время. Но зато немного медленнее чем слияниями и быстрая.

Материал подготовил(и): volvo

Распределяющая сортировка - RadixSort - цифровая - поразрядная

Пусть имеем максимум по k байт в каждом ключе (хотя за элемент сортировки вполне можно принять и что-либо другое, например слово - двойной байт, или буквы, если сортируются строки). k должно быть известно заранее, до сортировки.
Разрядность данных ( количество возможных значений элементов ) - m, также должна быть известна заранее и постоянна. Если мы сортируем слова, то элемент сортировки - буква, m = 33. Если в самом длинном слове 10 букв, k = 10.
Обычно мы будем сортировать данные по ключам из k байт, m=256.

Пусть у нас есть массив source из n элементов по одному байту в каждом.

Для примера можете выписать на листочек массив source = { 7,9,8,5,4,7,7 }, и проделать с ним все операции, имея в виду m=9.

I. Составим таблицу распределения. В ней будет m ( = 256 ) значений и заполняться она будет так:
Код
for i := 0 to Pred(255) Do distr[i]:=0;
for i := 0 to Pred(n) Do distr[source[i]] := distr[[i]] + 1;


Для нашего примера будем иметь distr = ( 0, 0, 0, 0, 1, 1, 0, 3, 1, 1 ), то есть i-ый элемент distr[] - количество ключей со значением i.

II. Заполним таблицу индексов:

Код
index: array[0 .. 255] of integer;
index[0]:=0;
for i := 1 to Pred(255) Do index[i]=index[i-1]+distr[i-1];


В index[i] мы поместили информацию о будущем количестве символов в отсортированном массиве до символа с ключом i.

Hапример, index[8] = 5 : имеем 4, 5, 7, 7, 7, 8.

А теперь заполняем новосозданный массив sorted размера n:
Код
for i := 0 to Pred(n) Do
  Begin
    sorted[ index[ source[i] ] ]:=source[i];
    { попутно изменяем index уже вставленных символов, чтобы
       одинаковые ключи шли один за другим: }
    index[ source[i] ] := index[ source[i] ] +1;
  End;


Итак, мы научились за O(n) сортировать байты. А от байтов до строк и чисел - 1 шаг. Пусть у нас в каждом числе - k байт.

Будем действовать в десятичной системе и сортировать обычные числа ( m = 10 ).
Цитата
сначала они в сортируем по младшему на один
беспорядке: разряду: выше: и еще раз:
523 523 523 088
153 153 235 153
088 554 153 235
554 235 554 523
235 088 088 554



Hу вот мы и отсортировали за O ( k*n ) шагов. Если количество возможных различных ключей ненамного превышает общее их число, то поразрядная 'сортировка' оказывается гораздо быстрее даже 'быстрой сортировки'!

Реализация алгоритма "распределяющей" сортировки:

Скачать:
Код
Const
n = 8;

Type
arrType = Array[0 .. Pred(n)] Of Byte;

Const
m = 256;
a: arrType =
(44, 55, 12, 42, 94, 18, 6, 67);

Procedure RadixSort(Var source, sorted: arrType);
Type
indexType = Array[0 .. Pred(m)] Of Byte;
Var
distr, index: indexType;

i: integer;
begin
fillchar(distr, sizeof(distr), 0);
for i := 0 to Pred(n) do
inc(distr[source[i]]);

index[0] := 0;
for i := 1 to Pred(m) do
index[i] := index[Pred(i)] + distr[Pred(i)];

for i := 0 to Pred(n) do
begin
sorted[ index[source[i]] ] := source[i];
index[source[i]] := index[source[i]]+1;
end;
end;

var
b: arrType;
begin
RadixSort(a, b);
end.


Материал подготовил(и): klem4

Пузырьковая сортировка с просеиванием

Аналогичен методу пузырьковой сортировки, но после перестановки пары соседних элементов выполняется просеивание: наименьший левый элемент продвигается к началу массива на сколько это возможно, пока не выполняется условие упорядоченности.

Приимущество: простой метод пузырька работает крайне медленно, когда мин/макс (в зависимости от сортировки) элемент массива стоит в конце, этот алгоритм намного быстрее.

Код
const n=10;
var x:array[1..n] of integer;
i,j,t:integer;
flagsort:boolean;

procedure bubble_P;
begin
repeat
flagsort:=true;
for i:=1 to n-1 do
if not(x[i]<=x[i+1]) then
begin
t:=x[i];
x[i]:=x[i+1];
x[i+1]:=t;
j:=i;

while (j>1)and not(x[j-1]<=x[j]) do
begin
t:=x[j];
x[j]:=x[j-1];
x[j-1]:=t;
dec(j);
end;
flagsort:=false;
end;
until flagsort;
end;


Добавлено: Тестировалось на массиве целых чисел (25000 элементов). Прирост скорости относительно простой пузырьковой сортировки - около 75%...

Материал подготовил(и): volvo

Древесная сортировка (TreeSort)

Использует Двоичные (бинарные) деревья, в которых для каждого предшественника выполнено следующее правило: левый преемник всегда меньше, а правый преемник всегда больше или равен предшественнику.
При добавлении в дерево нового элемента его последовательно сравнивают с нижестоящими узлами, таким образом вставляя на место: если элемент >= корня - он идет в правое поддерево, сравниваем его уже с правым сыном, иначе - он идет в левое поддерево, сравниваем с левым, и так далее, пока есть сыновья, с которыми можно сравнить.

Если мы будем рекурсивно обходить дерево по правилу "левый сын - родитель - правый сын", то, записывая все встречающиеся элементы в массив, мы получим упорядоченное в порядке возрастания множество. Hа этом и основана идея сортировки деревом.

Более подробно правило обхода можно сформулировать так: обойти левое поддерево - вывести корень - обойти правое поддерево, где рекурсивная процедура 'обойти' вызывает себя еще раз, если сталкивается с узлом-родителем и выдает очередной элемент, если у узла нет сыновей.

Код
Const n = 8;
Type
TType = Integer;
arrType = Array[1 .. n] Of TType;

Const
a: arrType =
(44, 55, 12, 42, 94, 18, 6, 67);

(* Сортировка с помощью бинарного дерева *)
Type
PTTree = ^TTree;
TTree = Record
a: TType;
left, right: PTTree;
End;

{ Добавление очередного элемента в дерево }
Function AddToTree(root: PTTree; nValue: TType): PTTree;
Begin
(* При отсутствии преемника создать новый элемент *)
If root = nil Then
Begin
root := New(PTTree);
root^.a := nValue;
root^.left := nil;
root^.right := nil;
AddToTree := root; Exit
End;

If root^.a < nValue Then
root^.right := AddToTree(root^.right, nValue)
Else
root^.left := AddToTree(root^.left, nValue);
AddToTree := root
End;


(* Заполнение массива *)
Procedure TreeToArray(root: PTTree; Var a: arrType);
Const maxTwo: Integer = 1;
Begin
(* При отсутствии преемников рекурсия остановится *)
If root = nil Then Exit;

(* Левое поддерево *)
TreeToArray(root^.left, a);
a[maxTwo] := root^.a; Inc(maxTwo);

(* Правое поддерево *)
TreeToArray(root^.right, a);
Dispose(root)
End;

(* Собственно процедура сортировки *)
Procedure SortTree(Var a: arrType; n: Integer);
Var
root: PTTree;
i: Integer;
Begin
root := nil;
For i := 1 To n Do
root := AddToTree(root, a[i]);
TreeToArray(root, a)
End;

Var i: Integer;
Begin
WriteLn('До сортировки:')
For i := 1 To n Do Write(a[i]:4);
WriteLn;

SortTree(a, n);

WriteLn('После сортировки:')
For i := 1 To n Do Write(a[i]:4);
WriteLn
End.


Общее быстродействие метода O(n*logn). Поведение неестественно, устойчивости, вообще говоря, нет.
Основной недостаток этого метода - большие требования к памяти под дерево. Очевидно, нужно n места под ключи и, кроме того, память на 2 указателя для каждого из них.

Поэтому TreeSort обычно применяют там, где:
  1. построенное дерево можно с успехом применить для других задач;
  2. данные уже построены в "дерево";
  3. данные можно считывать непосредственно в дерево. Hапример, при потоковом вводе с консоли или из файла.
Т.е. там, где не требуется дополнительной памяти...

Материал подготовил(и): klem4

Сортировка методом поиска нового номера
, в новый массив:

Краткая теория: Последовательно для каждого элемента массива вычисляется его новая позиция в отсортированном массиве, рассчитывается кол-во элементов , значения которых
1) < значения анализируемого
2) значения которых = значению анализируемого элемента и номера которых <= номера анализируемого.

Особенности: Требуется дополнительный массив, не чувствительный к изначальной упорядоченности.

Оценка числа операций : N*N

type
TArr = array[1..100] of integer;

var
mass1,NewMass : TArr;
n : integer;

{
n-размерность массива, mass1 - исходный массив,
NewMass - удет состоять из отсотртированных элементов массива mass1
}

procedure NewNSort(var mass,Nmass:TArr; size:integer);
var
i,j,NewN : integer;

begin
for i:=1 to size do begin
NewN:=0;
for j:=1 to size do
if (mass[j]<mass[i])or((mass[j]=mass[i])and(j<=i)) then inc(NewN);
Nmass[NewN]:=mass[i];
end;
end;



Пример использования :

NewNSort(mass1,NewMass,n);


Массив NewMassбудет состоять из элементов массива mass1, но уже отсортированный.

На небольших массивах работает неплохо.

Тесты на скорость (в условных единицах):

1. (набор данных - массив из 8 элементов типа integer)

Количество тестов: n = 4 000 000
#1: 292 (метод нового номера)
#2: 558 (сортировка пузырьком)
#3: 490 (поразрядная сортировка - radixsort)

2. (набор данных - массив из 800 элементов типа integer)

Количество тестов: n = 225
#1: 95 (метод нового номера)
#2: 174 (сортировка пузырьком)
#3: 2 (поразрядная сортировка - radixsort)

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


Материал подготовил(и): klem4

Метод последовательного поиска минимумов

Теория: Просматривается весь массив, ищется минимальный элемент и ставится на место первого, "старый" первый элемент ставится на место найденного
type
TArr = array[1..100] of integer;

var
mass1 : TArr;
n : integer;

procedure NextMinSearchSort(var mass:TArr; size:integer);
var
i,j,Nmin,temp:integer;
begin
for i:=1 to size-1 do begin
nmin:=i;
for j:=i+1 to size do
if mass[j]<mass[Nmin] then
Nmin:=j;

temp:=mass[i];
mass[i]:=mass[Nmin];
mass[Nmin]:=temp;
end;
end;


Вызов:
NextMinSearchSort(mass1, n);


Тесты на скорость (в условных единицах):

1. (набор данных - массив из 15 элементов типа integer)

Количество тестов: n = 1 000 000
#1: 159 (метод нового номера)
#2: 127 (поразрядная сортировка - radixsort)
#3: 61 (метод поиска минимумов)

2. (набор данных - массив из 800 элементов типа integer)

Количество тестов: n = 225
#1: 107 (метод нового номера)
#2: 1 (поразрядная сортировка - radixsort)
#3: 25 (метод поиска минимумов)

3. (набор данных - массив из 10000 элементов типа integer)

Количество тестов: n = 9
#1: 597 (метод нового номера)
#2: 2 (поразрядная сортировка - radixsort)
#3: 147 (метод поиска минимумов)
Комментарии: (0) | Pascal & Delphi | 2006-06-07


Страница 2 из 2«12