Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/dbase/mims.src

Text File | 1988-05-03 | 79.4 KB | 2,346 lines

--\\BALANCED_TREES_VIS.ADA
--< PACKAGE : Balanced_Trees.
--  AUTHOR : SSgt R. Kirchner
--           SSgt C. Rasmussen
--           Sgt  D. Hamm
--  LAST MODIFIED : 12 Nov 85
--  BY : Lt Brooke
--  CHANGES MADE : Made Position_in_Tree a PRIVATE type (it used to
--                 be a LIMITED type).
--<
--< PACKAGE DESCRIPTION :
--<
--<      Provides the neccessary functions to create, use and
--< maintain balanced-tree indexing.  The trees created by this
--< package must have a minimum node size of Four keys. (Anything
--< less than four will cause errors in Procedure Delete_Key at the
--< present time.)
--<
--<      The package is generic, instantiated for the Type_Definition
--< you want ASSOCIATED with the STRING data stored within the trees.
--< The string data evaluated within the trees are known as KEYS, and
--< the generic parameter type associated with each KEY is called ITEMS.
--< The data is stored as strings because of the need for searching
--< on partial values.  When creating a new_tree, a length of the
--< strings to be stored within that tree must be specified.  All
--< values inserted into or deleted from that tree must be of that
--< length, and searching for a value of greater length is not allowed.
--< The Exception KEY_LENGTH_ERROR is raised in such cases.
--<
--< PACKAGE DEPENDENCIES :
--<
--<      None.
--<
generic
  type Items is private;
  No_Of_Keys : Positive := 7;
    -- Must not be less than four or Program_Error is raised.

package Balanced_Trees is

  subtype Keys  is String;

  type Trees            is private;
  type Position_In_Tree is private;


  Key_Length_Error   : exception;
  Key_Not_Found      : exception;
  Key_Already_Exists : exception;
  End_Of_Tree        : exception;

  function New_Tree (With_Key_Length : Integer) return Trees;
        -- DESCRIPTION : Creates a tree for strings of KEY_LENGTH.
        -- INPUTS      : With_Key_Length - length of strings.
        -- OUTPUTS     : Trees type pointing to the newly createed tree.
        -- EXCEPTIONS  : None.

  procedure Delete_Tree (Tree : in out Trees);
        -- DESCRIPTION : Deletes a tree and deallocates the space
        --               previously used by that tree.
        -- INPUTS      : Tree - tree to be deleted.
        -- OUTPUTS     : Null Trees type.
        -- EXCEPTIONS  : None.

  function Item_Where (Key_Is : Keys; In_Tree : Trees) return Items;
        -- DESCRIPTION : Returns the item associated to the first
        --               instance (partial Key searches) of the
        --               Key in a Tree.
        -- INPUTS      : In_Tree - The tree to be searched.
        --               Key_Is - The key to be searched for.
        -- OUTPUTS     : The keys related item (if key is found).
        -- EXCEPTIONS  : Key_Length_Error when Using_Key is of greater
        --               length than strings stored in tree.
        --               Key_Not_Found when Using_Key is not found.

  procedure Delete_Key (With_Value : Keys; From : Trees);
        -- DESCRIPTION : Deletes a key from a tree.
        -- INPUTS      : With_Value - Key to be deleted.
        --               From - Tree where key is to be deleted.
        -- OUTPUTS     : None.
        -- EXCEPTIONS  : Key_Length_Error when Key_Value is not the same
        --               length as keys stored in tree.
        --               Key_Not_Found when Key_Value is not found.

  procedure Insert (Key_Value : Keys; And_Item : Items; Into : Trees);
        -- DESCRIPTION : Inserts a key into a tree.
        -- INPUTS      : Key_Value - Key to be inserted.
        --               And_Item - Item to be associated with Key_Value
        --               Into - Tree where Key_Value is inserted.
        -- OUTPUTS     : None.
        -- EXCEPTIONS  : Key_Length_Error when Key_Value is not the same
        --               length as keys stored in tree.
        --               Key_Already_Exists when Key_Value already
        --               exists in the tree.

  procedure Get_First (From            : Trees;
               Giving_Position : out Position_In_Tree;
               Giving_Item     : out Items);
        -- DESCRIPTION : Returns the FIRST position within a tree
        --               and the item at that position.
        -- INPUTS      : From - Tree you want the first
        --               position/item from.
        -- OUTPUTS     : Giving_Position - First Position_In_Tree.
        --               Giving_Item - Item associated with the
        --               Giving_Position.
        -- EXCEPTIONS  : End_Of_Tree when tree has no entries.

  procedure Get_First_Key (From            : Trees;
               With_Value      : Keys;
               Giving_Position : out Position_In_Tree;
               Giving_Item     : out Items);
        -- DESCRIPTION : Returns the position/item assosiated with the
        --               first instance of With_Value.
        -- INPUTS      : From - Tree you want the position/item from.
        --               With_Value - Key you are looking for the
        --               first instance of.
        -- OUTPUTS     : Giving_Position - Position_In_Tree of
        --               With_Value.
        --               And_Item - Item associated with the Key.
        -- EXCEPTIONS  : Key_Length_Error when Key_Value is of greater
        --               length than values stored in tree.
        --               Key_Not_Found when With_Value is not found.

  procedure Get_Last (From            : Trees;
              Giving_Position : out Position_In_Tree;
              Giving_Item     : out Items);
        -- DESCRIPTION : Returns the LAST position within a tree
        --               and the item at that position.
        -- INPUTS      : From - Tree you want the last
        --               position/item from
        -- OUTPUTS     : Giving_Position - Last Position_In_Tree.
        --               And_Item - Item associated with the
        --               Giving_Position.
        -- EXCEPTIONS  : End_Of_Tree when tree has no entries.

  procedure Get_Last_Key (From            : Trees;
              With_Value      : Keys;
              Giving_Position : out Position_In_Tree;
              Giving_Item     : out Items);
        -- DESCRIPTION : Returns the position/item associated with the
        --               last instance of With_Value.
        -- INPUTS      : From - Tree you want position/item from.
        --               With_Value - Key you are looking for the
        --               last instance of.
        -- OUTPUTS     : Giving_Position - Position_In_Tree of
        --               With_Value.
        --               Giving_Item - Item associated with the key.
        -- EXCEPTIONS  : Key_Length_Error when Key_Value is of greater
        --               length than keys stored in tree.
        --               Key_Not_Found when Key_Value is not found.

  procedure Get_Next (From        : in out Position_In_Tree;
              Giving_Item : out Items);
        -- DESCRIPTION : Allows you to get the NEXT sequential position
        --               in a tree and the item at that position.
        -- INPUTS      : From - your current position within a tree.
        -- OUTPUTS     : From - the NEXT position in the tree.
        --               Giving_Item  - The item at the NEXT position.
        -- EXCEPTIONS  : End_Of_Tree when there is not another position.

  procedure Get_Prior (From        : in out Position_In_Tree;
               Giving_Item : out Items);
        -- DESCRIPTION : Allows you to get the PRIOR sequential position
        --               in a tree and the item at that position.
        -- INPUTS      : From - Your current position within a tree.
        -- OUTPUTS     : From - The PRIOR position in the tree.
        --               Giving_Item  - The item at the PRIOR position.
        -- EXCEPTIONS  : End_Of_Tree when there is not a previous position.

  procedure Change_Item (For_Key : Keys; In_Tree : Trees; To : Items);
        -- DESCRIPTION : Changes the item associated with a key.
        -- INPUTS      : For_Key - Key of item to be changed.
        --               In_Tree - Tree where item is to be changed.
        --               To - New item to replace the old item.
        -- OUTPUTS     : None.
        -- EXCEPTIONS  : Key_Length_Error when Key_Value is not the same
        --               length as keys stored in tree.
        --               Key_Not_Found when Key_Value is not found.

  procedure Change_Item (At_Position : Position_In_Tree; To : Items);
        -- DESCRIPTION : Changes the item at a certain tree_position.
        -- INPUTS      : At_Position - Position of item to be changed.
        --               To - New item to replace the old item.
        -- OUTPUTS     : None.
        -- EXCEPTIONS  : None.

  function Key_At (Position : Position_In_Tree) return Keys;
        -- DESCRIPTION : Returns the key located at a position within
        --               a tree.
        -- INPUTS      : Position - Position where the key is at.
        -- OUTPUTS     : The key at that position.
        -- EXCEPTIONS  : None.

  function Item_At (Position : Position_In_Tree) return Items;
        -- DESCRIPTION : Returns the item located at a position within
        --               a tree.
        -- INPUTS      : Position - Position where the item is at.
        -- OUTPUTS     : The item at that position.
        -- EXCEPTIONS  : None.

  function Inclusive_Subtree (Of_Tree  : Trees;
                  From_Key : Keys;
                  To_Key   : Keys) return Trees;
        -- DESCRIPTION : Creates a tree from part of another tree of
        --               everythig between two keys (INCLUSIVE).
        -- INPUTS      : Of_Tree - Initial tree.
        --               From_Key - Starting key of new tree
        --               To_Key - Ending key of new tree.
        -- OUTPUTS     : Trees type pointing to the new tree.
        -- EXCEPTIONS  : Key_Length_Error when either keys are greater
        --               length than keys stored in the original tree.

  function Exclusive_Subtree (Of_Tree  : Trees;
                  From_Key : Keys;
                  To_Key   : Keys) return Trees;
        -- DESCRIPTION : Creates a tree from part of another tree of
        --               everything between two keys (EXCLUSIVE).
        -- INPUTS      : Of_Tree - Initial tree.
        --               From_Key - Starting key of new tree
        --               To_Key - Ending key of new tree.
        -- OUTPUTS     : New tree.
        -- EXCEPTIONS  : Key_Length_Error when either keys are greater
        --               length than keys stored in the original tree.

