home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / TREE.ZIP / TREE.INC < prev    next >
Encoding:
Text File  |  1985-07-13  |  7.3 KB  |  214 lines
  1. procedure InOrder (Ptr : Rec_Ptr);
  2.     begin
  3.         if Ptr <> nil then
  4.            begin
  5.                InOrder   (Ptr^.LPtr);
  6.                PrintNode (Ptr);
  7.                InOrder   (Ptr^.RPtr);
  8.            end;
  9.     end; { procedure InOrder }
  10.  
  11.  
  12. procedure PreOrder (Ptr : Rec_Ptr);
  13.     begin
  14.         if Ptr <> nil then
  15.            begin
  16.                PrintNode (Ptr);
  17.                PreOrder  (Ptr^.LPtr);
  18.                PreOrder  (Ptr^.RPtr);
  19.            end;
  20.     end; { procedure PreOrder }
  21.  
  22.  
  23. procedure PostOrder (Ptr : Rec_Ptr);
  24.     begin
  25.         if Ptr <> nil then
  26.            begin
  27.                PostOrder (Ptr^.LPtr);
  28.                PostOrder (Ptr^.RPtr);
  29.                PrintNode (Ptr);
  30.            end;
  31.     end; { procedure PostOrder }
  32.  
  33.  
  34. procedure FindNode (Root       : Rec_Ptr;
  35.                     var Ptr    : Rec_Ptr;
  36.                     Comp_Ptr   : Rec_Ptr;
  37.                     var Node_Found : boolean);
  38. var Relation : char;
  39.     begin
  40.         Node_Found := false;
  41.         Ptr        := nil;
  42.         if Root <> nil then begin
  43.            CompareNode (Comp_Ptr, Root, Relation);
  44.            case Relation of
  45.                 'L' : FindNode (Root^.LPtr, Ptr, Comp_Ptr, Node_Found);
  46.                 'G' : FindNode (Root^.RPtr, Ptr, Comp_Ptr, Node_Found);
  47.                 'E' : begin
  48.                           Node_Found := true;
  49.                           Ptr        := Root;
  50.                       end;
  51.            end; { case Relation }
  52.         end;
  53.     end; { procedure FindNode }
  54.  
  55.  
  56. procedure AddNode (var Root       : Rec_Ptr;
  57.                    Ptr            : Rec_Ptr;
  58.                    Cnt            : integer;
  59.                    var Node_Added : boolean);
  60. var Relation : char;
  61.     begin
  62.         Node_Added := false;
  63.         if Root = nil then begin
  64.            Root := Ptr;
  65.            Node_Added := true;
  66.         end else begin
  67.            CompareNode (Ptr, Root, Relation);
  68.            case Relation of
  69.                 'L' : begin
  70.                           AddNode (Root^.LPtr, Ptr, Cnt, Node_Added);
  71.                           if Node_Added then Root^.LCtr := Root^.LCtr + Cnt;
  72.                       end;
  73.                 'G' : begin
  74.                           AddNode (Root^.RPtr, Ptr, Cnt, Node_Added);
  75.                           if Node_Added then Root^.RCtr := Root^.RCtr + Cnt;
  76.                       end;
  77. 'E' : writeln ('Node not added. Nodes equal.',
  78.                '      Root = ', Root^.Data,
  79.                '  New data = ', Ptr^.Data);
  80. else writeln ('Node not added. Root = ', Root^.Data,
  81.                         '  New data = ', Ptr^.Data);
  82.            end; { case Relation }
  83.         end;
  84.     end; { procedure AddNode }
  85.  
  86.  
  87. procedure DeleteNode (var Root         : Rec_Ptr;
  88.                       Del_Ptr          : Rec_Ptr;
  89.                       var Node_Deleted : boolean);
  90. var Temp     : Rec_Ptr;
  91.     Flag     : boolean;
  92.     Relation : char;
  93.     begin
  94.         Node_Deleted := false;
  95.         if Root <> nil then
  96.            begin
  97.                CompareNode (Root, Del_Ptr, Relation);
  98.                case Relation of
  99.                     'G' : begin
  100.                               DeleteNode (Root^.LPtr, Del_Ptr, Node_Deleted);
  101.                               if Node_Deleted then
  102.                                  Root^.LCtr := Root^.LCtr - 1;
  103.                           end;
  104.                     'L' : begin
  105.                               DeleteNode (Root^.RPtr, Del_Ptr, Node_Deleted);
  106.                               if Node_Deleted then
  107.                                  Root^.RCtr := Root^.RCtr - 1;
  108.                           end;
  109.                     'E' : begin
  110.                               Node_Deleted := true;
  111.                               if Root^.RPtr <> nil then
  112.                                  AddNode (Root^.LPtr, Root^.RPtr,
  113.                                           Root^.RCtr, Flag);
  114.                               Temp := Root;
  115.                               Root := Root^.LPtr;
  116.                               dispose (Temp);
  117.                           end;
  118.                end; { case Relation }
  119.         end;
  120.     end; { procedure DeleteNode }
  121.  
  122.  
  123. procedure BalanceTree (var Root : Rec_Ptr);
  124.  
  125.     procedure MoveDown (var Root : Rec_Ptr);
  126.     var Flag : boolean;
  127.         Ptr  : Rec_Ptr;
  128.         begin
  129.             Ptr := Root;
  130.             if Root^.LCtr > Root^.RCtr then
  131.                begin
  132.                    Root      := Root^.LPtr;
  133.                    AddNode (Root, Ptr, Ptr^.RCtr + 1, Flag);
  134.                    Ptr^.LPtr := nil;
  135.                    Ptr^.LCtr := 0;
  136.                end else
  137.                begin
  138.                    Root      := Root^.RPtr;
  139.                    AddNode (Root, Ptr, Ptr^.LCtr + 1, Flag);
  140.                    Ptr^.RPtr := nil;
  141.                    Ptr^.RCtr := 0;
  142.                end;
  143.         end; { procedure MoveDown }
  144.  
  145.  
  146.     begin { procedure BalanceTree }
  147.         if (Root^.LPtr <> nil) or (Root^.RPtr <> nil) then
  148.            begin
  149.                while abs (Root^.LCtr - Root^.RCtr) > 1 do
  150.                      MoveDown (Root);
  151.                if Root^.LPtr <> nil then BalanceTree (Root^.LPtr);
  152.                if Root^.RPtr <> nil then BalanceTree (Root^.RPtr);
  153.            end;
  154.     end; { procedure BalanceTree }
  155.  
  156.  
  157. procedure CountNodes (Root : Rec_Ptr);
  158.     begin
  159.         if Root <> nil then begin
  160.            CountNodes (Root^.LPtr);
  161.            CountNodes (Root^.RPtr);
  162.            if Root^.LPtr = nil
  163.               then Root^.LCtr := 0
  164.               else Root^.LCtr := Root^.LPtr^.LCtr + Root^.LPtr^.RCtr + 1;
  165.            if Root^.RPtr = nil
  166.               then Root^.RCtr := 0
  167.               else Root^.RCtr := Root^.RPtr^.LCtr + Root^.RPtr^.RCtr + 1;
  168.         end;
  169.     end; { procedure CountNodes }
  170.  
  171.  
  172. procedure RebuildTree (var Root         : Rec_Ptr;
  173.                        var Tree_Rebuilt : boolean;
  174.                        Old_Key          : byte);
  175. var New_Root : Rec_Ptr;
  176.  
  177.  
  178.     procedure RestructureTree (Old_Root         : Rec_Ptr;
  179.                                var New_Root     : Rec_Ptr;
  180.                                var Tree_Rebuilt : boolean);
  181.     var Node_Added : boolean;
  182.         begin
  183.             if Old_Root <> nil then begin
  184.                RestructureTree (Old_Root^.LPtr, New_Root, Tree_Rebuilt);
  185.                if Tree_Rebuilt then begin
  186.                   Old_Root^.LPtr := nil;
  187.                   Old_Root^.LCtr := 0;
  188.                   RestructureTree (Old_Root^.RPtr, New_Root, Tree_Rebuilt);
  189.                   if Tree_Rebuilt then begin
  190.                      Old_Root^.RPtr := nil;
  191.                      Old_Root^.RCtr := 0;
  192.                      AddNode (New_Root, Old_Root, 1, Node_Added);
  193.                      if not Node_Added then Tree_Rebuilt := false;
  194.                   end;
  195.                end;
  196.             end;
  197.         end; { procedure RestructureTree }
  198.  
  199.  
  200.     begin
  201.         New_Root     := nil;
  202.         Tree_Rebuilt := true;
  203.         RestructureTree (Root, New_Root, Tree_Rebuilt);
  204.         if Tree_Rebuilt
  205.            then Root := New_Root
  206.            else begin
  207.                 Key_Field    := Old_Key;
  208.                 Tree_Rebuilt := true;
  209.                 RestructureTree (New_Root, Root, Tree_Rebuilt);
  210.                 Tree_Rebuilt := false;
  211.                 CountNodes  (Root);
  212.            end;
  213.         BalanceTree (Root);
  214.     end; { procedure RebuildTree }