tpu/u_orden2.pas

{ ppc386 -va -vh *.pas }
{ COMIENZO DE DESCRIPCION

  Unidad para clasificar (u ordenar) un vector de enteros 
  de menor a mayor, mediante los m\'etodos de: BURBUJA, 
  INSERCION, SELECCION, SHELL, MONTICULO y RAPIDO.
  keywords: clasificacion

FIN DE DESCRIPCION }
{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
{ $Id: u_orden2.pas,v 1.1 2002/04/25 15:57:09 mstorti Exp mstorti $}

unit u_orden2 ;

interface

const 
  n    = 10 ;
  nada = ' ';
type
  t_dato = integer ;
  OBJ = object
  private
    v : array [1..n] of t_dato ;
  private
    procedure  ERROR  (s: string);
    procedure  INTER  (var x, y: t_dato);
    procedure  EMPUJA (p, u: integer);
    function   BUS_PIVOT (i,j: integer): integer ;
    function   PARTICION (i,j: integer; pivot: t_dato):integer;
  public
    procedure  INI_VECTOR ; 
    procedure  DIS_VECTOR (s : string);
    procedure  ORD_BURBUJA ;
    procedure  ORD_INSERCION ;
    procedure  ORD_SELECCION ;
    procedure  ORD_SHELL ; 
    procedure  ORD_MONTICULO ;
    procedure  ORD_RAPIDO (i, j: integer); 
  end ;

implementation

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure OBJ.ERROR (s : string);
begin
  writeln ('error: ',s);
  halt;
end;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure  OBJ.INTER (var x, y : t_dato ) ;
var
  t : t_dato ;
begin 
  t := x ;
  x := y ;
  y := t ;
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
{ para clasificar de menor a mayor se ordena parcialmente V }
{ en forma maximal (el nodo padre es mayor que sus hijos    }
{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure OBJ.EMPUJA (p, u: integer);
var {entran cursores: p: primero ; q : ultimo }
  i1, i2, q, r : integer ;
begin
  r := p ; {indica posicion actual de V [primero] }
  q := u div 2 ;
  while (r <= q ) do begin
    i1 := 2 * r ;
    i2 := 2 * r + 1 ;
    if      (u = i1) then { r tiene un hijo en 2r }
      begin
      if ( v [r] < v [i1]) then INTER ( v [r], v [i1] ) ;
      r := u ;
      end
    else if ( v [r] < v [i1]) and (v [i1] >= v [i2]) then 
      begin {r tiene 2 hijos e intercambia r con h_izq}
      INTER ( v [r], v [i1] ) ;
      r := i1 ;
      end
    else if ( v [r] < v [i2]) and (v [i2] >  v [i1]) then 
      begin {r tiene 2 hijos e intercambia r con h_der}
      INTER (v [r], v [i2] ) ;
      r := i2 ;
      end
    else begin {r NO viola propiedad parcialmente ordenado}
      r := u ; {para forzar la terminacion del lazo}
    end ; {if}
  end ; {while}
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
function OBJ.BUS_PIVOT (i,j: integer): integer;
var
  a    : t_dato ;
  k    : integer ;
  siga : boolean ;
begin
  a         := v [i] ;
  siga      := true ;
  BUS_PIVOT := 0 ;
  k         := i + 1 ;
  while ( k <= j ) and (siga) do begin
    if      ( v [k] > a ) then
      begin
      BUS_PIVOT := k ;
      siga      := false ;
      end
    else if ( v [k] < a ) then begin
      BUS_PIVOT := i ;
      siga      := false ;
    end ;
    k := k + 1 ;
  end ; {while}
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
function OBJ.PARTICION (i,j: integer; pivot: t_dato):integer;
var
  z, d : integer ;
begin
  z := i ;
  d := j ;
  repeat
    INTER ( v [z], v [d] );
    while ( v [z] <  pivot) do  z := z + 1 ;
    while ( v [d] >= pivot) do  d := d - 1 ;
  until ( z > d ) ;
  PARTICION := z ;
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure OBJ.INI_VECTOR ;
var
  max_2 : t_dato ;
  k     : t_dato ;
begin
  max_2 := (n) div 2 ;
  randomize ;
  for k := 1 to (n) do v [k] := random (max_2) ;
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure OBJ.DIS_VECTOR (s : string);
var 
  k : integer ;
begin
  writeln ;
  writeln (s);
  for k := 1 to (n) do write (nada, v [k] ) ;
  writeln ;
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure OBJ.ORD_BURBUJA ;
var
  i, j : integer ;
begin 
  for i := 1 to  (n - 1) do begin
    for j := n downto (i + 1) do begin
      if  (v [j] < v [j - 1]) then INTER (v [j], v [j-1]) ;
    end ; {j}
  end ; {i}
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure OBJ.ORD_INSERCION ;
var
  i, j : integer ;
begin 
  for i := 2 to  (n) do begin
    j := i ;
    while (j > 1) and (v [j] < v [j - 1]) do begin
      INTER ( v [j], v [j-1] ) ;
      j := j - 1 ;
    end ; {while}
  end ; {i}
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure OBJ.ORD_SELECCION ;
var  {1ro busca el menor de todos, luego el sgte menor, ...} 
  i, j : integer ;
begin 
  for i := 1 to  (n - 1) do begin
    for j := (i + 1)  to (n) do begin
      if  ( v [j] < v [i] ) then INTER ( v [j], v [i] ) ;
    end ; {j} { ahora v [i] es el sucesor de v [i-1] }
  end ; {i}
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure  OBJ.ORD_SHELL ;
var 
  i, j, h : integer ;
begin
  h := n div 2 ;
  while (h > 0) do begin
    for i := (h + 1) to (n) do begin
      j := i - h ;
      while (j > 0) do begin
        if  ( v [j + h] >= v [j] ) then
          j := 0 
        else begin
          INTER ( v [j], v [j+h] ) ;
          j := j - h ;
        end ; {if}
      end ; {while}
    end ; {i}
    h := h div 2 ;
  end ; {while}
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure  OBJ.ORD_MONTICULO ;
var 
  i, j : integer ;
begin
  j := n div 2 ;
  for i := j downto (1) do begin {inicia propiedad de arbol}
    EMPUJA (i,n) ;
  end ; {i}
  for i := n downto (2) do  begin
    INTER ( v [1], v [i] ) ; {elimina el maximo del frente}
    EMPUJA (1, i-1) ;        {restablece propiedad arbol}
  end ; {i}
end ;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure  OBJ.ORD_RAPIDO (i, j: integer); 
var 
  k, p   : integer ;
  pivote : t_dato ;
begin
  p := BUS_PIVOT (i,j);
  if  ( p <> 0 ) then begin
    pivote := v [p] ;
    k := PARTICION (i,j,pivote);
    ORD_RAPIDO (i,k-1); 
    ORD_RAPIDO (k,j); 
  end ; {if}
end ;

end . {unit orden2}
{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}