private
  type Acc_Keys  is access Keys;
    -- Pointer to a Key.
  type Acc_Items is access Items;
    -- Pointer to a Item.
  type Datas is
    record
      Key  : Acc_Keys;
      Item : Acc_Items;
    end record;
      -- A record containing a matched pair of a Key and a Item.
  type Acc_Data   is access Datas;
    -- A pointer to a Datas containg the Key and Item
  type Tree_Array is array (1 .. No_Of_Keys + 1) of Trees;
    -- An Array of pointers.
  type Data_Array is array (1 .. No_Of_Keys) of Acc_Data;
    -- An Array of pointers to Datas.
  type Node;
  type Trees is access Node;
    -- A pointer to a Node.
  type Node is
    record
      Mother  : Trees;
      Pointer : Tree_Array;
      Data    : Data_Array;
    end record;
      -- A record containing a pointer to the parent Node, an array
      -- of pointers to lower Nodes and an array of pointers to the
      -- Data within the Node.
  type Position_In_Tree is
    record
      Node_In_Tree     : Trees;
      Position_In_Node : Integer;
    end record;
      -- A record containing a pointer to a node and a position
      -- within that node.
end Balanced_Trees;
--\\HaMM.ADA
package Source_Scanner is
  Scanner_Quote       : constant Character := '"';
  Scanner_Under_Score : constant Character := '_';

  Scanner_End_Of_File : exception;

  subtype Columns is Integer range 1 .. 81;

  type Symbols is (Id, Op, Literal, End_Of_Input);

  Input_Symbol         : Symbols;
  Scanner_All_Capitals : Boolean := True;
  Token_Upto           : Columns := Columns'First;
  Token80              : String (Columns) := (Columns => ' ');

  procedure Get_Next_Token;
  procedure Initialize_Scanner (File_Name : String);

end Source_Scanner;

with Text_Io;

