wanted, balanced binary tree package 
Author Message
 wanted, balanced binary tree package

I am looking for a generic balanced binary tree package.  Any assistance in
finding an existing coded package would be appreciated.

Barry


Keywords:



Mon, 24 Jun 1996 05:29:21 GMT  
 wanted, balanced binary tree package

Quote:

>I am looking for a generic balanced binary tree package.  Any assistance in
>finding an existing coded package would be appreciated.

>Barry


>Keywords:

Here you go...

/Bevin
DEC Ada team
Digital Equipment Corporation

--------------------------------------------------------------------------------

generic
    type Key_Type   is private;
    type Value_Type is private;
    with function "<"(Left,Right : Key_Type) return Boolean is <>;
package Generic_Balanced_Binary_Tree_1 is

    type Tree_Type is limited private;

    type Access_Node_Type is private;
    No_Such_Node : constant Access_Node_Type;

    procedure Free(Tree : in out Tree_Type);

    function Root(Tree : Tree_Type) return Access_Node_Type;

    function Size(Tree : Tree_Type) return Natural;

    procedure Set_Value(Node : in Access_Node_Type; Value : in Value_Type);
        pragma Inline(Set_Value);

    function Key_Value(Node : in Access_Node_Type) return Key_Type;
        pragma Inline(Key_Value);

    function Value(Node : in Access_Node_Type) return Value_Type;
        pragma Inline(Value);

    procedure Insert(
        Key                : Key_Type;
        Tree               : in out Tree_Type;
        Found_or_Made_Node : out Access_Node_Type;
        Was_Made           : out Boolean);

    procedure Look_Up(
        Key                : Key_Type;
        Tree               : in Tree_Type;
        Found_Node         : out Access_Node_Type);

    type Search_Direction_Type is (Search_Lower, Search_Higher, Give_Up);

    generic
        with function Examine(
            Node : Access_Node_Type;
            Key  : Key_Type) return Search_Direction_Type;
    procedure Search_Tree(Root : in Access_Node_Type);
        pragma Inline_Generic(Search_Tree);

    procedure Do_Nothing(
        Depth : in Natural;
        Node  : in Access_Node_Type;
        Key   : in Key_Type;
        Value : in out Value_Type;
        Quit  : in out Boolean);        pragma Inline(Do_Nothing);

    generic
        with procedure Pre_Action(
            Depth : in Natural;
            Node  : in Access_Node_Type;
            Key   : in Key_Type;
            Value : in out Value_Type;
            Quit  : in out Boolean) is Do_Nothing;
        with procedure In_Action(
            Depth : in Natural;
            Node  : in Access_Node_Type;
            Key   : in Key_Type;
            Value : in out Value_Type;
            Quit  : in out Boolean) is Do_Nothing;
        with procedure Post_Action(
            Depth : in Natural;
            Node  : in Access_Node_Type;
            Key   : in Key_Type;
            Value : in out Value_Type;
            Quit  : in out Boolean) is Do_Nothing;
    procedure Walk(Start : in Access_Node_Type; Depth : Natural := 0);
        pragma Inline_Generic(Walk);

    generic
        with procedure Put(Key   : Key_Type) is <>;
        with procedure Put(Value : Value_Type) is <>;
        with procedure Put(Str   : String) is <>;
        with procedure New_Line is <>;
    procedure Put_Subtree(Root : in Access_Node_Type);
        pragma Inline_Generic(Put_Subtree);

private
    type Side_Type is (Left,Right);
    type Balance_Type is array(Side_Type) of Boolean;
    type Sons_Type    is array(Side_Type) of Access_Node_Type;

    type Node_Type;
    type Access_Node_Type is access Node_Type;
    No_Such_Node : constant Access_Node_Type := null;
    type Node_Type is
        record
            Key       : Key_Type;
            Sons      : Sons_Type;
            Balance   : Balance_Type;
            Value     : Value_Type;
        end record;

    type Tree_Type is
        record
            Size : Natural := 0;
            Root : Access_Node_Type := null;
        end record;

end Generic_Balanced_Binary_Tree_1;
    pragma Inline_Generic(Generic_Balanced_Binary_Tree_1);

