program ArvoreSBB;

type TipoChave      = integer;
     TipoRegistro   = record
                        Chave: TipoChave
                        { outros componentes }
                      end;
     TipoInclinacao = (Vertical, Horizontal);
     TipoApontador  = ^TipoNo;
     TipoNo = record
                Reg       : TipoRegistro;
                Esq, Dir  : TipoApontador;
                BitE, BitD: TipoInclinacao
              end;
     TipoDicionario = TipoApontador;

procedure EE (var Ap: TipoApontador);
var Ap1: TipoApontador;
begin
  Ap1 := Ap^.Esq;        Ap^.Esq := Ap1^.Dir;  Ap1^.Dir := Ap;
  Ap1^.BitE := Vertical; Ap^.BitE := Vertical; Ap := Ap1;
end; { EE }

procedure ED (var Ap: TipoApontador);
var Ap1, Ap2: TipoApontador;
begin
  Ap1 := Ap^.Esq;       Ap2 := Ap1^.Dir;      Ap1^.BitD := Vertical; 
  Ap^.BitE := Vertical; Ap1^.Dir := Ap2^.Esq; Ap2^.Esq := Ap1;
  Ap^.Esq := Ap2^.Dir;  Ap2^.Dir := Ap;       Ap := Ap2;
end; { ED }

procedure DD (var Ap: TipoApontador);
var Ap1: TipoApontador;
begin
  Ap1 := Ap^.Dir;        Ap^.Dir := Ap1^.Esq;  Ap1^.Esq := Ap;
  Ap1^.BitD := Vertical; Ap^.BitD := Vertical; Ap := Ap1;
end; { DD }

procedure DE (var Ap: TipoApontador);
var Ap1, Ap2: TipoApontador;
begin
  Ap1 := Ap^.Dir;       Ap2 := Ap1^.Esq;      Ap1^.BitE := Vertical; 
  Ap^.BitD := Vertical; Ap1^.Esq := Ap2^.Dir; Ap2^.Dir := Ap1;
  Ap^.Dir := Ap2^.Esq;  Ap2^.Esq := Ap;       Ap := Ap2;
end; { DE }

procedure Insere (x: TipoRegistro; var Ap: TipoApontador);
var Fim: boolean; IAp: TipoInclinacao;
  procedure IInsere (x: TipoRegistro; var Ap: TipoApontador;
                     var IAp: TipoInclinacao; var Fim: boolean);
  begin
    if Ap = nil
    then begin
         new (Ap); IAp := Horizontal; Ap^.Reg := x;
         Ap^.BitE := Vertical; Ap^.BitD := Vertical;
         Ap^.Esq := nil; Ap^.Dir := nil;
         Fim := false;
         end
    else
    if x.Chave < Ap^.Reg.Chave
    then begin
         IInsere (x, Ap^.Esq, Ap^.BitE, Fim);
         if not Fim
         then if Ap^.BitE = Horizontal
              then begin
                   if Ap^.Esq^.BitE = Horizontal
                   then begin EE (Ap); IAp := Horizontal; end
                   else if Ap^.Esq^.BitD = Horizontal
                        then begin ED (Ap); IAp := Horizontal; end;
                   end
              else Fim := true;
         end
    else
    if x.Chave > Ap^.Reg.Chave
    then begin
         IInsere (x, Ap^.Dir, Ap^.BitD, Fim);
         if not Fim
         then if Ap^.BitD = Horizontal
              then begin
                   if Ap^.Dir^.BitD = Horizontal
                   then begin DD (Ap); IAp := Horizontal; end
                   else if Ap^.Dir^.BitE = Horizontal
                        then begin DE (Ap); IAp := Horizontal; end;
                   end
              else Fim := true;
         end
    else begin
         writeln ('Erro: Chave ja esta na arvore');
         Fim := true;
         end;
  end; { IInsere }

begin { Insere }
  IInsere (x, Ap, IAp, Fim);
end; { Insere }

procedure Inicializa (var Dicionario: TipoDicionario);
begin
  Dicionario := nil;
end; { Inicializa }

