program arvoreb;

const M  = 2;
      MM = 2 * M;

type TipoChave     = integer;
     TipoRegistro  = record
                       Chave: TipoChave;
                       {outros componentes}
                     end;
     TipoApontador = ^TipoPagina;
     TipoPagina    = record
                       n: 0..MM;
                       r: array [1..MM] of TipoRegistro;
                       p: array [0..MM] of TipoApontador
                     end;
     TipoDicionario = TipoApontador;

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

procedure Pesquisa (var x: TipoRegistro; Ap: TipoApontador);
var i: Integer;
begin
  if Ap = nil
  then writeln ('Registro nao esta presente na arvore')
  else with Ap^ do
       begin
       i := 1;
       while (i < n) and (x.Chave > r[i].Chave) do i := i + 1;
       if x.Chave = r[i].Chave
       then x := r[i]
       else if x.Chave < r[i].Chave
            then Pesquisa (x, p[i-1])
            else Pesquisa (x, p[i])
       end;
end; { Pesquisa }

procedure InsereNaPagina (Ap: TipoApontador;
                          Reg: TipoRegistro; ApDir: TipoApontador);
var NaoAchouPosicao: Boolean;
    k              : Integer;
begin
with Ap^ do
  begin
  k := n;
  NaoAchouPosicao := k > 0;
  while NaoAchouPosicao do
    if Reg.Chave < r[k].Chave
    then begin
         r[k+1] := r[k]; p[k+1] := p[k]; 
	 k := k - 1;
         if k < 1 then NaoAchouPosicao := false;
         end
    else NaoAchouPosicao := false;
  r[k+1] := Reg; p[k+1] := ApDir; 
  n := n + 1;
  end;
end; { InsereNaPagina }

procedure Insere (Reg: TipoRegistro; var Ap: TipoApontador);
var Cresceu: Boolean; RegRetorno: TipoRegistro;
    ApRetorno, ApTemp: TipoApontador;

procedure Ins(Reg:TipoRegistro; Ap: TipoApontador; var Cresceu:Boolean;
              var RegRetorno:TipoRegistro; var ApRetorno:TipoApontador);
var i, j: Integer; ApTemp: TipoApontador;
begin
  if Ap = nil
  then begin Cresceu := true; RegRetorno := Reg; ApRetorno := nil; end
  else with Ap^ do
    begin
    i := 1;
    while (i < n) and (Reg.Chave > r[i].Chave) do i := i + 1;
    if Reg.Chave = r[i].Chave
    then begin
         writeln (' Erro: Registro ja esta presente'); Cresceu:=false;
         end
    else begin
         if Reg.Chave < r[i].Chave then i := i - 1;
         Ins (Reg, p[i], Cresceu, RegRetorno, ApRetorno);
         if Cresceu
         then if n < MM
              then begin { Pagina tem espaco }
                   InsereNaPagina (Ap, RegRetorno, ApRetorno);
                   Cresceu := false;
                   end
         else begin { Overflow: Pagina tem que ser dividida }
              new (ApTemp);
              ApTemp^.n := 0; ApTemp^.p[0] := nil;
              if i < M + 1
              then begin
                   InsereNaPagina (ApTemp, r[MM], p[MM]);
                   n := n - 1;
                   InsereNaPagina (Ap, RegRetorno, ApRetorno)
                   end
              else InsereNaPagina (ApTemp, RegRetorno, ApRetorno);
              for j := M + 2 to MM do
                InsereNaPagina (ApTemp, r[j], p[j]);
              n := M; ApTemp^.p[0] := p[M+1];
              RegRetorno := r[M+1]; ApRetorno := ApTemp;
              end;
         end;
    end;
end; { Ins }

begin
  Ins (Reg, Ap, Cresceu, RegRetorno, ApRetorno);
  if Cresceu
  then begin { Arvore cresce na altura pela raiz }
  new (ApTemp);
  ApTemp^.n := 1;
  ApTemp^.r[1] := RegRetorno;
  ApTemp^.p[1] := ApRetorno;
  ApTemp^.p[0] := Ap; Ap := ApTemp
  end
end; { Insere }

