unit ubtree;

{$mode delphi}

interface

uses
  Classes, SysUtils;

type
  // Direcciones para navegación de un árblo binario
  TDirBTree = (FromUp, FromIzq, FromDer);

  TItemBTree = pointer;

  { TNodoBtree }
  TNodoBtree = class
    izq, sup, der: TNodoBTree;
    item: TItemBTree;
    constructor Create(izq, sup, der: TNodoBTree; item: TItemBTree);
    destructor Destroy; override;
  end;

  TCompareProc = function( a, b: TItemBTree ): integer of Object;

  { TBTree }
  TBTree = class
    raiz: TNodoBTree;
    flgAdmitirRepetidos: boolean;
    Count: integer;
    CompareProc : TCompareProc;

    constructor Create( flgAdmitirRepetidos: boolean; aCompareProc: TCompareProc = nil );

    // Si aCompareProc = nil, es obligatorio reescribir el método Compare.

    // Compare impone el orden entre los individuos y debe ser definida
    // en una clase refinada de TBTree para poder usar esta clase
    //  -1 =  b < a ; 0 = b = a ; 1 = b > a
    function Compare(a, b: TItemBTree): integer; virtual;

    // resCod = 0, indica que fue insertado,
    // resCod = 2 es duplicado y no se inserto
    // en ambos casos retorna el Nodo del árbol.
    function insert(a: TItemBTree; out ResCod: integer): TNodoBTree; virtual;

    // inserta a partir del Nodo
    function insertInNodo(var nodo: TNodoBTree; a: TItemBTree): integer;

    // busca el primer individuo tal que comparar( result, a ) = 0
    // y retorna el nodo o NIL si no lo encuentra.
    function locate_key(a: TItemBTree): TNodoBTree;

    // elimina el Nodo
    procedure Delete(a: TNodoBTree);


    // retorna el primer elemento del árbol en la lista ordenada.
    // si retoran NIL el árbol está vacío.
    procedure First( var cursor: TNodoBTree );

    // retorna el siguiente elemento del árbol en la lista ordenada.
    // si retorna NIL se llegó al final.
    procedure Next( var cursor: TNodoBTree );


    procedure Clear; virtual;
    destructor Destroy; override;
  private

    // si resCod = -1 cursor = izq
    // si resCod = 0 cursor = self  (insertado)
    // si resCod = 1 cursor = der
    procedure insert_repetidos(var cursor: TNodoBTree; a: TItemBTree;
      var resCod: integer);

    // si resCod = -1 cursor = izq
    // si resCod = 0 cursor = self  (insertado)
    // si resCod = 1 cursor = der
    // si resCod = 2 cursor = self (duplicado - no insertado)
    function insert_unique(var cursor: TNodoBTree; a: TItemBTree;
      var resCod: integer): TNodoBTree;


    // resCod = 0 implica que cursor tiene el Item con la misma key que a
    // resCod = -1 y 1 indica que a está a la izquierda o a la derecha del cursor devuelto
    // resCod = -2 y 2 indica que a está a la izquierda o derecha del cursor devuelto, pero
    //          que el árbol se termina en esa dirección.
    procedure locate_step(var cursor: TNodoBTree; a: TItemBTree;
      var resCod: integer);

    // retorna el siguiente elemento del árbol en el sentido de dir y modifica dir
    // retorna NIL si no quedan elementos por visitar.
    // Cuando dir = FromIzq corresponde ejecutar la acción para la que se recorre
    // el arbol.
    procedure Next_step(var cursor: TNodoBTree; var dir: TDirBTree);

    // inicializa cursor = raiz y dir = FromUP
    procedure First_step( out cursor: TNodoBTree; out dir: TDirBTree);

  end;


  { Utilidad para recorr linealmente el árbol }
  { TCursorBTree }

  TCursorBTree = class
    BTree: TBTree;
    cursor: TNodoBtree;
    dir: TDirBTree;

    constructor Create(aBTree: TBTree);
    function FirstNodo: TNodoBtree;
    function NextNodo: TNodoBtree;

    function EndOfItems: boolean;
    function FirstItem: TItemBTree;
    function NextItem: TItemBTree;

    // hace un recorrido del árbol en búsqueda del nodo que tiene
    // el item dado.
    function locateNodoByItem(aItem: TItemBTree): TNodoBtree;
  end;


implementation

{ TCursor }