procedure Retira (x: TipoRegistro; var Ap: TipoApontador);
var Fim: boolean;
procedure IRetira(x:TipoRegistro;var Ap:TipoApontador;var Fim:boolean);
var Aux: TipoApontador;
procedure EsqCurto (var Ap: TipoApontador; var Fim: boolean);
var Ap1: TipoApontador;
begin { Folha esquerda retirada => arvore curta na altura esquerda }
  if Ap^.BitE = Horizontal
  then begin Ap^.BitE := Vertical; Fim := true; end
  else if Ap^.BitD = Horizontal
       then begin
            Ap1:=Ap^.Dir; Ap^.Dir:=Ap1^.Esq; Ap1^.Esq:=Ap; Ap:=Ap1;
            if Ap^.Esq^.Dir^.BitE = Horizontal
            then begin DE (Ap^.Esq); Ap^.BitE := Horizontal; end
            else if Ap^.Esq^.Dir^.BitD = Horizontal
                 then begin DD (Ap^.Esq); Ap^.BitE := Horizontal; end;
            Fim := true;
            end
       else begin
            Ap^.BitD := Horizontal;
            if Ap^.Dir^.BitE = Horizontal
            then begin DE (Ap); Fim := true; end
            else if Ap^.Dir^.BitD = Horizontal
                 then begin DD (Ap); Fim := true; end;
            end;
end; { EsqCurto }
procedure DirCurto (var Ap: TipoApontador; var Fim: boolean);
var Ap1: TipoApontador;
begin { Folha direita retirada => arvore curta na altura direita }
  if Ap^.BitD = Horizontal
  then begin Ap^.BitD := Vertical; Fim := true; end
  else if Ap^.BitE = Horizontal
       then begin
            Ap1:=Ap^.Esq; Ap^.Esq:=Ap1^.Dir; Ap1^.Dir:=Ap; Ap:=Ap1;
            if Ap^.Dir^.Esq^.BitD = Horizontal
            then begin ED (Ap^.Dir); Ap^.BitD := Horizontal; end
            else if Ap^.Dir^.Esq^.BitE = Horizontal
                 then begin EE (Ap^.Dir); Ap^.BitD := Horizontal; end;
            Fim := true;
            end
       else begin
            Ap^.BitE := Horizontal;
            if Ap^.Esq^.BitD = Horizontal
            then begin ED (Ap); Fim := true; end
            else if Ap^.Esq^.BitE = Horizontal
                 then begin EE (Ap); Fim := true; end;
            end;
end; { DirCurto }

procedure Antecessor (q: TipoApontador; var r: TipoApontador;
                      var Fim: boolean);
begin
  if r^.Dir <> nil
  then begin
       Antecessor (q, r^.Dir, Fim);
       if not Fim then DirCurto (r, Fim);
       end
  else begin
       q^.Reg := r^.Reg; q := r; 
       r := r^.Esq;      dispose (q);
       if r <> nil then Fim := true;
       end;
end; { Antecessor }
begin { IRetira }
  if Ap = nil
  then begin writeln ('Chave nao esta na arvore'); Fim := true; end
  else if x.Chave < Ap^.Reg.Chave
       then begin
            IRetira (x, Ap^.Esq, Fim);
            if not Fim then EsqCurto (Ap, Fim);
            end
       else if x.Chave > Ap^.Reg.Chave
       then begin
            IRetira (x, Ap^.Dir, Fim);
            if not Fim then DirCurto (Ap, Fim);
            end
       else begin { Encontrou chave }
            Fim := false; Aux := Ap;
            if Aux^.Dir = nil
            then begin
                 Ap := Aux^.Esq; dispose (Aux);
                 if Ap <> nil then Fim := true;
                 end
            else if Aux^.Esq = nil
                 then begin
                      Ap := Aux^.Dir; dispose (Aux);
                      if Ap <> nil then Fim := true;
                      end
                 else begin
                      Antecessor (Aux, Aux^.Esq, Fim);
                      if not Fim then EsqCurto (Ap, Fim);
                      end;
            end;
end; { IRetira }
begin { Retira }
  IRetira (x, Ap, Fim)
end; { Retira }

