home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / TREE.ZIP / TREE.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1985-07-13  |  5.0 KB  |  199 lines
  1. program TREE;
  2.  
  3. type
  4.     Rec_Ptr    = ^Data_Record;
  5.     Rec_Num    = integer;
  6.     Rec_Char    = char;
  7.     Data_Record = record
  8.               Data     : Rec_Num;
  9.               Data2     : Rec_Char;
  10.               LCtr, RCtr : integer;
  11.               LPtr, RPtr : Rec_Ptr;
  12.           end;
  13.  
  14. var
  15.     Root, Ptr     : Rec_Ptr;
  16.     Test_Ptr     : Rec_Ptr;
  17.     Node_Added,
  18.     Node_Found,
  19.     Node_Deleted,
  20.     Tree_Rebuilt : boolean;
  21.     Option     : char;
  22.     Key_Field     : byte;
  23.     Tab      : array [0..15] of byte;
  24.     I, Rand     : integer;
  25.     New_Char     : Rec_Char;
  26.     Count     : integer;
  27.  
  28. procedure CreateNode (New_Data    : Rec_Num;
  29.               New_Data2 : Rec_Char;
  30.               var Ptr    : Rec_Ptr);
  31.     begin
  32.     new (Ptr);
  33.     Ptr^.Data  := New_Data;
  34.     Ptr^.Data2 := New_Data2;
  35.     Ptr^.LCtr  := 0;
  36.     Ptr^.RCtr  := 0;
  37.     Ptr^.LPtr  := nil;
  38.     Ptr^.RPtr  := nil;
  39.     end; { procedure CreateNode }
  40.  
  41. procedure CompareNode (Ptr1, Ptr2   : Rec_Ptr;
  42.                var Relation : char);
  43.     begin
  44.     case Key_Field of
  45.          1 : begin
  46.              if Ptr1^.Data < Ptr2^.Data then Relation := 'L';
  47.              if Ptr1^.Data > Ptr2^.Data then Relation := 'G';
  48.              if Ptr1^.Data = Ptr2^.Data then Relation := 'E';
  49.          end;
  50.          2 : begin
  51.              if Ptr1^.Data2 < Ptr2^.Data2 then Relation := 'L';
  52.              if Ptr1^.Data2 > Ptr2^.Data2 then Relation := 'G';
  53.              if Ptr1^.Data2 = Ptr2^.Data2 then Relation := 'E';
  54.          end;
  55.          else Relation := ' ';
  56.     end; { case Key_Field }
  57.     end; { procedure CompareNode }
  58.  
  59. procedure PrintNode (Ptr : Rec_Ptr);
  60.     begin
  61.     writeln (Ptr^.Data:3, ' ',
  62.          Ptr^.Data2, ' ',
  63.          Ptr^.LCtr:3, ' ',
  64.          Ptr^.RCtr:3);
  65.     end; { procedure PrintNode }
  66.  
  67. {$I tree.inc }
  68.  
  69.  
  70. procedure GetKeyData (Test_Ptr : Rec_Ptr);
  71.     begin
  72.     if Key_Field = 1
  73.        then begin
  74.             write ('enter an integer : ');
  75.             readln (Rand);
  76.             Test_Ptr^.Data := Rand;
  77.         end
  78.        else begin
  79.             write ('enter a character : ');
  80.             readln (New_Char);
  81.             Test_Ptr^.Data2 := New_Char;
  82.        end;
  83.     end; { procedure GetKeyData }
  84.  
  85.  
  86. begin
  87.     Root      := nil;
  88.     Key_Field := 1;
  89.     New_Char  := 'A';
  90.     new (Test_Ptr);
  91.     randomize;
  92.     for I := 1 to 15 do Tab [I] := 0;
  93.     Count := 0;
  94.     repeat
  95.        Rand := random (16);
  96.        if Tab [Rand] = 0 then
  97.       begin
  98.           Count     := Count + 1;
  99.           Tab [Rand] := 1;
  100.           CreateNode (Rand, New_Char, Ptr);
  101.           AddNode (Root, Ptr, 1, Node_Added);
  102.           New_Char := succ (New_Char);
  103.       end;
  104.     until Count = 15;
  105.     repeat
  106.     writeln ('A : Add node');
  107.     writeln ('B : Find node');
  108.     writeln ('C : Delete node');
  109.     writeln ('D : Balance tree');
  110.     writeln ('E : Rebuild tree');
  111.     writeln ('F : Inorder search');
  112.     writeln ('G : Preorder search');
  113.     writeln ('H : Postorder search');
  114.     writeln ('I : Change keys');
  115.     writeln ('X : Exit program');
  116.     writeln; write ('please choose one : '); readln (Option);
  117.     Option := upcase (Option);
  118.     case Option of
  119.          'A' : begin
  120.             writeln ('adding a new node');
  121.             write (' enter an integer : '); readln (Rand);
  122.             write ('enter a character : '); readln (New_Char);
  123.             CreateNode (Rand, New_Char, Ptr);
  124.             AddNode (Root, Ptr, 1, Node_Added);
  125.             if Node_Added
  126.                then writeln ('Node added.')
  127.                else writeln ('Node not added.  Duplicate keys.');
  128.            end;
  129.          'B' : begin
  130.             writeln ('finding a node');
  131.             GetKeyData (Test_Ptr);
  132.             FindNode (Root, Ptr, Test_Ptr, Node_Found);
  133.             if Node_Found
  134.                then PrintNode (Ptr)
  135.                else writeln ('node not found');
  136.            end;
  137.          'C' : begin
  138.             writeln ('deleting a node');
  139.             GetKeyData (Test_Ptr);
  140.             DeleteNode (Root, Test_Ptr, Node_Deleted);
  141.             if Node_Deleted then writeln ('Node deleted.')
  142.                     else writeln ('Node not deleted.');
  143.            end;
  144.          'D' : begin
  145.             writeln ('balancing tree');
  146.             BalanceTree (Root);
  147.             writeln ('Tree balanced');
  148.            end;
  149.          'E' : begin
  150.             writeln ('rebuilding the tree');
  151.             if Key_Field = 1
  152.                then begin
  153.                      writeln ('switching to character keys');
  154.                      Key_Field := 2;
  155.                      RebuildTree (Root, Tree_Rebuilt, 1);
  156.                 end
  157.                else begin
  158.                      writeln ('switching to integer keys');
  159.                      Key_Field := 1;
  160.                      RebuildTree (Root, Tree_Rebuilt, 2);
  161.                end;
  162.             if Tree_Rebuilt then writeln ('Tree rebuilt')
  163.                     else writeln ('Tree not rebuilt');
  164.            end;
  165.          'F' : begin
  166.             writeln ('starting inorder search');
  167.             Inorder (Root);
  168.             writeln ('inorder finished.  press return');
  169.             readln;
  170.            end;
  171.          'G' : begin
  172.             writeln ('starting preorder search');
  173.             Preorder (Root);
  174.             writeln ('preorder finished.  press return');
  175.             readln;
  176.            end;
  177.          'H' : begin
  178.             writeln ('starting postorder search');
  179.             Postorder (Root);
  180.             writeln ('postorder finished.  press return');
  181.             readln;
  182.            end;
  183.          'I' : begin
  184.             if Key_Field = 1
  185.                then begin
  186.                      Key_Field := 2;
  187.                      writeln ('using characters as key');
  188.                 end
  189.                else begin
  190.                      Key_Field := 1;
  191.                      writeln ('using integers as key');
  192.                end;
  193.            end;
  194.     end; { case Option }
  195.     until Option = 'X';
  196.     Mark (Root);
  197.     Release (Root);
  198. end.
  199.