|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 82009 (0x14059)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦797a3cc76⟧
└─⟦this⟧
generic
type ItemType is private; --| This is the data being manipulated.
with function Equal ( X,Y: in ItemType) return boolean is "=";
--| This allows the user to define
--| equality on ItemType. For instance
--| if ItemType is an abstract type
--| then equality is defined in terms of
--| the abstract type. If this function
--| is not provided equality defaults to
--| =.
package Lists is
--| This package provides singly linked lists with elements of type
--| ItemType, where ItemType is specified by a generic parameter.
--| Overview
--| When this package is instantiated, it provides a linked list type for
--| lists of objects of type ItemType, which can be any desired type. A
--| complete set of operations for manipulation, and releasing
--| those lists is also provided. For instance, to make lists of strings,
--| all that is necessary is:
--|
--| type StringType is string(1..10);
--|
--| package Str_List is new Lists(StringType); use Str_List;
--|
--| L:List;
--| S:StringType;
--|
--| Then to add a string S, to the list L, all that is necessary is
--|
--| L := Create;
--| Attach(S,L);
--|
--|
--| This package provides basic list operations.
--|
--| Attach append an object to an object, an object to a list,
--| or a list to an object, or a list to a list.
--| Copy copy a list using := on elements
--| CopyDeep copy a list by copying the elements using a copy
--| operation provided by the user
--| Create Creates an empty list
--| DeleteHead removes the head of a list
--| DeleteItem delete the first occurrence of an element from a list
--| DeleteItems delete all occurrences of an element from a list
--| Destroy remove a list
--| DestroyDeep destroy a list as well as the elements in that list
--| Equal are two lists equal
--| FirstValue get the information from the first element of a list
--| Forward advances an iterator
--| IsInList determines whether a given element is in a given list
--| IsEmpty returns true if the list is empty
--| LastValue return the last value of a list
--| Length Returns the length of a list
--| MakeList this takes a single element and returns a list
--| MakeListIter prepares for an iteration over a list
--| More are there any more items in the list
--| Next get the next item in a list
--| ReplaceHead replace the information at the head of the list
--| ReplaceTail replace the tail of a list with a new list
--| Tail get the tail of a list
--| CellValue this takes an iterator and returns the value of the element
--| whose position the iterator holds
--|
--| N/A: Effects, Requires, Modifies, and Raises.
--| Notes
--| Programmer Buddy Altus
--| Types
--| -----
type List is private;
type ListIter is private;
--| Exceptions
--| ----------
CircularList :exception; --| Raised if an attemp is made to
--| create a circular list. This
--| results when a list is attempted
--| to be attached to itself.
EmptyList :exception; --| Raised if an attemp is made to
--| manipulate an empty list.
ItemNotPresent :exception; --| Raised if an attempt is made to
--| remove an element from a list in
--| which it does not exist.
NoMore :exception; --| Raised if an attemp is made to
--| get the next element from a list
--| after iteration is complete.
--| Operations
--| ----------
----------------------------------------------------------------------------
procedure Attach( --| appends List2 to List1
List1: in out List; --| The list being appended to.
List2: in List --| The list being appended.
);
--| Raises
--| CircularList
--| Effects
--| Appends List1 to List2. This makes the next field of the last element
--| of List1 refer to List2. This can possibly change the value of List1
--| if List1 is an empty list. This causes sharing of lists. Thus if
--| user Destroys List1 then List2 will be a dangling reference.
--| This procedure raises CircularList if List1 equals List2. If it is
--| necessary to Attach a list to itself first make a copy of the list and
--| attach the copy.
--| Modifies
--| Changes the next field of the last element in List1 to be List2.
-------------------------------------------------------------------------------
function Attach( --| Creates a new list containing the two
--| Elements.
Element1: in ItemType; --| This will be first element in list.
Element2: in ItemType --| This will be second element in list.
) return List;
--| Effects
--| This creates a list containing the two elements in the order
--| specified.
-------------------------------------------------------------------------------
procedure Attach( --| List L is appended with Element.
L: in out List; --| List being appended to.
Element: in ItemType --| This will be last element in l ist.
);
--| Effects
--| Appends Element onto the end of the list L. If L is empty then this
--| may change the value of L.
--|
--| Modifies
--| This appends List L with Element by changing the next field in List.
--------------------------------------------------------------------------------
procedure Attach( --| Makes Element first item in list L.
Element: in ItemType; --| This will be the first element in list.
L: in out List --| The List which Element is being
--| prepended to.
);
--| Effects
--| This prepends list L with Element.
--|
--| Modifies
--| This modifies the list L.
--------------------------------------------------------------------------
function Attach ( --| attaches two lists
List1: in List; --| first list
List2: in List --| second list
) return List;
--| Raises
--| CircularList
--| Effects
--| This returns a list which is List1 attached to List2. If it is desired
--| to make List1 be the new attached list the following ada code should be
--| used.
--|
--| List1 := Attach (List1, List2);
--| This procedure raises CircularList if List1 equals List2. If it is
--| necessary to Attach a list to itself first make a copy of the list and
--| attach the copy.
-------------------------------------------------------------------------
function Attach ( --| prepends an element onto a list
Element: in ItemType; --| element being prepended to list
L: in List --| List which element is being added
--| to
) return List;
--| Effects
--| Returns a new list which is headed by Element and followed by L.
------------------------------------------------------------------------
function Attach ( --| Adds an element to the end of a list
L: in List; --| The list which element is being added to.
Element: in ItemType --| The element being added to the end of
--| the list.
) return List;
--| Effects
--| Returns a new list which is L followed by Element.
--------------------------------------------------------------------------
function Copy( --| returns a copy of list1
L: in List --| list being copied
) return List;
--| Effects
--| Returns a copy of L.
--------------------------------------------------------------------------
generic
with function Copy(I: in ItemType) return ItemType;
function CopyDeep( --| returns a copy of list using a user supplied
--| copy function. This is helpful if the type
--| of a list is an abstract data type.
L: in List --| List being copied.
) return List;
--| Effects
--| This produces a new list whose elements have been duplicated using
--| the Copy function provided by the user.
------------------------------------------------------------------------------
function Create --| Returns an empty List
return List;
------------------------------------------------------------------------------
procedure DeleteHead( --| Remove the head element from a list.
L: in out List --| The list whose head is being removed.
);
--| RAISES
--| EmptyList
--|
--| EFFECTS
--| This will return the space occupied by the first element in the list
--| to the heap. If sharing exists between lists this procedure
--| could leave a dangling reference. If L is empty EmptyList will be
--| raised.
------------------------------------------------------------------------------
procedure DeleteItem( --| remove the first occurrence of Element
--| from L
L: in out List; --| list element is being removed from
Element: in ItemType --| element being removed
);
--| EFFECTS
--| Removes the first element of the list equal to Element. If there is
--| not an element equal to Element than ItemNotPresent is raised.
--| MODIFIES
--| This operation is destructive, it returns the storage occupied by
--| the elements being deleted.
----------------------------------------------------------------------------
function DeleteItem( --| remove the first occurrence of Element
--| from L
L: in List; --| list element is being removed from
Element: in ItemType --| element being removed
) return List;
--| EFFECTS
--| This returns the List L with the first occurrence of Element removed.
------------------------------------------------------------------------------
function DeleteItems ( --| remove all occurrences of Element
--| from L.
L: in List; --| The List element is being removed from
Element: in ItemType --| element being removed
) return List;
--| EFFECTS
--| This function returns a copy of the list L which has all elements which
--| have value Element removed.
-------------------------------------------------------------------------------
procedure DeleteItems ( --| remove all occurrences of Element
--| from L.
L: in out List; --| The List element is being removed from
Element: in ItemType --| element being removed
);
--| EFFECTS
--| This procedure removes all occurrences of Element from the List L. This
--| is a destructive procedure.
------------------------------------------------------------------------------
procedure Destroy ( --| removes the list
L: in out List --| the list being removed
);
--| Effects
--| This returns to the heap all the storage that a list occupies. Keep in
--| mind if there exists sharing between lists then this operation can leave
--| dangling references.
------------------------------------------------------------------------------
generic
with procedure Dispose (I :in out ItemType);
procedure DestroyDeep ( --| Destroy a list as well as all objects which
--| comprise an element of the list.
L :in out List
);
--| OVERVIEW
--| This procedure is used to destroy a list and all the objects contained
--| in an element of the list. For example if L is a list of lists
--| then destroy L does not destroy the lists which are elements of L.
--| DestroyDeep will now destroy L and all the objects in the elements of L.
--| The produce Dispose is a procedure which will destroy the objects which
--| comprise an element of a list. For example if package L was a list
--| of lists then Dispose for L would be the Destroy of list type package L was
--| instantiated with.
--| REQUIRES
--| This procedure requires no sharing between elements of lists.
--| For example if L_int is a list of integers and L_of_L_int is a list
--| of lists of integers and two elements of L_of_L_int have the same value
--| then doing a DestroyDeep will cause an access violation to be raised.
--| The best way to avoid this is not to have sharing between list elements
--| or use copy functions when adding to the list of lists.
------------------------------------------------------------------------------
function FirstValue( --| returns the contents of the first record of the
--| list
L: in List --| the list whose first element is being
--| returned
) return ItemType;
--| Raises
--| EmptyList
--|
--| Effects
--| This returns the Item in the first position in the list. If the list
--| is empty EmptyList is raised.
-------------------------------------------------------------------------------
procedure Forward ( --| Advances the iterator.
I :in out ListIter --| The iterator.
);
--| OVERVIEW
--| This procedure can be used in conjunction with Cell to iterate over a list.
--| This is in addition to Next. Instead of writing
--|
--| I :ListIter;
--| L :List;
--| V :List_Element_Type;
--|
--| I := MakeListIter(L);
--| while More(I) loop
--| Next (I, V);
--| Print (V);
--| end loop;
--|
--| One can write
--| I := MakeListIter(L);
--| while More (I) loop
--| Print (Cell (I));
--| Forward (I);
--| end loop;
-------------------------------------------------------------------------------
function IsEmpty( --| Checks if a list is empty.
L: in List --| List being checked.
) return boolean;
--------------------------------------------------------------------------
function IsInList( --| Checks if element is an element of
--| list.
L: in List; --| list being scanned for element
Element: in ItemType --| element being searched for
) return boolean;
--| Effects
--| Walks down the list L looking for an element whose value is Element.
------------------------------------------------------------------------------
function LastValue( --| Returns the contents of the last record of
--| the list.
L: in List --| The list whose first element is being
--| returned.
) return ItemType;
--| Raises
--| EmptyList
--|
--| Effects
--| Returns the last element in a list. If the list is empty EmptyList is
--| raised.
------------------------------------------------------------------------------
function Length( --| count the number of elements on a list
L: in List --| list whose length is being computed
) return integer;
------------------------------------------------------------------------------
function MakeList ( --| This takes in an element and returns a List.
E :in ItemType
) return List;
------------------------------------------------------------------------------
function MakeListIter( --| Sets a variable to point to the head
--| of the list. This will be used to
--| prepare for iteration over a list.
L: in List --| The list being iterated over.
) return ListIter;
--| This prepares a user for iteration operation over a list. The iterater is
--| an operation which returns successive elements of the list on successive
--| calls to the iterator. There needs to be a mechanism which marks the
--| position in the list, so on successive calls to the Next operation the
--| next item in the list can be returned. This is the function of the
--| MakeListIter and the type ListIter. MakeIter just sets the Iter to the
--| the beginning of the list. On subsequent calls to Next the Iter
--| is updated with each call.
-----------------------------------------------------------------------------
function More( --| Returns true if there are more elements in
--| the and false if there aren't any more
--| the in the list.
L: in ListIter --| List being checked for elements.
) return boolean;
------------------------------------------------------------------------------
procedure Next( --| This is the iterator operation. Given
--| a ListIter in the list it returns the
--| current item and updates the ListIter.
--| If ListIter is at the end of the list,
--| More returns false otherwise it
--| returns true.
Place: in out ListIter; --| The Iter which marks the position in
--| the list.
Info: out ItemType --| The element being returned.
);
--| The iterators subprograms MakeListIter, More, and Next should be used
--| in the following way:
--|
--| L: List;
--| Place: ListIter;
--| Info: SomeType;
--|
--|
--| Place := MakeListIter(L);
--|
--| while ( More(Place) ) loop
--| Next(Place, Info);
--| process each element of list L;
--| end loop;
----------------------------------------------------------------------------
procedure ReplaceHead( --| Replace the Item at the head of the list
--| with the parameter Item.
L: in out List; --| The list being modified.
Info: in ItemType --| The information being entered.
);
--| Raises
--| EmptyList
--| Effects
--| Replaces the information in the first element in the list. Raises
--| EmptyList if the list is empty.
------------------------------------------------------------------------------
procedure ReplaceTail( --| Replace the Tail of a list
--| with a new list.
L: in out List; --| List whose Tail is replaced.
NewTail: in List --| The list which will become the
--| tail of Oldlist.
);
--| Raises
--| EmptyList
--|
--| Effects
--| Replaces the tail of a list with a new list. If the list whose tail
--| is being replaced is null EmptyList is raised.
-------------------------------------------------------------------------------
function Tail( --| returns the tail of a list L
L: in List --| the list whose tail is being returned
) return List;
--| Raises
--| EmptyList
--|
--| Effects
--| Returns a list which is the tail of the list L. Raises EmptyList if
--| L is empty. If L only has one element then Tail returns the Empty
--| list.
------------------------------------------------------------------------------
function CellValue ( --| Return the value of the element where the iterator is
--| positioned.
I :in ListIter
) return ItemType;
--| OVERVIEW
--| This returns the value of the element at the position of the iterator.
--| This is used in conjunction with Forward.
--------------------------------------------------------------------------
function Equal( --| compares list1 and list2 for equality
List1: in List; --| first list
List2: in List --| second list
) return boolean;
--| Effects
--| Returns true if for all elements of List1 the corresponding element
--| of List2 has the same value. This function uses the Equal operation
--| provided by the user. If one is not provided then = is used.
------------------------------------------------------------------------------
private
type Cell;
type List is access Cell; --| pointer added by this package
--| in order to make a list
type Cell is --| Cell for the lists being created
record
Info: ItemType;
Next: List;
end record;
type ListIter is new List; --| This prevents Lists being assigned to
--| iterators and vice versa
end Lists;
\f
with unchecked_deallocation;
package body Lists is
procedure Free is new unchecked_deallocation (Cell, List);
--------------------------------------------------------------------------
function Last (L: in List) return List is
Place_In_L: List;
Temp_Place_In_L: List;
--| Link down the list L and return the pointer to the last element
--| of L. If L is null raise the EmptyList exception.
begin
if L = null then
raise EmptyList;
else
--| Link down L saving the pointer to the previous element in
--| Temp_Place_In_L. After the last iteration Temp_Place_In_L
--| points to the last element in the list.
Place_In_L := L;
while Place_In_L /= null loop
Temp_Place_In_L := Place_In_L;
Place_In_L := Place_In_L.Next;
end loop;
return Temp_Place_In_L;
end if;
end Last;
--------------------------------------------------------------------------
procedure Attach (List1: in out List;
List2: in List ) is
EndOfList1: List;
--| Attach List2 to List1.
--| If List1 is null return List2
--| If List1 equals List2 then raise CircularList
--| Otherwise get the pointer to the last element of List1 and change
--| its Next field to be List2.
begin
if List1 = null then
List1 := List2;
return;
elsif List1 = List2 then
raise CircularList;
else
EndOfList1 := Last (List1);
EndOfList1.Next := List2;
end if;
end Attach;
--------------------------------------------------------------------------
procedure Attach (L: in out List;
Element: in ItemType ) is
NewEnd: List;
--| Create a list containing Element and attach it to the end of L
begin
NewEnd := new Cell'(Info => Element, Next => null);
Attach (L, NewEnd);
end;
--------------------------------------------------------------------------
function Attach (Element1: in ItemType;
Element2: in ItemType ) return List is
NewList: List;
--| Create a new list containing the information in Element1 and
--| attach Element2 to that list.
begin
NewList := new Cell'(Info => Element1, Next => null);
Attach (NewList, Element2);
return NewList;
end;
--------------------------------------------------------------------------
procedure Attach (Element: in ItemType;
L: in out List ) is
--| Create a new cell whose information is Element and whose Next
--| field is the list L. This prepends Element to the List L.
begin
L := new Cell'(Info => Element, Next => L);
end;
--------------------------------------------------------------------------
function Attach ( List1: in List;
List2: in List ) return List is
Last_Of_List1: List;
begin
if List1 = null then
return List2;
elsif List1 = List2 then
raise CircularList;
else
Last_Of_List1 := Last (List1);
Last_Of_List1.Next := List2;
return List1;
end if;
end Attach;
-------------------------------------------------------------------------
function Attach( L: in List;
Element: in ItemType ) return List is
NewEnd: List;
Last_Of_L: List;
--| Create a list called NewEnd and attach it to the end of L.
--| If L is null return NewEnd
--| Otherwise get the last element in L and make its Next field
--| NewEnd.
begin
NewEnd := new Cell'(Info => Element, Next => null);
if L = null then
return NewEnd;
else
Last_Of_L := Last (L);
Last_Of_L.Next := NewEnd;
return L;
end if;
end Attach;
--------------------------------------------------------------------------
function Attach (Element: in ItemType;
L: in List ) return List is
begin
return (new Cell'(Info => Element, Next => L));
end Attach;
---------------------------------------------------------------------------
function Copy (L: in List) return List is
--| If L is null return null
--| Otherwise recursively copy the list by first copying the information
--| at the head of the list and then making the Next field point to
--| a copy of the tail of the list.
begin
if L = null then
return null;
else
return new Cell'(Info => L.Info, Next => Copy (L.Next));
end if;
end Copy;
--------------------------------------------------------------------------
function CopyDeep (L: in List) return List is
--| If L is null then return null.
--| Otherwise copy the first element of the list into the head of the
--| new list and copy the tail of the list recursively using CopyDeep.
begin
if L = null then
return null;
else
return new Cell'( Info => Copy (L.Info), Next => CopyDeep(L.Next));
end if;
end CopyDeep;
--------------------------------------------------------------------------
function Create return List is
--| Return the empty list.
begin
return null;
end Create;
--------------------------------------------------------------------------
procedure DeleteHead (L: in out List) is
TempList: List;
--| Remove the element of the head of the list and return it to the heap.
--| If L is null EmptyList.
--| Otherwise save the Next field of the first element, remove the first
--| element and then assign to L the Next field of the first element.
begin
if L = null then
raise EmptyList;
else
TempList := L.Next;
Free (L);
L := TempList;
end if;
end DeleteHead;
--------------------------------------------------------------------------
function DeleteItem( --| remove the first occurrence of Element
--| from L
L: in List; --| list element is being removed from
Element: in ItemType --| element being removed
) return List is
I :List;
Result :List;
Found :boolean := false;
begin
--| ALGORITHM
--| Attach all elements of L to Result except the first element in L
--| whose value is Element. If the current element pointed to by I
--| is not equal to element or the element being skipped was found
--| then attach the current element to Result.
I := L;
while (I /= null) loop
if (not Equal (I.Info, Element)) or (Found) then
Attach (Result, I.Info);
else
Found := true;
end if;
I := I.Next;
end loop;
return Result;
end DeleteItem;
------------------------------------------------------------------------------
function DeleteItems ( --| remove all occurrences of Element
--| from L.
L: in List; --| The List element is being removed from
Element: in ItemType --| element being removed
) return List is
I :List;
Result :List;
begin
--| ALGORITHM
--| Walk over the list L and if the current element does not equal
--| Element then attach it to the list to be returned.
I := L;
while I /= null loop
if not Equal (I.Info, Element) then
Attach (Result, I.Info);
end if;
I := I.Next;
end loop;
return Result;
end DeleteItems;
-------------------------------------------------------------------------------
procedure DeleteItem (L: in out List;
Element: in ItemType ) is
Temp_L :List;
--| Remove the first element in the list with the value Element.
--| If the first element of the list is equal to element then
--| remove it. Otherwise, recurse on the tail of the list.
begin
if Equal(L.Info, Element) then
DeleteHead(L);
else
DeleteItem(L.Next, Element);
end if;
end DeleteItem;
--------------------------------------------------------------------------
procedure DeleteItems (L: in out List;
Element: in ItemType ) is
Place_In_L :List; --| Current place in L.
Last_Place_In_L :List; --| Last place in L.
Temp_Place_In_L :List; --| Holds a place in L to be removed.
--| Walk over the list removing all elements with the value Element.
begin
Place_In_L := L;
Last_Place_In_L := null;
while (Place_In_L /= null) loop
--| Found an element equal to Element
if Equal(Place_In_L.Info, Element) then
--| If Last_Place_In_L is null then we are at first element
--| in L.
if Last_Place_In_L = null then
Temp_Place_In_L := Place_In_L;
L := Place_In_L.Next;
else
Temp_Place_In_L := Place_In_L;
--| Relink the list Last's Next gets Place's Next
Last_Place_In_L.Next := Place_In_L.Next;
end if;
--| Move Place_In_L to the next position in the list.
--| Free the element.
--| Do not update the last element in the list it remains the
--| same.
Place_In_L := Place_In_L.Next;
Free (Temp_Place_In_L);
else
--| Update the last place in L and the place in L.
Last_Place_In_L := Place_In_L;
Place_In_L := Place_In_L.Next;
end if;
end loop;
--| If we have not found an element raise an exception.
end DeleteItems;
------------------------------------------------------------------------------
procedure Destroy (L: in out List) is
Place_In_L: List;
HoldPlace: List;
--| Walk down the list removing all the elements and set the list to
--| the empty list.
begin
Place_In_L := L;
while Place_In_L /= null loop
HoldPlace := Place_In_L;
Place_In_L := Place_In_L.Next;
Free (HoldPlace);
end loop;
L := null;
end Destroy;
--------------------------------------------------------------------------
procedure DestroyDeep (L: in out List) is
Place_In_L: List;
HoldPlace: List;
--| Walk down the list removing all the elements and set the list to
--| the empty list.
begin
Place_In_L := L;
while Place_In_L /= null loop
HoldPlace := Place_In_L;
Place_In_L := Place_In_L.Next;
Dispose (HoldPlace.Info);
Free (HoldPlace);
end loop;
L := null;
end DestroyDeep;
--------------------------------------------------------------------------
function FirstValue (L: in List) return ItemType is
--| Return the first value in the list.
begin
if L = null then
raise EmptyList;
else
return (L.Info);
end if;
end FirstValue;
--------------------------------------------------------------------------
procedure Forward (I: in out ListIter) is
--| Return the pointer to the next member of the list.
begin
if I = null then
raise NoMore;
else
I := ListIter (I.Next);
end if;
end Forward;
--------------------------------------------------------------------------
function IsInList (L: in List;
Element: in ItemType ) return boolean is
Place_In_L: List;
--| Check if Element is in L. If it is return true otherwise return false.
begin
Place_In_L := L;
while Place_In_L /= null loop
if Equal(Place_In_L.Info, Element) then
return true;
end if;
Place_In_L := Place_In_L.Next;
end loop;
return false;
end IsInList;
--------------------------------------------------------------------------
function IsEmpty (L: in List) return boolean is
--| Is the list L empty.
begin
return (L = null);
end IsEmpty;
--------------------------------------------------------------------------
function LastValue (L: in List) return ItemType is
LastElement: List;
--| Return the value of the last element of the list. Get the pointer
--| to the last element of L and then return its information.
begin
LastElement := Last (L);
return LastElement.Info;
end LastValue;
--------------------------------------------------------------------------
function Length (L: in List) return integer is
--| Recursively compute the length of L. The length of a list is
--| 0 if it is null or 1 + the length of the tail.
begin
if L = null then
return (0);
else
return (1 + Length (Tail (L)));
end if;
end Length;
--------------------------------------------------------------------------
function MakeList (
E :in ItemType
) return List is
begin
return new Cell ' (Info => E, Next => null);
end;
--------------------------------------------------------------------------
function MakeListIter (L: in List) return ListIter is
--| Start an iteration operation on the list L. Do a type conversion
--| from List to ListIter.
begin
return ListIter (L);
end MakeListIter;
--------------------------------------------------------------------------
function More (L: in ListIter) return boolean is
--| This is a test to see whether an iteration is complete.
begin
return L /= null;
end;
--------------------------------------------------------------------------
procedure Next (Place: in out ListIter;
Info: out ItemType ) is
PlaceInList: List;
--| This procedure gets the information at the current place in the List
--| and moves the ListIter to the next postion in the list.
--| If we are at the end of a list then exception NoMore is raised.
begin
if Place = null then
raise NoMore;
else
PlaceInList := List(Place);
Info := PlaceInList.Info;
Place := ListIter(PlaceInList.Next);
end if;
end Next;
--------------------------------------------------------------------------
procedure ReplaceHead (L: in out List;
Info: in ItemType ) is
--| This procedure replaces the information at the head of a list
--| with the given information. If the list is empty the exception
--| EmptyList is raised.
begin
if L = null then
raise EmptyList;
else
L.Info := Info;
end if;
end ReplaceHead;
--------------------------------------------------------------------------
procedure ReplaceTail (L: in out List;
NewTail: in List ) is
Temp_L: List;
--| This destroys the tail of a list and replaces the tail with
--| NewTail. If L is empty EmptyList is raised.
begin
Destroy(L.Next);
L.Next := NewTail;
exception
when constraint_error =>
raise EmptyList;
end ReplaceTail;
--------------------------------------------------------------------------
function Tail (L: in List) return List is
--| This returns the list which is the tail of L. If L is null
--| EmptyList is raised.
begin
if L = null then
raise EmptyList;
else
return L.Next;
end if;
end Tail;
--------------------------------------------------------------------------
function CellValue (
I :in ListIter
) return ItemType is
L :List;
begin
-- Convert I to a List type and then return the value it points to.
L := List(I);
return L.Info;
end CellValue;
--------------------------------------------------------------------------
function Equal (List1: in List;
List2: in List ) return boolean is
PlaceInList1: List;
PlaceInList2: LIst;
Contents1: ItemType;
Contents2: ItemType;
--| This function tests to see if two lists are equal. Two lists
--| are equal if for all the elements of List1 the corresponding
--| element of List2 has the same value. Thus if the 1st elements
--| are equal and the second elements are equal and so up to n.
--| Thus a necessary condition for two lists to be equal is that
--| they have the same number of elements.
--| This function walks over the two list and checks that the
--| corresponding elements are equal. As soon as we reach
--| the end of a list (PlaceInList = null) we fall out of the loop.
--| If both PlaceInList1 and PlaceInList2 are null after exiting the loop
--| then the lists are equal. If they both are not null the lists aren't
--| equal. Note that equality on elements is based on a user supplied
--| function Equal which is used to test for item equality.
begin
PlaceInList1 := List1;
PlaceInList2 := List2;
while (PlaceInList1 /= null) and (PlaceInList2 /= null) loop
if not Equal (PlaceInList1.Info, PlaceInList2.Info) then
return false;
end if;
PlaceInList1 := PlaceInList1.Next;
PlaceInList2 := PlaceInList2.Next;
end loop;
return ((PlaceInList1 = null) and (PlaceInList2 = null) );
end Equal;
end Lists;
--------------------------------------------------------------------------
\f
with Bounded_String,Lists;
package Fields is
type Object is private;
type Field_Index is limited private;
Error_Field_Store : exception;
Error_Field_Empty : exception;
Error_Field_Index : exception;
--Creation
procedure Create(D : in out Object);
--Access
function Has_Field (D : in Object; Name : in String) return Boolean;
function Get_Field_Type_By_Name(D : Object; Name : String)return String;
procedure Dump_Number_Of_Field(D : in Object);
procedure Dump_Fields (D : in Object);
procedure Surface_Copy(To_Fields : in out Object;The_Fields : Object);
procedure Deep_Copy(To_Fields : in out Object;The_Fields : Object);
-- function Object_Image (D : in Object) return String;
--Modification
procedure Store_Field(D : in out Object; aName : String;aType: String);
--Liberation
procedure Dispose_Object (D : in out Object);
--Iteration
procedure Open_Field_Indexation(D : Object; I : in out Field_Index);
procedure Next_Field_Index (I : in out Field_Index);
function Get_Indexed_Field_Name (I : Field_Index) return String;
function Get_Indexed_Field_Type (I : Field_Index) return String;
function No_More_Fields (I : Field_Index) return Boolean;
private
MAX_STRING_Field:Constant natural:=32;
type Field is Record
Field_Name:Bounded_string.Variable_String(MAX_STRING_Field);
Field_Type:Bounded_string.Variable_String(MAX_STRING_Field);
end record;
function isEqual ( X,Y: in Field) return boolean;
package Fields_List is new Lists(ItemType=>Field,Equal=>isEqual);
Type Object is record
Node:Fields_List.List;
end record;
Type Field_index is record
Node:Fields_List.ListIter;
end record;
end Fields;with Text_Io, Bounded_String,Lists;
package body Fields is
use Fields_List;
function Create_Field(N: String;T : String) return Field is
A:Field;
begin
Bounded_string.free(A.Field_Name);
Bounded_string.Copy(A.Field_Name,N);
Bounded_string.free(A.Field_Type);
Bounded_string.Copy(A.Field_Type,T);
return A;
end;
function isEqual ( X,Y: in Field) return boolean is
begin
declare
Use Bounded_String;
begin
if image(X.Field_name) = image(Y.Field_name) then
return True;
else return False;
end if;
end;
end;
procedure Dispose_Field (The_Field : in out Field) is
begin
Bounded_String.Free(The_Field.Field_Name);
Bounded_String.Free(The_Field.Field_Type);
end Dispose_Field;
procedure Destroy_Object is New DestroyDeep(Dispose =>Dispose_Field);
Function Copy_Field (The_Field : Field) return Field is
begin
return Create_Field(Bounded_String.Image(The_Field.Field_Name),
Bounded_String.Image(The_Field.Field_Type));
end Copy_Field;
Function Copy_object is New CopyDeep(Copy=>Copy_Field);
--Creation
procedure Create(D : in out Object) is
begin
D.Node:=Create;
end;
--Access
function Has_Field (D : in Object; Name : in String) return Boolean is
begin
if not isEmpty(D.Node)
then return isInlisT(D.Node,Create_Field(Name,Name));
else return False;
end if;
end;
function Get_Field_Type_By_Name(D : Object; Name : String)return String is
Index : Field_Index;
Info : Field;
Search: Field;
Found : Boolean:=False;
begin
if not isEmpty(D.Node)
then
Search:=Create_Field(Name,Name);
Index.Node:= MakeListIter(D.Node);
while ( More(Index.Node) and not Found ) loop
Next(Index.Node, Info);
if isEqual(Info,Search)
then found:=True;
return (Bounded_String.Image(Info.Field_Type));
end if;
end loop;
else raise Error_Field_Empty;
end if;
end;
procedure Dump_Fields (D : in Object) is
Index : Field_Index;
Info : Field;
begin
if not isEmpty(D.Node)
then
declare
use Bounded_string;
begin
Index.Node:= MakeListIter(D.Node);
while ( More(Index.Node) ) loop
Next(Index.Node, Info);
Text_io.put_Line("Nom: "&Image(Info.Field_Name)&
" Type: "&Image(Info.Field_Type));
end loop;
end;
else raise Error_Field_Empty;
end if;
end;
procedure Dump_Number_Of_Field(D : in Object) is
begin
Text_io.Put_Line("Number of field : "&Integer'Image(Fields_List.Length(D.node)));
end;
procedure Surface_Copy(To_Fields : in out Object;The_Fields : Object) is
begin
To_fields.Node:=The_fields.Node;
end;
procedure Deep_Copy(To_Fields : in out Object;The_Fields : Object) is
begin
To_Fields.Node:=Copy_Object(The_fields.Node);
end;
-- function Object_Image (D : in Object) return String;
--Modification
procedure Store_Field(D : in out Object; aName : String;aType: String) is
begin
if not isEmpty(D.Node)
then
Attach(D.Node,Create_Field(aName,aType));
else
Attach(Create_Field(aName,aType),D.Node);
end if;
end;
--Liberation
procedure Dispose_Object (D : in out Object) is
begin
if not isEmpty(D.Node)
then
Destroy_Object(D.Node);
end if;
end;
--Iteration
procedure Open_Field_Indexation(D : Object; I : in out Field_Index) is
begin
I.Node:= MakeListIter(D.Node);
end;
procedure Next_Field_Index (I : in out Field_Index) is
Info:Field;
begin
Next(I.Node, Info);
end;
function Get_Indexed_Field_Name (I : Field_Index) return String is
Info:Field;
begin
Info:=CellValue(I.node);
return Bounded_String.Image(Info.Field_Name);
end;
function Get_Indexed_Field_Type (I : Field_Index) return String is
Info:Field;
begin
Info:=CellValue(I.node);
return Bounded_String.Image(Info.Field_Type);
end;
function No_More_Fields (I : Field_Index) return Boolean is
begin
return Not More(I.Node);
end;
end fields;generic
type Value_Type is private; --| Type of values stored in the tree.
with function Difference(P, Q: Value_Type) return integer is <>;
--| Must return a value > 0 if P > Q, 0 if P = Q, and less than
--| zero otherwise.
package binary_trees_pkg is --| Efficient implementation of binary trees.
--| OVERVIEW
--| This package is an efficient implementation of unbalanced binary trees.
--| These trees have the following properties:
--|-
--| 1. Inserting a value is cheap (log n Differences per insertion).
--| 2. Finding a value is cheap (log n Differences per querey).
--| 3. Can iterate over the values in sorted order in linear time.
--| 4. Space overhead is moderate (2 "pointers" per value stored).
--|+
--| They are thus useful both for sorting sequences of indeterminate size
--| and for lookup tables.
--|
--| OPERATIONS
--|
--|-The following operations are provided:
--|
--| Insert Insert a node into a tree
--| Insert_if_not_Found Insert a node into a tree if not there already
--| Replace_if_Found Replace a node if duplicate exists, else insert.
--| Destroy Destroy a tree
--| Destroy_Deep* Destroy a tree and its contents
--| Balanced_Tree* Create a balanced tree from values supplied in order
--| Copy* Copy a tree. The copy is balanced.
--|
--| Queries:
--| Is_Empty Return TRUE iff a tree is empty.
--| Find Search tree for a node
--| Is_Found Return TRUE iff tree contains specified value.
--| Size Return number of nodes in the tree.
--|
--| Iterators:
--| Visit* Apply a procedure to every node in specified order
--| Make_Iter Create an iterator for ordered scan
--| More Test for exhausted iterator
--| Next Bump an iterator to the next element
--|
--| * Indicates generic subprogram
--|
--| USAGE
--|
--| The following example shows how to use this package where nodes in
--| the tree are labeled with a String_Type value (for which a natural
--| Difference function is not available).
--|-
--| package SP renames String_Pkg;
--|
--| type my_Value is record
--| label: SP.string_type;
--| value: integer;
--| end record;
--|
--| function differ_label(P, Q: SP.string_type) return integer is
--| begin
--| if SP."<"(P, Q) then return -1;
--| elsif SP."<"(Q, P) then return 1;
--| else return 0;
--| end if;
--| end differ_label;
--|
--| package my_Tree is new Binary_Trees_pkg(my_Value, differ_Label);
--|
--| Note that the required Difference function may be easily written in terms
--| of "<" if that is available, but that frequently two comparisons must
--| be done for each Difference. However, both comparisons would have
--| to be done internally by this package for every instantiation if the
--| generic parameter were "<" instead of Difference.
--|
--| PERFORMANCE
--|
--| Every node can be visited in the tree in linear time. The cost
--| of creating an iterator is small and independent of the size
--| of the tree.
--|
--| Recognizing that comparing values can be expensive, this package
--| takes a Difference function as a generic parameter. If it took
--| a comparison function such as "<", then two comparisons would be
--| made per node visited during a search of the tree. Of course this
--| is more costly when "<" is a trivial operation, but in those cases,
--| Difference can be bound to "-" and the overhead in negligable.
--|
--| Two different kinds of iterators are provided. The first is the
--| commonly used set of functions Make_Iter, More, and Next. The second
--| is a generic procedure called Visit. The generic parameter to Visit is
--| a procedure which is called once for each value in the tree. Visit
--| is more difficult to use and results in code that is not quite as clear,
--| but its overhead is about 20% of the More/Next style iterator. It
--| is therefore recommended for use only in time critical inner loops.
----------------------------------------------------------------------------
-- Exceptions --
----------------------------------------------------------------------------
Duplicate_Value: exception;
--| Raised on attempt to insert a duplicate node into a tree.
Not_Found: exception;
--| Raised on attempt to find a node that is not in a tree.
No_More: exception;
--| Raised on attempt to bump an iterator that has already scanned the
--| entire tree.
Out_Of_Order: exception;
--| Raised if a problem in the ordering of a tree is detected.
Invalid_Tree: exception;
--| Value is not a tree or was not properly initialized.
----------------------------------------------------------------------------
-- Types --
----------------------------------------------------------------------------
type Scan_Kind is (inorder, preorder, postorder);
--| Used to specify the order in which values should be scanned from a tree:
--|-
--| inorder: Left, Node, Right (nodes visited in increasing order)
--| preorder: Node, Left, Right (top down)
--| postorder: Left, Right, Node (bottom up)
type Tree is private;
type Iterator is private;
----------------------------------------------------------------------------
-- Operations --
----------------------------------------------------------------------------
Function Create --| Return an empty tree.
return Tree;
--| Effects: Create and return an empty tree. Note that this allocates
--| a small amount of storage which can only be reclaimed through
--| a call to Destroy.
----------------------------------------------------------------------------
Procedure Insert( --| Insert a value into a tree.
V: Value_Type; --| Value to be inserted
T: Tree --| Tree to contain the new value
);
--| Raises: Duplicate_Value, Invalid_Tree.
--| Effects: Insert V into T in the proper place. If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, the exception Duplicate_Value is raised.
--| Caution: Since this package does not attempt to balance trees as
--| values are inserted, it is important to remember that inserting
--| values in sorted order will create a degenerate tree, where search
--| and insertion is proportional to the N instead of to Log N. If
--| this pattern is common, use the Balanced_Tree function below.
----------------------------------------------------------------------------
procedure Insert_if_not_Found(
--| Insert a value into a tree, provided a duplicate value is not already there
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean; --| Becomes True iff V already in tree
Duplicate: out Value_Type --| the duplicate value, if there is one
); --| Raises: Invalid_Tree.
--| Effects: Insert V into T in the proper place. If a value equal
--| to V (according to the Difference function) is already contained
--| in the tree, Found will be True and Duplicate will be the duplicate
--| value. This might be a sequence of values with the same key, and
--| V can then be added to the sequence.
----------------------------------------------------------------------------
procedure Replace_if_Found(
--| Replace a value if label exists, otherwise insert it.
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean; --| Becomes True iff L already in tree
Old_Value: out Value_Type --| the duplicate value, if there is one
); --| Raises: Invalid_Tree.
--| Effects: Search for V in T. If found, replace the old value with V,
--| and return Found => True, Old_Value => the old value. Otherwise,
--| simply insert V into T and return Found => False.
----------------------------------------------------------------------------
procedure Destroy( --| Free space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
);
--| Effects: The space allocated to T is reclaimed. The space occupied by
--| the values stored in T is not however, recovered.
----------------------------------------------------------------------------
generic
with procedure free_Value(V: in out Value_Type) is <>;
procedure Destroy_Deep( --| Free all space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
);
--| Effects: The space allocated to T is reclaimed. The values stored
--| in T are reclaimed using Free_Value, and the tree nodes themselves
--| are then reclaimed (in a single walk of the tree).
----------------------------------------------------------------------------
generic
with function next_Value return Value_Type is <>;
--| Each call to this procedure should return the next value to be
--| inserted into the balanced tree being created. If necessary,
--| this function should check that each value is greater than the
--| previous one, and raise Out_of_Order if necessary. If values
--| are not returned in strictly increasing order, the results are
--| unpredictable.
Function Balanced_Tree(
Count: natural
) return Tree;
--| Effects: Create a balanced tree by calling next_Value Count times.
--| Each time Next_Value is called, it must return a value that compares
--| greater than the preceeding value. This function is useful for balancing
--| an existing tree (next_Value iterates over the unbalanced tree) or
--| for creating a balanced tree when reading data from a file which is
--| already sorted.
----------------------------------------------------------------------------
generic
with function Copy_Value(V: Value_Type) return Value_Type is <>;
--| This function is called to copy a value from the old tree to the
--| new tree.
Function Copy_Tree(
T: Tree
) return Tree; --| Raises Invalid_Tree.
--| Effects: Create a balanced tree that is a copy of the tree T.
--| The exception Invalid_Tree is raised if T is not a valid tree.
----------------------------------------------------------------------------
Function Is_Empty( --| Check for an empty tree.
T: Tree
) return boolean;
--| Effects: Return TRUE iff T is an empty tree or if T was not initialized.
----------------------------------------------------------------------------
Function Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Value_Type; --| Raises: Not_Found, Invalid_Tree.
--| Effects: Search T for a value that matches V. The matching value is
--| returned. If no matching value is found, the exception Not_Found
--| is raised.
Procedure Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree; --| Tree to be searched
Found: out Boolean; --| TRUE iff a match was found
Match: out Value_Type --| Matching value found in the tree
); --| Raises: Invalid_Tree;
--| Effects: Search T for a value that matches V. On return, if Found is
--| TRUE then the matching value is returned in Match. Otherwise, Found
--| is FALSE and Match is undefined.
----------------------------------------------------------------------------
function is_Found( --| Check a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Boolean; --| Raises: Invalid_Tree;
--| Effects: Return TRUE iff V is found in T.
----------------------------------------------------------------------------
function Size( --| Return the count of values in T.
T: Tree --| a tree
) return natural;
--| Effects: Return the number of values stored in T.
----------------------------------------------------------------------------
generic
with procedure Process(V: Value_Type) is <>;
procedure Visit(
T: Tree;
Order: Scan_Kind
); --| Raises: Invalid_Tree;
--| Effects: Invoke Process(V) for each value V in T. The nodes are visited
--| in the order specified by Order. Although more limited than using
--| an iterator, this function is also much faster.
----------------------------------------------------------------------------
function Make_Iter( --| Create an iterator over a tree
T: Tree
) return Iterator; --| Raises: Invalid_Tree;
----------------------------------------------------------------------------
function More( --| Test for exhausted iterator
I: Iterator --| The iterator to be tested
) return boolean;
--| Effects: Return TRUE iff unscanned nodes remain in the tree being
--| scanned by I.
----------------------------------------------------------------------------
procedure Next( --| Scan the next value in I
I: in out Iterator; --| an active iterator
V: out Value_Type --| Next value scanned
); --| Raises: No_More.
--| Effects: Return the next value in the tree being scanned by I.
--| The exception No_More is raised if there are no more values to scan.
----------------------------------------------------------------------------
private
type Node;
type Node_Ptr is access Node;
type Node is
record
Value: Value_Type;
Less: Node_Ptr;
More: Node_Ptr;
end record;
type Tree_Header is
record
Count: natural := 0;
Root: Node_Ptr := Null;
end record;
type Tree is access Tree_Header;
type Iter_State is (Left, Middle, Right, Done);
type Iterator_Record;
type Iterator is access Iterator_Record;
type Iterator_Record is
record
State: Iter_State;
Parent: Iterator;
subtree: Node_Ptr;
end record;
end binary_trees_pkg;
with unchecked_deallocation;
Package body Binary_Trees_Pkg is
--| Efficient implementation of binary trees.
----------------------------------------------------------------------------
-- Local Operations --
----------------------------------------------------------------------------
procedure Free_Node is
new unchecked_deallocation(Node, Node_Ptr);
procedure Free_Tree is
new unchecked_deallocation(Tree_Header, Tree);
procedure Free_Iterator is
new unchecked_deallocation(Iterator_Record, Iterator);
----------------------------------------------------------------------------
-- Visible Operations --
----------------------------------------------------------------------------
Function Create --| Return an empty tree.
return Tree is
begin
return new Tree_Header'(0, Null);
end Create;
----------------------------------------------------------------------------
Procedure Insert_Node(
V: Value_Type;
N: in out Node_Ptr;
Found: out boolean;
Duplicate: out Value_Type
)
is
D: integer;
begin
Found := False;
if N = null then
N := new Node'(V, Null, Null);
else
D := Difference(V, N.Value);
if D < 0 then
Insert_Node(V, N.Less, Found, Duplicate);
elsif D > 0 then
Insert_Node(V, N.More, Found, Duplicate);
else
Found := True;
Duplicate := N.Value;
end if;
end if;
end Insert_Node;
Procedure Replace_Node(
V: Value_Type;
N: in out Node_Ptr;
Found: out boolean;
Duplicate: out Value_Type
)
is
D: integer;
begin
Found := False;
if N = null then
N := new Node'(V, Null, Null);
else
D := Difference(V, N.Value);
if D < 0 then
Replace_Node(V, N.Less, Found, Duplicate);
elsif D > 0 then
Replace_Node(V, N.More, Found, Duplicate);
else
Found := True;
Duplicate := N.Value;
N.Value := V;
end if;
end if;
end Replace_Node;
Procedure Insert( --| Insert a value into a tree.
V: Value_Type; --| Value to be inserted
T: Tree --| Tree to contain the new value
) --| Raises: Duplicate_Value, Invalid_Tree.
is
Found: boolean;
Duplicate: Value_Type;
begin
if T = null then
raise Invalid_Tree;
end if;
Insert_Node(V, T.Root, Found, Duplicate);
if Found then
raise Duplicate_Value;
end if;
T.Count := T.Count + 1;
end Insert;
Procedure Insert_if_not_Found(
--| Insert a value into a tree, provided a duplicate value is not already there
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean;
Duplicate: out Value_Type
) --| Raises: Invalid_Tree.
is
was_Found: boolean;
begin
if T = null then
raise Invalid_Tree;
end if;
Insert_Node(V, T.Root, was_Found, Duplicate);
Found := was_Found;
if not was_Found then
T.Count := T.Count + 1;
end if;
end Insert_if_Not_Found;
procedure Replace_if_Found(
--| Replace a value if label exists, otherwise insert it.
V: Value_Type; --| Value to be inserted
T: Tree; --| Tree to contain the new value
Found: out boolean; --| Becomes True iff L already in tree
Old_Value: out Value_Type --| the duplicate value, if there is one
) --| Raises: Invalid_Tree.
is
was_Found: boolean;
Duplicate: Value_Type;
begin
if T = null then
raise Invalid_Tree;
end if;
Replace_Node(V, T.Root, was_Found, Duplicate);
Found := was_Found;
if was_Found then
Old_Value := Duplicate;
else
T.Count := T.Count + 1;
end if;
end Replace_if_Found;
----------------------------------------------------------------------------
procedure Destroy_Nodes(
N: in out Node_Ptr
) is
begin
if N /= null then
Destroy_Nodes(N.Less);
Destroy_Nodes(N.More);
Free_Node(N);
end if;
end Destroy_Nodes;
procedure Destroy( --| Free space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
) is
begin
if T /= Null then
Destroy_Nodes(T.Root);
Free_Tree(T);
end if;
end Destroy;
----------------------------------------------------------------------------
procedure Destroy_Deep( --| Free all space allocated to a tree.
T: in out Tree --| The tree to be reclaimed.
)
is
procedure Destroy_Nodes(
N: in out node_Ptr
) is
begin
if N /= null then
Free_Value(N.Value);
Destroy_Nodes(N.Less);
Destroy_Nodes(N.More);
Free_Node(N);
end if;
end Destroy_Nodes;
begin
if T /= Null then
Destroy_Nodes(T.Root);
Free_Tree(T);
end if;
end Destroy_Deep;
----------------------------------------------------------------------------
Function Balanced_Tree(
Count: natural
) return Tree
is
new_Tree: Tree := Create;
procedure subtree(Count: natural; N: in out Node_Ptr)
is
new_Node: Node_Ptr;
begin
if Count = 1 then
new_Node := new Node'(next_Value, Null, Null);
elsif Count > 1 then
new_node := new Node;
subtree(Count/2, new_Node.Less); -- Half are less
new_Node.Value := next_Value; -- Median value
subtree(Count - Count/2 - 1, new_Node.More); -- Other half are more
end if;
N := new_Node;
end subtree;
begin
new_Tree.Count := Count;
subtree(Count, new_Tree.Root);
return new_Tree;
end Balanced_Tree;
----------------------------------------------------------------------------
Function Copy_Tree(
T: Tree
) return Tree
is
I: Iterator;
function next_Val return Value_type
is
V: Value_Type;
begin
Next(I, V);
return copy_Value(V);
end next_Val;
function copy_Balanced is new Balanced_Tree(next_Val);
begin
I := Make_Iter(T); -- Will raise Invalid_Tree if necessary
return copy_Balanced(Size(T));
end Copy_Tree;
----------------------------------------------------------------------------
Function Is_Empty( --| Check for an empty tree.
T: Tree
) return boolean is
begin
return T = Null or else T.Root = Null;
end Is_Empty;
----------------------------------------------------------------------------
procedure Find_Node(
V: Value_Type; --| Value to be located
N: Node_Ptr; --| subtree to be searched
Match: out Value_Type; --| Matching value found in the tree
Found: out Boolean --| TRUE iff a match was found
)
is
D: integer;
begin
if N = null then
Found := False;
return;
end if;
D := Difference(V, N.Value);
if D < 0 then
Find_Node(V, N.Less, Match, Found);
elsif D > 0 then
Find_Node(V, N.More, Match, Found);
else
Match := N.Value;
Found := TRUE;
end if;
end Find_Node;
Function Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Value_Type --| Raises: Not_Found.
is
Found: Boolean;
Match: Value_Type;
begin
if T = Null then
raise Invalid_Tree;
end if;
Find_Node(V, T.Root, Match, Found);
if Found then
return Match;
else
raise Not_Found;
end if;
end Find;
Procedure Find( --| Search a tree for a value.
V: Value_Type; --| Value to be located
T: Tree; --| Tree to be searched
Found: out Boolean; --| TRUE iff a match was found
Match: out Value_Type --| Matching value found in the tree
) is
begin
if T = Null then
raise Invalid_Tree;
end if;
Find_Node(V, T.Root, Match, Found);
end Find;
----------------------------------------------------------------------------
function is_Found( --| Check a tree for a value.
V: Value_Type; --| Value to be located
T: Tree --| Tree to be searched
) return Boolean
is
Found: Boolean;
Match: Value_Type;
begin
if T = Null then
raise Invalid_Tree;
end if;
Find_Node(V, T.Root, Match, Found);
return Found;
end is_Found;
----------------------------------------------------------------------------
function Size( --| Return the count of values in T.
T: Tree --| a tree
) return natural is
begin
if T = Null then
Return 0;
else
Return T.Count;
end if;
end Size;
----------------------------------------------------------------------------
procedure Visit(
T: Tree;
Order: Scan_Kind
) is
procedure visit_Inorder(N: Node_Ptr) is
begin
if N.Less /= null then
visit_Inorder(N.Less);
end if;
Process(N.Value);
if N.More /= null then
visit_Inorder(N.More);
end if;
end visit_Inorder;
procedure visit_preorder(N: Node_Ptr) is
begin
Process(N.Value);
if N.Less /= null then
visit_preorder(N.Less);
end if;
if N.More /= null then
visit_preorder(N.More);
end if;
end visit_preorder;
procedure visit_postorder(N: Node_Ptr) is
begin
if N.Less /= null then
visit_postorder(N.Less);
end if;
if N.More /= null then
visit_postorder(N.More);
end if;
Process(N.Value);
end visit_postorder;
begin
if T = Null then
raise Invalid_Tree;
else
case Order is
when inorder =>
Visit_Inorder(T.Root);
when preorder =>
Visit_preorder(T.Root);
when postorder =>
Visit_postorder(T.Root);
end case;
end if;
end Visit;
----------------------------------------------------------------------------
function subtree_Iter( --| Create an iterator over a subtree
N: Node_Ptr;
P: Iterator
) return Iterator is
begin
if N = Null then
return new Iterator_Record'(State => Done, Parent => P, subtree => N);
elsif N.Less = Null then
return new Iterator_Record'(State => Middle, Parent => P, subtree => N);
else
return new Iterator_Record'(State => Left, Parent => P, subtree => N);
end if;
end subtree_Iter;
function Make_Iter( --| Create an iterator over a tree
T: Tree
) return Iterator is
begin
if T = Null then
raise Invalid_Tree;
end if;
return subtree_Iter(T.Root, Null);
end Make_Iter;
----------------------------------------------------------------------------
function More( --| Test for exhausted iterator
I: Iterator --| The iterator to be tested
) return boolean is
begin
if I = Null then
return False;
elsif I.Parent = Null then
return I.State /= Done and I.subtree /= Null;
elsif I.State = Done then
return More(I.Parent);
else
return True;
end if;
end More;
----------------------------------------------------------------------------
procedure pop_Iterator(
I: in out Iterator
)
is
NI: Iterator;
begin
loop
NI := I;
I := I.Parent;
Free_Iterator(NI);
exit when I = Null;
exit when I.State /= Done;
end loop;
end pop_Iterator;
procedure Next( --| Scan the next value in I
I: in out Iterator; --| an active iterator
V: out Value_Type --| Next value scanned
) --| Raises: No_More.
is
NI: Iterator;
begin
if I = Null or I.State = Done then
raise No_More;
end if;
case I.State is
when Left => -- Return the leftmost value
while I.subtree.Less /= Null loop -- Find leftmost subtree
I.State := Middle; -- Middle is next at this level
I := subtree_Iter(I.subtree.Less, I);
end loop;
V := I.subtree.Value;
if I.subtree.More /= Null then -- There will be more...
I.State := Right; -- ... coming from the right
else -- Nothing else here
pop_Iterator(I); -- Pop up to parent iterator
end if;
when Middle =>
V := I.subtree.Value;
if I.subtree.More /= Null then -- There will be more...
I.State := Right; -- ... coming from the right
else -- Nothing else here so...
pop_Iterator(I); -- ... Pop up to parent iterator
end if;
when Right => -- Return the value on the right
I.State := Done; -- No more at this level
I := subtree_Iter(I.subtree.More, I);
Next(I, V);
when Done =>
pop_Iterator(I);
Next(I, V);
end case;
end Next;
----------------------------------------------------------------------------
end binary_trees_pkg;
with Fields, Text_Io, Bounded_String,binary_trees_pkg;
package Models is
Error_Model_Store : exception;
Error_Model_Index : exception;
Error_Model_Search: exception;
type Object is limited private;
type Model_Index is limited private;
Max_Model_String : constant := 32;
--Creation
procedure Create (D : in out Object);
--Access
function Has_Model
(D : in Object; Name : in String) return Boolean;
function Get_Model_Type_By_Name(D : Object; Name : String)return String;
Procedure Get_Model_Fields_By_Name(D : Object; Name : String;F:in out Fields.Object);
procedure Dump_Models (D : in Object);
procedure Dump_Number_Of_Model(D : in Object);
--Modification
procedure Store_Model
(D : in out Object; aName : String;aType :String;F :Fields.Object);
--Liberation
procedure Dispose_Object (D : in out Object);
--Iteration
procedure Open_Model_Indexation
(D : Object; I : in out Model_Index);
procedure Next_Model_Index (I : in out Model_Index);
function Get_Indexed_Model_Name (I : Model_Index) return String;
function Get_Indexed_Model_Type (I : Model_Index) return String;
procedure Get_Indexed_Model_Fields(I : Model_Index;F:in out Fields.Object);
function No_More_Models (I : Model_Index) return Boolean;
private
type Model is
record
Model_Name : Bounded_String.Variable_String (Max_Model_String);
Model_Type : Bounded_String.Variable_String (Max_Model_String);
Model_Fields: Fields.Object;
end record;
function Compare (A, B : Model) return integer;
package Models_Tree is new binary_Trees_pkg(Model,Compare);
type Object is
record
Node : Models_Tree.Tree;
end record;
type Model_Index is
record
Node : Models_Tree.Iterator;
end record;
end Models;
with Fields, Text_Io, Bounded_String,binary_trees_pkg;
package body Models is
Use Models_Tree;
INF :constant Integer := -1;
EQU :constant Integer := 0;
SUP :constant Integer := 1;
Current_Model :Model;
LookAhead :Boolean;
function Create_Model(N: String;T: String; F : Fields.Object) return Model is
A:Model;
begin
Bounded_string.free(A.Model_Name);
Bounded_string.Copy(A.Model_Name,N);
Bounded_string.free(A.Model_Type);
Bounded_string.Copy(A.Model_Type,T);
Fields.Surface_copy(A.Model_Fields,F);
return A;
end;
function Compare (A, B : Model) return integer is
begin
declare
Use Bounded_String;
begin
if image(A.Model_name) < image(B.Model_name) then
return INF;
elsif image(A.Model_name) = image(B.Model_name) then
return EQU;
else return SUP;
end if;
end;
end Compare;
procedure Dispose_Model (The_Model : in out Model) is
begin
Fields.Dispose_Object(The_Model.Model_Fields);
Bounded_String.Free(The_Model.Model_Name);
Bounded_String.Free(The_Model.Model_Type);
end Dispose_Model;
procedure Destroy_Object is New Destroy_Deep(Free_Value =>Dispose_Model);
procedure Dump_An_Model ( A : Model ) is
begin
Text_IO.Put_Line("........................................");
Text_Io.Put_Line ( Bounded_String.image(A.Model_Name) &" "&
Bounded_String.image(A.Model_Type) &"With Fields:");
Fields.Dump_Fields(A.Model_Fields);
end Dump_An_Model ;
procedure Dump is new Visit ( Process => Dump_An_Model ) ;
--Creation
procedure Create (D : in out Object) is
begin
D.Node := Models_Tree.Create;
end ;
--Access
procedure Dump_Number_Of_Model(D : in Object) is
begin
text_io.put_line("Number of Model:"&natural'image(Models_tree.size(D.Node)));
end;
function Has_Model
(D : in Object; Name : in String) return Boolean is
A : Model;
F : Fields.Object;
begin
Fields.Create(F);
A:=Create_Model(Name,Name,F); -- Only the first param. is important
return Models_tree.Is_Found (A,D.node);
end Has_Model;
function Get_Model_Type_By_Name(D : Object; Name : String)return String is
Found : Boolean := False;
A : Model;
B :Fields.Object;
begin
Fields.Create(B);
A:=Create_Model(Name,Name,B); -- Only the first param. is important
Models_tree.Find(A,D.node,Found,A);
if found then
return Bounded_String.Image(A.Model_Type);
else return "";
end if;
exception
when others =>
raise Error_Model_Search;
end;
Procedure Get_Model_Fields_By_Name(D : Object; Name : String;F:in out Fields.Object) is
Found : Boolean := False;
A : Model;
B :Fields.Object;
begin
Fields.Create(B);
A:=Create_Model(Name,Name,B); -- Only the first param. is important
Models_tree.Find(A,D.node,Found,A);
if found then
Fields.Deep_copy(F,A.Model_Fields);
end if;
exception
when others =>
raise Error_Model_Search;
end;
procedure Dump_Models (D : in Object) is
begin
Dump ( D.Node,Models_tree.inorder);
end Dump_Models;
--Modification
procedure Store_Model
(D : in out Object; aName : String;aType :String;F :Fields.Object)is
Found : Boolean := False;
A : Model;
B :Fields.Object;
begin
Fields.Create(B);
Fields.Deep_copy(B,F);
Models_tree.Replace_If_Found (Create_Model(aName,aType,B),D.Node,Found,A);
if Found then Dispose_Model(A); end if;
exception
when others =>
raise Error_Model_Store;
end Store_Model;
--Liberation
procedure Dispose_Object (D : in out Object) is
begin
Destroy_Object(D.Node);
end Dispose_Object;
--Iteration
procedure Open_Model_Indexation
(D : Object; I : in out Model_Index) is
begin
I.Node := Models_tree.Make_Iter(D.Node);
LookAhead:=FALSE;
Next_Model_Index(I);
end Open_Model_Indexation;
procedure Next_Model_Index (I : in out Model_Index) is
begin
if not Lookahead then
if Models_tree.More (I.Node) then
Models_tree.Next(I.Node,Current_Model);
else
raise Error_Model_Index;
end if;
end if;
end Next_Model_Index;
function Get_Indexed_Model_Name (I : Model_Index) return String is
begin
return Bounded_String.Image (Current_Model.Model_Name);
exception
when others=> raise Error_Model_Index;
end Get_Indexed_Model_Name;
function Get_Indexed_Model_Type (I : Model_Index) return String is
begin
return Bounded_String.Image (Current_Model.Model_Type);
exception
when others=> raise Error_Model_Index;
end Get_Indexed_Model_Type;
procedure Get_Indexed_Model_Fields(I : Model_Index;F:in out Fields.Object) is
begin
Fields.Deep_Copy (F, Current_Model.Model_Fields);
exception
when others=> raise Error_Model_Index;
raise Error_Model_Index;
end Get_Indexed_Model_Fields;
function No_More_Models (I : Model_Index) return Boolean is
More:Boolean:=TRUE;
begin
More:= Models_tree.More (I.Node);
if More then return (False); end if;
if (not More AND not LookAhead) then
Lookahead:=TRUE;
return(FALSE);
elsif (not More AND LookAhead) then
return(TRUE);
end if;
end No_More_Models;
end Models;
with fields,models,Text_io;
procedure main is
L1:Fields.Object;
L2:Fields.Object;
L3:Fields.Object;
M:Models.Object;
procedure Print_With_Index(D :Models.Object) is
Index : Models.Model_Index;
Liste:Fields.Object;
begin
Models.Open_Model_Indexation (D , Index);
while not Models.No_More_Models(Index) loop
Text_IO.Put_Line("****************************************");
Text_Io.Put_Line (Models.Get_Indexed_Model_Name (Index) &
" : " & Models.Get_Indexed_Model_Type(Index)&"-> WITH:");
Fields.Create(Liste);
Models.Get_Indexed_Model_Fields(Index,Liste);
Fields.Dump_Fields(Liste);
Fields.Dispose_Object(Liste);
Models.Next_Model_Index (Index);
end loop;
end Print_With_Index;
begin
Fields.Create(L1);
Fields.Create(L2);
Fields.Create(L3);
Models.Create(M);
Fields.Store_field(L1,"Description","Chaine ");
Fields.Store_field(L1,"NiveauEau ","Niveau ");
Fields.Store_field(L1,"NiveauEnerg","Energie ");
Text_IO.Put_Line("----------------------------------------");
Text_IO.Put_Line("--- Print Liste L1 ----------");
Fields.Dump_Fields(L1);
Fields.Dump_Number_Of_Field(L1);
Fields.Store_field(L2,"Lumiere ","Eclairage ");
Fields.Store_field(L2,"Intensite ","Entier ");
Fields.Store_field(L2,"Tension ","Entier ");
Fields.Store_field(L2,"Puissance ","Entier ");
Text_IO.Put_Line("----------------------------------------");
Text_IO.Put_Line("--- Print Liste L2 ----------");
Fields.Dump_Fields(L2);
Fields.Dump_Number_Of_Field(L2);
Fields.Store_field(L3,"Cuisine ","Piece ");
Fields.Store_field(L3,"Salon ","Piece ");
Text_IO.Put_Line("----------------------------------------");
Text_IO.Put_Line("--- Print Liste L3 ----------");
Fields.Dump_Fields(L3);
Fields.Dump_Number_Of_Field(L3);
Models.Store_Model(M,"Niveau ","Struct ",L1);
Models.Store_Model(M,"Electriqu","Struct ",L2);
Models.Store_Model(M,"Maison ","Struct ",L3);
Text_IO.Put_Line("----------------------------------------");
Text_IO.Put_Line("--- Print Modele M ----------");
Models.Dump_Models(M);
Models.Dump_Number_Of_Model(M);
Text_IO.Put_Line("========================================");
Text_IO.Put_Line("--- Recherche du type Electriq ---------");
if Models.Has_Model(M,"Electriqu") Then
declare
List:Fields.Object;
begin
Text_Io.Put_Line ("Electriqu :"&Models.Get_Model_Type_By_Name (M,"Electriqu") &"WITH:");
Fields.Create(List);
Models.Get_Model_Fields_by_Name(M,"Electriqu",List);
Fields.Dump_Fields(List);
Fields.Dispose_Object(List);
end;
end if;
Text_IO.Put_Line("========================================");
Text_IO.Put_Line("--- Print Modele M with Index -------");
Print_With_Index(M);
Fields.Dispose_Object(L1);
Fields.Dispose_Object(L2);
Fields.Dispose_Object(L3);
Models.Dispose_Object(M);
end