← Back to branch summary

~ubuntu-branches/ubuntu/jaunty/adacontrol/jaunty

« back to all changes in this revision

Viewing changes to src/binary_map.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2006-08-24 08:44:11 UTC
  • Revision ID: james.westby@ubuntu.com-20060824084411-1r15uio1h75lqgpx
Tags: upstream-1.4r20
Import upstream version 1.4r20

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/binary_map.adb
 
1
----------------------------------------------------------------------
 
2
--  Binary_Map - Package body                                       --
 
3
--  Copyright (C) 2005 Adalog                                       --
 
4
--  Author: J-P. Rosen                                              --
 
5
--                                                                  --
 
6
--  ADALOG   is   providing   training,   consultancy,   expertise, --
 
7
--  assistance and custom developments  in Ada and related software --
 
8
--  engineering techniques.  For more info about our services:      --
 
9
--  ADALOG                   Tel: +33 1 41 24 31 40                 --
 
10
--  19-21 rue du 8 mai 1945  Fax: +33 1 41 24 07 36                 --
 
11
--  94110 ARCUEIL            E-m: info@adalog.fr                    --
 
12
--  FRANCE                   URL: http://www.adalog.fr              --
 
13
--                                                                  --
 
14
--  This  unit is  free software;  you can  redistribute  it and/or --
 
15
--  modify  it under  terms of  the GNU  General Public  License as --
 
16
--  published by the Free Software Foundation; either version 2, or --
 
17
--  (at your  option) any later version.  This  unit is distributed --
 
18
--  in the hope  that it will be useful,  but WITHOUT ANY WARRANTY; --
 
19
--  without even the implied warranty of MERCHANTABILITY or FITNESS --
 
20
--  FOR A  PARTICULAR PURPOSE.  See the GNU  General Public License --
 
21
--  for more details.   You should have received a  copy of the GNU --
 
22
--  General Public License distributed  with this program; see file --
 
23
--  COPYING.   If not, write  to the  Free Software  Foundation, 59 --
 
24
--  Temple Place - Suite 330, Boston, MA 02111-1307, USA.           --
 
25
--                                                                  --
 
26
--  As  a special  exception, if  other files  instantiate generics --
 
27
--  from  this unit,  or you  link this  unit with  other  files to --
 
28
--  produce an executable,  this unit does not by  itself cause the --
 
29
--  resulting executable  to be covered  by the GNU  General Public --
 
30
--  License.  This exception does  not however invalidate any other --
 
31
--  reasons why  the executable  file might be  covered by  the GNU --
 
32
--  Public License.                                                 --
 
33
----------------------------------------------------------------------
 
34
 
 
35
with Ada.Unchecked_Deallocation;
 
36
package body Binary_Map is
 
37
   procedure Free is new Ada.Unchecked_Deallocation (Node, Map);
 
38
 
 
39
   --
 
40
   -- Internal utilities
 
41
   --
 
42
 
 
43
   --------------
 
44
   -- Get_Node --
 
45
   --------------
 
46
 
 
47
   function Get_Node (M : Map; Key : Key_Type) return Map is
 
48
      Current : Map := M;
 
49
   begin
 
50
      loop
 
51
         if Current = null then
 
52
            -- Not found
 
53
            return null;
 
54
 
 
55
         elsif Key < Current.Key then
 
56
            Current := Current.Children (Before);
 
57
 
 
58
         elsif Key > Current.Key then
 
59
            Current := Current.Children (After);
 
60
 
 
61
         else
 
62
            -- Found
 
63
            return Current;
 
64
         end if;
 
65
      end loop;
 
66
   end Get_Node;
 
67
 
 
68
   ---------------
 
69
   -- Linearize --
 
70
   ---------------
 
71
 
 
72
   procedure Linearize (M : Map; First, Last : out Map; Count : out Natural) is
 
73
      -- Precondition: M is not null
 
74
      -- Postconditions: First is the first element of a linear tree (all Left pointers are null)
 
75
      --                 Last is the last element
 
76
      --                 Count is the number of elements in the tree
 
77
 
 
78
      Temp_Map   : Map;
 
79
      Temp_Count : Natural;
 
80
   begin
 
