Примеры

В приведенном ниже примере берется массив случайных чисел; массив сортируется, после чего с применением  2-х методов поиска ( метод половинного деления и  метод простого перебора ) осуществляется поиск элемента x. 

program pr1;{ программа поиска }
uses crt;
const max=100;
type feld=array[1..max] of integer;
var f:feld;
x:integer;

procedure binaersuchen(x:integer;f:feld);
(* Поиск методом половинного деления.
Массив должен быть отсортирован. *)
var i,rechts,links,mitte:integer;
found:boolean;
begin
links:=1; rechts:=max;
repeat mitte:=(links+rechts) div 2;
if x else links:=mitte+1;
found:=x=f[mitte];
until found or (links>rechts);
if found
then
begin
write(x:3,'при i=',mitte:3);
writeln(' успешный поиск');
end
else writeln(x:3,' безрезультатный поиск');
end; (* по методу половинного деления *)

procedure feld_anlegen(var f:feld);
var i:integer;
begin
for i:=1 to max do f[i]:=random(99)+1;
end;  { заполнение массива }

procedure druckfeld(f:feld);
var i:integer;
begin
for i:=1 to max do write(f[i]:4);
writeln;
end;  { поле печати }

procedure ksuchen(x:integer; f:feld);
(* Простой перебор сверху вниз *)
var i:integer;
found:boolean;
begin
i:=1; found:=false;
while (i<=max) and not found do
begin
found:=x=f[i];
inc(i);
end;
if found
then writeln(x:3,'при i=',i-1:3,'элемент найден')
else writeln(x:3,'элемент не найден');
end;   (* поиск *)

procedure sortiere(var f:feld);
var i,j,hilf:integer;
begin
(* Здесь просто сравниваются два соседних элемента
и соответствующим образом меняются местами (см.
следующий пример); это простейший, но к сожале-
нию, малоэффективный метод сортировки *)
for i:=1 to max-1 do
for j:=i+1 to max do
if f[j] begin
hilf:=f[i];
f[i]:=f[j];
f[j]:=hilf;
end;
end; { сортировка }

begin  (********** Исполняемая часть **********)
feld_anlegen(f);
druckfeld(f);
sortiere(f);
druckfeld(f);
writeln('Какое число искать? (Конец=0)');
readln(x);
while x0 do begin
ksuchen(x,f);
binaersuchen(x,f);
write('Какое число');
writeln(' искать?');
readln(x);
end;
end.


Центральной проблемой обработки данных является сортировка множества данных. Существует большое число методов сортировки. Следующий пример демонстрирует три элементарных способа поиска, добавления и замены элементов массива с некоторыми их модификациями ( heapsort, shellsort, quicksort ).


(* Здесь приведено три наиболее распространенных алгоритма,
применяемых при сортировке массива: перебор, добавление,
замена. Реализуется основной принцип сортировки. Каждый
способ допускает модификацию. Они известны
для: перебора           как heapsort
добавления             shellsort
замены                 quicksort
Частично отсортированный массив состоит из:
выходной последовательности =
уже отсортированный кусок в начале массива;
исходной последовательности =
не отсортированный кусок в конце массива. *)


program pr2;
{программа сортировки}
uses crt;
const n=1000;
type feld=array[-9..n] of integer;
(* -9 по методу shellsort *)
var a:feld;
anz,nr:integer;

procedure eingabe(var f:feld);
var i:integer;
begin
for i:=1 to anz do f[i]:=random(99)+1;
end;  (* Ввод *)

procedure druckfeld(f:feld);
(* Выдаются первые 20 элементов *)
var i:integer;
begin
for i:=1 to 20 do write(f[i]:4); writeln;
end;  (* Поле печати *)

procedure austausch(var a:feld);
(* Последовательно сравниваются между собой два соседних
элемента и соответствующим образом меняются местами.
Это самый примитивный способ сортировки ( называемый
также пузырьковым методом или методом британского музея).*)

