tpu/u_liscrf.pas

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

  Listas de reales por cursores, con celdas de
  encabezamiento y cursores al final (mucho mejor
  que 'u_listcr'). keywords: lista, cursores

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

unit u_liscrf ;

interface

const
  maxlen = 100 ; {longitud del arreglo de cursores}
  nyl    =   0 ; {equivalente del nil en punteros}
type
  tipo_elemento = real ;
  posicion = 1..maxlen; {cursor en rango admisible}
  L        = 1..maxlen; {lista  en rango admisible}

  t_espacio = array [1..maxlen] of record 
    elemento : tipo_elemento;
    sig      : posicion
  end;

var
  espacio : t_espacio ;
  disp    : posicion ;

procedure INICIALIZA_NODOS (var espacio : t_espacio) ;

type

  liscrf = object
  private
   { 'ant' apunta a la celda de encabezamiento, 'post' }
    ant, post : posicion ;
    procedure ERROR (s: string);
    function  MUEVE (var p, q : posicion): boolean ;
  public
    procedure INSERTA   (x: tipo_elemento; p: posicion);
    function  LOCALIZA  (x: tipo_elemento): posicion;
    function  RECUPERA  (p: posicion) : tipo_elemento;
    procedure SUPRIME   (var p: posicion);
    function  SIGUIENTE (p: posicion): posicion;
    function  ANTERIOR  (p: posicion): posicion;
    function  PRIMERO : posicion;
    procedure ANULA ;
    function  FIN     : posicion;
    procedure IMPRIME (s : string) ;
  end;			    

implementation

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

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure INICIALIZA_NODOS (var espacio : t_espacio) ;
var
  i : posicion ;
begin
  for i := (maxlen - 1) downto 1 do begin
    espacio [i].sig := i + 1 ;
  end ; {for}
  disp := 1 ;
  espacio [maxlen].sig := 0 ;
end ; {INICIALIZA_NODOS}

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
function liscrf.MUEVE (var p, q : posicion) : boolean ;
var { coloca la celda apuntada por p adelante de q}
  t : posicion;
begin
  MUEVE := false ;
  if ( p = nyl ) then
    writeln ('celda inexistente')
  else begin
    MUEVE := true ;
    t := q ;
    q := p ;
    p := espacio [q].sig ; 
    espacio [q].sig := t ;
  end ; {if}
end; {MUEVE}

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure liscrf.INSERTA (x : tipo_elemento; 
			  p : posicion);
var
  q : posicion;
begin	    
  if not MUEVE (disp, espacio [p].sig) then begin
      ERROR ('no puede alocar nueva celda');
  end ; {if}
  { hace q : = cursor a la celda donde esta el dato }
  q := espacio [p].sig;
  espacio [q].elemento := x;
  if (espacio [q].sig = nyl) then post := q;
end; {INSERTA}

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
function liscrf.LOCALIZA (x: tipo_elemento): posicion;
var
  p : posicion;
begin { Esta version es independiente de la implementacion}
  p := PRIMERO ;
  while (p <> FIN) do begin
    if (RECUPERA (p) = x) then break ;
    p := SIGUIENTE (p);
  end ; {while}
  LOCALIZA := p;
end; {LOCALIZA}

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
function liscrf.RECUPERA (p: posicion): tipo_elemento;
var
  q : posicion;
begin
  q := espacio [p].sig;
  RECUPERA := espacio [q].elemento ;
end; {RECUPERA}

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure liscrf.SUPRIME (var p: posicion);
begin 
  if not MUEVE (espacio [p].sig, disp) then begin
    ERROR ('No puede liberar celda');
  end ; {if}
  if ( espacio [p].sig = nyl) then post := p;
end; {SUPRIME}

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
function liscrf.SIGUIENTE (p: posicion): posicion;
begin
  SIGUIENTE := espacio [p].sig;
end; {SIGUIENTE}

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
function liscrf.ANTERIOR (p: posicion): posicion;
var
  q : posicion;
begin {Esta version es independiente de la implementacion }
  if (p = primero) then begin
    ERROR ('No se puede dar la posicion anterior a primero');
  end ; {if}
  q := PRIMERO ;
  while (q <> FIN) do begin
    if ( SIGUIENTE (q) = p ) then break;
  end ; {while}
  ANTERIOR := p;
end; {ANTERIOR}

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure liscrf.ANULA ;
var 
   p : posicion;
begin
  if (ant = nyl) then MUEVE (disp, ant);
  p := espacio [ant].sig;
  while (p <> nyl) do begin
    MUEVE (p, disp);
    p := espacio [p].sig
  end ; {while}
  post := ant;
end; {ANULA}

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
function liscrf.PRIMERO : posicion;
begin
  PRIMERO := ant;
end; {PRIMERO}

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
function liscrf.FIN : posicion;
begin
  fin := post;
end;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure liscrf.IMPRIME (s : string) ;
var
  q : posicion;
begin
  if length (s) > 0 then writeln (s);
  write   ('imprime lista: ');

  q := PRIMERO ;
  while (q <> FIN) do begin
    writeln ( RECUPERA (q) );
    q := SIGUIENTE (q);
  end; {while}
  writeln ;
end; {IMPRIME}

end.
{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}