Unidade de busca
Código
// Desenvolvida por FABIO ANDRIOLI SILVA
// Email: fabio.andrioli@terra.com.br
// Reune os principais metonos de ordenação
// A ordenação e feita por ordem de caracteres, assim serve tanto para ordenaão numerica como de strings
unit MetodosOrd;
interface
type
TVetorCar = array [1..1000] of string;
TOrdem = (Crescente, Decrescente);
TMetodoOrd = class
private
procedure Troca(var Valor1, Valor2:String; troc1,troc2:Integer);
public
procedure InsercaoDireta (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
procedure ShellSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
procedure HeapSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
procedure SelectionSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
procedure BubbleSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
procedure ShakeSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
procedure CombSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
procedure Quicksort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
end;
implementation
uses UMain;
//====================== INSERÇÃO DIRETA ==================
procedure TMetodoOrd.InsercaoDireta (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
var
i,j,k : integer;
ch: string; {ch: chave a ser inserida}
begin
MainForm.nComp :=0;
MainForm.nTroc :=0;
for i:= 2 to nPt do begin {i: posição do elemento a ser inserido}
k:= 1;
j:= i-1;
ch:= VetorCar[i];
While (j >= 1) and (k = 1) do begin {k, j: início do primeiro segmento}
case Ordem of
Crescente: begin
inc(MainForm.nComp);
If (ch < VetorCar[j]) then begin
inc(MainForm.nTroc);
VetorCar[j+1] := VetorCar[j];
j:= j-1;
MainForm.AtualizaTab(0,j+1);
end else
k:= j+1
end;
Decrescente: begin
inc(MainForm.nComp);
If (ch > VetorCar[j]) then begin
inc(MainForm.nTroc);
VetorCar[j+1] := VetorCar[j];
j:= j-1;
MainForm.AtualizaTab(0,j+1);
end else
k:= j+1
end;
end;
end;
VetorCar[k] := ch;
MainForm.AtualizaTab(0,k);
end;
end;
//====================== SHELL SORT ==================
procedure TMetodoOrd.ShellSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
var
gap, i, j, k : integer;
begin
MainForm.nComp :=0;
MainForm.nTroc :=0;
gap := nPt div 2;
while (gap > 0) do begin
for i := (gap + 1) to nPt do begin
j:= i - gap;
while (j > 0) do begin
k:= j+ gap;
inc(MainForm.nComp);
case Ordem of
Crescente: begin //Ordem Crescente
if (VetorCar[j] > VetorCar[k]) then begin
Troca(VetorCar[j],VetorCar[k],j,k);
end else
j:=0;
end;
Decrescente: begin //Ordem Decrescente
if (VetorCar[j] < VetorCar[k]) then begin
Troca(VetorCar[j],VetorCar[k],j,k);
end else
j:=0;
end;
end;
j:= j - gap;
end;
end;
gap := gap div 2;
end;
end;
//====================== HEAP SORT ==================
procedure TMetodoOrd.HeapSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
var
i, left, right : integer;
//------------------------------------------------------------------------------
procedure Heapfy(L, R : LongInt);
var
i, j : LongInt;
x : String;
begin
i := L;
j := 2 * L;
x := VetorCar[i];
case Ordem of
Crescente: begin //Ordem Crescente
if (j < R) and (VetorCar[j + 1] > VetorCar[j]) then
Inc(j);
while (j <= R) and (VetorCar[j] > x) do begin
VetorCar[i] := VetorCar[j];
MainForm.AtualizaTab(i,j);
inc(MainForm.nTroc);
i := j;
j := j * 2;
if (j < R) and (VetorCar[j + 1] > VetorCar[j]) then
Inc(j);
end;
end;
Decrescente: begin //Ordem Decrescente
if (j < R) and (VetorCar[j + 1] < VetorCar[j]) then
Inc(j);
while (j <= R) and (VetorCar[j] < x) do begin
VetorCar[i] := VetorCar[j];
MainForm.AtualizaTab(i,j);
inc(MainForm.nTroc);
i := j;
j := j * 2;
inc(MainForm.nComp,2); //soma a comparação do "while" + "if"
if (j < R) and (VetorCar[j + 1] < VetorCar[j]) then
Inc(j);
end;
end;
end;
inc(MainForm.nComp); //soma ultima comparação do "while"
VetorCar[i] := x;
end;
//------------------------------------------------------------------------------
begin
MainForm.nComp :=0;
MainForm.nTroc :=0;
left := (nPt div 2) + 1;
right := nPt;
while (left > 1) do begin
dec(left);
Heapfy(left,right);
end;
for i := right downto 1 do begin
Troca(VetorCar[1],VetorCar[i],1,i);
Heapfy(1,i - 1);
end;
end;
//====================== SELECTION SORT ==================
procedure TMetodoOrd.SelectionSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
var
i,j,min : integer;
begin
MainForm.nComp :=0;
MainForm.nTroc :=0;
for i:=1 to nPt do begin
min:=i;
for j:=i+1 to nPt do begin
inc(MainForm.nComp);
case Ordem of
Crescente: if VetorCar[j]<VetorCar[min] then
Troca(VetorCar[j],VetorCar[min],j,min);
Decrescente: if VetorCar[j]>VetorCar[min] then
Troca(VetorCar[j],VetorCar[min],j,min)
end;
end;
end;
end;
//====================== BUBLE SORT ==================
procedure TMetodoOrd.BubbleSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
var
i, j : integer;
begin
MainForm.nComp :=0;
MainForm.nTroc :=0;
for i := 1 to nPt do begin
for j := i+1 to nPt do begin
inc(MainForm.nComp);
case Ordem of
Crescente: if VetorCar[i] > VetorCar[j] then
Troca(VetorCar[i],VetorCar[j],i,j);
Decrescente: if VetorCar[i] < VetorCar[j] then
Troca(VetorCar[i],VetorCar[j],i,j);
end;
end;
end;
end;
//====================== SHAKE SORT ==================
procedure TMetodoOrd.ShakeSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
var
i : integer;
Mudou : boolean;
begin
MainForm.nComp :=0;
MainForm.nTroc :=0;
repeat
Mudou:= false;
for i:= 1 to nPt-1 do begin
inc(MainForm.nComp);
case Ordem of
Crescente: if (VetorCar[i] > VetorCar[i+1]) then begin
Troca(VetorCar[i],VetorCar[i+1],i,i+1);
Mudou:= true;
end;
Decrescente: if (VetorCar[i] < VetorCar[i+1]) then begin
Troca(VetorCar[i],VetorCar[i+1],i,i+1);
Mudou:= true;
end;
end;
end;
if Mudou then begin
Mudou:= false;
for i:= nPt downto 2 do begin
inc(MainForm.nComp);
case Ordem of
Crescente: if (VetorCar[i] < VetorCar[i-1]) then begin
Troca(VetorCar[i],VetorCar[i-1],i,i-1);
Mudou:= true;
end;
Decrescente: if(VetorCar[i] > VetorCar[i-1]) then begin
Troca(VetorCar[i],VetorCar[i-1],i,i-1);
Mudou:= true;
end;
end;
end;
end;
until not Mudou; //até não mudou
end;
//====================== COMB SORT ==================
procedure TMetodoOrd.CombSort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
var
gap, i,j : integer;
begin
gap:= trunc(nPt/1.33);
While not (gap < 1) do begin
for i := 1 to (nPt - gap) do begin
j := i + gap;
inc(MainForm.nComp);
case Ordem of
Crescente: if VetorCar[i] > VetorCar[j] then
Troca(VetorCar[i],VetorCar[j],i,j);
Decrescente: if VetorCar[i] < VetorCar[j] then
Troca(VetorCar[i],VetorCar[j],i,j);
end;
end;
gap:= trunc(gap/1.33);
end;
end;
//====================== QUICK SORT ==================
procedure TMetodoOrd.Quicksort (var VetorCar: TVetorCar ; nPt: integer ; Ordem: TOrdem);
//------------------------------------------------------------------------------
procedure PartialSortC(left, right : integer; var VetorCar: TVetorCar);
var
l,r : integer;
mid : string;
begin
l:= left;
r:= right;
mid:= VetorCar[(l+r) div 2];
repeat
case Ordem of
Crescente:
begin
while (VetorCar[l] < mid) do begin
inc(l);
inc(MainForm.nComp);
end;
while (mid < VetorCar[r]) do begin
dec(r);
inc(MainForm.nComp);
end;
end;
Decrescente:
begin
while (VetorCar[l] > mid) do begin
inc(l);
inc(MainForm.nComp);
end;
while (mid > VetorCar[r]) do begin
dec(r);
inc(MainForm.nComp);
end;
end;
end;
inc(MainForm.nComp,2); //Comparaçoes dos "While"
if (l <= r) then begin
if (l<>r) then
Troca(VetorCar[l],VetorCar[r],l,r);
inc(l);
dec(r);
end;
until (l > r);
if (left < r)then
PartialSortC(left,r,VetorCar);
if (l < right)then
PartialSortC(l,right,VetorCar);
end;
//------------------------------------------------------------------------------
begin
MainForm.nComp :=0;
MainForm.nTroc :=0;
PartialSortC(1,nPt,VetorCar);
end;
procedure TMetodoOrd.Troca(var Valor1, Valor2:String; troc1,troc2:Integer);
var aux: string;
begin
aux := Valor1;
Valor1:= Valor2;
Valor2:= aux;
inc(MainForm.nTroc);
MainForm.AtualizaTab(troc1,troc2);
end;
end.
Publicidade
Vote na dica
Quantidade de votos: 0 votos
Aceitação: 0%
Detalhes da dica
Adicionada dia: 12/06/08
Por: Fabio
Visualizada: 5072 vezes
Publicidade
Enquete
O que achou do novo site?
Planeta Delphi - www.planetadelphi.com.br - Todos os direitos reservados | Copyright 2001-2009