constructor TCursorBTree.Create(aBTree: TBTree);
begin
  BTree := aBTree;
  cursor := nil;
end;

function TCursorBTree.FirstNodo: TNodoBtree;
begin
  BTree.First(cursor);
  Result := cursor;
end;

function TCursorBTree.NextNodo: TNodoBtree;
begin
  BTree.Next(cursor);
  Result := cursor;
end;

function TCursorBTree.EndOfItems: boolean;
begin
  Result := cursor = nil;
end;

function TCursorBTree.FirstItem: TItemBTree;
begin
  FirstNodo;
  if cursor <> nil then
    Result := cursor.item
  else
    Result := nil;
end;

function TCursorBTree.NextItem: TItemBTree;
begin
  NextNodo;
  if cursor <> nil then
    Result := cursor.item
  else
    Result := nil;
end;

function TCursorBTree.locateNodoByItem(aItem: TItemBTree): TNodoBtree;
var
  cursor: TNodoBTree;
begin
  cursor := FirstNodo;
  while (not EndOfItems) and (cursor.item <> aItem) do
    cursor := NextNodo;
  Result := cursor;
end;


{ TBTree }

constructor TBTree.Create(flgAdmitirRepetidos: boolean;
  aCompareProc: TCompareProc);
begin
  Count := 0;
  raiz := nil;
  self.flgAdmitirRepetidos := flgAdmitirRepetidos;
  CompareProc:= aCompareProc;
end;

function TBTree.Compare(a, b: TItemBTree): integer;
begin
  if Assigned( CompareProc ) then
    result:= CompareProc( a, b )
  else
    raise Exception.Create('BTree -  falta definir una función de comparación' );
end;

function TBTree.insert(a: TItemBTree; out ResCod: integer): TNodoBTree;
var
  cursor: TNodoBtree;
begin
  if raiz = nil then
  begin
    raiz := TNodoBtree.Create(nil, nil, nil, a);
    resCod := 0;
    Result := raiz;
    Count := 1;
    exit;
  end;

  cursor := raiz;

  resCod := InsertInNodo(cursor, a);

  if rescod = 0 then
    Inc(Count);

  Result := cursor;
end;

function TBTree.insertInNodo(var nodo: TNodoBTree; a: TItemBTree): integer;
var
  resCod: integer;

begin
  if flgAdmitirRepetidos then
    repeat
      insert_repetidos(nodo, a, resCod);
    until abs(resCod) <> 1
  else
    repeat
      insert_unique(nodo, a, resCod);
    until abs(resCod) <> 1;
  result:= resCod;
end;


function TBTree.locate_key(a: TItemBTree): TNodoBTree;
var
  cursor: TNodoBTree;
  resCod: integer;
begin
  if raiz = nil then
  begin
    result:= nil;
    exit;
  end;

  cursor:= raiz;
  repeat
    // resCod = 0 implica que cursor tiene el Item con la misma key que a
    // resCod = -1 y 1 indica que a está a la izquierda o a la derecha del cursor devuelto
    // resCod = -2 y 2 indica que a está a la izquierda o derecha del cursor devuelto, pero
    //          que el árbol se termina en esa dirección.
    locate_step( cursor, a, resCod );
  until abs( resCod ) <> 1;

  if resCod = 0 then
    Result:= cursor
  else
    Result:= nil;
end;

procedure TBTree.Delete(a: TNodoBTree);
var
  NodoSuperior, c: TNodoBTree;

  procedure linkSup(nodo: TNodoBTree);
  begin
    if NodoSuperior = nil then // a es la raíz
      raiz := nodo
    else if NodoSuperior.izq = a then
      NodoSuperior.izq := nodo
    else
      NodoSuperior.der := nodo;
  end;

begin
  NodoSuperior := a.sup;
  if a.izq = nil then
    linkSup(a.der)
  else if a.der = nil then
    linkSup(a.izq)
  else
  begin
    linkSup(a.der);
    c := a.der;
    while c.izq <> nil do
      c := c.izq;
    c.izq := a.izq;
  end;
  a.Free;
end;

procedure TBTree.First(var cursor: TNodoBTree);
var
  dir: TDirBTree;
begin
  First_step( cursor, dir );
  while ( dir <> FromIzq ) and ( cursor <> nil ) do
    next_step( cursor, dir );
end;

