===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,225 +27,8 @@
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with Ada.Unchecked_Deallocation;
-
package body Ada.Containers.Unbounded_Priority_Queues is
- package body Implementation is
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function Before_Or_Equal (X, Y : Queue_Priority) return Boolean;
- -- True if X is before or equal to Y. Equal means both Before(X,Y) and
- -- Before(Y,X) are False.
-
- procedure Free is
- new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
-
- ---------------------
- -- Before_Or_Equal --
- ---------------------
-
- function Before_Or_Equal (X, Y : Queue_Priority) return Boolean is
- begin
- return (if Before (X, Y) then True else not Before (Y, X));
- end Before_Or_Equal;
-
- -------------
- -- Dequeue --
- -------------
-
- procedure Dequeue
- (List : in out List_Type;
- Element : out Queue_Interfaces.Element_Type)
- is
- H : constant Node_Access := List.Header'Unchecked_Access;
- pragma Assert (List.Length /= 0);
- pragma Assert (List.Header.Next /= H);
- -- List can't be empty; see the barrier
-
- pragma Assert
- (List.Header.Next.Next = H or else
- Before_Or_Equal (Get_Priority (List.Header.Next.Element),
- Get_Priority (List.Header.Next.Next.Element)));
- -- The first item is before-or-equal to the second
-
- pragma Assert
- (List.Header.Next.Next_Unequal = H or else
- Before (Get_Priority (List.Header.Next.Element),
- Get_Priority (List.Header.Next.Next_Unequal.Element)));
- -- The first item is before its Next_Unequal item
-
- -- The highest-priority item is always first; just remove it and
- -- return that element.
-
- X : Node_Access := List.Header.Next;
-
- -- Start of processing for Dequeue
-
- begin
- Element := X.Element;
- X.Next.Prev := H;
- List.Header.Next := X.Next;
- List.Header.Next_Unequal := X.Next;
- List.Length := List.Length - 1;
- Free (X);
- end Dequeue;
-
- procedure Dequeue
- (List : in out List_Type;
- At_Least : Queue_Priority;
- Element : in out Queue_Interfaces.Element_Type;
- Success : out Boolean)
- is
- begin
- -- This operation dequeues a high priority item if it exists in the
- -- queue. By "high priority" we mean an item whose priority is equal
- -- or greater than the value At_Least. The generic formal operation
- -- Before has the meaning "has higher priority than". To dequeue an
- -- item (meaning that we return True as our Success value), we need
- -- as our predicate the equivalent of "has equal or higher priority
- -- than", but we cannot say that directly, so we require some logical
- -- gymnastics to make it so.
-
- -- If E is the element at the head of the queue, and symbol ">"
- -- refers to the "is higher priority than" function Before, then we
- -- derive our predicate as follows:
- -- original: P(E) >= At_Least
- -- same as: not (P(E) < At_Least)
- -- same as: not (At_Least > P(E))
- -- same as: not Before (At_Least, P(E))
-
- -- But that predicate needs to be true in order to successfully
- -- dequeue an item. If it's false, it means no item is dequeued, and
- -- we return False as the Success value.
-
- Success := List.Length > 0
- and then
- not Before (At_Least, Get_Priority (List.Header.Next.Element));
-
- if Success then
- List.Dequeue (Element);
- end if;
- end Dequeue;
-
- -------------
- -- Enqueue --
- -------------
-
- procedure Enqueue
- (List : in out List_Type;
- New_Item : Queue_Interfaces.Element_Type)
- is
- P : constant Queue_Priority := Get_Priority (New_Item);
- H : constant Node_Access := List.Header'Unchecked_Access;
-
- function Next return Node_Access;
- -- The node before which we wish to insert the new node
-
- ----------
- -- Next --
- ----------
-
- function Next return Node_Access is
- begin
- return Result : Node_Access := H.Next_Unequal do
- while Result /= H
- and then not Before (P, Get_Priority (Result.Element))
- loop
- Result := Result.Next_Unequal;
- end loop;
- end return;
- end Next;
-
- -- Local varaibles
-
- Prev : constant Node_Access := Next.Prev;
- -- The node after which we wish to insert the new node. So Prev must
- -- be the header, or be higher or equal priority to the new item.
- -- Prev.Next must be the header, or be lower priority than the
- -- new item.
-
- pragma Assert
- (Prev = H or else Before_Or_Equal (Get_Priority (Prev.Element), P));
- pragma Assert
- (Prev.Next = H
- or else Before (P, Get_Priority (Prev.Next.Element)));
- pragma Assert (Prev.Next = Prev.Next_Unequal);
-
- Node : constant Node_Access :=
- new Node_Type'(New_Item,
- Prev => Prev,
- Next => Prev.Next,
- Next_Unequal => Prev.Next);
-
- -- Start of processing for Enqueue
-
- begin
- Prev.Next.Prev := Node;
- Prev.Next := Node;
-
- if Prev = H then
-
- -- Make sure Next_Unequal of the Header always points to the first
- -- "real" node. Here, we've inserted a new first "real" node, so
- -- must update.
-
- List.Header.Next_Unequal := Node;
-
- elsif Before (Get_Priority (Prev.Element), P) then
-
- -- If the new item inserted has a unique priority in queue (not
- -- same priority as precedent), set Next_Unequal of precedent
- -- element to the new element instead of old next element, since
- -- Before (P, Get_Priority (Next.Element) or Next = H).
-
- Prev.Next_Unequal := Node;
- end if;
-
- pragma Assert (List.Header.Next_Unequal = List.Header.Next);
-
- List.Length := List.Length + 1;
-
- if List.Length > List.Max_Length then
- List.Max_Length := List.Length;
- end if;
- end Enqueue;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (List : in out List_Type) is
- Ignore : Queue_Interfaces.Element_Type;
- begin
- while List.Length > 0 loop
- List.Dequeue (Ignore);
- end loop;
- end Finalize;
-
- ------------
- -- Length --
- ------------
-
- function Length (List : List_Type) return Count_Type is
- begin
- return List.Length;
- end Length;
-
- ----------------
- -- Max_Length --
- ----------------
-
- function Max_Length (List : List_Type) return Count_Type is
- begin
- return List.Max_Length;
- end Max_Length;
-
- end Implementation;
-
protected body Queue is
-----------------
@@ -254,7 +37,7 @@
function Current_Use return Count_Type is
begin
- return List.Length;
+ return Q_Elems.Length;
end Current_Use;
-------------
@@ -262,10 +45,14 @@
-------------
entry Dequeue (Element : out Queue_Interfaces.Element_Type)
- when List.Length > 0
+ when Q_Elems.Length > 0
is
+ -- Grab the first item of the set, and remove it from the set
+
+ C : constant Cursor := First (Q_Elems);
begin
- List.Dequeue (Element);
+ Element := Sets.Element (C).Item;
+ Delete_First (Q_Elems);
end Dequeue;
--------------------------------
@@ -277,8 +64,19 @@
Element : in out Queue_Interfaces.Element_Type;
Success : out Boolean)
is
+ -- Grab the first item. If it exists and has appropriate priority,
+ -- set Success to True, and remove that item. Otherwise, set Success
+ -- to False.
+
+ C : constant Cursor := First (Q_Elems);
begin
- List.Dequeue (At_Least, Element, Success);
+ Success := Has_Element (C) and then
+ not Before (At_Least, Get_Priority (Sets.Element (C).Item));
+
+ if Success then
+ Element := Sets.Element (C).Item;
+ Delete_First (Q_Elems);
+ end if;
end Dequeue_Only_High_Priority;
-------------
@@ -287,7 +85,15 @@
entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is
begin
- List.Enqueue (New_Item);
+ Insert (Q_Elems, (Next_Sequence_Number, New_Item));
+ Next_Sequence_Number := Next_Sequence_Number + 1;
+
+ -- If we reached a new high-water mark, increase Max_Length
+
+ if Q_Elems.Length > Max_Length then
+ pragma Assert (Max_Length + 1 = Q_Elems.Length);
+ Max_Length := Q_Elems.Length;
+ end if;
end Enqueue;
--------------
@@ -296,7 +102,7 @@
function Peak_Use return Count_Type is
begin
- return List.Max_Length;
+ return Max_Length;
end Peak_Use;
end Queue;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -32,8 +32,8 @@
------------------------------------------------------------------------------
with System;
+with Ada.Containers.Ordered_Sets;
with Ada.Containers.Synchronized_Queue_Interfaces;
-with Ada.Finalization;
generic
with package Queue_Interfaces is
@@ -59,63 +59,44 @@
pragma Implementation_Defined;
- type List_Type is tagged limited private;
-
- procedure Enqueue
- (List : in out List_Type;
- New_Item : Queue_Interfaces.Element_Type);
-
- procedure Dequeue
- (List : in out List_Type;
- Element : out Queue_Interfaces.Element_Type);
-
- procedure Dequeue
- (List : in out List_Type;
- At_Least : Queue_Priority;
- Element : in out Queue_Interfaces.Element_Type;
- Success : out Boolean);
-
- function Length (List : List_Type) return Count_Type;
-
- function Max_Length (List : List_Type) return Count_Type;
-
- private
-
- -- List_Type is implemented as a circular doubly-linked list with a
- -- dummy header node; Prev and Next are the links. The list is in
- -- decreasing priority order, so the highest-priority item is always
- -- first. (If there are multiple items with the highest priority, the
- -- oldest one is first.) Header.Element is undefined and not used.
+ -- We use an ordered set to hold the queue elements. This gives O(lg N)
+ -- performance in the worst case for Enqueue and Dequeue.
+ -- Sequence_Number is used to distinguish equivalent items. Each Enqueue
+ -- uses a higher Sequence_Number, so that a new item is placed after
+ -- already-enqueued equivalent items.
--
- -- In addition, Next_Unequal points to the next item with a different
- -- (i.e. strictly lower) priority. This is used to speed up the search
- -- for the next lower-priority item, in cases where there are many items
- -- with the same priority.
- --
- -- An empty list has Header.Prev, Header.Next, and Header.Next_Unequal
- -- all pointing to Header. A nonempty list has Header.Next_Unequal
- -- pointing to the first "real" item, and the last item has Next_Unequal
- -- pointing back to Header.
+ -- At any time, the first set element is the one to be dequeued next (if
+ -- the queue is not empty).
- type Node_Type;
- type Node_Access is access all Node_Type;
-
- type Node_Type is limited record
- Element : Queue_Interfaces.Element_Type;
- Prev, Next : Node_Access := Node_Type'Unchecked_Access;
- Next_Unequal : Node_Access := Node_Type'Unchecked_Access;
+ type Set_Elem is record
+ Sequence_Number : Count_Type;
+ Item : Queue_Interfaces.Element_Type;
end record;
- type List_Type is new Ada.Finalization.Limited_Controlled with record
- Header : aliased Node_Type;
- Length : Count_Type := 0;
- Max_Length : Count_Type := 0;
- end record;
+ function "=" (X, Y : Queue_Interfaces.Element_Type) return Boolean is
+ (not Before (Get_Priority (X), Get_Priority (Y))
+ and then not Before (Get_Priority (Y), Get_Priority (X)));
+ -- Elements are equal if neither is Before the other
- overriding procedure Finalize (List : in out List_Type);
+ function "=" (X, Y : Set_Elem) return Boolean is
+ (X.Sequence_Number = Y.Sequence_Number and then X.Item = Y.Item);
+ -- Set_Elems are equal if the elements are equal, and the
+ -- Sequence_Numbers are equal. This is passed to Ordered_Sets.
+ function "<" (X, Y : Set_Elem) return Boolean is
+ (if X.Item = Y.Item
+ then X.Sequence_Number < Y.Sequence_Number
+ else Before (Get_Priority (X.Item), Get_Priority (Y.Item)));
+ -- If the items are equal, Sequence_Number breaks the tie. Otherwise,
+ -- use Before. This is passed to Ordered_Sets.
+
+ pragma Suppress (Container_Checks);
+ package Sets is new Ada.Containers.Ordered_Sets (Set_Elem);
+
end Implementation;
+ use Implementation, Implementation.Sets;
+
protected type Queue (Ceiling : System.Any_Priority := Default_Ceiling)
with
Priority => Ceiling
@@ -142,7 +123,15 @@
overriding function Peak_Use return Count_Type;
private
- List : Implementation.List_Type;
+ Q_Elems : Set;
+ -- Elements of the queue
+
+ Max_Length : Count_Type := 0;
+ -- The current length of the queue is the Length of Q_Elems. This is the
+ -- maximum value of that, so far. Updated by Enqueue.
+
+ Next_Sequence_Number : Count_Type := 0;
+ -- Steadily increasing counter
end Queue;
end Ada.Containers.Unbounded_Priority_Queues;