Program BTree;
 
Const m = 2;
 
Type ref = ^ node;
     node = record
        cnt: integer;
        key: array [1..2*m] of integer;
        br: array [1..2*m+1] of ref;
     end;
 
Var root: ref;
 
Procedure Pridej (p: ref; vi: integer; vs: ref; vk: integer; var ns: ref; var nk: integer);
// Vlozit hodnotu vk a podstrom vs na pozici vi
// Pokud pri vkladani dojde k rozdeleni stranky,
// nasledujici parametry obsahuji informaci o nove (leve) strance
// ns - nova stranka
// nk - novy klic
Var  i, s, t: integer;
     u: ref;
Begin
     if p^.cnt < 2*m then begin
        for i := p^.cnt downto vi do p^.key[i+1] := p^.key[i]; // posun klice
        for i := p^.cnt+1 downto vi do p^.br[i+1] := p^.br[i]; // posun vetve (pod-stranky)
        p^.key[vi] := vk; // vloz klic
        p^.br[vi] := vs; // vloz stranku
        p^.cnt := p^.cnt + 1;
     end
     else begin
        new (u); // nova stranka
        ns := u;
        for i := 1 to 2*m do u^.key[i] := 0;
        for i := 1 to 2*m+1 do u^.br[i] := nil;
 
        u^.cnt := m;
        p^.cnt := m;
 
        s := 1; // s ... source index (uvnitr p)
 
        // prenes m klicu a ukatelu do nove (leve) stranky
        for t := 1 to m do
           if t = vi then begin
              u^.br[t] := vs;
              u^.key[t] := vk; // jsme na pozici vi vloz klic vk a stranku vs
           end
           else begin
              u^.br[t] := p^.br[s];
              u^.key[t] := p^.key[s];
              s := s + 1; // dalsi hodnotu
           end;
 
        // prostredni klic do nk, ukazatel jeste do leve stranky
        t := m+1;
        if t = vi then begin
           u^.br[t] := vs;
           nk := vk;
        end
        else begin
           u^.br[t] := p^.br[s];
           nk := p^.key[s];
           s := s + 1;
        end;
 
        // m hodnot na zacatek prave stranky
        for i := 1 to m do begin
           t := m + 1 + i;
           if t = vi then begin
              p^.key[i] := vk;
              p^.br[i] := vs;
           end
           else begin
              p^.key[i] := p^.key[s];
              p^.br[i] := p^.br[s];
              s := s + 1;
           end;
        end;
 
        // posledni ukazatel;
        p^.br[m+1] := p^.br[s];
 
        for i := m+1 to 2*m do p^.key[i] := 0;
        for i := m+2 to 2*m+1 do u^.br[i] := nil;
     end;
End;
 
Procedure Vloz2 (h: integer; p: ref; var ns: ref; var nk: integer);
// Vlozit hodnotu h do podstromu p
// Pokud pri vkladani dojde k rozdeleni stranky,
// nasledujici parametry obsahuji informaci o nove (leve) strance
// ns - nova stranka
// nk - novy klic
Var  i, rk: integer;
     rs: ref;
Begin
     ns := nil; // neni zatim zadna nova stranka
     nk := 0; // neni potreba
 
     i := 1;
     while (i <= p^.cnt) and (p^.key[i] < h) do i := i+1;
     if (i <= p^.cnt) and (p^.key[i] = h) then
        writeln (h, ' je jiz ve stromu')
     else begin
         if p^.br[i] = nil then
            Pridej (p, i, nil, h, ns, nk) // jsme na na urovni listu
         else begin
            Vloz2 (h, p^.br[i], rs, rk); // vloz na nizsi urovni
            if rs <> nil then Pridej (p, i, rs, rk, ns, nk);
         end;
     end;
End;
 
Procedure Vloz (h: integer; var p: ref);
Var  i, rk: integer;
     t, rs: ref;
Begin
     if p = nil then begin
        new (p);
        p^.cnt := 1;
        p^.key [1] := h;
        for i := 2 to 2*m do p^.key[i] := 0;
        for i := 1 to 2*m+1 do p^.br[i] := nil;
     end
     else begin
        Vloz2 (h, p, rs, rk);
        if rs <> nil then begin
           t := p;
           new (p); // novy koren
           p^.cnt := 1;
           p^.key [1] := rk;
           p^.br [1] := rs; // nova stranka
           p^.br [2] := t; // puvodni stranka
           for i := 2 to 2*m do p^.key[i] := 0;
           for i := 3 to 2*m+1 do p^.br[i] := nil;
        end;
     end;
End;
 
Procedure Kontrola (p: ref);
Var i: integer;
    q: ref;
Begin
     for i := 1 to p^.cnt-1 do
        if p^.key[i] >= p^.key[i+1] then
           writeln ('chyba');
 
     if p^.br[1] <> nil then begin
        for i := 1 to p^.cnt do begin
           q := p^.br[i];
           if q^.key [q^.cnt] >= p^.key[i] then
              writeln ('chyba');
        end;
 
        for i := 1 to p^.cnt+1 do
           Kontrola (p^.br [i]);
     end;
End;
 
Procedure VypisPatro (p: ref; level: integer);
Var i: integer;
Begin
     if level > 1 then begin
        for i := 1 to p^.cnt+1 do
           VypisPatro (p^.br[i], level-1) ;
        writeln;
     end
     else begin
        for i := 1 to p^.cnt do begin
           write (p^.key[i]);
           if i < p^.cnt then write (', ')
                         else writeln;
        end;
     end;
End;
 
Procedure Vypis (p: ref);
Var  i, depth: integer;
     t: ref;
Begin
     depth := 0;
     t := p;
     while t <> nil do begin
        t := t^.br[1];
        depth := depth + 1;
     end;
 
     for i := 1 to depth do begin
        writeln (i, '. patro');
        writeln ('--------');
        VypisPatro (p, i);
        writeln;
     end;
End;
 
Procedure Add (h: integer);
Begin
     Vloz (h, root);
End;
 
 
Var i: integer;
Begin
      root := nil;
 
      (*
      Add (30);
      Add (20);
      Add (40);
      Add (10);
 
      Add (15);
      *)
 
      for i := 1 to 80 do
         Add (random (100));
 
      Vypis (root);
      Kontrola (root);
End.