File: dbf\b_tree_avl.adb

    1 --::::::::::
    2 --btreeavl.adb
    3 --::::::::::
    4 -- Developed by (C) Wasiliy W. Molostoff 1994, 1995.
    5 --                  Moscow, Russia,
    6 --                  Voice:   7 (095) 398-23-38
    7 --                  e-mail:  edv@edv.msk.ru
    8 -- This is free software; you can  freely  redistribute  it  and/or
    9 -- modify  it  without any restrictions.  Please report any errors.
   10 -- All corrections will be made as soon as possible.
   11 with unchecked_deallocation;
   12 package body b_tree_avl is
   13 
   14   type balance is (l_disb, no_disb, r_disb);
   15 
   16   type tree_data is record
   17        item: item_type;
   18        data: data_type;
   19        bal:  balance          := no_disb;
   20        left, right: tree_type := null;
   21   end record;
   22 
   23   procedure free is new unchecked_deallocation(tree_data, tree_type);
   24 
   25   --------------------------------------------------------------------
   26 
   27   procedure insert (tree: in out tree_type;
   28                     item:        item_type;
   29                     data:        data_type) is
   30 
   31        upd : boolean := false;
   32        hght: boolean;
   33 
   34        procedure tryput (node: in out tree_type; h: in out boolean) is
   35             pp1, pp2: tree_type;
   36        begin
   37             if  node = null then
   38                  node       := new tree_data;
   39                  node.item  := item;
   40                  node.data  := data;
   41                  h         := true;
   42             elsif item < node.item then
   43                  tryput (node.left, h);
   44                  if h then
   45                       case node.bal is
   46                            when  r_disb => node.bal :=  no_disb; h:= false;
   47                            when  no_disb => node.bal := l_disb;
   48                            when l_disb =>
   49                                 pp1 := node.left;
   50                                 if pp1.bal = l_disb then
   51                                      node.left := pp1.right;
   52                                      pp1.right := node;
   53                                      node.bal := no_disb; node := pp1;
   54                                 else
   55                                      pp2 := pp1.right;
   56                                      pp1.right := pp2.left;
   57                                      pp2.left := pp1;
   58                                      node.left := pp2.right;
   59                                      pp2.right := node;
   60 
   61                                      if pp2.bal = l_disb then
   62                                           node.bal := r_disb;
   63                                      else
   64                                           node.bal := no_disb;
   65                                      end if;
   66 
   67                                      if pp2.bal =  r_disb then
   68                                           pp1.bal := l_disb;
   69                                      else
   70                                           pp1.bal := no_disb;
   71                                      end if;
   72                                      node := pp2;
   73                                 end if;
   74                                 node.bal := no_disb; h:= false;
   75                       end case;
   76                  end if;
   77             elsif node.item < item then
   78                  tryput (node.right, h);
   79                  if h then
   80                       case node.bal is
   81                            when l_disb => node.bal :=  no_disb; h:= false;
   82                            when  no_disb => node.bal :=  r_disb;
   83                            when  r_disb =>
   84                                 pp1 := node.right;
   85                                 if pp1.bal = r_disb then
   86                                      node.right := pp1.left;
   87                                      pp1.left := node;
   88                                      node.bal := no_disb; node := pp1;
   89                                 else
   90                                      pp2 := pp1.left;
   91                                      pp1.left := pp2.right;
   92                                      pp2.right := pp1;
   93                                      node.right := pp2.left;
   94                                      pp2.left := node;
   95 
   96                                      if pp2.bal =  r_disb then
   97                                           node.bal := l_disb;
   98                                      else
   99                                           node.bal := no_disb;
  100                                      end if;
  101 
  102                                      if pp2.bal =  l_disb then
  103                                           pp1.bal := r_disb;
  104                                      else
  105                                           pp1.bal := no_disb;
  106                                      end if;
  107                                      node := pp2;
  108                                 end if;
  109                                 node.bal := no_disb; h:= false;
  110                       end case;
  111                  end if;
  112             else -- dup
  113                  if upd then
  114                     node.data  := data;
  115                  end if;
  116             end if;
  117        end tryput;
  118   begin
  119        tryput (tree, hght);
  120   end insert;
  121 
  122   --------------------------------------------------------------------
  123 
  124   procedure free_nodes (node: in out tree_type) is
  125   begin
  126        if node /= null then
  127             free_nodes (node.left);
  128             free_nodes (node.right);
  129             free (node);
  130        end if;
  131   end;
  132 
  133   --------------------------------------------------------------------
  134 
  135   procedure delete (tree : in out tree_type) is
  136   begin
  137        free_nodes (tree);
  138   end;
  139 
  140   --------------------------------------------------------------------
  141 
  142   procedure b_left (pp: in out tree_type; h: in out boolean) is
  143        pp1, pp2: tree_type;
  144        bb1, bb2: balance;
  145   begin
  146        case pp.bal is
  147             when l_disb => pp.bal := no_disb;
  148             when  no_disb => pp.bal := r_disb; h := false;
  149             when  r_disb => pp1 := pp.right; bb1 := pp1.bal;
  150                  if bb1 >= no_disb then
  151                       pp.right := pp1.left; pp1.left := pp;
  152                       if bb1 = no_disb then
  153                            pp.bal := r_disb; pp1.bal := l_disb; h:= false;
  154                       else
  155                            pp.bal := no_disb; pp1.bal := no_disb;
  156                       end if;
  157                       pp := pp1;
  158                  else
  159                       pp2 := pp1.left; bb2 := pp2.bal;
  160                       pp1.left := pp2.right; pp2.right := pp1;
  161                       pp.right := pp2.left; pp2.left := pp;
  162                       if bb2 = r_disb then pp.bal := l_disb; else pp.bal := no_disb; end if;
  163                       if bb2 = l_disb then pp1.bal := r_disb; else pp1.bal := no_disb; end if;
  164                       pp := pp2; pp2.bal := no_disb;
  165                  end if;
  166        end case;
  167   end b_left;
  168 
  169   --------------------------------------------------------------------
  170 
  171   procedure b_right (pp: in out tree_type; h: in out boolean) is
  172        pp1, pp2: tree_type;
  173        bb1, bb2: balance;
  174   begin
  175        case pp.bal is
  176             when  r_disb => pp.bal :=  no_disb;
  177             when  no_disb => pp.bal := l_disb; h := false;
  178             when  l_disb => pp1 := pp.left; bb1 := pp1.bal;
  179                  if bb1 <= no_disb then
  180                       pp.left := pp1.right; pp1.right := pp;
  181                       if bb1 = no_disb then
  182                            pp.bal := l_disb; pp1.bal := r_disb; h:= false;
  183                       else
  184                            pp.bal := no_disb; pp1.bal := no_disb;
  185                       end if;
  186                       pp := pp1;
  187                  else
  188                       pp2 := pp1.right; bb2 := pp2.bal;
  189                       pp1.right := pp2.left; pp2.left := pp1;
  190                       pp.left := pp2.right; pp2.right := pp;
  191                       if bb2 = l_disb then pp.bal := r_disb; else pp.bal := no_disb; end if;
  192                       if bb2 = r_disb then pp1.bal := l_disb; else pp1.bal := no_disb; end if;
  193                       pp := pp2; pp2.bal := no_disb;
  194                  end if;
  195        end case;
  196   end b_right;
  197 
  198   --------------------------------------------------------------------
  199 
  200   procedure delete (tree     : in out tree_type;
  201                     item     :        item_type;
  202                     data     :    out data_type;
  203                      ok     :    out boolean) is
  204 
  205        hei: boolean;
  206 
  207        procedure recur_del  (p: in out tree_type; h: in out boolean) is
  208             q: tree_type;
  209             procedure x_del (node: in out tree_type; h: in out boolean) is
  210             begin
  211                  if node.right /= null then
  212                       x_del (node.right, h);
  213                       if h then b_right (node, h); end if;
  214                  else
  215                       q.item := node.item;
  216                       q.data := node.data; q := node;
  217                       node := node.left; h := true;
  218                  end if;
  219             end x_del;
  220 
  221        begin
  222             if p = null then return;
  223             elsif item < p.item then
  224                  recur_del (p.left, h);
  225                  if h then b_left (p, h); end if;
  226             elsif p.item = item then
  227                  q := p;
  228                  if    q.right = null then
  229                       p := q.left; h:= true;
  230                  elsif q.left  = null then
  231                       p := q.right; h := true;
  232                  else
  233                       x_del (q.left, h);
  234                       if h then b_left (p, h); end if;
  235                  end if;
  236                  data := q.data;
  237                  ok  := true;
  238                  free (q);
  239             else -- not "<"
  240                  recur_del (p.right, h);
  241                  if h then b_right (p, h); end if;
  242             end if;
  243        end recur_del;
  244   begin
  245        ok := false;
  246        recur_del (tree, hei);
  247   end delete;
  248 
  249   --------------------------------------------------------------------
  250 
  251   procedure get_first (tree  : in     tree_type;
  252                        item  :    out item_type;
  253                        data  :    out data_type;
  254                        ok    :    out boolean) is
  255 
  256        x: tree_type := tree;
  257   begin
  258        ok  := false;
  259        if x = null then return; end if;
  260 
  261        loop
  262              exit when x.left = null;
  263              x := x.left;
  264        end loop;
  265        item := x.item;
  266        data := x.data;
  267        ok  := true;
  268   end;
  269 
  270   --------------------------------------------------------------------
  271 
  272   procedure get_last  (tree  : in     tree_type;
  273                        item  :    out item_type;
  274                        data  :    out data_type;
  275                        ok    :    out boolean) is
  276 
  277        x: tree_type := tree;
  278   begin
  279        ok  := false;
  280        if x = null then return; end if;
  281 
  282        loop
  283              exit when x.right = null;
  284              x := x.right;
  285        end loop;
  286        item := x.item;
  287        data := x.data;
  288        ok  := true;
  289   end;
  290 
  291   --------------------------------------------------------------------
  292 
  293   procedure modify (tree     : in out tree_type;
  294                     item     :        item_type;
  295                     data     :        data_type;
  296                       ok     :    out boolean) is
  297 
  298        x: tree_type := tree;
  299   begin
  300        ok := false;
  301        loop
  302             exit when x = null;
  303             exit when x.item = item;
  304             if   item < x.item then
  305                  x := x.left;
  306             else    x := x.right;
  307             end if;
  308        end loop;
  309        if x /= null then
  310           x.data := data;
  311           ok    := true;
  312        end if;
  313   end;
  314 
  315   --------------------------------------------------------------------
  316 
  317   procedure get_ge (tree     :        tree_type;
  318                     item     : in out item_type;
  319                     data     :    out data_type;
  320                       ok     :    out boolean) is
  321 
  322        x: tree_type := tree;
  323        g: tree_type := null;
  324   begin
  325        ok  := false;
  326        loop
  327             exit when x = null;
  328             exit when x.item = item;
  329             if   item < x.item then
  330                  g := x;
  331                  x := x.left;
  332             else x := x.right;
  333             end if;
  334        end loop;
  335 
  336        if x = null then
  337           x := g;
  338        end if;
  339 
  340        if x /= null then
  341             item := x.item;
  342             data := x.data;
  343             ok  := true;
  344        end if;
  345   end;
  346 
  347   --------------------------------------------------------------------
  348 
  349   procedure get_gt (tree     :        tree_type;
  350                     item     : in out item_type;
  351                     data     :    out data_type;
  352                       ok     :    out boolean) is
  353 
  354        x: tree_type := tree;
  355        g: tree_type;
  356   begin
  357        ok  := false;
  358        loop
  359             exit when x = null;
  360             if   item < x.item then
  361                  g := x;
  362                  x := x.left;
  363             else
  364                  x := x.right;
  365             end if;
  366        end loop;
  367        if g /= null then
  368             item := g.item;
  369             data := g.data;
  370             ok  := true;
  371        end if;
  372   end;
  373 
  374   --------------------------------------------------------------------
  375 
  376   procedure get_le (tree     :        tree_type;
  377                     item     : in out item_type;
  378                     data     :    out data_type;
  379                       ok     :    out boolean) is
  380 
  381        x: tree_type := tree;
  382        l: tree_type := null;
  383   begin
  384        ok  := false;
  385        loop
  386             exit when x = null;
  387             exit when x.item = item;
  388             if   x.item < item then
  389                  l := x;
  390                  x := x.right;
  391             else x := x.left;
  392             end if;
  393        end loop;
  394 
  395        if x = null then
  396           x := l;
  397        end if;
  398 
  399        if x /= null then
  400             item := x.item;
  401             data := x.data;
  402             ok  := true;
  403        end if;
  404   end;
  405 
  406   --------------------------------------------------------------------
  407 
  408   procedure get_lt (tree    :        tree_type;
  409                     item    : in out item_type;
  410                     data    :    out data_type;
  411                       ok    :    out boolean) is
  412 
  413        x: tree_type := tree;
  414        l: tree_type;
  415   begin
  416        ok  := false;
  417        loop
  418             exit when x = null;
  419             if   x.item < item then
  420                  l := x;
  421                  x := x.right;
  422             else x := x.left;
  423             end if;
  424        end loop;
  425        if l /= null then
  426             item := l.item;
  427             data := l.data;
  428             ok  := true;
  429        end if;
  430   end;
  431 
  432 end;
  433