procedure Retira (Ch: TipoChave; var Ap: TipoApontador);
var Diminuiu: Boolean;
    Aux     : TipoApontador;

  procedure Ret(Ch:TipoChave;var Ap:TipoApontador;var Diminuiu:Boolean);
  var Ind, j: Integer;

    procedure Reconstitui (ApPag: TipoApontador; ApPai: TipoApontador;
                           PosPai: Integer; var Diminuiu: Boolean);
    var Aux      : TipoApontador;
        DispAux,j: Integer;
    begin
      if PosPai < ApPai^.n
      then begin { Aux = Pagina a direita de ApPag }
           Aux := ApPai^.p[PosPai+1];
           DispAux := (Aux^.n - M + 1) div 2;
           ApPag^.r[ApPag^.n+1] := ApPai^.r[PosPai+1];
           ApPag^.p[ApPag^.n+1] := Aux^.p[0];
           ApPag^.n := ApPag^.n + 1;
           if DispAux > 0
           then begin { Existe folga: transfere de Aux para ApPag }
                for j := 1 to DispAux - 1 do
                  InsereNaPagina (ApPag, Aux^.r[j], Aux^.p[j]);
                  ApPai^.r[PosPai+1] := Aux^.r[DispAux];
                  Aux^.n := Aux^.n - DispAux;
                  for j := 1 to Aux^.n do Aux^.r[j]:=Aux^.r[j+DispAux];
                  for j := 0 to Aux^.n do Aux^.p[j]:=Aux^.p[j+DispAux];
                  Diminuiu := false
                  end
           else begin { Fusao: intercala Aux em ApPag e libera Aux }
                for j := 1 to M do
                  InsereNaPagina (ApPag, Aux^.r[j], Aux^.p[j]);
                dispose (Aux);
                for j := PosPai + 1 to ApPai^.n - 1 do with ApPai^ do
                  begin 
		  r[j] := r[j+1]; p[j] := p[j+1] 
		  end;
                ApPai^.n := ApPai^.n - 1;
                if ApPai^.n >= M
                then Diminuiu := false;
                end
           end
      else begin { Aux = Pagina a esquerda de ApPag }
           Aux := ApPai^.p[PosPai-1];
           DispAux := (Aux^.n - M + 1) div 2;
           for j := ApPag^.n downto 1 do 
	     ApPag^.r[j+1] := ApPag^.r[j];
           ApPag^.r[1] := ApPai^.r[PosPai];
           for j := ApPag^.n downto 0 do 
	     ApPag^.p[j+1] := ApPag^.p[j];
           ApPag^.n := ApPag^.n + 1;
           if DispAux > 0
           then begin { Existe folga: transfere de Aux para ApPag }
                for j := 1 to DispAux - 1 do with Aux^ do
                  InsereNaPagina (ApPag, r[Aux^.n+1-j], p[n+1-j]);
                ApPag^.p[0] := Aux^.p[Aux^.n+1-DispAux];
                ApPai^.r[PosPai] := Aux^.r[Aux^.n+1-DispAux];
                Aux^.n := Aux^.n - DispAux;
                Diminuiu := false
                end
           else begin { Fusao: intercala ApPag em Aux e libera ApPag }
                for j := 1 to M do
                  InsereNaPagina (Aux, ApPag^.r[j], ApPag^.p[j]);
                dispose (ApPag);
                ApPai^.n := ApPai^.n - 1;
                if ApPai^.n >= M then Diminuiu := false;
           end;
      end;
    end; { Reconstitui }

    procedure Antecessor (Ap: TipoApontador; Ind: Integer;
                          ApPai: TipoApontador; 
			  var Diminuiu: Boolean);
    begin
    with ApPai^ do
      begin
      if p[n] <> nil
      then begin
           Antecessor (Ap, Ind, p[n], Diminuiu);
           if Diminuiu then Reconstitui (p[n], ApPai, n, Diminuiu);
           end
      else begin 
           Ap^.r[Ind] := r[n]; 
	   n := n - 1; 
	   Diminuiu := n < M; 
	   end;
      end
    end; { Antecessor }

  begin { Ret }
    if Ap = nil
    then begin
         writeln ('Erro: registro nao esta na arvore'); 
	 Diminuiu := false;
         end
    else with Ap^ do
         begin
         Ind := 1;
         while (Ind < n) and (Ch > r[Ind].Chave) do Ind := Ind + 1;
         if Ch = r[Ind].Chave
         then if p[Ind-1] = nil
              then begin { Pagina folha }
              n := n - 1; Diminuiu := n < M;
              for j := Ind to n do
                begin 
		r[j] := r[j+1]; 
		p[j] := p[j+1]; 
		end;
              end
         else begin { Pagina nao e folha: trocar com antecessor }
              Antecessor (Ap, Ind, p[Ind-1], Diminuiu);
              if Diminuiu
              then Reconstitui (p[Ind-1], Ap, Ind-1, Diminuiu);
              end
         else begin
              if Ch > r[Ind].Chave then Ind := Ind + 1;
              Ret (Ch, p[Ind-1], Diminuiu);
              if Diminuiu
              then Reconstitui (p[Ind-1], Ap, Ind-1, Diminuiu);
              end
         end
  end; { Ret }

