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