Calculate Binary Search Tree

Mit diesem Beispiel lässt sich ein grafischer Suchbaum zeichnen, der mit Zahlenreihenfolgen belegt werden kann.

uses ComCtrls

zeiger = ^knoten;
  knoten = record
             info : integer;
             li,re : zeiger;
           end;

var Form1 : TForm1;
     root : zeiger;    // Wurzel des binären Baums

//

// erzeugt einen Baum bzw. Teilbaum mit der Wurzel x
function construct (x: integer): zeiger;
var k : zeiger;
begin
  new (k);
  k^.li := nil; k^.info := x; k^.re := nil;
  construct := k
end;

// fügt x als Blatt an der Stelle ein, wo die Suche erfolglos abgebrochen wurde
function insert (p:zeiger; x:integer): boolean;
var q : zeiger;
begin
  q := p;
  while (p^.info <>x) and (q <> nil) do
    begin
      p := q;                                               // Vorgänger merken
      if x < p^.info then q := p^.li                 // q zeigt auf linken Sohn
                     else q := p^.re                // q zeigt auf rechten Sohn
    end;
  if x < p^.info then p^.li := construct (x)
                 else if x > p^.info then p^.re := construct (x);
  insert := (x <> p^.info)
end;

// gibt einen Zeiger auf den gefundenen Knoten oder NIL zurück
function search (p:zeiger; x: integer): zeiger;
begin
  while (p <> nil) and (x <> p^.info) do
    if x < p^.info then p := p^.li else p := p^.re;
  search := p
end;

// durchläuft den kompletten Suchbaum rekursiv
procedure traverse (p: zeiger; var s: string);
begin
  if p <> nil then begin
                     traverse (p^.li, s);
                     s := s + IntToStr (p^.info) + ' ';
                     traverse (p^.re, s)
                   end
end;

// durchläuft den kompletten Suchbaum rekursiv
procedure paint (x,y,b:integer; tree:zeiger);
begin
  if tree <> nil then with Form1.Image1.Canvas do
    begin
      if tree^.li <> nil then begin
                                MoveTo (x, y);
                                LineTo (x - b div 2, y+16);
                                paint (x - b div 2, y+30, b div 2, tree^.li);
                              end;
      TextOut (x-6, y-13, IntToStr(tree^.info));
      if tree^.re <> nil then begin
                                MoveTo (x, y);
                                LineTo (x + b div 2, y+16);
                                paint (x + b div 2, y+30, b div 2, tree^.re);
                              end
  end
end;

procedure PaintTree;
begin
  with Form1.Image1 do begin
    Canvas.Rectangle (0, 0, Width, Height);
    paint (Width div 2 - 6, 20, Width div 2 - 6, root);
  end
end;

// löscht den kompletten Baum rekursiv
procedure delete (p: zeiger);
begin
  if p <> nil then begin
                     delete (p^.li);
                     delete (p^.re);
                     dispose (p)
                   end
end;

// liefert den kompletten Pfad von der Wurzel bis zum Knoten
function trace (p:zeiger; x: integer): string;
var s : string;
begin
  s := '';
  while (p <> nil) and (x <> p^.info) do
    begin
      s := s + IntToStr (p^.info) + '-';
      if x < p^.info then p := p^.li else p := p^.re
    end;
  if p <> nil then trace := s + IntToStr (p^.info)
              else trace := ''
end;