var i,j,x:integer;
begin (*Прямая замена*)
for i:=2 to anz do
for j:=anz downto i do
if a[j-1]>a[j] then (* поменять местами *)
begin
x:=a[j-1];
a[j-1]:=a[j];
a[j]:=x;
end;
end;  (* Замена *)

procedure quicksort(var a:feld);
(* Число операций перемены местоположения элементов внутри
массива значительно сократится, если менять местами да-
леко отстоящие друг от друга элементы. Для этого выбира-
ется для сравнения один элемент x ( наиболее целесообразно
выбрать элемент из середины массива), отыскивается слева
первый элемент, который не меньше x, а справа первый эле-
мент, который не больше x. Найденные элементы меняются
местами. После первого же прохода все элементы, которые
меньше x, будут стоять слева от x, а все элементы, кото-
рые больше x,- справа от x. С двумя половинами массива
поступают точно так же. Из-за такой рекурсии метод оформ-
ляется как процедура. *)

procedure quicks(links,rechts:integer);
var i,j,x,w:integer;
begin
i:=links; j:=rechts;
x:=a[(links+rechts) div 2];
repeat
while a[i] while x if i<=j then
begin
w:=a[i]; a[i]:=a[j]; a[j]:=w;
i:=i+1; j:=j-1;
end;
until i>j;
if links if iend;  (* quicks *)

(* Работа с алгоритмом заключается тогда в серии
отдельных обращений *)
begin
quicks(1,anz);
end;  (* quicksort *)

procedure einfuegen(var a:feld);
(* Из исходной последовательности берется следующий элемент
и добавляется в выходной массив, причем для него с шагом
1 ищется соответствующее место, начиная с конца массива. *)
var i,j,x:integer;
begin (* Непосредственное добавление *)
for i:=2 to anz do
begin
x:=a[i]; a[0]:=x; j:=i-1;
while x begin
a[j+1]:=a[j];
j:=j-1;
end;
a[j+1]:=x;
end;
end;  (* Добавление *)

procedure shellsort(var a:feld);
(* Алгоритм добавления выполняется t раз с уменьшающимся
каждый раз шагом s[1], s[2], ..., s[t] для "следующего
x". Пусть s[1]=anf, а s[t]=1. Для того, чтобы установить
конечную метку для добавления, нужно массив a сначала
продлить на начальную длину шага anf. Итак, нужно задать
type feld = array[-anf..n] of integer;
Для выбора шага рекомендуется, например, 40, 13, 4, 1
или 31, 15, 7, 3, 1 или 9, 5, 4, 1 *)
var s:array[1..4] of integer;
marke,m,t,i,j,k,x:integer;
begin  (* shellsort *)
t:=4; s[4]:=1; s[3]:=3; s[2]:=5; s[1]:=9;
for m:=1 to t do
begin
k:=s[m]; marke:=-k;
for i:=k+1 to anz do
begin
x:=a[i];
j:=i-k;
if marke=0 then marke:=-k;
marke:=marke+1;
a[marke]:=x;
while x begin
a[j+k]:=a[j]; j:=j-k;
end;
a[j+k]:=x;
end;
end;
end;  (* shellsort *)

procedure auswahl(var a:feld);
(* Из исходной последовательности выбираются те элементы,
которые следует добавить в конец выходной последователь-
ности *)
var i,j,k,x:integer;
begin  (* Прямой выбор *)
for i:=1 to anz-1 do
begin
k:=i; x:=a[i];
for j:=i+1 to anz do
{ В оставшейся части ищется наименьший элемент }
if a[j] begin
k:=j;
x:=a[j];
end;
a[k]:=a[i]; a[i]:=x;
end;
end;  (* Перебор *)