81
      Count := 1;
 
82
      if M.Children (Before) /= null then
 
83
         Linearize (M.Children (Before), First, Temp_Map, Temp_Count);
 
84
         Temp_Map.Children (After) := M;
 
85
         Count          := Count + Temp_Count;
 
86
      else
 
87
         First := M;
 
88
      end if;
 
89
      M.Children (Before) := null;
 
90
 
 
91
      if M.Children (After) = null then
 
92
         Last := M;
 
93
      else
 
94
         Linearize (M.Children (After), Temp_Map, Last, Temp_Count);
 
95
         M.Children (After) := Temp_Map;
 
96
         Count   := Count + Temp_Count;
 
97
      end if;
 
98
   end Linearize;
 
99
 
 
100
   --------------
 
101
   --Rebalance --
 
102
   --------------
 
103
 
 
104
   procedure Rebalance (M : in out Map; Size : Natural; Rest : out Map) is
 
105
      -- Precondition: M is a linear tree (all Left pointers are null)
 
106
      -- Postcondions: M is a balanced tree containing the first Size elements
 
107
      --               Rest is the first of the remaining elements from the linear tree
 
108
      Top : Map;
 
109
      Left : Map;
 
110
   begin
 
111
      case Size is
 
112
         when 0 =>
 
113
            Rest := M;
 
114
            M    := null;
 
115
 
 
116
         when 1 =>
 
117
            Rest    := M.Children (After);
 
118
            M.Children (After) := null;
 
119
 
 
120
         when others =>
 
121
            Left := M;
 
122
            Rebalance (Left, (Size-1) / 2, Top);
 
123
            Top.Children (Before) := Left;
 
124
            Rebalance (Top.Children (After), Size - (Size-1)/2 - 1, Rest);
 
125
            M := Top;
 
126
      end case;
 
127
   end Rebalance;
 
128
 
 
129
 
 
130
   --
 
131
   -- Exported subprograms
 
132
   --
 
133
 
 
134
   ---------
 
135
   -- Add --
 
136
   ---------
 
137
 
 
138
   procedure Add (To    : in out Map;
 
139
                  Key   : in     Key_type;
 
140
                  Value : in     Value_type) is
 
141
   begin
 
142
      if To = null then
 
143
         To := new Node'(Key, Value, (null, null));
 
144
         return;
 
145
      end if;
 
146
 
 
147
      if Key < To.Key then
 
148
         Add (To.Children (Before), Key, Value);
 
149
      elsif Key = To.Key then
 
150
         To.Value := Value;
 
151
      else
 
152
         Add (To.Children (After), Key, Value);
 
153
      end if;
 
154
   end Add;
 
155
 
 
156
   -------------
 
157
   -- Balance --
 
158
   ------------
 
159
 
 
160
   procedure Balance (The_Map : in out Map) is
 
161
      First, Last : Map;
 
162
      Count       : Natural;
 
163
   begin
 
164
      if The_Map = null then
 
165
         return;
 
166
      end if;
 
167
 
 
168
      Linearize (The_Map, First, Last, Count);
 
169
      The_Map := First;
 
170
      Rebalance  (The_Map, Count, First);
 
171
   end Balance;
 
172
 
 
173
   ------------
 
174
   -- Delete --
 
175
   ------------
 
176
 
 
177
   procedure Delete (From : in out Map; Key : Key_Type) is
 
178
      Count1, Count2: Natural;
 
179
      Last     : Map;
 
180
      Parent   : Map := null;
 
181
      Slot     : Slots;
 
182
      Cur_Node : Map := From;
 
183
      Result   : Map;
 
184
   begin
 
185
      loop
 
186
         if Cur_Node = null then
 
187
            -- Not found
 
188
            raise Not_present;
 
189
 
 
190
         elsif Key > Cur_Node.Key then
 
191
            Slot   := After;
 
192
 
 
193
         elsif Key < Cur_Node.Key then
 
194
            Slot   := Before;
 
195
 
 
196
         else
 
197
            -- Found
 
198
            exit;
 
199
         end if;
 
200
         Parent   := Cur_Node;
 
201
         Cur_Node := Cur_Node.Children (Slot);
 
