Идеально сбалансированное дерево

[Simon1712]

ИСД - бинарное дерево, в котором количество элементов в левом и правом поддереве отличается не более чем на 1.
Написал процедуру построения, удаления элемента, а также вывода дерева...
Появилась проблема, элемент надо удалять так чтобы дерево осталось идеально сбалансированным, есть случай, когда после удаления балнс нарушается. Интересует, как можно переписать процедуру удаления или написать процедуру балансировки такого дерева. Благодарю за помощь!

[Simon1712]

type
  ptr = ^tree;
  tree = record
    left, right : ptr;
    val : integer;
  end;

var
  n, k : integer;
  p : ptr;

function CrTree(n : integer) : ptr;
var
  newtree : ptr;
  x, n1, n2 : integer;
begin
  if n = 0 then
    CrTree := nil
  else
  begin
    n1 := n div 2;
    n2 := n - n1 - 1;
    read(x);
    new(newtree);
    with newtree^ do
    begin
      val := x;
      left := CrTree(n1);
      right := CrTree(n2);
    end;
    CrTree := newtree;
  end;
end;

procedure print(t : ptr; h : integer);
var
  i : integer;
Begin
  if t <> nil then
    with t^ do
    begin
      print(right, h + 1);
      for i := 1 to h do
        write('   ');
      writeln(val);
      print(left, h + 1);
    end;
end;

procedure del(k : integer; var t : ptr);
var
  q : ptr;

procedure lr(var m : ptr);
begin
  if m^.right <> nil then
    lr(m^.right)
  else
  begin
    q^.val := m^.val;
    q := m;
    m := m^.left;
    dispose(q);
  end;
end;

begin
  if t <> nil then
  begin
    if k <> t^.val then
    begin
      del(k, t^.left);
      del(k, t^.right);
    end
    else
    begin
      q := t;
      if q^.right = nil then
      begin
        t := q^.left;
        dispose(q);
      end
      else
      begin
        if q^.left = nil then
        begin
          t := q^.right;
          dispose(q);
        end
        else
          lr(q^.left);
      end;
    end;
  end;
end;

begin
  readln(n);
  p := CrTree(n);
  print(p, 0);
  readln(k);
  del(k, p);
  print(p, 0);
end.

Вот то что есть