package body Source_Scanner is

  subtype Lines is String (1 .. 80);

  Upto             : Integer; -- col within row, or row in file
  Line             : Lines;
  Next_Label       : Integer := 100;
  Current          : Character;
  Scanner_File     : Text_Io.File_Type;
  Last             : Integer;
  Still_More_Stuff : Boolean := True;


  function Capitals_Of (S : String) return String is
    Temp : String (S'range) := S;
  begin
    for A in Temp'range loop
      case Temp (A) is
        when 'a' .. 'z' =>
      Temp (A) := Character'Val (Character'Pos (Temp (A)) - 32);

        when others =>
      null;
      end case;
    end loop;

    return Temp;
  end Capitals_Of;


  function String_Of (Message      : String;
                      Until_Length : Integer) return String is
  begin
    if Message'Length >= Until_Length then
      return Message (Message'First .. Message'First + Until_Length - 1);
    else
      return Message & (Message'Length + 1 .. Until_Length => ' ');
    end if;
  end String_Of;


  procedure Get_Next_Token is

    type Scanner_States is
     (Start,             Ident_String,      Ident_Under_Score,
      Digit_String,      Digit_Under_Score, Decimal_Point,
      Decimal_Part,      Literal_String,    Quotes,
      Multi_Delims,      Accept_Token,      Commenting);

    State : Scanner_States := Start;

    Lex_Error                  : exception;
    End_Of_Stuff               : exception;
    Couldnt_Get_Next_Character : exception;
    Inconsistent_Double_Op     : exception;


    procedure Condense is
    begin
      Token80 (Token_Upto) := Current;
      Token_Upto := Token_Upto + 1;
    end Condense;


    procedure Get_Next_Line is
    begin
      Line := (others => ' ');
      Text_Io.Get_Line (Scanner_File, Line, Last);
      Upto := 0;
      Current := ' ';
    exception
      when Text_Io.End_Error =>
    Text_Io.Close (Scanner_File);
    Current := ' ';
    Line := (others => ' ');
    Upto := Line'Last;
    Still_More_Stuff := False;
    end Get_Next_Line;


    procedure Get_Next_Character is
    begin
      if Upto = 0 then
    Upto := Line'First;
      else
    Upto := Upto + 1;

    if State = Start then
      while Line (Upto) in Character'Val (1) .. ' ' loop
        Upto := Upto + 1;
      end loop;
    end if;
      end if;

      Current := Line (Upto);
    exception
      when Program_Error =>  raise;

      when Constraint_Error =>
    if Still_More_Stuff then
      Get_Next_Line;
    else
      raise End_Of_Stuff;
    end if;

      when others =>  raise Couldnt_Get_Next_Character;
    end Get_Next_Character;
  begin
    Token_Upto := Columns'First;

    loop
      case State is
    when Start =>
      case Current is
        when 'a' .. 'z' | 'A' .. 'Z' =>
          State := Ident_String;

        when '0' .. '9' =>
          State := Digit_String;

        when '"' =>
          State := Literal_String;
          Get_Next_Character;

        when '-' | '<' | '>' | '=' | '*' | ':' | '/' | '.' | '+' =>
          State := Multi_Delims;

        when Character'Val (1) .. ' ' =>
          Get_Next_Character;

        when others =>  -- is a single delimiter
          Condense;
          Input_Symbol := Op;
          State := Accept_Token;
          Get_Next_Character;
      end case;

    when Ident_String =>
      case Current is
        when 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' =>
          Condense;
          Get_Next_Character;

        when Scanner_Under_Score =>
          Condense;
          Get_Next_Character;
          State := Ident_Under_Score;

        when others =>
          if Scanner_All_Capitals then
        Token80 (1 .. Token_Upto) :=
          Capitals_Of (Token80 (1 .. Token_Upto));
          end if;

          Input_Symbol := Id;
          State := Accept_Token;
      end case;

    when Ident_Under_Score =>
      case Current is
        when 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' =>
          State := Ident_String;

        when others =>
          raise Lex_Error;
      end case;

    when Digit_String =>
      case Current is
        when '0' .. '9' =>
          Condense;
          Get_Next_Character;

        when Scanner_Under_Score =>
          Condense;
          Get_Next_Character;
          State := Digit_Under_Score;

        when '.' =>
          Get_Next_Character;
          State := Decimal_Point;

        when others =>
          Input_Symbol := Literal;
          State := Accept_Token;
      end case;

    when Digit_Under_Score =>
      case Current is
        when '0' .. '9' =>
          State := Digit_String;

        when others =>
          raise Lex_Error;
      end case;

    when Decimal_Point =>
      case Current is
        when '.' =>
          State := Accept_Token;
          Input_Symbol := Literal;
          Line := String_Of ("..", Line'Length);
          Upto := 0;
          Get_Next_Character;

        when '0' .. '9' =>
          Token80 (Token_Upto) := '.';
          Token_Upto := Token_Upto + 1;
          State := Decimal_Part;

        when others =>
          raise Lex_Error;
      end case;

    when Decimal_Part =>
      case Current is
        when '0' .. '9' =>
          Condense;
          Get_Next_Character;

        when others =>
          Input_Symbol := Literal;
          State := Accept_Token;
      end case;

    when Literal_String =>
      case Current is
        when Scanner_Quote =>
          Get_Next_Character;
          State := Quotes;

        when others =>
          Condense;
          Get_Next_Character;
      end case;

    when Quotes =>
      case Current is
        when Scanner_Quote =>
          Condense;
          Get_Next_Character;
          State := Literal_String;

        when others =>
          Input_Symbol := Literal;
          State := Accept_Token;
      end case;

    when Multi_Delims =>
      case Current is
        when '-' =>
          Get_Next_Character;

          if Current = '-' then
        State := Commenting;
          else
        Token80 (1) := '-';
        Token_Upto := 2;
        State := Accept_Token;
          end if;

        when '>' | '/' =>
          Condense;
          Get_Next_Character;

          if Current = '=' then
        Condense;
        Get_Next_Character;
          end if;

          State := Accept_Token;

        when '<' =>
          Condense;
          Get_Next_Character;

          if (Current = '>') or (Current = '=') then
        Condense;
        Get_Next_Character;
          end if;

          State := Accept_Token;

        when ':' =>
          Condense;
          Get_Next_Character;

          case Current is
        when '=' =>
          Condense;
          Get_Next_Character;

        when ':' =>
          Condense;
          Get_Next_Character;

          if Current = '=' then
            Condense;
            Get_Next_Character;
          end if;

        when others =>  null;
          end case;

          State := Accept_Token;

        when '=' =>
          Condense;
          Get_Next_Character;

          if Current = '>' then
        Condense;
        Get_Next_Character;
          end if;

          State := Accept_Token;

        when '.' =>
          Condense;
          Get_Next_Character;

          if Current = '.' then
        Condense;
        Get_Next_Character;
          end if;

          State := Accept_Token;

        when '+' =>
          Condense;
          Get_Next_Character;

          if Current = '*' then
        Condense;
        Get_Next_Character;
          end if;

          State := Accept_Token;

        when '*' =>
          Condense;
          Get_Next_Character;

          case Current is
        when '*' | '+' =>
          Condense;
          Get_Next_Character;

        when others =>  null;
          end case;

          State := Accept_Token;

        when others =>  raise Inconsistent_Double_Op;
      end case;

      Input_Symbol := Op;

    when Commenting =>
      State := Start;
      Get_Next_Line;

    when Accept_Token =>
      Token_Upto := Token_Upto - 1;
      exit;
      end case;
    end loop;
  exception
    when Scanner_End_Of_File =>  raise;

    when Lex_Error =>
      Text_Io.Put_Line ("***");
      Text_Io.Put_Line ("->" & Current & "<- cannot follow =>" &
            Token80 (1 .. Token_Upto - 1) & "<=");
      raise;

    when End_Of_Stuff =>
      if Input_Symbol = End_Of_Input then
    raise Scanner_End_Of_File;
      else
    Token80 (1) := '|';
    Token_Upto := 1;
    Input_Symbol := Symbols'(End_Of_Input);
      end if;

    when Constraint_Error =>  -- Probably token_upto = 0.
      Token_Upto := 1;
      Token80 (1) := ' ';
      Input_Symbol := Literal;
  end Get_Next_Token;


  procedure Closing_Procedure_Test is
  begin
    Text_Io.Close (Scanner_File);
  exception
    when others =>  null;
  end Closing_Procedure_Test;


  procedure Initialize_Scanner (File_Name : String) is
    This_File : Text_Io.File_Type;
  begin
    Closing_Procedure_Test;
    Text_Io.Open (Scanner_File, Text_Io.In_File, File_Name);
    Line := (others => ' ');
    Text_Io.Get_Line (Scanner_File, Line, Last);
    Upto := 0;
    Current := ' ';
    Still_More_Stuff := True;
    Input_Symbol := Literal;
    Token80 := (others => ' ');
    Token_Upto := 1;
  exception
    when Text_Io.End_Error =>
      Text_Io.Close (Scanner_File);
      Current := ' ';
      Line := (others => ' ');
      Upto := Line'Last;
      Still_More_Stuff := False;
  end Initialize_Scanner;

end Source_Scanner;
--\\VARIABLE_LISTS.ADA
-- last modified : 15 Nov 85
-- by            : TCB
-- changes made  : Added final touches to documentation.
--
--
with Unchecked_Deallocation,
     Text_Io;  -- This can be pulled if Self_Test is also pulled.

package body Variable_Lists is
--
--
--
-- Some notes on implementation:
--
-- The primary author took the cheap way out.  In order to avoid
-- constantly checking to see if there are any blocks at all in a
-- particular list, he insures that there is ALWAYS exactly ONE
-- empty block at the end of a list. e.g., if the block size is 5,
-- then when a list is declared, it will start with 0 Elements, but
-- one block of 5 empty slots. As Elements are added, when this last
-- empty block is used, a new empty block is added; so when item # 1
-- is added to the list, it is put in slot number 1 of the "old" last
-- block and a "new" last block is created. So there are 10 slots, only
-- the first of which is filled. As more Elements are added, it is not
-- until the last block is again touched (Element # 6) that a new block
-- is again allocated.  Similarly, as Elements are deleted, it is not
-- until there are TWO blank blocks at the end that one is deallocated.
-- However, since we always keep 1 blank one there, as soon as another
-- one BECOMES empty we know we can deallocate the last block.
-- This technique may waste a little space, but it makes everyday use
-- of lists run much more efficiently.
--
-- It may be expedient to include "Total_Elements : natural := 0" as
-- a component of the Lists type in the private part, and maitain this
-- value in procedures Add, Remove, and Empty.  This will make Item_At
-- and Number_In run much more efficiently.  However, this redundancy
-- of information may cause inconsistencies if there is an abnormal
-- termination.
--
--

  procedure Flush is new Unchecked_Deallocation
       (Object => List_Block, Name => Block_Ptr);


  procedure Deallocate (Ptr : in out Block_Ptr) is
    -- This is needed because Unchecked_Deallocation of a NULL
    -- access object raises nasty errors in the ROLM / DG  ADE.
  begin
    if Ptr /= null then
      Flush (Ptr);
    end if;
  end Deallocate;


  function Block_Number (N : Positive; Within : Lists) return Block_Ptr is
    List    : Lists renames Within;
    Current : Block_Ptr;
  begin
    Current := List.First_Block;

    for Block in 2 .. N loop
      Current := Current.Next;
    end loop;

    return Current;
  exception
    when Constraint_Error =>  raise Arent_That_Many_Elements;
  end Block_Number;


  function Block_Of (N : Positive) return Positive is
  begin
    return ((N - 1) / Block_Size) + 1;
  end Block_Of;


  function Last_Block_In (List : Lists) return Block_Ptr is
  begin
    return Block_Number (List.Number_Blocks, Within => List);
  end Last_Block_In;


  procedure Reclaim (From_Here : in out Block_Ptr) is
    -- Recovers ALL the blocks from this point on, not just
    -- the one pointed to in FROM_HERE.
    Current_Block, Next_Block : Block_Ptr;
  begin
    Current_Block := From_Here;
    Next_Block := Current_Block.Next;

    while Next_Block /= null loop
      Deallocate (Current_Block);
      Current_Block := Next_Block;
      Next_Block := Next_Block.Next;
    end loop;

    Deallocate (Current_Block);
    From_Here := null;
  exception
    when Constraint_Error =>  -- From_Here is ALREADY null, dummy.
      null;
  end Reclaim;


  function Row_Of (N : Positive) return Positive is
  begin
    return ((N - 1) mod Block_Size) + 1;
  end Row_Of;


  procedure Add (Item : Element; Onto : in out Lists) is
    Last_Block : Block_Ptr;
    List       : Lists renames Onto;
    Last_Entry : Count_Range renames List.Last_Block_Upto;
  begin
    Last_Block := Last_Block_In (List);
    Last_Entry := Last_Entry + 1; -- this gets a C_E if we try to put
                                  -- something in the last slot of a
                                  -- block.
    Copy (Item, Into => Last_Block.Item (Last_Entry));
  exception
    when Constraint_Error =>
              -- filled up the block. need a new one.
      Copy (Item, Into => Last_Block.Item (Block_Size));
      Last_Block.Next := new List_Block;
      Last_Entry := 0;
      List.Number_Blocks := List.Number_Blocks + 1;
  end Add;


  procedure Copy (Value : Lists; Into : in out Lists) is
    Source_List : Lists renames Value;
    Destination : Lists renames Into;
  begin
    Empty (Destination);

    for Current in 1 .. Number_In (Source_List) loop
      Add (Item_At (Current, Within => Source_List), Onto => Destination);
    end loop;
  end Copy;


  procedure Empty (List : in out Lists) is
  begin
    List.Last_Block_Upto := 0;
    List.Number_Blocks := 1;
    Reclaim (From_Here => List.First_Block.Next);
  end Empty;


  function Item_At (Number : Positive; Within : Lists) return Element is
    List : Lists renames Within;
  begin
    if Number <= Number_In( List ) then
      return Block_Number (Block_Of (Number), Within => List).Item
          (Row_Of (Number));
    else
      raise Arent_That_Many_Elements;
    end if;
  end Item_At;


  function Number_In (List : Lists) return Natural is
  begin
    return (List.Number_Blocks - 1) * Block_Size + List.Last_Block_Upto;
  end Number_In;


  procedure Remove (Number : Positive; From : in out Lists) is
    List       : Lists renames From;
    Last_Block : Block_Ptr;
  begin
    if Number <= Number_In (List) then
      for Current_Item in Number + 1 .. Number_In (List) loop
    Replace (Current_Item - 1, Within => List,
         By => Item_At (Current_Item, Within => List));
      end loop;

      List.Last_Block_Upto := List.Last_Block_Upto - 1;
    else
      raise Arent_That_Many_Elements;
    end if;
  exception
    when Constraint_Error =>
               -- now have an empty block.
      List.Last_Block_Upto := Count_Range'Last;
      Last_Block := Last_Block_In (List);
      Reclaim (Last_Block);
      List.Number_Blocks := List.Number_Blocks - 1;
      Last_Block_In (List).Next := null;
  end Remove;


  procedure Replace (Number : Positive;
             Within : in out Lists;
             By     : Element) is
    List  : Lists renames Within;
    Value : Element renames By;
  begin
    if Number <= Number_In ( List ) then
      Copy (Value,
        Into =>
          Block_Number (Block_Of (Number), Within => List).Item
             (Row_Of (Number)));
    else
      raise Arent_That_Many_Elements;
    end if;
  end Replace;

  procedure Self_Test is
    List         : Lists;
    Error_Caught : Boolean := False;

    procedure Error_Is (Message : String) is
    begin
      Text_Io.Put_Line ("*** Variable_lists Self Test : " & Message);
      Error_Caught := True;
    end Error_Is;

  begin
    if Number_In (List) /= 0 then
      Error_Is ("Number_In not 0");

    elsif List.Number_Blocks /= 1 then
      Error_Is ("Number of Blocks not 1");

    elsif List.First_Block = null then
      Error_Is ("First_Block is null");
    end if;

    if Error_Caught then
      raise Program_Error;
    end if;
  end Self_Test;

begin
  Self_Test;
end Variable_Lists;
--\\VARIABLE_LISTS_VIS.ADA
--< PACKAGE :        Variable_Lists
--  author        : Thomas C. Brooke
--  created on    : 3 Jul 85
--  last modified : 5 Jul 85
--  by            : TCB
--<
--< PACKAGE DESCRIPTION:
--<
--< This package provides true variable length lists.
--<
--< The items in a list are ordered and are given an ordinal number
--< starting at 1;  e.g. the first item added to a list is item # 1,
--< the second is item # 2, etc. Items can be retrieved directly by
--< their position number: >>> Item_At( 45, within => list_a ) <<<.
--< The length of a list is the Number_In that list, so iteration
--< can occur: >>> 1 .. Number_In( list_b ) <<< will reach every element
--< in list_b.  Items may be removed (although this process is in-
--< efficient). Lists may be emptied, this process is efficient.
--< Any item can be directly replaced by another element.
--<
--< Note that the implementation is a linked list of blocks.  This
--< makes it a relatively efficient infinite length, but there is
--< still direct retrieval of any single element.  The user may
--< specify the size of blocks as best fits his needs, if he so
--< desires.
--<
--< Lists are created merely by declaring an object of type Lists.
--< This new list is initially empty, so no explicit initialization
--< is required.
--<
--< Choosing the Block_By size may greatly affect performance.  The
--< larger Block_By is, the fewer links have to be traversed to get
--< to elements near the end of the list; however, a good deal more
--< space is wasted on the last partially full block.  A smaller
--< Block_By will waste less space, but may slow down processing in
--< the back end of the lists.
--<
--< PACKAGE DEPENDENCIES : none.
--
--
--
generic
  type Element is limited private;
    -- creates lists of Element, where Element can be any
        -- CONSTRAINED subtype.  Note that this specifically
        -- prohibits variant records, even with a default
        -- descriminant value.

  with procedure Copy (Value : Element; Into : in out Element);
    -- how to copy one Element into another.

  Block_By : Positive := 50;
    -- what size to make blocks of Elements.

package Variable_Lists is

  type Lists is limited private; -- because it may use access types.
                                 -- and we may have Lists of Lists.

  Arent_That_Many_Elements : exception;

  procedure Add       (Item : Element; Onto : in out Lists);
    -- DESCRIPTION : Adds ITEM to the list ONTO.
    -- INPUTS      : Item - The Element to be added to a list.
    --               Onto - The list to which ITEM is added.
    -- OUTPUTS     : Onto - the new list with the ITEM appended
    -- EXCEPTIONS  : should never raise any.

  procedure Copy      (Value : Lists; Into : in out Lists);
    -- DESCRIPTION : Empties the destination list INTO, then
    --               copies the contents of VALUE into INTO.
    -- INPUTS      : Value - the source list to copy
    --               Into  - the destination where it is copied into
    -- OUTPUTS     : Into  - the resulting list.
    -- EXCEPTIONS  : should not raise any.

  procedure Empty     (List : in out Lists);
    -- DESCRIPTION : Empties the LIST
    -- INPUTS      : List - the list to be emptied.
    -- OUTPUTS     : List - the resulting empty list.
    -- EXCEPTIONS  : should never raise any.

  function  Item_At   (Number : Positive; Within : Lists) return Element;
    -- DESCRIPTION : Returns the Element at position NUMBER in the
    --               list WITHIN.
    -- INPUTS      : Number - the ordinal position of the Element.
    --               Within - the list from which it is retrieved.
    -- OUTPUTS     : the Element at that position.
    -- EXCEPTIONS  : Arent_That_Many_Elements when NUMBER is
    --               greater than the Number_In the list.

  function  Number_In (List : Lists) return Natural;
    -- DESCRIPTION : Returns the number of Elements in LIST
    -- INPUTS      : List - the list to check the number in.
    -- OUTPUTS     : the number of Elements in LIST
    -- EXCEPTIONS  : should never raise any.

  procedure Remove    (Number : Positive; From : in out Lists);
    -- DESCRIPTION : Deletes Element NUMBER from the list FROM.
    -- INPUTS      : Number - Ordinal # of the Element to remove.
    --               From   - the list to remove it from.
    -- OUTPUTS     : From   - the list after the Element is removed.
    -- EXCEPTIONS  : Arent_That_Many_Elements when Number is
    --               greater than the Number_In the list FROM.

  procedure Replace   (Number : Positive;
               Within : in out Lists;
               By     : Element);
    -- DESCRIPTION : Replaces the Element at NUMBER in the list
    --               WITHIN by the Element BY.
    -- INPUTS      : Number - Ordinal number of Element to replace.
    --               Within - the list within which it is replaced.
    --               By     - the Element it is replaced by.
    -- OUTPUTS     : Within - the list with the Element replaced.
    -- EXCEPTIONS  : Arent_That_Many_Elements when Number is
    --               greater than the Number_In the list WITHIN.


private

  Block_Size : Positive renames Block_By;
  type Array_Of_Elements is array (1 .. Block_Size) of Element;
  type List_Block;
  type Block_Ptr is access List_Block;
  type List_Block is
    record
      Item : Array_Of_Elements;
      Next : Block_Ptr;
    end record;

  subtype Count_Range is Natural range 0 .. Block_Size - 1;

  type Lists is
    record
      Last_Block_Upto : Count_Range := 0;
      Number_Blocks   : Positive := 1;
      First_Block     : Block_Ptr := new List_Block;
    end record;

end Variable_Lists;
--\\BALANCED_TREES.ADA
with Unchecked_Deallocation;

package body Balanced_Trees is
    --   There are three key parts to any tree, Seed_Node,
    -- Root_Node, and tree Nodes.  Seed_Node is a node outside
    -- of the tree. It contains a pointer to the first node of the tree
    -- in Seed_Node.Pointer(1) and a string of blanks equal to
    -- the max key length for that tree in Seed_Node.Data.Key(Last).
    -- The Root_Node is the "actual" top Node of the tree.  It
    -- contains Data and Pointers like any other Node in the tree.
    --   All the procedures and functions in B_Trees work on the
    -- premise that any single node of the tree will never be
    -- less than half full.  Half full is defined as the max
    -- number of Keys per node  divided by two (No_Of_Keys / 2).

  Middle_Of_Node : constant Integer := (1 + No_Of_Keys) / 2;

  procedure Free_Ptr is new Unchecked_Deallocation (Node, Trees);
  procedure Free_Key is new Unchecked_Deallocation (Keys, Acc_Keys);
  procedure Free_Data is new Unchecked_Deallocation (Datas, Acc_Data);
  procedure Free_Item is new Unchecked_Deallocation (Items, Acc_Items);

  function Node_Is_Full (This_Node : Trees) return Boolean is
    -- Checks to see if the given node is full.
  begin
    return This_Node.Data (No_Of_Keys) /= null;
  end Node_Is_Full;


  function Key_Exists (Key         : Keys;
               At_Position : Position_In_Tree) return Boolean is
       --   Checks to see if the given Key actually exists at the given
       -- Position_In_Tree.
  begin
    Return At_Position.Node_In_Tree.Data (At_Position.Position_In_Node).Key
       (1 .. Key'Length) = Key;
    exception
      When Constraint_Error =>
        Return False;
          -- Constraint_Error will be raised if the Key location
          -- being checked against the input value is a null Key or
          -- if the position is outside the node limits.
  end Key_Exists;


  function Key_At (Position : Position_In_Tree) return Keys is
  begin
    return Position.Node_In_Tree.Data (Position.Position_In_Node)
       .Key.all;
  end Key_At;


  function Item_At (Position : Position_In_Tree) return Items is
  begin
    return Position.Node_In_Tree.Data (Position.Position_In_Node)
       .Item.all;
  end Item_At;


  function New_Tree (With_Key_Length : Integer) return Trees is
      --   New_Tree creates the "seed_node" and the "root_node"
      -- of a tree.
    Seed              : Trees := new Node;
    Key_Length : Keys (1 .. With_Key_Length) := (others => ' ');
  begin
    Seed.Data (No_Of_Keys) := new Datas;
    Seed.Data (No_Of_Keys).Key := new Keys'(Key_Length);
    Seed.Pointer (1) := new Node;
    Seed.Pointer (1).Mother := Seed;
    return Seed;
  end New_Tree;


  function Position (Of_Key : Keys; Within_Node : Trees) return Integer is
      -- Does a binary search on a node to find a position where a
      -- Key is located or where it would be if were there.
      -- It is possible that this position could be outside of
      -- the nodes limits (No_Of_Keys) by one. When used Search_For_Node
      -- this extra position subscripts the pointer to a lower node.
    First      : Integer := 1;
    Middle     : Integer;
    Last       : Integer := No_Of_Keys;
    Trees_Data : Data_Array renames Within_Node.Data;
    Key_Value  : Keys renames Of_Key;
  begin
    while First <= Last loop
      Middle := (First + Last) / 2;

      if Trees_Data (Middle) = null or else
        Key_Value < Trees_Data (Middle).Key (1 .. Key_Value'Length) then
    Last := Middle - 1;

      elsif Trees_Data (Middle).Key (1 .. Key_Value'Length) < Key_Value then
    First := Middle + 1;
      else
    return Middle;
      -- This exit returns the node_position the value was found at.
      end if;
    end loop;

    return First;
      -- This exit returns the node_position the value would
      -- be if it was there.
  end Position;


  function Search_For_Node (Starting_At : Trees;
                            Containing : Keys) return Trees is
      --   This will search a tree and return the first node that
      -- "this_value" is located at.  It compares "this_value"
      -- against "this_value"'range  of the values stored
      -- in the tree, enabling searches on partial Keys.
      -- When Search_For_Node returns a recursive call to itself it
      -- passes in the next lower node where the key may exist.
    Current_Data    : Acc_Data;
    Current_Pointer : Trees;
    Node_Position   : Integer;
    Value           : Keys renames Containing;
    Tree            : Trees renames Starting_At;
  begin
    Node_Position := Position (Of_Key => Value, Within_Node => Tree);
    Current_Pointer := Tree.Pointer (Node_Position);
      -- Finds the next lower node to look for the given key.

    if Node_Position > No_Of_Keys then
      if Tree.Pointer (Node_Position) /= null then
    return Search_For_Node (Starting_At => Current_Pointer,
                                Containing => Value);
      else
    return Tree;
      -- Bottom level node.
      end if;
    end if;

    Current_Data := Tree.Data (Node_Position);

    if Current_Data = null then
      if Current_Pointer /= null then
    return Search_For_Node (Starting_At => Current_Pointer,
                                Containing => Value);
      else
    return Tree;
      -- Bottom level node.
      end if;

    elsif Value = Current_Data.Key (1 .. Value'Length) or else
      Tree.Pointer (Node_Position) = null then
      return Tree;
        -- Only if the key being looked for in the tree is actually
        -- there will a node other than a bottom node be returned to the
        -- calling procedure.
    else
      return Search_For_Node (Starting_At => Tree.Pointer (Node_Position),
                              Containing => Value);
    end if;
  end Search_For_Node;


  function Tree_Position (In_Tree    : Trees;
              Containing : Keys) return Position_In_Tree is
      -- This combines procedures Position and Search_For_Node
      -- into a single operation.
    Tree_Position  : Position_In_Tree;
    Tree           : Trees renames In_Tree;
    Key_Value      : Keys renames Containing;
  begin
    Tree_Position.Node_In_Tree :=
         Search_For_Node (Starting_At => Tree, Containing => Key_Value);
    Tree_Position.Position_In_Node :=
         Position (Of_Key => Key_Value,
         Within_Node => Tree_Position.Node_In_Tree);
    return Tree_Position;
  end Tree_Position;


  procedure Search_For_First_Instance (Of_Key : Keys;
                                   In_Tree : in out Position_In_Tree;
                               Giving_Item  : out Items) is
       --   This search takes a position within a tree and a value and
       -- searches for prior instances of that value, which would occur
       -- only if the value is a partial length of the Key stored in
       -- the tree. It loacates the very first instance of the Key in
       -- the tree.
     Tree_Position : Position_In_Tree renames In_Tree;
     Key_Value     : Keys renames Of_Key;
     Out_Item      : Items renames Giving_Item;
  begin
    Get_Prior (From => Tree_Position, Giving_Item => Out_Item);

    while Key_At (Tree_Position) (1 .. Key_Value'Length) = Key_Value loop
      Get_Prior (From => Tree_Position, Giving_Item => Out_Item);
    end loop;

    Get_Next (From => Tree_Position, Giving_Item => Out_Item);
      -- If the loop ends normally then the first instance of the Key
      -- will be be in the next position.
  exception
    when End_Of_Tree =>
      Out_Item := Tree_Position.Node_In_Tree.Data (1).Item.all;
        --   Sets the Out_Item when the first instance is the
        -- only instance, and the first Key in the tree.
        -- This is accomplished here due to the fact that if a
        -- procedure ends abnormally (ie. raised exceptions) any
        -- out paramaters revert to there previous states.  If the
        -- Key being searched for was the FIRST value in the tree
        -- and unique the Out_Item would never be set.  This holds
        -- true for Search_For_Last_Instance where the Key is the
        -- LAST value in the tree and unique.
  end Search_For_First_Instance;


  procedure Search_For_Last_Instance (Of_Key : Keys;
                                  In_Tree : in out Position_In_Tree;
                                    Giving_Item : out Items) is
      --   This search takes a position within a tree and a value and
      -- searches for next instances of the value, which would occur
      -- only if the value is a partial length of the Keys stored in
      -- the tree. It loacates the very last instance of the Key
      -- in the tree.
    Tree_Position : Position_In_Tree renames In_Tree;
    Key_Value     : Keys renames Of_Key;
    Out_Item      : Items renames Giving_Item;
  begin
    Get_Next (From => Tree_Position,Giving_Item => Out_Item);

    while Key_At (Tree_Position) (1 .. Key_Value'Length) = Key_Value loop
      Get_Next (From => Tree_Position, Giving_Item => Out_Item);
    end loop;

    Get_Prior (From => Tree_Position, Giving_Item => Out_Item);
      -- If the loop ends normally then the Last instance of the Key
      -- will be be in the prior position.
  exception
    when End_Of_Tree =>
      Out_Item := Tree_Position.Node_In_Tree.Data
             (Tree_Position.Position_In_Node).Item.all;
        -- See documentation at end of Search_For_First_Instance.
  end Search_For_Last_Instance;


  function Item_Where (Key_Is : Keys;In_Tree : Trees) return items is
    Out_Item           : Items;
    Temp_Tree_Position : Position_In_Tree;
    Key_Value          : Keys renames Key_Is;
    Max_Key_Length     : Integer := In_Tree.Data (No_Of_Keys).Key'Length;
  begin
    if Key_Value'Length > Max_Key_Length then
      raise Key_Length_Error;
    end if;
      -- Checks to see if the Key given is larger than the Key
      -- length that the tree is built on.

    Temp_Tree_Position := Tree_Position (In_Tree => In_Tree.Pointer (1),
                                         Containing => Key_Value);
      -- Finds where the key should be located in the tree.

    if Key_Exists (Key_Value, At_Position => Temp_Tree_Position) then
      -- If the key actually EXIST in the tree a serch for the first
      -- instance of that key is made in case it is a partial value
      -- being searched for.

      Search_For_First_Instance (Of_Key => Key_Value,
                                 In_Tree => Temp_Tree_Position,
                                 Giving_Item => Out_Item);
      return Out_Item;
    else
      raise Key_Not_Found;
    end if;
  end Item_Where;


  procedure Get_First (From            : Trees;
               Giving_Position : out Position_In_Tree;
               Giving_Item    : out Items) is
      --   Loops down the given nodes      1              X
      -- first pointer until it reaches   / \            / \
      -- the bottom where it returns     2   X    ie    X   1
      -- the first position and         / \ / \        / \ / \
      -- item of that node.            3  X X  X      X  X 2  X
    Current_Node : Trees := From;
  begin
    if Current_Node.Pointer (1) /= null and then
       Current_Node.Pointer (1).Data (1) = null then
      raise End_Of_Tree;
    end if;
      -- Checks to see if the tree contains any Data.

    while Current_Node.Pointer (1) /= null loop
      Current_Node := Current_Node.Pointer (1);
    end loop;

    Giving_Position := (Current_Node, 1);
    Giving_Item := Item_At (Position => (Current_Node, 1));
  end Get_First;


  procedure Get_Last (From            : Trees;
              Giving_Position : out Position_In_Tree;
              Giving_Item        : out Items) is
      --   Starting at the given node Get_Last loops through the node
      -- backwards (since each node will at least half full or
      -- greater it is quicker to go backwards)       1          X
      -- until a pointer to a lower node is          / \        / \
      -- met. The loop continues down the           X   2  ie  1   X
      -- tree until a data is met with no          / \ / \    / \ / \
      -- pointer to a lower node.                 X  X X  3  X  2 X  X
    Current_Node     : Trees := From;
    Current_Position : Integer;
    Temp_Node        : Trees;
  begin
    if Current_Node.Pointer (1) /= null and then
       Current_Node.Pointer (1).Data (1) = null then
      raise End_Of_Tree;
        -- Checks to see if the tree contains any Data.
    elsif Current_Node.Mother = null then
      Current_Node := Current_Node.Pointer (1);
        -- Puts the caller at the root_node level.
        -- When a Get_Last is done in the tree itself the
        -- input trees type is already at the proper place.
    end if;

    while Current_Node /= null loop
      Current_Position := No_Of_Keys;

      while Current_Node.Pointer (Current_Position + 1) = null and then
        Current_Node.Data (Current_Position) = null loop
    Current_Position := Current_Position - 1;
      end loop;

      Temp_Node := Current_Node;
      Current_Node := Current_Node.Pointer (Current_Position + 1);
    end loop;

    Giving_Position := (Temp_Node, Current_Position);
    Giving_Item := Item_At (Position => (Temp_Node, Current_Position));
  end Get_Last;


  procedure Get_First_Key (From            : Trees;
               With_Value      : Keys;
               Giving_Position : out Position_In_Tree;
               Giving_Item     : out Items) is
    Temp_Tree_Position : Position_In_Tree;
    Key_Value          : Keys renames With_Value;
      -- Performs the same operations as Item_Where.
  begin
    Temp_Tree_Position := Tree_Position (In_Tree => From,
                                         Containing => Key_Value);

    if Key_Exists (Key_Value, At_Position => Temp_Tree_Position) then
      Search_For_First_Instance (Of_Key => Key_Value,
                                 In_Tree => Temp_Tree_Position,
                                 Giving_Item => Giving_Item);
      Giving_Position := Temp_Tree_Position;
    else
      raise Key_Not_Found;
    end if;
  end Get_First_Key;


  procedure Get_Last_Key (From            : Trees;
              With_Value      : Keys;
              Giving_Position : out Position_In_Tree;
              Giving_Item        : out Items) is
    Temp_Tree_Position : Position_In_Tree;
    Key_Value          : Keys renames With_Value;
      -- Performs the same operations at Get_First_Key except
      -- it gets the LAST instance of the Key.
  begin
    Temp_Tree_Position := Tree_Position (In_Tree => From,
                                         Containing => Key_Value);

    if Key_Exists (Key_Value, At_Position => Temp_Tree_Position) then
      Search_For_Last_Instance (Of_Key => Key_Value,
                                In_Tree => Temp_Tree_Position,
                                Giving_Item => Giving_Item);
      Giving_Position := Temp_Tree_Position;
    else
      raise Key_Not_Found;
    end if;
  end Get_Last_Key;


  procedure Get_Next (From        : in out Position_In_Tree;
              Giving_Item : out Items) is
    Temp_Position : Integer;
    Nodes         : Trees renames From.Node_In_Tree;
    Position      : Integer Renames From.Position_In_Node;

    procedure Climb_Tree (Upper, Lower : Trees) is
      -- Used to traverse up a tree to the next logical
      -- position.  Also checks to see if the next position
      -- would be outside the tree limits.
    begin

      if Upper.Data (1) = null then
    Position := Temp_Position;
    raise End_Of_Tree;
      -- Raises End_Of_Tree when Climb_Tree traverses up the
      -- tree to the Seed_Node.  This resets the position back
      -- to the last Data in the tree.
      end if;

      Position := 1;

      while Upper.Pointer (Position) /= Lower loop
    Position := Position + 1;
      end loop;
        -- Find the position of the pointer in the
        -- mother_node to the lower node.

      if Position = No_Of_Keys + 1 or else
     Upper.Data (Position) = null then
    Climb_Tree (Upper => Upper.Mother, Lower => Upper);
        -- Recursively called by going up multiple levels
            -- in the tree
      else
    Nodes := Upper;
    Giving_Item := Item_At (Position => From);
      end if;
    end Climb_Tree;
  begin
    if Nodes.Pointer (Position + 1) = null then
      if Position + 1 > No_Of_Keys or else
     Nodes.Data (Position + 1) = null then
    Temp_Position := Position;
    Climb_Tree (Upper => Nodes.Mother, Lower => Nodes);
      else
    Position := Position + 1;
    Giving_Item := Item_At (Position => From);
      end if;
    else
@@
      Nodes := Nodes.Pointer (Position + 1);
      Get_First (From => Nodes, Giving_Position => From,
                 Giving_Item => Giving_Item);
    end if;
  end Get_Next;


  procedure Get_Prior (From        : in out Position_In_Tree;
               Giving_Item : out Items) is
    Nodes    : Trees renames From.Node_In_Tree;
    Position : Integer renames From.Position_In_Node;

    procedure Climb_Tree (Upper : Trees; Lower : Trees) is
        -- Used to traverse up a tree to the next logical
        -- position.  Also checks to see if the prior position
        -- would be outside the tree limits.
    begin

      if Upper.Data (1) = null then
    raise End_Of_Tree;
         -- Raises End_Of_Tree when Climb_Tree traverses up to the
         -- tree to the Seed_Node.
      end if;

      Position := No_Of_Keys + 1;

      while Upper.Pointer (Position) /= Lower loop
    Position := Position - 1;
      end loop;
           -- Find the position of the pointer in the
           -- mother_node to the lower node.

      if Position = 1 then
    Climb_Tree (Upper => Upper.Mother, Lower => Upper);
          -- Recursively called by going up multiple levels in the tree
      else
    From := (Upper, Position - 1);
    Giving_Item := Item_At (Position => From);
      end if;
    end Climb_Tree;
  begin
    if Nodes.Pointer (Position) /= null then
      Nodes := Nodes.Pointer (Position);
      Get_Last (From => Nodes, Giving_Position => From,
                Giving_Item => Giving_Item);

    elsif Position = 1 then
      Climb_Tree (Upper => Nodes.Mother,
                  Lower => Nodes);
    else
      Position := Position - 1;
      Giving_Item := Item_At (Position => From);
    end if;
  end Get_Prior;


  procedure Change_Item (For_Key : Keys;
             In_Tree : Trees;
             To      : Items) is


    Key_Value     : Keys renames For_Key;
    Node_Position : Position_In_Tree;
    Hold_Item     : Items;
    Max_Key_Length : Integer := In_Tree.Data (No_Of_Keys).Key'Length;
      -- Changes the item of the FIRST instance of Key_Value.
  begin
    if Key_Value'Length /= Max_Key_Length then
      raise Key_Length_Error;
    end if;
      -- Checks to see if Key_Value is exactly the same length
      -- as the Key length the tree was built on.
    Get_First_Key (From => In_Tree, With_Value => Key_Value,
                   Giving_Position => Node_Position,
                   Giving_Item => Hold_Item);
    Free_Item (Node_Position.Node_In_Tree.Data
                     (Node_Position.Position_In_Node).Item);
    Node_Position.Node_In_Tree.Data
         (Node_Position.Position_In_Node).Item := new Items'(To);
  end Change_Item;


  procedure Change_Item (At_Position : Position_In_Tree;To : Items) is
  begin
    Free_Item (At_Position.Node_In_Tree.Data
                     (At_Position.Position_In_Node).Item);
    At_Position.Node_In_Tree.Data (At_Position.Position_In_Node).item
         := new Items'(To);
  end Change_Item;


  function Inclusive_Subtree (Of_Tree  : Trees;
                  From_Key : Keys;
                  To_Key   : Keys) return Trees is
    Hold_Item      : Items;
    Sub_Tree       : Trees := Of_Tree;
    Position       : Position_In_Tree;
    Max_Key_Length : Integer := Of_Tree.Data (No_Of_Keys).Key'Length;
  begin
    if From_Key'Length > Max_Key_Length or else
       To_Key'Length > Max_Key_Length then
      raise Key_Length_Error;
    end if;

    Sub_Tree := New_Tree (With_Key_Length => Max_Key_Length);

    Position := Tree_Position (In_Tree => Of_Tree,
                               Containing => From_Key);

    if Position.Position_In_Node > No_Of_Keys or else
       Position.Node_In_Tree.Data (Position.Position_In_Node) = null then
      Position.Position_In_Node := Position.Position_In_Node - 1;
      Get_Next (From => Position, Giving_Item => Hold_Item);
    end if;
      --   Checks the position passed back by Tree_Position
      -- to make sure it is valid.  It's possible for the
      -- position to be pointing to a null value or a position
      -- outside the node limits.  If true, the position is moved
      -- back one.
    Search_For_First_Instance (Of_Key => From_Key, In_Tree => Position,
                               Giving_Item => Hold_Item);

    while Key_At (Position) (1 .. To_Key'Length) <= To_Key loop
      Insert (Key_Value => Key_At (Position),
          And_Item => Hold_Item, Into => Sub_Tree);
      Get_Next (From => Position, Giving_Item => Hold_Item);
    end loop;

    return Sub_Tree;
  exception
    when End_Of_Tree =>
      return Sub_Tree;
        --   A Subtree can be built even if no Data is inserted
        -- into it.  In this case a Seed_Node is still passed back,
        -- but the tree contains no entries.
  end Inclusive_Subtree;


  function Exclusive_Subtree (Of_Tree  : Trees;
                  From_Key : Keys;
                  To_Key   : Keys) return Trees is
    Hold_Item      : Items;
    Sub_Tree       : Trees := Of_Tree;
    Position       : Position_In_Tree;
    Max_Key_Length : Integer := Of_Tree.Data (No_Of_Keys).Key'Length;
  begin
    if From_Key'Length > Max_Key_Length or else
       To_Key'Length > Max_Key_Length then
      raise Key_Length_Error;
    end if;

    Sub_Tree := New_Tree (With_Key_Length => Max_Key_Length);

    Position := Tree_Position (In_Tree => Of_Tree,
                               Containing => From_Key);

    if Position.Position_In_Node > No_Of_Keys or else
       Position.Node_In_Tree.Data (Position.Position_In_Node) = null then
      Position.Position_In_Node := Position.Position_In_Node - 1;
      Get_Next (From => Position, Giving_Item => Hold_Item);
    end if;
      --   Checks the position passed back by Tree_Position
      -- to make sure it is valid.  It's possible for the
      -- position to be pointing to a null value or a position
      -- outside the node limits.  If true, the position is moved
      -- back one.
    Search_For_Last_Instance (Of_Key => From_Key, In_Tree => Position,
                              Giving_Item => Hold_Item);

    if Key_At (Position) (1 .. From_Key'Length) = From_Key then
      Get_Next (From => Position, Giving_Item => Hold_Item);
        -- Since it is an exclusive tree the first position to
        -- right of the Key is the starting point and the first
        -- position to the left of To_Key is the ending point.
    end if;

    while Key_At (Position) (1 .. To_Key'Length) < To_Key loop
      Insert (Key_Value => Key_At (Position),
          And_Item  => Hold_Item, Into => Sub_Tree);
      Get_Next (From => Position, Giving_Item => Hold_Item);
    end loop;

    return Sub_Tree;
  exception
    when End_Of_Tree =>
      return Sub_Tree;
        --   A Subtree can be built even if no Data is inserted
        -- into it.  In this case a Seed_Node is still Passed backe, but
        -- the tree contains no entries.
  end Exclusive_Subtree;


  procedure Delete_Tree (Tree : in out Trees) is
      --   This procedure deallocates the space used by a B_tree.
      -- It starts at the lower right hand corner of a tree and
      -- deallocates each node in a right to left, bottom to top
      -- motion for each branch of the Root_Node.  The order of
      -- deallocation (1..7) =>    7
      --                          / \
      --                         6   3
      --                        / \ / \
      --                       5  4 2  1
      -- After deallocation of the tree the Seed_Node pointing to
      -- that tree is deallocated and passed back as null.
    Position     : Integer := 2;
    Upper_Node   : Trees := Tree;
    Lower_Node   : Trees;
    Max_Position : Positive := No_Of_Keys + 1;
  begin
    if Tree /= null then

      Lower_Node := Tree.Pointer (1);
      while Lower_Node.Pointer (1) /= null loop
        Position := 1;

        while Position <= Max_Position and then
              Lower_Node.Pointer (Position) /= null loop
      Position := Position + 1;
        end loop;

        Upper_Node := Lower_Node;
        Lower_Node := Upper_Node.Pointer (Position- 1);
      end loop;
      -- Loops to the right most bottom node.

      Upper_Node.Pointer (Position - 1) := null;
      Position := 1;

      while Position < Max_Position and then
            Lower_Node.Data (Position) /= null loop
        Free_Key (Lower_Node.Data (Position).Key);
        Free_Item (Lower_Node.Data (Position).Item);
        Free_Data (Lower_Node.Data (Position));
        Position := Position + 1;
      end loop;
      -- Deallocates the nodes data.

      Lower_Node.Mother := null;
      Free_Ptr (Lower_Node);
      -- Deallocates the Node.

      if Upper_Node = Tree then
        Free_Key (Upper_Node.Data (No_Of_Keys).Key);
        Free_Data (Upper_Node.Data (No_Of_Keys));
        Free_Ptr (Upper_Node);
        -- Deallocates the seed node.
      else
        Delete_Tree (Tree);
      end if;
    end if;
  end Delete_Tree;


  procedure Insert (Key_Value : Keys; And_Item : Items; Into : Trees) is

      --   To insert data with a key value of X you search
      -- to locate where the data should belong (node_B).  If there
      -- is fewer than N data in the tree (where N is the number
      -- of data allowed per node) the current data in node_B is
      -- shifted right starting at the point where the data being
      -- inserted should be and that data is inserted into the
      -- cleared position.
      --    ie.
      --      node_B  before insertion of key 'B'  => |A,C,_|
      --      node_B  after  insertion of key 'B'  => |A,B,C|
      --
      --   If node_B contains N data it is required to split node_B
      -- into two separate nodes to make room for the new data.
      -- When split, data out of node_B or the data being inserted
      -- must be raised and inserted into its mother node.  This is
      -- done so a pointer can be pointed from the mother node to
      -- the newly created node.  The new node is created (node_C)
      -- and data is moved and raised by the following algorithm.
      --
      --    M       = (No_Of_Keys + 1) / 2   -- Middle of node
      --    x       = The Key being inserted.
      --    |A,D,F| = Node_B
      --
      --    When =>        x < Node_B.Key(M)
      --       Everything less than Node_B.Key(M) moves to node_C
      --       including x.  Node_B.Key(M) gets raised and inserted
      --       into the parent node.
      --                              node_C =>  |A,x,_|
      --                              node_B =>  |F,_,_|
      --                              Raised =>   D
      --
      --    When =>        x > Node_B.Key(M+1)
      --       Everything less than Node_B.Key(M+1) moves to node_C
      --       and x is inserted into Node_B.  Node_B.Key(M+1)
      --       gets raised and inserted into the parent node.
      --                              node_C =>  |A,D,_|
      --                              node_B =>  |x,_,_|
      --                              Raised =>   F
      --
      --    When =>      Node_B.Key(M) < x < Node_B.Key(M+1)
      --       Everything less than Node_B.Key(M+1) moves to node_C
      --       and the starting key x is raised and inserted
      --       into the parent node.
      --                               node_C => |A,D,_|
      --                               node_B => |F,_,_|
      --                               Raised =>  x
      --
      --   ie.
      --     Inserting Key 'B' into Node_B in a two level tree
      --            Before               After
      --              |                   |
      --             seed                seed
      --              |                   |
      --            |K,R,_|             |D,K,R|
      --           /  |  \             /  |  \ \
      --      |A,D,F| n   n     |A,B,_||F,_,_|n n
      --         |                 |      |
      --       node_B            node_C node_B

    Seed                     : Trees renames Into;
    Stored_Data              : Acc_Data;
    Temp_Node, Current_Node  : Trees;
    Left, Right              : Trees;
    Temp_Position            : Integer;
    Max_Key_Length           : Integer := Seed.Data(No_Of_Keys).Key'Length;

    procedure Insert ( This_Data : Acc_Data; Into : Trees) is
        --   Does the actual insertion of the Data into a node.
        -- It locates the position where the Data should go,
        -- makes room for the Data and inserts it.
      Receiving_Node : Trees renames Into;
      M, First       : Integer;
      Last           : Integer := No_Of_Keys;
    begin
      First := Position (Of_Key      => This_Data.Key.all,
             Within_Node => Receiving_Node);

      while First < Last loop
    Receiving_Node.Data (Last) := Receiving_Node.Data (Last - 1);
    Receiving_Node.Pointer (Last + 1) := Receiving_Node.Pointer (Last);
    Last := Last - 1;
      end loop;

      Receiving_Node.Data (First) := This_Data;

      if Left /= null then
    Receiving_Node.Pointer (First) := Left;
    Receiving_Node.Pointer (First + 1) := Right;
      end if;
    end Insert;


    procedure Create_New_Root_Node is
        -- Creates a new Root node when spliting of the present
        -- root node is required due to insertion of data.
      Root_Node : Trees := new Node;
    begin
      Root_Node.Mother := Right.Mother;
      Root_Node.Mother.Pointer (1) := Root_Node;
      Right.Mother := Root_Node;
      Left.Mother := Root_Node;
      Insert (Stored_Data, Into => Root_Node);
     -- If by spliting you raise all the way to the root_node
     -- this creates a new root_node where the old one was
     -- split in two.  The insert of the data is done here
         -- because at the time this is the only place Root_Node
         -- is visable.
    end Create_New_Root_Node;


    procedure Split (Nodes : Trees; Using : Acc_Data) is
         --   Split does the actual checking to see where
         -- a node needs to be split and what value needs to be raised
         -- and inserted into the parent node of the one being split.
       The_Data   : Acc_Data renames Using;
      procedure Compose (This_Node                  : Trees;
             From_Position, To_Position : Integer) is
          -- Compose takes a range from a node thats being split
      -- and places it (left_justified) in the new node, or the node
      -- that was split. Also nulls out the remainder of the node
      -- being split after it left_justifies the data.
    Current_Position : Integer := 1;
      begin
    for A in From_Position .. To_Position loop
      This_Node.Pointer (Current_Position) := Nodes.Pointer (A);
      This_Node.Data (Current_Position) := Nodes.Data (A);
      Current_Position := Current_Position + 1;
    end loop;

    This_Node.Pointer (Current_Position) :=
                       Nodes.Pointer (To_Position + 1);

    if This_Node = Nodes then
      for A in Current_Position .. No_Of_Keys loop
        Nodes.Data (A) := null;
        Nodes.Pointer (A + 1) := null;
      end loop;
    end if;
      end Compose;
    begin
      Temp_Node := new Node;

      if The_Data.Key.all < Nodes.Data (Middle_Of_Node).Key.all then
    Stored_Data := Nodes.Data (Middle_Of_Node);
    Compose (Temp_Node, From_Position => 1,
                 To_position => Middle_Of_Node - 1);
    Compose (Nodes, From_Position => Middle_Of_Node + 1,
                 To_Position => No_Of_Keys);
    Insert (The_Data, Into => Temp_Node);

      elsif Nodes.Data (Middle_Of_Node + 1).Key.all < The_Data.Key.all then
    Stored_Data := Nodes.Data (Middle_Of_Node + 1);
    Compose (Temp_Node, From_Position => 1,
                 To_Position => Middle_Of_Node);
    Compose (Nodes, From_Position => Middle_Of_Node + 2,
                 To_Position => No_Of_Keys);
    Insert (The_Data, Into => Nodes);

    if Left /= null then
      Left.Mother := Right.Mother;
    end if;
      else
    Stored_Data := The_Data;
    Compose (Temp_Node, From_Position => 1,
                 To_Position => Middle_Of_Node);
    Compose (Nodes, From_Position => Middle_Of_Node + 1,
                 To_Position => No_Of_Keys);

    if Left /= null then
      Temp_Node.Pointer (Middle_Of_Node + 1) := Left;
    end if;
      end if;
      Left := Temp_Node;
      Right := Nodes;

      for A in 1 .. No_Of_Keys + 1 loop
    exit when Left.Pointer (A) = null;
    Left.Pointer (A).Mother := Left;
      -- Changes the mother pointer in the lower node to point
      -- back at the new node.
      end loop;

      if Nodes.Mother = Seed then
    Create_New_Root_Node;

      elsif Node_Is_Full (Nodes.Mother) then
    Split (Nodes.Mother, Using => Stored_Data);
0V
      -- Recalls the spliting process for the raised data.
      else
    Insert (Stored_Data, Into => Nodes.Mother);
    Left.Mother := Right.Mother;
      -- Inserts the raised data into the mother node and
      -- sets the new nodes mother pointer equal its
      -- counterparts mother.
      end if;
    end Split;
  begin
-------------INSERT----------------
    if Key_Value'Length /= Max_Key_Length then
      raise Key_Length_Error;
    end if;
      -- Checks to see if the inserting keys length is exactly
      -- equal to the key length the that the tree is built on.

    Current_Node := Search_For_Node (Seed.Pointer (1), Key_Value);
    Temp_Position := Position (Of_Key      => Key_Value,
                   Within_Node => Current_Node);
       -- Finds where the key should belong in the tree.

    if Key_Exists (Key_Value, (Current_Node, Temp_Position)) then
      raise Key_Already_Exists;
    end if;

    Stored_Data := new Datas;
    Stored_Data.Key := new Keys'(Key_Value);
    Stored_Data.Item := new Items'(And_Item);

    if Node_Is_Full (Current_Node) then
      Split (Current_Node, Using => Stored_Data);
    else
      Insert (Stored_Data, Into => Current_Node);
    end if;
  end Insert;


procedure Delete_Key (With_Value : Keys; From : Trees) is
    --   This procedure doesn't contain much imagination and its main
    -- purpose was just to work at all.  It is probably not the
    -- most efficient way of deleting keys and keeping the tree
    -- balanced, but it does work.  The problems lies in never having
    -- a node less than half full or one branch of a tree containing
    -- more/less levels than the other brances of the tree.
    --
    --   This procedure's main problem is the fact that it doesn't work
    -- on trees with nodes of less than 4.  This is due to the fact
    -- that a node could contain only 1 data and be half full.  When
    -- this data is deleted it leaves the node with nothing in it which
    -- Delete_Key can't handle.  If deletion of this key causes a
    -- rebalancing to take place, that breaks off the unbalanced branch
    -- of the tree and reinserts it, then a CONSTRAINT_ERROR will be
    -- raised.  This is caused by procedure Get_Next going into the
    -- empty node and trying to return a Item.all of a null Items access
    -- type.

  Nodes          : Trees;
  Seed_Node      : Trees := From;
  Hold_Item      : Items;
  Node_Position  : Position_In_Tree;
  Temp_Node      : Position_In_Tree;
  Position       : Integer;
  Ptr_To_Node    : Integer := 1;
  Half_Of_Node   : Integer := No_Of_Keys / 2;
  Max_Key_Length : Integer := From.Data (No_Of_Keys).Key'Length;


  procedure Left_Justify (Tree : Position_In_Tree) is
      -- Left justifies the data in the node starting at
      -- the given position.
    Place : Integer := Tree.Position_In_Node;
    Left  : Trees := Tree.Node_In_Tree;
  begin
    while Place < No_Of_Keys loop
      Left.Pointer (Place) := Left.Pointer (Place + 1);
      Left.Data (Place) := Left.Data (Place + 1);
      Place := Place + 1;
    end loop;

    Left.Pointer (Place) := Left.Pointer (Place + 1);
    Left.Data (Place) := null;
    Left.Pointer (Place + 1) := null;
  end Left_Justify;


  function Half_Full (Tree : Trees; X : Integer := 0) return Boolean is
      -- Checks the given node to see if it is "X" less than half full.
    Num : Integer := X;
  begin
    for A in 1 .. No_Of_Keys loop
      if Tree.Data (A) /= null then
    Num := Num + 1;
      end if;
    end loop;

    return Num <= No_Of_Keys / 2;
  end Half_Full;


  procedure Reorg_Tree (Tree : Trees) is
      -- When the bottom nodes have become empty enough so that no
      -- combining or switching keys is possible then that part of the
      -- tree is broken off and reinserted back into the Tree.

    Sub_Tree    : Trees := new Node;
    Mother_Node : Trees := Tree;


    procedure Balance_Tree (Tree : Trees) is
        -- Loops through the Sub_Tree and inserts each data back into
        -- the original Tree.
      Position : Position_In_Tree;
    begin
      Get_First (From            => Sub_Tree,
         Giving_Position => Position,
         Giving_Item     => Hold_Item);

      loop
    Insert (Key_Value => Position.Node_In_Tree.Data
                            (Position.Position_In_Node).Key.all,
        And_Item  => Hold_Item,
        Into      => Seed_Node);
    Get_Next (From => Position, Giving_Item => Hold_Item);
      end loop;
    exception
      when End_Of_Tree =>
    Delete_Tree (Sub_Tree);
          -- Deallocates the Sub_Tree.
    end Balance_Tree;


    procedure Make_A_Sub_Tree (Data_Position, Ptr_Position : Integer) is
      -- Breaks a branch off the Tree, creating a Sub_Tree.
    begin
      Sub_Tree.Data (No_Of_Keys) := new Datas;
      Sub_Tree.Data (No_Of_Keys).Key :=
    new Keys'(Mother_Node.Data (Data_Position).Key.all);
      Sub_Tree.Pointer (1) := Mother_Node.Pointer (Ptr_Position);

      if Sub_Tree.Pointer (1).Data (Half_Of_Node) = null then
    Sub_Tree.Pointer (1).Data (Half_Of_Node) :=
      Mother_Node.Data (Data_Position);
      else
    Sub_Tree.Pointer (1).Data (Half_Of_Node + 1) :=
      Mother_Node.Data (Data_Position);
      end if;

      Sub_Tree.Pointer (1).Mother := Sub_Tree;
    end Make_A_Sub_Tree;

  begin
    while Half_Full (Mother_Node) and then Mother_Node.Mother /= Seed_Node loop
      Temp_Node.Node_In_Tree := Mother_Node;
      Mother_Node := Mother_Node.Mother;
        -- Loops up the Tree searching for a place to
        -- break off a branch from the tree.
    end loop;

    Ptr_To_Node := 1;

    while Mother_Node.Pointer (Ptr_To_Node) /= Temp_Node.Node_In_Tree loop
      Ptr_To_Node := Ptr_To_Node + 1;
    end loop;

    if Mother_Node.Data (2) = null then
      if Ptr_To_Node = 1 then
    Make_A_Sub_Tree (Ptr_To_Node, Ptr_To_Node);
    Mother_Node.Pointer (2).Mother := Seed_Node;
    Seed_Node.Pointer (1) := Mother_Node.Pointer (2);
      else
    Make_A_Sub_Tree (Ptr_To_Node - 1, Ptr_To_Node);
    Mother_Node.Pointer (1).Mother := Seed_Node;
    Seed_Node.Pointer (1) := Mother_Node.Pointer (1);
      end if;
        -- This happens when the reorg takes place at the Root_Node
        -- where it contains only 1 data record.

    elsif Ptr_To_Node = 1 then
      Make_A_Sub_Tree (Ptr_To_Node, Ptr_To_Node);
      Left_Justify ((Mother_Node, Ptr_To_Node));
    else
      Make_A_Sub_Tree (Ptr_To_Node - 1, Ptr_To_Node);
      Mother_Node.Pointer (Ptr_To_Node) :=
    Mother_Node.Pointer (Ptr_To_Node - 1);
      Left_Justify ((Mother_Node, Ptr_To_Node - 1));
    end if;

    Balance_Tree (Sub_Tree);
  end Reorg_Tree;


  procedure Try_To_Combine_Nodes is
      -- This contains the Logic of What to do after a Key has been
      -- deleted which leaves a bottom node less than half full.

    procedure Combine_Two_Nodes (Com_Tree         : Trees;
                 Center, Position : Integer) is
        -- Combines two bottom level nodes together along with one
        -- record from their parent node.
      Mid : Integer := Center;
    begin
      if Com_Tree.Data (Mid) /= null then
    Mid := Mid + 1;
      end if;

      Com_Tree.Data (Mid) := Nodes.Data (Position);

      for A in Mid + 1 .. No_Of_Keys loop
    Com_Tree.Data (A) := Temp_Node.Node_In_Tree.Data (A - (Mid));
    Temp_Node.Node_In_Tree.Data (A - (Mid)) := null;
          -- Moves the Data from the old node into the new one.
      end loop;

      Free_Ptr (Temp_Node.Node_In_Tree);
        -- Deallocates the old node
      Left_Justify ((Nodes, Position));
    end Combine_Two_Nodes;


    procedure Switch_Keys_In_Nodes (Where : String := "LFT") is
        -- Yoyos data between three connected nodes.
      Yoyo_Tree : Position_In_Tree;

      procedure Yoyo (To, From : Integer) is
      begin
    Temp_Node.Node_In_Tree.Data (To) := Nodes.Data (From);
    Nodes.Data (From) := Yoyo_Tree.Node_In_Tree.Data
                (Yoyo_Tree.Position_In_Node);
    Yoyo_Tree.Node_In_Tree.Data (Yoyo_Tree.Position_In_Node) := null;
      end Yoyo;
    begin
      if Where = "RGT" then
    for A in 1 .. Position - 1 loop
      Temp_Node.Node_In_Tree.Data (A + 1) :=
        Temp_Node.Node_In_Tree.Data (A);
    end loop;
      -- When going to the right, room must be made in the first
      -- position of the node to accept a key.  This loop
      -- right justifies temp_node starting at the position of
      -- the deleted key.
    Get_Last (From            => Nodes.Pointer (Ptr_To_Node - 1),
          Giving_Position => Yoyo_Tree,
          Giving_Item     => Hold_Item);
      -- Gets the last key in the node on temp_nodes' left
    Yoyo (1, Ptr_To_Node - 1);
      else
    Yoyo_Tree := (Nodes.Pointer (Ptr_To_Node + 1), 1);
      -- sets yoyo_tree at position 1 of the node to temp_nodes
      -- right.
    Yoyo (Half_Of_Node, Ptr_To_Node);
    Left_Justify (Yoyo_Tree);
      end if;
    end Switch_Keys_In_Nodes;


    procedure Combine_Right_Node is
      -- Checks to see if the Node on the left can be combined
      -- into itself.
    begin
      if Half_Full (Nodes.Pointer (Ptr_To_Node - 1), (-1)) then
    Left_Justify (Temp_Node);
    Nodes.Pointer (Ptr_To_Node) := Nodes.Pointer (Ptr_To_Node - 1);
    Combine_Two_Nodes (Nodes.Pointer (Ptr_To_Node - 1), Half_Of_Node + 1,
               Ptr_To_Node - 1);
      else
    Switch_Keys_In_Nodes ("RGT");
      end if;
    end Combine_Right_Node;


    procedure Combine_Left_Node is
      -- Checks to see if the Node on the right can be combined
      -- into itself.
    begin
      Left_Justify (Temp_Node);

      if Half_Full (Nodes.Pointer (Ptr_To_Node + 1), (-1)) then
    Temp_Node.Node_In_Tree := Nodes.Pointer (Ptr_To_Node + 1);
    Nodes.Pointer (Ptr_To_Node + 1) := Nodes.Pointer (Ptr_To_Node);
    Combine_Two_Nodes (Nodes.Pointer (Ptr_To_Node), Half_Of_Node,
               Ptr_To_Node);
      else
    Switch_Keys_In_Nodes;
      end if;
    end Combine_Left_Node;
  begin
    Nodes := Nodes.Mother;

    while Nodes.Pointer (Ptr_To_Node) /= Temp_Node.Node_In_Tree loop
      Ptr_To_Node := Ptr_To_Node + 1;
    end loop;

    if Half_Full (Nodes) then
      if Ptr_To_Node /= 1 and then
     not Half_Full (Nodes.Pointer (Ptr_To_Node - 1)) then
    Switch_Keys_In_Nodes ("RGT");
      -- going from left to right

      elsif Nodes.Pointer (Ptr_To_Node + 1) /= null and then
        not Half_Full (Nodes.Pointer (Ptr_To_Node + 1)) then
    Left_Justify (Temp_Node);
    Switch_Keys_In_Nodes;
      -- going from right to left

      elsif Nodes /= Seed_Node then
    Left_Justify (Temp_Node);
    Reorg_Tree (Nodes);
      else
    Left_Justify (Temp_Node);
      -- Where Temp_Node is the Root_Node
      -- The Root_Node is the only node left in the tree.
      end if;

    elsif Ptr_To_Node = 1 then
      Combine_Left_Node;

    elsif Ptr_To_Node = No_Of_Keys + 1 or else
      Nodes.Data (Ptr_To_Node) = null then
      Combine_Right_Node;

    elsif Half_Full (Nodes.Pointer (Ptr_To_Node + 1)) then
      Combine_Left_Node;
    else
      Combine_Right_Node;
    end if;
  end Try_To_Combine_Nodes;

begin
  if With_Value'Length /= Max_Key_Length then
    raise Key_Length_Error;
  end if;
    -- Check to make sure the Key being deleted is the same length as
    -- keys the tree was built on.

  Node_Position := Tree_Position
              (In_Tree => Seed_Node, Containing => With_Value);
    -- Finds where the key should be in the tree.

  Temp_Node := Node_Position;
  Nodes := Node_Position.Node_In_Tree;
  Position := Node_Position.Position_In_Node;

  if Key_Exists (With_Value, At_Position => Node_Position) then
    Free_Key (Nodes.Data (Position).Key);
    Free_Item (Nodes.Data (Position).Item);
    Free_Data (Nodes.Data (Position));

    if Nodes.Pointer (1) /= null then
      Get_First (From            => Nodes.Pointer (Position + 1),
         Giving_Position => Temp_Node,
         Giving_Item     => Hold_Item);
      Nodes.Data (Position) :=
    Temp_Node.Node_In_Tree.Data (Temp_Node.Position_In_Node);
      Nodes := Temp_Node.Node_In_Tree;
      Position := Temp_Node.Position_In_Node;
      Nodes.Data (Position) := null;
        -- If the keys position in the tree is other than the bottom
        -- level then a bottom level node is pulled up into the vacant
        -- position left by the deleted data.
    end if;

    if Half_Full (Nodes, 1) then
        -- Checking to see if the node is ONE less than half full.
      Try_To_Combine_Nodes;
    else
      Left_Justify ((Nodes, Position));
    end if;
  else
    raise Key_Not_Found;
  end if;

end Delete_Key;

begin
  if No_Of_Keys < 4 then
    raise Program_Error;
  end if;
end Balanced_Trees;
 $