202
      end loop;
 
203
 
 
204
      if Cur_Node.Children (Before) = null then
 
205
         if Cur_Node.Children (After) = null then
 
206
            Result := null;
 
207
         else
 
208
            Result := Cur_Node.Children (After);
 
209
         end if;
 
210
 
 
211
      elsif Cur_Node.Children (After) = null then
 
212
         Result := Cur_Node.Children (Before);
 
213
 
 
214
      else
 
215
         -- At this point, deleting the node involves walking down the tree.
 
216
         -- it is not much more effort to rebalance (and actually simpler to program)
 
217
         Linearize (Cur_Node.Children (Before), Result,                 Last, Count1);
 
218
         Linearize (Cur_Node.Children (After),  Last.Children (After),  Last, Count2);
 
219
         Rebalance (Result, Count1 + Count2, Last);
 
220
      end if;
 
221
 
 
222
      if Parent = null then
 
223
         From := Result;
 
224
      else
 
225
         Parent.Children (Slot) := Result;
 
226
      end if;
 
227
      Free (Cur_Node);
 
228
   end Delete;
 
229
 
 
230
   -----------
 
231
   -- Fetch --
 
232
   -----------
 
233
 
 
234
   function Fetch (From : Map; Key : Key_type) return Value_type is
 
235
      Cur_Node : constant Map := Get_Node (From, Key);
 
236
   begin
 
237
      if Cur_Node = null then
 
238
         raise Not_present;
 
239
      else
 
240
         return Cur_Node.Value;
 
241
      end if;
 
242
   end Fetch;
 
243
 
 
244
   -----------
 
245
   -- Fetch --
 
246
   -----------
 
247
 
 
248
   function Fetch (From : Map; Key : Key_type; Default_Value : Value_Type) return Value_type is
 
249
      Cur_Node : constant Map := Get_Node (From, Key);
 
250
   begin
 
251
      if Cur_Node = null then
 
252
         return Default_Value;
 
253
      else
 
254
         return Cur_Node.Value;
 
255
      end if;
 
256
   end Fetch;
 
257
 
 
258
   ----------------
 
259
   -- Is_Present --
 
260
   ----------------
 
261
 
 
262
   function Is_Present (Within : Map; Key : Key_type) return Boolean is
 
263
   begin
 
264
      return Get_Node (Within, Key) /= null;
 
265
   end Is_present;
 
266
 
 
267
   -------------
 
268
   -- Iterate --
 
269
   -------------
 
270
 
 
271
   procedure Iterate (On : Map) is
 
272
   begin
 
273
      if On = null then
 
274
         return;
 
275
      end if;
 
276
 
 
277
      Iterate(On.Children (Before));
 
278
      Action(On.Key, On.Value);
 
279
      Iterate(On.Children (After));
 
280
   end Iterate;
 
281
 
 
282
   -----------
 
283
   -- Clear --
 
284
   -----------
 
285
 
 
286
   procedure Clear (The_Map : in out Map) is
 
287
   begin
 
288
      if The_Map = null then
 
289
         return;
 
290
      end if;
 
291
 
 
292
      Clear (The_Map.Children (Before));
 
293
      Clear (The_Map.Children (After));
 
294
      Free (The_Map);
 
295
   end Clear;
 
296
 
 
297
   -------------------------------
 
298
   -- Generic_Clear_And_Release --
 
299
   -------------------------------
 
300
 
 
301
   procedure Generic_Clear_And_Release (The_Map : in out Map) is
 
302
   begin
 
303
      if The_Map = null then
 
304
         return;
 
305
      end if;
 
306
 
 
307
      Clear (The_Map.Children (Before));
 
308
      Clear (The_Map.Children (After));
 
309
      Release (The_Map.Value);
 
310
      Free (The_Map);
 
311
   end Generic_Clear_And_Release;
 
312
 
 
313
   --------------
 
314
   -- Is_Empty --
 
315
   --------------
 
316
 
 
317
   function Is_Empty (The_Map : in Map) return Boolean is
 
318
   begin
 
319
      return The_Map = null;
 
320
   end Is_Empty;
 
321
 
 
322
end Binary_Map;
 
323