with Unchecked_Deallocation;
package body Generic_Balanced_Binary_Tree_1 is

    procedure Deallocate is new Unchecked_Deallocation(
        Object => Node_Type,
        Name   => Access_Node_Type);

    procedure Free(Tree : in out Tree_Type) is
        procedure Free(Access_Node : in out Access_Node_Type) is
        begin
            if Access_Node /= null then
                Free(Access_Node.Sons(Left));
                Free(Access_Node.Sons(Right));
                Deallocate(Access_Node);
            end if;
        end;
    begin
        Free(Tree.Root);
        Tree.Size := 0;
    end;

    function Root(Tree : Tree_Type) return Access_Node_Type is
    begin
        return Tree.Root;
    end;

    function Size(Tree : Tree_Type) return Natural is
    begin
        return Tree.Size;
    end;

    procedure Set_Value(Node : in Access_Node_Type; Value : in Value_Type) is
    begin
        Node.Value := Value;
    end;

    function Key_Value(Node : in Access_Node_Type) return Key_Type is
    begin
        return Node.Key;
    end;

    function Value(Node : in Access_Node_Type) return Value_Type is
    begin
        return Node.Value;
    end;

    procedure Insert(
        Key                : Key_Type;
        Tree               : in out Tree_Type;
        Found_or_Made_Node : out Access_Node_Type;
        Was_Made           : out Boolean)
    is

        procedure Insert(
            Into        : in out Access_Node_Type;
            Got_Deeper  : out Boolean)
        is
        begin
            -- Make if reached bottom
            if Into = null then
                Into        := new Node_Type;
                Into.Key    := Key;
                Into.Balance := (False, False);

                Tree.Size := Tree.Size + 1;

                Found_or_Made_Node := Into;
                Was_Made   := True;
                Got_Deeper := True;
                return;
            end if;

            -- Decide which way to go, and insert on that side
            declare
                Node : Node_Type renames Into.all;

                generic
                    Insert_Side, Other_Side : in Side_Type;
                package Do_Insert is
                end;

                package body Do_Insert is
                    Son_Deeper : Boolean;
                begin
                    Insert(Node.Sons(Insert_Side),Son_Deeper);

                    if not Son_Deeper then
                        -- Nothing changed.
                        --
                        Got_Deeper := False;

                    elsif not Node.Balance(Insert_Side) then
                        -- Either is now balanced, or now marginally tipped
                        -- to the insert side.
                        --
                        if Node.Balance(Other_Side) then
                            Node.Balance(Other_Side)  := False;
                            Got_Deeper := False;
                        else
                            Node.Balance(Insert_Side) := True;
                            Got_Deeper := True;
                        end if;

                    else
                        declare
                            PA : constant Access_Node_Type := Into;
                            A  : Node_Type renames Node;
                            PB : constant Access_Node_Type := A.Sons(Insert_Side);
                            B  : Node_Type renames PB.all;
                        begin
                            if B.Balance(Insert_Side) then
                                --   A+         -->     Be
                                -- 1   B+             Ae  C
                                --    2 C            12   34
                                --      34                  
                                --
                                declare
                                    PC  : constant Access_Node_Type
                                        := B.Sons(Insert_Side);
                                    C  : Node_Type renames PC.all;
                                begin
                                    Into := PB;
                                    A.Sons(Insert_Side) := B.Sons(Other_Side);
                                    B.Sons(Other_Side)  := PA;

                                    A.Balance(Insert_Side) := False;
                                    B.Balance(Insert_Side) := False;

                                    Got_Deeper := False;
                                end;

                            else --if B.Balance(Other_Side) then
                                --   A+         -->     Ce
                                -- 1  +B              A   B
                                --    C 4            12   34
                                --   23                    
                                --

                                declare
                                    PC  : constant Access_Node_Type
                                        := B.Sons(Other_Side);
                                    C   : Node_Type renames PC.all;
                                begin
                                    Into := PC;
                                    A.Sons(Insert_Side) := C.Sons(Other_Side);
                                    B.Sons(Other_Side)  := C.Sons(Insert_Side);
                                    C.Sons(Other_Side)  := PA;
                                    C.Sons(Insert_Side) := PB;

                                    A.Balance(Insert_Side) := False;
                                    A.Balance(Other_Side)  := C.Balance(Insert_Side);
                                    B.Balance(Insert_Side) := C.Balance(Other_Side);
                                    B.Balance(Other_Side)  := False;
                                    C.Balance(Insert_Side) := False;
                                    C.Balance(Other_Side)  := False;

                                    Got_Deeper := False;
                                end;
                            end if;
                        end;
                    end if;
                end Do_Insert;

            begin
                if Key < Node.Key then
                    declare
                        package Do_Left_Insert is new Do_Insert(Left,Right);
                    begin
                        null;
                    end;
                elsif Node.Key < Key then
                    declare
                        package Do_Right_Insert is new Do_Insert(Right,Left);
                    begin
                        null;
                    end;
                else
                    Found_or_Made_Node := Into;
                    Got_Deeper := False;
                    Was_Made := False;
                end if;
            end;
        end;

    begin -- Insert
        Found_or_Made_Node := null;
        Was_Made           := False;

        declare
            Got_Deeper : Boolean;
        begin
            Insert(Tree.Root, Got_Deeper);
        end;
    end Insert;

    procedure Look_Up(
        Key         : Key_Type;
        Tree        : in Tree_Type;
        Found_Node  : out Access_Node_Type)
    is
        A : Access_Node_Type := Tree.Root;
    begin
        while A /= null loop
            declare
                N : Node_Type renames A.all;
            begin
                if Key < N.Key then
                    A := N.Sons(Left);
                elsif N.Key < Key then
                    A := N.Sons(Right);
                else
                    exit;
                end if;
            end;
        end loop;
        Found_Node := A;  -- Note : null and No_Such_Node are the same!
    end;

    procedure Search_Tree(Root : in Access_Node_Type) is
        A : Access_Node_Type := Root;
    begin
        while A /= null loop
            declare
                N : Node_Type renames A.all;
            begin
                case Examine(A, N.Key) is
                    when Search_Lower  => A := N.Sons(Left);
                    when Search_Higher => A := N.Sons(Right);
                    when Give_Up       => exit;
                end case;
            end;
        end loop;
    end;

    procedure Do_Nothing(
        Depth : in Natural;
        Node  : in Access_Node_Type;
        Key   : in Key_Type;
        Value : in out Value_Type;
        Quit  : in out Boolean) is
    begin
        null;
    end;

    procedure Walk(Start : in Access_Node_Type; Depth : Natural := 0) is
        Quit : Boolean := False;

        procedure Do_Node(Start : in Access_Node_Type; Depth : Natural := 0) is
        begin
            if Start /= null then
                declare
                    Node : Node_Type renames Start.all;
                begin
                    Pre_Action (Depth, Start, Node.Key, Node.Value, Quit);
                    if Quit then return; end if;
                    Do_Node(Start.Sons(Left), Depth+1);
                    if Quit then return; end if;
                    In_Action  (Depth, Start, Node.Key, Node.Value, Quit);
                    if Quit then return; end if;
                    Do_Node(Start.Sons(Right),  Depth+1);
                    if Quit then return; end if;
                    Post_Action(Depth, Start, Node.Key, Node.Value, Quit);
                end;
            end if;
        end;

    begin
        Do_Node(Start,Depth);
    end;

    procedure Put_Subtree(Root : in Access_Node_Type) is
...

read more »



Mon, 24 Jun 1996 04:41:16 GMT  
 
 [ 2 post ] 

 Relevant Pages 

1. Balanced binary tree in Haskell

2. Balanced binary tree in Haskell

3. Balanced Binary Tree

4. looking for balancing (binary/avl) tree programs

5. avl-2.0, a balanced binary tree extension

6. n-ary/balanced binary trees in Common Lisp

7. Height-balanced tree, source code wanted.

8. re-usable software wanted: balanced trees (and more)

9. Modula-2 Binary Tree Routines wanted.

10. Self-Adjusting Binary Search Trees (Splay Trees)

11. Self-Adjusting Binary Search Trees (Splay Trees)

12. AVL Tree,Binary Tree,Sorting..

 

 
Powered by phpBB® Forum Software