Сортировка

{ сортировка пузырьковым методом}

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; { конец поиска }

Методы программрования: переборные алгоритмы

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

Основные идеи первого задания - ПЕРЕБОР, РЕКУРСИЯ, ПЕРЕБОР С ОТХОДОМ HАЗАД. Этими понятиями должен хорошо владеть каждый программист. Кроме того, переборные задачи составляют значительную долю всех школьных олимпиад по информатике.