procedure heapsort(var a:feld);
(* При выборе сохраняется появляющаяся по пути информация
о соотношениях между элементами ( теряющаяся при прямом
переборе), так что следующий шаг выбора значительно сок-
ращается. Согласно предварительному условию о том, что
место в памяти должно использоваться лишь для хранения
a, весь массив a предварительно упорядочивается таким
образом, чтобы всеми элементами выполнялись следующие
соотношения:
a[i]>=a[2i] для всех i=1, ..., n/2
a[i]>=a[2i+1]
Упорядоченный таким образом массив называется "кучей"
(heap - динамическая область). Вначале в состояние "ку-
чи" приводится левая половина массива a. Затем берется
первый элемент справа ( поскольку он имеет наибольшее
значение ), правая граница сдвигается влево на единицу
и остальной массив вновь отфильтровывается, чтобы опять
получить "кучу". Затем повторяется тот же процесс. Итак,
в отличие простого перебора выходная последовательность
формируется справа. *)

var rechts,links,x:integer;
procedure sieb;
(* Массив a, как и переменные links,rechts
является глобальным *)
var i,j:integer;
begin
i:=links; j:=2*i; x:=a[i];
while j<=rechts do
begin
if j if a[j] if x begin
a[i]:=a[j]; i:=j;
j:=2*i;
end
else j:=rechts+1;
end;
a[i]:=x;
end;  (* Фильтрация *)

begin  (* heapsort *)
rechts:=anz;
for links:=(anz div 2) downto 1 do sieb;
(* В результате получим массив в форме "кучи" *)
(* Теперь начнем сортировать *)
while rechts>1 do
begin
links:=1;
x:=a[links];
a[links]:=a[rechts];
a[rechts]:=x;
rechts:=rechts-1;
sieb;
end;
end;  (* heapsort *)

begin (********** Исполняемая часть **********)
write('Сколько элементов (<=1000):');
readln(anz);
eingabe(a);
clrscr;
druckfeld(a);
writeln(anz:50);
writeln ('Какой метод?');
writeln ('1=einfuegen');
writeln ('2=shellsort');
writeln ('3=auswaehlen');
writeln ('4=heapsort');
writeln ('5=austauschen');
writeln ('6=quicksort');
readln(nr);
writeln('Внимание:'); delay(500); write(^g);

case nr of
1: einfuegen(a);
2: shellsort(a);
3: auswahl(a);
4: heapsort(a);
5: austausch(a);
6: quicksort(a);
else writeln('Ничего не нужно'); end;
write(^g);
writeln('Выполнить с сортировкой:');
druckfeld(a);
end.

Здесь будут считаны n чисел и отсортированы в соответствии с таблицей ASCII ( таблица кодов ).


program pr3;
{ Программа сортировки строк }
uses crt;
const n=10;
type feld=array[1..n] of string[10];
var z:feld;

procedure lies(var a:feld);
var i:integer;
begin
clrscr;
for i:=1 to n do
begin
write('слово: ',i:2,'  '); readln(a[i]);
end;
end;   (* Считывание *)

procedure drucklinks(f:feld);
(* Выдается массив слов, выравненных по левому краю *)
var i:integer;
begin
for i:=1 to n do writeln(f[i]);
end;  (* Печать *)

procedure druckrechts(f:feld);
(* Выдается массив слов, выравненных по правому краю *)
var i:integer;
begin
for i:=1 to n do writeln(f[i]:10);
end;   (* Печать *)

procedure sortieren(var a:feld);
var i,j:integer;
x:string[10];
begin (* Прямой перебор *)
for i:=2 to n do
for j:=n downto i do
if a[j-1]>a[j] then  (* Перемена местами *)
begin
x:=a[j-1];
a[j-1]:=a[j];
a[j]:=x;
end;
end;    (* Сортировка *)

begin (********** Исполняемая часть **********)
lies(z);
writeln('до сортировки:');
drucklinks(z);
sortieren(z);
writeln(^j'после сортировки:');
druckrechts(z);
end.