{ Tree - DEMO fuer Datenstruktur Vorlesung, SS03-Benn }
{ Autor: Dipl.-Ing. Thomas Speiser                    }
{ Source from: http://Codes.TurboTools.de             }

program tree_demo;
uses Crt;
type ref = ^baum;
       baum = record
       value: integer;
       left, right: ref;
end;

var count: integer;
    tree: ref;
    c: char;

procedure DelMostRight(var OldTree: ref; var SeekNode: ref);
var tmp: ref;
begin
  if SeekNode = nil
  then writeln('Das htte nie passieren drfen!')
  else begin
         if SeekNode^.right <> nil
	 then DelMostRight(OldTree,SeekNode^.right)
	 else begin
	        OldTree^.Value:=SeekNode^.Value;
		tmp:=SeekNode^.Left;
		dispose(SeekNode);
	        SeekNode:=tmp;
         end;
       end;
end;

procedure Delete(var Tree: ref; i: integer);
var tmp: ref;
begin
  if tree <> nil then begin
  if i < Tree^.Value
     then Delete(Tree^.left,i)
  else if i > Tree^.Value
         then Delete(Tree^.right,i)
      else {Gefunden}
        begin
          if Tree^.Left = nil
            then begin
	           writeLN('0. oder 1. Sohn, rechte Seite wird uebernommen!');
                   tmp:=Tree^.right;
	           dispose(tree);
                   Tree:=tmp;
		 end
          else if Tree^.right = nil
                 then begin
	           writeLN('0. oder 1. Sohn, linke Seite wird uebernommen!');
                   tmp:=Tree^.left;
	           dispose(tree);
                   Tree:=tmp;
     	         end
               else begin
                   writeLN('2. Shne!');
                   DelMostRight(tree,tree^.left);
	         end;
        end end;
end;

procedure Del_element(var tree: ref);
var i: integer;
begin
 write('Welches Element soll geloescht werden? ');
 readLN(i);
 Delete(tree,i);
end;

procedure Insert_Node(var tree: ref; i: integer);
begin
 if tree = nil then
 begin
   new(tree);
   tree^.left:=nil;
   tree^.right:=nil;
   tree^.value:=i;
   writeLN(i,'. hinzugefuegt!');
  end else
  begin
   if i < tree^.value then
  begin
   Insert_Node(tree^.left,i);
  end else
  begin
   Insert_Node(tree^.right,i);
   end;
 end;
end;

procedure Del_Tree(var tree: ref; i: integer);
begin
 if tree <> nil then
 begin
   tree^.left:=nil;
   tree^.right:=nil;
   tree:=nil;
 end else begin
  if i < tree^.value then
  begin
   Del_Tree(tree^.left,tree^.Value);
  end else
  begin
   Del_Tree(tree^.right,tree^.Value);
   end; end;
end;

procedure Element;
var i: integer;
begin
 write('Welches Element hinzufuegen? ');
 readLN(i);
 insert_Node(tree,i);
end;

procedure Draw_Tree(var tree: ref; tiefe: integer);
var Zahl : String;
begin
  if tree <> nil then begin
    Str(tree^.Value,Zahl);
    if tree^.right <> nil
      then draw_tree(tree^.right,Tiefe + Length(Zahl));
    Write(' ':Tiefe);
    Writeln(Zahl);
    if tree^.left <> nil
      then draw_tree(tree^.left,Tiefe + Length(Zahl));
  end else Writeln('Leerer Baum');
end;

function buildtree(amount: integer): ref;
var node: ref;
    leftnodes, rightnodes: integer;
begin
 if amount = 0 then
 buildtree:=nil else
 begin
  leftnodes:= amount div 2;
  rightnodes:= amount - leftnodes - 1;
  new(node);
  node^.value:=amount;
  write('L-> ',amount,' ');
  node^.left:= buildtree(leftnodes);
  write('Wechsel!!!');
  writeLN;
  node^.value:=amount;
  write('R-> ',amount,' ');
  node^.right:= buildtree(rightnodes);
  buildtree:=node;
 end;
end;

procedure search(var tree: ref; value: integer);
begin
if tree <> nil then begin
if value = tree^.value then
 writeLN(value,'. gefunden!')
else
 if value < tree^.value then
   search(tree^.left, value)
 else
   search(tree^.right, value); end;
end;

procedure Seek_element(var tree: ref);
var i: integer;
begin
 write('Welches Element soll gesucht werden? ');
 readLN(i);
 Search(tree,i);
end;

procedure insert(var tree: ref; value:integer);
begin
 if tree <> nil then
    search(tree,value);
 new(tree);
 tree^.value:=value;
end;

procedure order(var tree: ref; var i: integer);
begin
if tree <> nil then begin
{PreOrder!!!}
if i = 0 then write(tree^.value,' ');
 Order(tree^.left,i);
{InOrder!!!}
if i = 1 then write(tree^.value,' ');
 Order(tree^.right,i);
{PostOrder!!!}
if i = 2 then write(tree^.value,' ');
end;
end;

procedure order2(var tree: ref; var i: integer; var i2: integer);
begin
{PreOrder!!!}
if i2 = 0 then insert_Node(tree,i);
 Order2(tree^.left,i,i2);
{InOrder!!!}
if i2 = 1 then insert_Node(tree,i);
 Order2(tree^.right,i,i2);
{PostOrder!!!}
if i2 = 2 then insert_Node(tree,i);
end;

procedure OrderProc(var tree: ref);
var i: integer;
begin
 writeLN;
 write('Welche Order-Folge! (0-Pre, 1-In, 2-Post)!');
 readLN(i);
 order(tree,i);
end;

procedure OrderProc2(var tree: ref);
var i,a,i2: integer;
    s: string;
begin
 writeLN;
 write('Order-Folge eingeben! (keine Zahlen > 9)');
 readLN(s);
 write('Welche Order-Folge! (0-Pre, 1-In, 2-Post)!');
 readLN(i2);
 for a:=1 to length(s) do begin
 val(s[a],i,i);
 order2(tree,i,i2); end;
end;

procedure Menu_Set;
begin
ClrScr;
writeLN('T R E E - D E M O ! ! !');
writeLN;
writeLN('m - Make_Node');
writeLN('d - Draw_Tree');
writeLN('f - Build_Tree');
writeLN('s - Search_Tree');
writeLN('o - OrderProc');
writeLN('v - Order_Eingeben');
writeLN('n - Del_Node');
writeLN('l - Del_Tree');
writeLN('______________x_');
writeLN('e - Menu_set');
writeLN('q - Ende_Gelnde');
writeLN;
end;

begin
TextMode(CO80 xor Lo(LastMode)+Font8x8 xor LASTMODE);
Menu_Set;
repeat
c:=readkey;
case c of
'm': Element;
'd': begin
     writeLN;
     Draw_Tree(tree,1);
     writeLN;
     end;
'f': tree:=BuildTree(7);
's': Seek_Element(tree);
'o': OrderProc(tree);
'v': OrderProc2(tree);
'x': begin
      insert_Node(tree,4);
      insert_Node(tree,2);
      insert_Node(tree,6);
      insert_Node(tree,3);
      insert_Node(tree,1);
      insert_Node(tree,5);
      insert_Node(tree,8);
      insert_Node(tree,7);
      insert_Node(tree,9);
     end;
'n': Del_element(tree);
'l': Del_Tree(tree,1);
{________________}
'e': Menu_Set;
'q': Halt(1);
end;
until count = 1;
end.