--::::::::::
--mims.pro
--::::::::::
-------- SIMTEL20 Ada Software Repository Prologue ------------
-- -*
-- Unit name : Mobile Information Management System (MIMS)
-- Version :
-- Author : Strategic Air Command (SAC)
-- : HQ SAC SICA
-- : Offutt AFB, NE
-- : Contact: Lt. Colonel Falgiano
-- : ESD/SCW
-- : Hanscom AFB, MA 01731
-- DDN Address :
-- Copyright :
-- Date created : Jan. 1985
-- Release date : Nov 1985
-- Last update :
-- Machine/System Compiled/Run on :
-- -*
---------------------------------------------------------------
-- -*
-- Keywords :
----------------:
--
-- Abstract :
----------------: As a demonstration of the use of Ada for command and control
----------------: applications, the current airborne and ground mobile systems
----------------: at SAC (600,000 LOC - JOVIAL) are being consolidated into a
----------------: mobile data management system using a common data format and
----------------: query language with graphical display capabilities. The
----------------: system includes an integrated data management system,
----------------: automatic and manual update of the data, ad hoc data
----------------: retrieval, building and maintaining displays as well as
----------------: interaction with the working file, display transfers, and
----------------: manual backup. It uses a multiple task environment to
----------------: interface with several I/O devices, enter data into and
----------------: retrieve data from similar systems across the communication
----------------: links, and provide timely access to about 500 million
----------------: characters of data.
----------------:
----------------: Three packages (two generic) are provided from the MIMS at
----------------: this time, balanced trees, source scanner, and variable lists.
----------------:
----------------: This tool was developed as a precursor for
----------------: the WMCCS Information System (WIS). An
----------------: executable version of the tool has been
----------------: demonstrated. This source code has sub-
----------------: sequently been recompiled but has not under-
----------------: gone extensive testing.
----------------:
-- -*
------------------ Revision history ---------------------------
-- -*
-- DATE VERSION AUTHOR HISTORY
--
-- -*
------------------ Distribution and Copyright -----------------
-- -*
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
-- software released to the Public Domain is not subject
-- to copyright protection).
-- Restrictions on use or distribution: NONE
-- -*
----------------- Disclaimer ----------------------------------
-- -*
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
--
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered. The user is advised to
-- test the software thoroughly before relying on it. The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
-- -*
----------------- END-PROLOGUE -------------------------------
--::::::::::
--mims.ada
--::::::::::
--\\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);
-- 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;
--::::::::::
--mims.cmm
--::::::::::
Comments on Porting
Packages from the Mobile Information Management System (MIMS)
by Strategic Air Command (SAC)
to DEC Ada
Tool 23
January 30, 1986
COMPILATION
-----------
We were able to compile the paged source file, MIMS.ADA, after modifying
the order in which the files had been paged. No command file was
provided, and we chose not to create one because there were only a
few packages to compile.
EXECUTION
---------
Execution was not attempted because MIMS is a set of procedures to be
invoked by an applications program and no such program was readily
available.
COMMENT
-------
The paged source file, MIMS.ADA contains three packages, of which
two are generic. The names of the two generic files are, BALANCED_TREES and
VARIABLE_LISTS and the name of the third package is SOURCE_SCANNER.