procedure Pesquisa (var x: TipoRegistro; var p: TipoApontador);
begin
  if p = nil
  then begin 
       writeln ('Erro: Registro nao esta presente na arvore'); 
       exit; 
       end
  else if x.Chave < p^.Reg.Chave
       then Pesquisa (x, p^.Esq)
       else if x.Chave > p^.Reg.Chave
            then Pesquisa (x, p^.Dir)
            else x := p^.Reg;
end;

procedure Testa (Arvore: TipoDicionario);
var NivelFolhas: integer; PrimeiraFolha: boolean;

  procedure Testa1 (p: TipoApontador; nivel: integer);
  begin
    if p <> nil
    then with p^ do
         begin
         if PrimeiraFolha
         then if NivelFolhas < nivel
              then NivelFolhas := nivel;
         if (Esq = nil) and (Dir = nil)
         then begin
              if PrimeiraFolha = true
              then PrimeiraFolha := false
              else begin
                   if nivel <> NivelFolhas
                   then begin
                        writeln ('Erro: Folhas em niveis diferentes');
                        halt;
                        end;
                   end;
              end;
         if BitE = Horizontal
         then Testa1 (Esq, nivel)
         else Testa1 (Esq, nivel+1);
         if BitD = Horizontal
         then Testa1 (Dir, nivel)
         else Testa1 (Dir, nivel+1);
         end;
  end; { Testa1 }

  procedure Testa2 (p: TipoApontador);
  begin
    if p <> nil
    then with p^ do
         begin
         if Esq <> nil
         then begin
              if Reg.Chave < Esq^.Reg.Chave
              then begin
                   writeln ('Erro: ', Reg.Chave, ' < que filho a esquerda ');
                   halt;
                   end;
              Testa2 (Esq);
              end;
         if Dir <> nil
         then begin
              if Reg.Chave > Dir^.Reg.Chave
              then begin
                   writeln ('Erro: ', Reg.Chave, ' > que filho a direita ');
                   halt;
                   end;
              Testa2 (Dir);
              end;
         end;
  end; { Testa2 }

begin { Testa }
  NivelFolhas := 0;
  PrimeiraFolha := true;
  Testa1 (Arvore, 1);
  Testa2 (Arvore);
end; { Testa }

const MAX = 10;

var Dicionario: TipoDicionario;
    x         : TipoRegistro;
    vetor     : array [1..MAX] of integer;
    i, j, k, n: integer;

begin

  Inicializa (Dicionario);

  { Gera uma permutacao aleatoria de chaves entre 1 e MAX }
  randomize;
  for i := 1 to MAX do vetor[i] := i;
  for i := 1 to MAX do
    begin
    k := 1 + random (MAX);
    j := 1 + random (MAX);
    n := vetor[k];
    vetor[k] := vetor[j];
    vetor[j] := n;
    end;
  
  { Insere cada chave na arvore e testa sua integridade apos cada insercao }
  for i := 1 to MAX do
    begin
    x.Chave := vetor[i];
    Insere (x, Dicionario);
    writeln ('Inseriu chave: ', x.Chave);
    Testa (Dicionario);
    end;
  
  { Retira uma chave aleatoriamente e realiza varias pesquisas }
  for i := 1 to MAX do
    begin
    k := 1 + random (MAX);
    n := vetor[k];
    x.Chave := n;
    Retira (x, Dicionario);
    Testa (Dicionario);
    writeln ('Retirou chave: ', x.Chave);
    for j := 1 to MAX do
      begin
      x.Chave := vetor[1+random (MAX)];
      if x.Chave <> n
      then begin
           writeln ('Pesquisando chave: ', x.Chave);
           Pesquisa (x, Dicionario);
           end;
      end;
    x.Chave := n;
    Insere (x, Dicionario);
    writeln ('Inseriu chave: ', x.Chave);
    Testa (Dicionario);
    end;

  { Retira a raiz da arvore ate que ela fique vazia }
  for i := 1 to MAX do
    begin
    x.Chave := Dicionario^.Reg.Chave;
    Retira (x, Dicionario);
    Testa (Dicionario);
    writeln ('Retirou chave: ', x.Chave);
    end;

end.