procedure TBTree.Next_step(var cursor: TNodoBTree; var dir: TDirBTree);

  procedure goUp;
  begin
    if cursor.sup = nil then
    begin
      cursor:= nil;
      dir:= FromDer;
      exit;
    end;

    if cursor.sup.izq = cursor then
      dir := FromIzq
    else
      dir := FromDer;
    cursor := cursor.sup;
  end;

begin
  if cursor = nil then
  begin
    dir := FromDer;
    exit;
  end;

  case dir of
    FromUp:
    begin
      if cursor.izq <> nil then
        cursor := cursor.izq
      else
        // no modifico cursor pero si la dirección
        dir:= FromIzq;
    end;
    FromIzq:
    begin
      if cursor.der <> nil then
      begin
        cursor := cursor.der;
        dir := FromUp;
      end
      else
        goUP;
    end;
    FromDer:
      goUp;
  end;
end;

procedure TBTree.First_step(out cursor: TNodoBTree; out dir: TDirBTree);
begin
  cursor := raiz;
  dir := FromUp;
end;

procedure TBTree.Next(var cursor: TNodoBTree);
var
  dir: TDirBTree;
begin
  next_step( cursor, dir );
  while ( dir <> FromIzq ) and ( cursor <> nil ) do
    next_step( cursor, dir );
end;


procedure TBTree.Clear;
begin
  if raiz <> nil then
    raiz.Free;
  raiz := nil;
end;

destructor TBTree.Destroy;
begin
  Clear;
  inherited Destroy;
end;


procedure TBTree.locate_step(var cursor: TNodoBTree; a: TItemBTree;
  var resCod: integer);
var
  aNodo: TNodoBtree;
begin
  resCod := compare(cursor.item, a);
  case resCod of
    -1:
    begin
      if cursor.izq = nil then
        resCod := -2
      else
      begin
        cursor:= cursor.izq;
        resCod:= -1;
      end;
    end;
    0:
      resCod:= 0;

    else // 1:
    begin
      if cursor.der = nil then
      begin
        resCod := 2;
      end
      else
      begin
        cursor := cursor.der;
        resCod:= 1;
      end;
    end;
  end;
end;



procedure TBTree.insert_repetidos(var cursor: TNodoBTree; a: TItemBTree;
  var resCod: integer);

var
  aNodo: TNodoBtree;
begin
  resCod := compare(cursor.item, a);
  case resCod of
    -1:
    begin
      if cursor.izq = nil then
      begin
        cursor.izq := TNodoBTree.Create(nil, cursor, nil, a);
        resCod := 0;
      end;
      cursor := cursor.izq;
    end;
    0:
    begin
      aNodo := TNodoBTree.Create(nil, cursor, nil, a);
      if cursor.der = nil then
      begin
        cursor.der := aNodo;
      end
      else
      begin
        aNodo.der := cursor.der;
        cursor.der.sup := aNodo;
        cursor.der := aNodo;
      end;
      cursor := aNodo;
    end;
    else // 1:
    begin
      if cursor.der = nil then
      begin
        cursor.der := TNodoBTree.Create(nil, cursor, nil, a);
        resCod := 0;
      end;
      cursor := cursor.der;
    end;
  end;
end;


function TBTree.insert_unique(var cursor: TNodoBTree; a: TItemBTree;
  var resCod: integer): TNodoBTree;
var
  aNodo: TNodoBtree;
begin

  resCod := compare(cursor.item, a);
  case resCod of
    -1:  // a < self
    begin
      if cursor.izq = nil then
      begin
        cursor.izq := TNodoBTree.Create(nil, cursor, nil, a);
        resCod := 0;
      end;
      cursor := cursor.izq;
    end;
    0: // a = self
    begin
      // cursor := cursor;
      resCod := 2;
    end;
    else // 1:
    begin  // a > self
      if cursor.der = nil then
      begin
        cursor.der := TNodoBTree.Create(nil, cursor, nil, a);
        resCod := 0;
      end;
      cursor := cursor.der;
    end;
  end;
end;

constructor TNodoBtree.Create(izq, sup, der: TNodoBTree; item: TItemBTree);
begin
  inherited Create;
  self.izq := izq;
  self.sup := sup;
  self.der := der;
  self.item := item;
end;

destructor TNodoBtree.Destroy;
begin
  if izq <> nil then
    izq.Free;
  if der <> nil then
    der.Free;
  inherited Destroy;
end;



end.