// entfernt den Knoten, auf den z zeigt, aus dem Baum mit der Wurzel r
procedure remove (var r:zeiger; z:zeiger);
var h,p,q : zeiger;
begin
  q := r;                                        // Suche beginnt an der Wurzel
  p := nil; // ist der zu löschende Knoten die Wurzel, gibt es keinen Vorgänger
  while z^.info <> q^.info do begin
                                p := q;                     // Vorgänger merken
                                if z^.info < q^.info then q := q^.li
                                                     else q := q^.re
                              end;
  if z^.re = nil
    then q := q^.li                       // FALL 1: rechts gibt es keinen Sohn
    else if z^.re^.li = nil              // FALL 2a: links gibt es keinen Enkel
           then begin
                  q := q^.re;                     // Knoten durch Sohn ersetzen
                  q^.li := z^.li                         // Rest links anhängen
                end
           else begin                     // FALL 2b: links gibt es einen Enkel
                  h := q^.re;             // suche Ersatzknoten im re. Teilbaum
                  while h^.li^.li <> nil do h := h^.li;   // suche Ersatzknoten
                  q := h^.li;                        // dieser Knoten ersetzt z
                  h^.li := q^.re; // re. Teilbaum des leftmost-Knotens umhängen
                  q^.li := z^.li;           // li. Teilbaum von z an q anhängen
                  q^.re := z^.re            // re. Teilbaum von z an q anhängen
                end;
  if p = nil then r := q
             else if z^.info < p^.info then p^.li := q
                                       else p^.re := q;
  dispose (z)
end;

// Button Baum erzeugen
procedure TForm1.Init(Sender: TObject);
var i,n,x : integer;
begin
  randomize;
  n := TrackBar1.Position;
  Label1.Caption := IntToStr(n) + ' Zahlen';
  DeleteTree(Sender);
  root := construct (10+random(90));
  for i:=2 to n do
    repeat x := 10 + random(90) until insert (root,x);
  ShowTree (sender);
  btnLoad.Enabled := true
end;

// Button Einfügen
procedure TForm1.InsertNode(Sender: TObject);
var x : integer;
    p : zeiger;
begin
  x := StrToInt(Edit1.Text);
  p := search (root,x);
  if p = nil then begin
                    if root = nil then root := construct (x)
                                  else insert (root,x);
                    ShowTree (sender)
                  end
             else Memo1.Lines[1] := Edit1.Text + ' ist schon im Baum.';
  btnLoad.Enabled := true
end;

// Button Löschen
procedure TForm1.RemoveNode(Sender: TObject);
var x : integer;
    p : zeiger;
begin
  x := StrToInt(Edit1.Text);
  p := search (root,x);
  if p = nil then Memo1.Lines[1] := Edit1.Text + ' ist nicht im Baum.'
             else begin
                    remove (root, p);
                    ShowTree (sender);
                    Memo1.Lines[1] := ' '
                  end;
end;

// Button gesamten Baum löschen
procedure TForm1.DeleteTree(Sender: TObject);
begin
  delete (root);
  root := nil;
  ShowTree (sender);
  btnLoad.Enabled := false
end;

// Button Suchen
procedure TForm1.SearchNode(Sender: TObject);
var x : integer;
    p : zeiger;
begin
  x := StrToInt(Edit1.Text);
  p := search (root,x);
  if p = nil then Memo1.Lines[1] := Edit1.Text + ' ist nicht im Baum.'
             else Memo1.Lines[1] := Edit1.Text + ' wurde gefunden.'
end;

// Button Pfad verfolgen
procedure TForm1.TracePath(Sender: TObject);
var x : integer;
    s : string;
begin
  x := StrToInt(Edit1.Text);
  s := trace (root,x);
  if s = '' then Memo1.Lines[1] := Edit1.Text + ' ist nicht im Baum.'
            else Memo1.Lines[1] := s
end;

// Button Baum traversieren
procedure TForm1.ShowTree(Sender: TObject);
var s : string;
begin
  s := '';
  traverse (root, s);
  Memo1.Lines[0] := s;
  PaintTree;
end;

// Button Baum laden
procedure TForm1.btnLoadClick(Sender: TObject);
var i,l,x : integer;
        s : string;
begin
  s := Memo1.Lines[0];
  l := length(s);
  if s[l] <> ' ' then s := s + ' ';
  i := pos (' ', s);
  x := StrToInt(Copy (s, 1, i-1));
  root := construct (x);
  System.Delete (s, 1, i);
  while s <> '' do begin
                     i := pos (' ', s);
                     x := StrToInt(Copy (s, 1, i-1));
                     insert (root,x);
                     System.Delete (s, 1, i);
                   end;
  PaintTree;
end;