1-- PragmAda Reusable Component (PragmARC)
2-- Copyright (C) 2016 by PragmAda Software Engineering.  All rights reserved.
3-- **************************************************************************
4--
5-- History:
6-- 2016 Jun 01     J. Carter          V1.2--Changed comment for empty declarative part
7-- 2013 Oct 01     J. Carter          V1.1--Added exception handler to Finalize
8-- 2013 Mar 01     J. Carter          V1.0--Initial Ada-07 version
9---------------------------------------------------------------------------------
10-- 2002 Oct 01     J. Carter          V1.4--Added Context to Iterate; use mode out to allow scalars
11-- 2002 May 01     J. Carter          V1.3--Added Assign
12-- 2001 May 01     J. Carter          V1.2--Added Is_Empty; improved memory usage
13-- 2000 Jul 01     J. Carter          V1.1--Changed to use Ada.Numerics.Float_Random
14-- 2000 May 01     J. Carter          V1.0--Initial release
15--
16with Ada.Numerics.Float_Random;
17with Ada.Unchecked_Deallocation;
18
19use Ada;
20use Ada.Numerics;
21package body PragmARC.Skip_List_Unbounded is
22   Gen : Float_Random.Generator;
23
24   procedure Dispose is new Unchecked_Deallocation (Object => Node, Name => Link);
25
26   procedure Clear (List : in out Skip_List) is
27      Ptr : Link;
28   begin -- Clear
29      Remove_All : loop
30         exit Remove_All when List.Header.Forward (Level_Id'First) = null;
31
32         Ptr := List.Header.Forward (Level_Id'First);
33         List.Header.Forward (Level_Id'First) := Ptr.Forward (Level_Id'First);
34         Dispose (X => Ptr);
35      end loop Remove_All;
36
37      List.Header.Forward := Forward_Set'(Level_Id => null);
38      List.Last := null;
39      List.Level := Level_Id'First;
40   end Clear;
41
42   procedure Assign (To : out Skip_List; From : in Skip_List) is
43      Ptr : Link := From.Header.Forward (Level_Id'First);
44   begin -- Assign
45      if To.Header = From.Header then
46         return; -- These are the same lists
47      end if;
48
49      Clear (List => To);
50
51      if From.Last = null then -- From is empty
52         return;
53      end if;
54
55      Copy : loop
56         exit Copy when Ptr = null;
57
58         Insert (List => To, Item => Ptr.Value);
59         Ptr := Ptr.Forward (Level_Id'First);
60      end loop Copy;
61   end Assign;
62
63   function Search (List : Skip_List; Item : Element) return Result is
64      Ptr : Link := List.Header;
65   begin -- Search
66      All_Levels : for I in reverse Level_Id'First .. List.Level loop
67         Advance : loop
68            exit Advance when Ptr.Forward (I) = null or else not (Ptr.Forward (I).Value < Item);
69
70            Ptr := Ptr.Forward (I);
71         end loop Advance;
72      end loop All_Levels;
73
74      Ptr := Ptr.Forward (Level_Id'First);
75
76      if Ptr = null or else Ptr.Value /= Item then
77         return Result'(Found => False);
78      end if;
79
80      return Result'(Found => True, Item => Ptr.Value);
81   end Search;
82
83   procedure Insert (List : in out Skip_List; Item : in Element) is
84      New_Level : Level_Id;
85      Update    : Forward_Set (Level_Id) := Forward_Set'(Level_Id => List.Header);
86      Ptr       : Link                   := List.Header;
87
88      function Random_Level (List_Level : Level_Id) return Level_Id is
89         Probability : constant := 0.25;
90
91         New_Level : Level_Id := Level_Id'First;
92      begin -- Random_Level
93         Increment : loop
94            exit Increment when Float_Random.Random (Gen) >= Probability or New_Level >= Max_Level or New_Level >= List_Level + 1;
95
96            New_Level := New_Level + 1;
97         end loop Increment;
98
99         return New_Level;
100      end Random_Level;
101   begin -- Insert
102      All_Levels : for I in reverse Level_Id'First .. List.Level loop
103         Advance : loop
104            exit Advance when Ptr.Forward (I) = null or else not (Ptr.Forward (I).Value < Item);
105
106            Ptr := Ptr.Forward (I);
107         end loop Advance;
108
109         Update (I) := Ptr;
110      end loop All_Levels;
111
112      Ptr := Ptr.Forward (Level_Id'First);
113
114      if Ptr /= null and then Ptr.Value = Item then
115         Ptr.Value := Item;
116      else
117         New_Level := Random_Level (List.Level);
118         Ptr := new Node (Has_Data => True, Level => New_Level);
119
120         Ptr.Value := Item;
121
122         if New_Level > List.Level then
123            List.Level := New_Level;
124         end if;
125
126         Adjust_Links : for I in Level_Id'First .. New_Level loop
127            Ptr.Forward (I) := Update (I).Forward (I);
128            Update (I).Forward (I) := Ptr;
129         end loop Adjust_Links;
130
131         if Ptr.Forward (Level_Id'First) = null then -- New last Node
132            List.Last := Ptr;
133         end if;
134      end if;
135   exception -- Insert
136   when Storage_Error =>
137      raise Storage_Exhausted;
138   end Insert;
139
140   procedure Delete (List : in out Skip_List; Item : in Element) is
141      Update : Forward_Set (Level_Id) := Forward_Set'(Level_Id => List.Header);
142      Ptr    : Link                   := List.Header;
143   begin -- Delete
144      All_Levels : for I in reverse Level_Id'First .. List.Level loop
145         Advance : loop
146            exit Advance when Ptr.Forward (I) = null or else not (Ptr.Forward (I).Value < Item);
147
148            Ptr := Ptr.Forward (I);
149         end loop Advance;
150
151         Update (I) := Ptr;
152      end loop All_Levels;
153
154      Ptr := Ptr.Forward (Level_Id'First);
155
156      if Ptr /= null and then Ptr.Value = Item then
157         Adjust_Links : for I in Level_Id'First .. List.Level loop
158            exit Adjust_Links when Update (I).Forward (I) /= Ptr;
159
160            Update (I).Forward (I) := Ptr.Forward (I);
161         end loop Adjust_Links;
162
163         Adjust_Level : loop
164            exit Adjust_Level when List.Level <= Level_Id'First or else List.Header.Forward (List.Level) /= null;
165
166            List.Level := List.Level - 1;
167         end loop Adjust_Level;
168
169         if List.Last = Ptr then -- Deleted Node at end of List
170            List.Last := Update (Level_Id'First);
171
172            if List.Last = List.Header then -- This deletion emptied the List
173               List.Last := null;
174            end if;
175         end if;
176
177         Dispose (X => Ptr);
178      end if;
179   end Delete;
180
181   function Get_First (List : Skip_List) return Element is
182      Ptr : Link := List.Header.Forward (Level_Id'First);
183   begin -- Get_First
184      if Ptr = null then
185         raise Empty;
186      end if;
187
188      return Ptr.Value;
189   end Get_First;
190
191   function Get_Last (List : Skip_List) return Element is
192      -- Empty
193   begin -- Get_Last
194      if List.Last = null then
195         raise Empty;
196      end if;
197
198      return List.Last.Value;
199   end Get_Last;
200
201   function Is_Empty (List : Skip_List) return Boolean is
202      -- Empty
203   begin -- Is_Empty
204      return List.Last = null;
205   end Is_Empty;
206
207   function Length (List : Skip_List) return Natural is
208      Count : Natural := 0;
209      Ptr   : Link    := List.Header.Forward (Level_Id'First);
210   begin -- Length
211      All_Nodes : loop
212         exit All_Nodes when Ptr = null;
213
214         Count := Count + 1;
215         Ptr := Ptr.Forward (Level_Id'First);
216      end loop All_Nodes;
217
218      return Count;
219   end Length;
220
221   procedure Finalize (Object : in out Skip_List) is
222      -- Empty
223   begin -- Finalize
224      if Object.Header /= null then
225         Clear (List => Object);
226      end if;
227
228      Dispose (X => Object.Header);
229      Object.Last := null;
230   exception -- Finalize
231   when others =>
232      null;
233   end Finalize;
234
235   procedure Iterate (List : in out Skip_List) is
236      Ptr      : Link := List.Header.Forward (Level_Id'First);
237      Continue : Boolean;
238   begin -- iterate
239      All_Nodes : loop
240         exit All_Nodes when Ptr = null;
241
242         Action (Item => Ptr.Value, Continue => Continue);
243
244         exit All_Nodes when not Continue;
245
246         Ptr := Ptr.Forward (Level_Id'First);
247      end loop All_Nodes;
248   end Iterate;
249begin -- PragmARC.Skip_List_Unbounded
250   Float_Random.Reset (Gen);
251end PragmARC.Skip_List_Unbounded;
252--
253-- This is free software; you can redistribute it and/or modify it under
254-- terms of the GNU General Public License as published by the Free Software
255-- Foundation; either version 2, or (at your option) any later version.
256-- This software is distributed in the hope that it will be useful, but WITH
257-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
258-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
259-- for more details. Free Software Foundation, 59 Temple Place - Suite
260-- 330, Boston, MA 02111-1307, USA.
261--
262-- As a special exception, if other files instantiate generics from this
263-- unit, or you link this unit with other files to produce an executable,
264-- this unit does not by itself cause the resulting executable to be
265-- covered by the GNU General Public License. This exception does not
266-- however invalidate any other reasons why the executable file might be
267-- covered by the GNU Public License.
268