[Back to POINTERS SWAG index] [Back to Main SWAG index] [Original]

    {
    > Does anyone have code(preferably TP) the implements AVL trees?
    > I'm having trouble With the insertion part of it.  I'm writing a small
    > parts inventory Program For work(although I'm not employed as a
    > Programmer) and the AVL tree would be very fast For it.
    }

    Program avl;

    Type
      nodeptr = ^node;
      node    = Record
        key   : Char;
        bal   : -1..+1; { bal = h(right) - h(left) }
        left,
        right : nodeptr
      end;

      tree = nodeptr;

    Var
      t : tree;
      h : Boolean; { insert & delete parameter }

    Procedure maketree(Var t : tree);
    begin
      t := nil;
    end;

    Function member(k : Char; t : tree) : Boolean;
    begin { member }
      if t = nil then
        member := False
      else
      if k = t^.key then
        member := True
      else
      if k < t^.key then
        member := member(k, t^.left)
      else
        member := member(k, t^.right);
    end;

    Procedure ll(Var t : tree);
    Var
      p : tree;
    begin
      p := t^.left;
      t^.left  := p^.right;
      p^.right := t;
      t := p;
    end;

    Procedure rr(Var t : tree);
    Var
       p : tree;
    begin
      p := t^.right;
      t^.right := p^.left;
      p^.left  := t;
      t := p;
    end

    Procedure lr(Var t : tree);
    begin
      rr(t^.left);
      ll(t);
    end;

    Procedure rl(Var t : tree);
    begin
      ll(t^.right);
      rr(t);
    end;

    Procedure insert(k : Char; Var t : tree; Var h : Boolean);

      Procedure balanceleft(Var t : tree; Var h : Boolean);
      begin
        Writeln('balance left');
        Case t^.bal of
          +1 :
            begin
              t^.bal := 0;
              h := False;
            end;
           0 : t^.bal := -1;
          -1 :
            begin { rebalance }
              if t^.left^.bal = -1 then
              begin { single ll rotation }
                Writeln('single ll rotation');
                ll(t);
                t^.right^.bal := 0;
              end
              else { t^.left^.bal  = +1 }
              begin  { double lr rotation }
                Writeln('double lr rotation');
                lr(t);
                if t^.bal = -1 then
                  t^.right^.bal := +1
                else
                  t^.right^.bal := 0;
                if t^.bal = +1 then
                  t^.left^.bal := -1
                else
                  t^.left^.bal := 0;
              end;
              t^.bal := 0;
              h := False;
            end;
        end;
      end;

      Procedure balanceright(Var t : tree; Var h : Boolean);
      begin
        Writeln('balance right');
        Case t^.bal of
          -1 :
            begin
              t^.bal := 0;
              h := False;
            end;
           0 : t^.bal := +1;
          +1 :
            begin { rebalance }
              if t^.right^.bal = +1 then
              begin { single rr rotation }
                Writeln('single rr rotation');
                rr(t);
                t^.left^.bal := 0
              end
              else { t^.right^.bal  = -1 }
              begin  { double rl rotation }
                Writeln('double rl rotation');
                rl(t);
                if t^.bal = -1 then
                  t^.right^.bal := +1
                else
                  t^.right^.bal := 0;
                if t^.bal = +1 then
                  t^.left^.bal := -1
                else
                  t^.left^.bal := 0;
              end;
              t^.bal := 0;
              h := False;
            end;
        end;
      end;

    begin { insert }
      if t = nil then
      begin
        new(t);
        t^.key   := k;
        t^.bal   := 0;
        t^.left  := nil;
        t^.right := nil;
              h := True;
      end
      else
      if k < t^.key then
      begin
        insert(k, t^.left, h);
              if h then
          balanceleft(t, h);
      end
      else
      if k > t^.key then
      begin
        insert(k, t^.right, h);
        if h then
          balanceright(t, h);
      end;
    end;

    Procedure delete(k : Char; Var t : tree; Var h : Boolean);

      Procedure balanceleft(Var t : tree; Var h : Boolean);
      begin
        Writeln('balance left');
        Case t^.bal of
          -1 :
            begin
              t^.bal := 0;
              h := True;
            end;
           0 :
             begin
                     t^.bal := +1;
                     h := False;
                   end;
          +1 :
            begin { rebalance }
              if t^.right^.bal >= 0 then
              begin
                Writeln('single rr rotation'); { single rr rotation }
                            if t^.right^.bal = 0 then
                begin
                  rr(t);
                              t^.bal := -1;
                              h := False;
                            end
                            else
                begin
                  rr(t);
                              t^.left^.bal := 0;
                              t^.bal := 0;
                              h := True;
                            end;
              end
              else { t^.right^.bal  = -1 }
              begin
                            Writeln('double rl rotation');
                       rl(t);
                            t^.left^.bal := 0;
                t^.right^.bal := 0;
                            h := True;
                          end;
            end;
        end;
      end;

      Procedure balanceright(Var t : tree; Var h : Boolean);
      begin
        Writeln('balance right');
        Case t^.bal of
          +1 :
            begin
              t^.bal := 0;
              h := True;
            end;
           0 :
             begin
                     t^.bal := -1;
                     h := False;
                   end;
          -1 :
            begin { rebalance }
              if t^.left^.bal <= 0 then
              begin { single ll rotation }
                Writeln('single ll rotation');
                            if t^.left^.bal = 0 then
                begin
                  ll(t);
                              t^.bal := +1;
                              h := False;
                            end
                            else
                begin
                  ll(t);
                              t^.left^.bal := 0;
                              t^.bal := 0;
                              h := True;
                            end;
              end
              else { t^.left^.bal  = +1 }
              begin  { double lr rotation }
                Writeln('double lr rotation');
                lr(t);
                            t^.left^.bal := 0;
                            t^.right^.bal := 0;
                            h := True;
              end;
            end;
        end;
      end;

      Function deletemin(Var t : tree; Var h : Boolean) : Char;
      begin { deletemin }
        if t^.left = nil then
        begin
          deletemin := t^.key;
          t := t^.right;
                h := True;
        end
        else
        begin
          deletemin := deletemin(t^.left, h);
                if h then
            balanceleft(t, h);
        end;
      end;

    begin { delete }
      if t <> nil then
      begin
        if k < t^.key then
        begin
          delete(k, t^.left, h);
                if h then
            balanceleft(t, h);
        end
        else
        if k > t^.key then
        begin
          delete(k, t^.right, h);
                if h then
            balanceright(t, h);
        end
        else
        if (t^.left = nil) and (t^.right = nil) then
        begin
          t := nil;
                h := True;
        end
        else
        if t^.left = nil then
        begin
          t := t^.right;
                h := True;
        end
        else
        if t^.right = nil then
        begin
          t := t^.left;
                h := True;
        end
        else
        begin
          t^.key := deletemin(t^.right, h);
                if h then
                  balanceright(t, h);
        end;
      end;
    end;

    begin
    end.

[Back to POINTERS SWAG index] [Back to Main SWAG index] [Original]