begin { Retira }
  Ret (Ch, Ap, Diminuiu);
  if Diminuiu and (Ap^.n = 0)
  then begin { Arvore diminui na altura }
       Aux := Ap; Ap := Aux^.p[0]; 
       dispose (Aux);
       end
end; { Retira }

procedure Imprime (p: TipoApontador);
var n: integer;

  procedure ImprimeI (p: TipoApontador; nivel: integer);
  var i: integer;
  begin
    if p <> nil
    then begin
         write ('Nivel ', nivel, ' : ');
         for i := 1 to p^.n do write (p^.r[i].Chave, ' ');
         writeln;
         nivel := nivel + 1;
         for i := 0 to p^.n do ImprimeI (p^.p[i], nivel);
         end;
  end; { ImprimeI }

begin
  n := 0;
  ImprimeI (p, n);
end; { Imprime }

procedure Testa (p: TipoApontador);
var i: integer;

  procedure TestaI (p: TipoApontador; pai: integer; direita: boolean);
  var i, antecessor: integer;
  begin
    if p <> nil then begin
      if (p^.r[1].Chave > pai) and (direita = false)
      then begin
           writeln ('Erro: filho ', p^.r[1].Chave, ' maior que pai ', pai);
           exit;
           end;
      antecessor := 0;
      for i := 1 to p^.n do
      begin
        if (p^.r[i].Chave > antecessor)
        then antecessor := p^.r[i].Chave
        else begin
             writeln ('Erro: irmao ', p^.r[i].Chave, ' maior que irmao a esquerda ', antecessor);
             exit;
             end;
      end;
      for i := 0 to (p^.n - 1) do
        begin
        TestaI (p^.p[i], p^.r[i+1].Chave, false);
        {writeln ('Filhos da esquerda de ', p^.r[i+1].Chave, ' OK');}
        end;
      TestaI (p^.p[p^.n], p^.r[i+1].Chave, true);
      {writeln ('Filhos da direita de ', p^.r[i+1].Chave, ' OK');}
    end;
  end; { TestaI }

begin
  if p <> nil 
  then begin
       for i := 0 to (p^.n - 1) do
         begin
         TestaI (p^.p[i], p^.r[i+1].Chave, false);
         {writeln ('Filhos da esquerda de ', p^.r[i+1].Chave, ' OK');}
         end;
       TestaI (p^.p[p^.n], p^.r[i+1].Chave, true);
       {writeln ('Filhos da direita de ', p^.r[i+1].Chave, ' OK');}
  end;
end; { Testa }

var x: TipoRegistro;
    D: TipoDicionario;

begin
  Inicializa (D);
  write ('Chave: ');
  readln (x.Chave);
  while (x.Chave <> 0) do begin
    Insere (x, D);
    Imprime (D);
    write ('Chave: ');
    readln (x.Chave);
  end;
  Testa (D);
  write ('Chave: ');
  readln (x.Chave);
  while (x.Chave <> 0) do begin
    Retira (x.Chave, D);
    Imprime (D);
    write ('Chave: ');
    readln (x.Chave);
  end;
  Testa (D);
end.