⟦f4fb62d46⟧

TextFile

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 Binary_Trees_Pkg,Bounded_String;
Use  Bounded_String;

Package Set_of_Links is

   Duplicate_Value:Exception;

   type Object is private;

   type Lock   is (No_State,Locked,Unlocked);

   Procedure Create       (set: in out Object);
   Procedure Destroy      (set: in out Object);

   Procedure Add_New      (first_item,second_item: String;
                           link_state:Lock;
                           set: in out Object);

   Procedure Modify_State (first_item,second_item: String;
                           link_state:Lock;
                           set: in out Object);

   Procedure Exchange     (first_item,second_item,third_item: String;
                           set: in out Object);

   Function  Exist        (first_item,second_item: String; set: Object) return Boolean;

   Procedure List         (item: String; link_state:Lock; set: Object);

   Function  What_State   (first_item,second_item: String; set: Object) return Lock;

   Procedure Dump         (set: Object);

   Private

      type Link is record
                      First     :Variable_String(32);
                      Second    :Variable_String(32);
                      State     :Lock;
                   end record;

      Function  Compare (a,b:Link) return Integer;

      Package Links_Tree is new Binary_Trees_Pkg (Link,Compare);

      type Object is record
                        Root:Links_Tree.Tree;
                     end record;

end Set_of_Links;
With Binary_Trees_Pkg,Bounded_String,Text_Io;
Use  Bounded_String;

Package body Set_of_Links is

   Lower: Constant Integer := -1;
   Equal: Constant Integer :=  0;
   Upper: Constant Integer :=  1;

-- ----------------------------------------------------
-- Definition des fonctions pour le paquetage generique
-- ----------------------------------------------------

Function Compare (a,b:Link) return Integer is
begin
   if (Image(a.First)  = Image(b.First) or Image(a.First)  = Image(b.Second)) and
      (Image(a.Second) = Image(b.First) or Image(a.Second) = Image(b.Second)) then
         return Equal;
   else
      if Image(a.First) < Image(b.First) then
         return Lower;
      else
         return Upper;
      end if;
   end if;
end Compare;


Procedure Write (a:Link) is
begin
   Text_Io.Put_Line ("First ->"&Image(a.First) &
                     " / Second ->"&Image(a.Second) &
                     " / State ->"&Lock'Image(a.State));
end Write;


Procedure Show is new Links_Tree.Visit (Write);


-- ---------------------------------------
-- Definition des fontions de Set_of_Links
-- ---------------------------------------

Function  Make_Link (first_item,second_item: String; link_state:Lock) return Link is
   tmp_link:Link;
begin
   Bounded_String.Free(tmp_link.First);
   Bounded_String.Free(tmp_link.Second);
   Bounded_String.Copy(tmp_link.First,first_item);
   Bounded_String.Copy(tmp_link.Second,second_item);
   tmp_link.State:=link_state;
   return tmp_link;
end Make_Link;


Procedure Create (set: in out Object) is
begin
   set.Root:=Links_Tree.Create;
end Create;


Procedure Destroy (set: in out Object) is
begin
   Links_Tree.Destroy (set.Root);
end Destroy;


Procedure Add_New (first_item,second_item: String; link_state:Lock; set: in out Object) is
   tmp_link:Link;
begin
   tmp_link:=Make_Link(first_item,second_item,link_state);
   Links_Tree.Insert(tmp_link,set.Root);

   Exception
      when Links_Tree.Duplicate_Value => raise Duplicate_Value;
end Add_New;


Procedure Modify_State (first_item,second_item: String; link_state:Lock; set: in out Object) is
   tmp_link,result_link:Link;
   result:Boolean;
begin
   tmp_link:=Make_Link(first_item,second_item,link_state);
   if Links_Tree.Is_Found(tmp_link,set.Root) then
      Links_Tree.Replace_if_Found(tmp_link,set.Root,result,result_link);
   end if;
end Modify_State;


Procedure Exchange (first_item,second_item,third_item: String; set: in out Object) is
   new_link,old_link,result_link:Link;
   result:Boolean;
   set_iter:Links_Tree.Iterator;
begin
   old_link:=Make_Link(first_item,second_item,No_State);
   new_link:=Make_Link(first_item,third_item,No_State);
   if Links_Tree.Is_Found(old_link,set.Root) and Links_Tree.Is_Found(new_link,set.Root) then
      set_iter:=Links_Tree.Make_Iter(set.Root);
      while Links_Tree.More(set_iter) loop
         Links_Tree.Next(set_iter,result_link);
         exit when Compare(result_link,old_link)=Equal;
      end loop;
      if result_link.State=UnLocked then
         old_link:=Make_Link(first_item,second_item,Locked);
         new_link:=Make_Link(first_item,third_item,UnLocked);
      else
         old_link:=Make_Link(first_item,second_item,UnLocked);
         new_link:=Make_Link(first_item,third_item,Locked);
      end if;
      Links_Tree.Replace_if_Found(old_link,set.Root,result,result_link);
      Links_Tree.Replace_if_Found(new_link,set.Root,result,result_link);
   end if;
end Exchange;


Function  Exist (first_item,second_item: String; set: Object) return Boolean is
   tmp_link:Link;
begin
   tmp_link:=Make_Link(first_item,second_item,No_State);
   return Links_Tree.Is_Found(tmp_link,set.Root);
end Exist;


Procedure List (item: String; link_state:Lock; set: Object) is
   tmp_link:Link;
   set_iter:Links_Tree.Iterator;
begin
   set_iter:=Links_Tree.Make_Iter(set.Root);
   while Links_Tree.More(set_iter) loop
      Links_Tree.Next(set_iter,tmp_link);
      if (Image(tmp_link.First)=item or Image(tmp_link.Second)=item) and tmp_link.State=link_state then
         if Image(tmp_link.First)=item then
            Text_Io.Put_Line(Image(tmp_link.Second));
         else
            Text_Io.Put_Line(Image(tmp_link.First));
         end if;
      end if;
   end loop;
end List;


Function  What_State (first_item,second_item: String; set: Object) return Lock is
   search_link,found_link:Link;
   set_iter:Links_Tree.Iterator;
begin
   search_link:=Make_Link(first_item,second_item,No_State);
   while Links_Tree.More(set_iter) loop
      Links_Tree.Next(set_iter,found_link);
      if Compare(found_link,search_link)=Equal then
         return found_link.State;
      end if;
   end loop;
   return No_State;
end What_State;


Procedure Dump (set:Object) is
begin
   Show(set.Root,Links_Tree.InOrder);
end Dump;


end Set_of_Links;
With Set_of_Links;

Procedure T_Link is
   all_links:Set_of_Links.Object;
begin
   Set_of_Links.Create(all_links);

   Set_of_Links.Add_New("Porte1","Chambre_noire",Set_of_Links.Locked,all_links);
   Set_of_Links.Add_New("Sac","Montre",Set_of_Links.UnLocked,all_links);
   Set_of_Links.Add_New("Sac","Couteau_tout_rouille",Set_of_Links.Locked,all_links);

   Set_of_Links.Dump(all_links);

   Set_of_Links.Destroy(all_links);
end T_Link;
DataMuseum.dk

Rational R1000/400

⟦f4fb62d46⟧ TextFile

Derivation

TextFile
