1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . --
6 -- G E N E R I C _ S E T _ O P E R A T I O N S --
10 -- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- This unit was originally developed by Matthew J Heaney. --
31 ------------------------------------------------------------------------------
33 with System
; use type System
.Address
;
35 package body Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
is
37 -----------------------
38 -- Local Subprograms --
39 -----------------------
41 procedure Clear
(Tree
: in out Tree_Type
);
43 function Copy
(Source
: Tree_Type
) return Tree_Type
;
49 procedure Clear
(Tree
: in out Tree_Type
) is
50 pragma Assert
(Tree
.Busy
= 0);
51 pragma Assert
(Tree
.Lock
= 0);
53 Root
: Node_Access
:= Tree
.Root
;
54 pragma Warnings
(Off
, Root
);
69 function Copy
(Source
: Tree_Type
) return Tree_Type
is
73 if Source
.Length
= 0 then
77 Target
.Root
:= Copy_Tree
(Source
.Root
);
78 Target
.First
:= Tree_Operations
.Min
(Target
.Root
);
79 Target
.Last
:= Tree_Operations
.Max
(Target
.Root
);
80 Target
.Length
:= Source
.Length
;
89 procedure Difference
(Target
: in out Tree_Type
; Source
: Tree_Type
) is
90 Tgt
: Node_Access
:= Target
.First
;
91 Src
: Node_Access
:= Source
.First
;
94 if Target
'Address = Source
'Address then
95 if Target
.Busy
> 0 then
96 raise Program_Error
with
97 "attempt to tamper with cursors (container is busy)";
104 if Source
.Length
= 0 then
108 if Target
.Busy
> 0 then
109 raise Program_Error
with
110 "attempt to tamper with cursors (container is busy)";
122 if Is_Less
(Tgt
, Src
) then
123 Tgt
:= Tree_Operations
.Next
(Tgt
);
125 elsif Is_Less
(Src
, Tgt
) then
126 Src
:= Tree_Operations
.Next
(Src
);
130 X
: Node_Access
:= Tgt
;
132 Tgt
:= Tree_Operations
.Next
(Tgt
);
133 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
137 Src
:= Tree_Operations
.Next
(Src
);
142 function Difference
(Left
, Right
: Tree_Type
) return Tree_Type
is
145 L_Node
: Node_Access
:= Left
.First
;
146 R_Node
: Node_Access
:= Right
.First
;
148 Dst_Node
: Node_Access
;
149 pragma Warnings
(Off
, Dst_Node
);
152 if Left
'Address = Right
'Address then
153 return Tree
; -- Empty set
156 if Left
.Length
= 0 then
157 return Tree
; -- Empty set
160 if Right
.Length
= 0 then
165 if L_Node
= null then
169 if R_Node
= null then
170 while L_Node
/= null loop
175 Dst_Node
=> Dst_Node
);
177 L_Node
:= Tree_Operations
.Next
(L_Node
);
184 if Is_Less
(L_Node
, R_Node
) then
189 Dst_Node
=> Dst_Node
);
191 L_Node
:= Tree_Operations
.Next
(L_Node
);
193 elsif Is_Less
(R_Node
, L_Node
) then
194 R_Node
:= Tree_Operations
.Next
(R_Node
);
197 L_Node
:= Tree_Operations
.Next
(L_Node
);
198 R_Node
:= Tree_Operations
.Next
(R_Node
);
204 Delete_Tree
(Tree
.Root
);
212 procedure Intersection
213 (Target
: in out Tree_Type
;
216 Tgt
: Node_Access
:= Target
.First
;
217 Src
: Node_Access
:= Source
.First
;
220 if Target
'Address = Source
'Address then
224 if Target
.Busy
> 0 then
225 raise Program_Error
with
226 "attempt to tamper with cursors (container is busy)";
229 if Source
.Length
= 0 then
237 if Is_Less
(Tgt
, Src
) then
239 X
: Node_Access
:= Tgt
;
241 Tgt
:= Tree_Operations
.Next
(Tgt
);
242 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
246 elsif Is_Less
(Src
, Tgt
) then
247 Src
:= Tree_Operations
.Next
(Src
);
250 Tgt
:= Tree_Operations
.Next
(Tgt
);
251 Src
:= Tree_Operations
.Next
(Src
);
255 while Tgt
/= null loop
257 X
: Node_Access
:= Tgt
;
259 Tgt
:= Tree_Operations
.Next
(Tgt
);
260 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
266 function Intersection
(Left
, Right
: Tree_Type
) return Tree_Type
is
269 L_Node
: Node_Access
:= Left
.First
;
270 R_Node
: Node_Access
:= Right
.First
;
272 Dst_Node
: Node_Access
;
273 pragma Warnings
(Off
, Dst_Node
);
276 if Left
'Address = Right
'Address then
281 if L_Node
= null then
285 if R_Node
= null then
289 if Is_Less
(L_Node
, R_Node
) then
290 L_Node
:= Tree_Operations
.Next
(L_Node
);
292 elsif Is_Less
(R_Node
, L_Node
) then
293 R_Node
:= Tree_Operations
.Next
(R_Node
);
300 Dst_Node
=> Dst_Node
);
302 L_Node
:= Tree_Operations
.Next
(L_Node
);
303 R_Node
:= Tree_Operations
.Next
(R_Node
);
309 Delete_Tree
(Tree
.Root
);
319 Of_Set
: Tree_Type
) return Boolean
322 if Subset
'Address = Of_Set
'Address then
326 if Subset
.Length
> Of_Set
.Length
then
331 Subset_Node
: Node_Access
:= Subset
.First
;
332 Set_Node
: Node_Access
:= Of_Set
.First
;
336 if Set_Node
= null then
337 return Subset_Node
= null;
340 if Subset_Node
= null then
344 if Is_Less
(Subset_Node
, Set_Node
) then
348 if Is_Less
(Set_Node
, Subset_Node
) then
349 Set_Node
:= Tree_Operations
.Next
(Set_Node
);
351 Set_Node
:= Tree_Operations
.Next
(Set_Node
);
352 Subset_Node
:= Tree_Operations
.Next
(Subset_Node
);
362 function Overlap
(Left
, Right
: Tree_Type
) return Boolean is
363 L_Node
: Node_Access
:= Left
.First
;
364 R_Node
: Node_Access
:= Right
.First
;
367 if Left
'Address = Right
'Address then
368 return Left
.Length
/= 0;
373 or else R_Node
= null
378 if Is_Less
(L_Node
, R_Node
) then
379 L_Node
:= Tree_Operations
.Next
(L_Node
);
381 elsif Is_Less
(R_Node
, L_Node
) then
382 R_Node
:= Tree_Operations
.Next
(R_Node
);
390 --------------------------
391 -- Symmetric_Difference --
392 --------------------------
394 procedure Symmetric_Difference
395 (Target
: in out Tree_Type
;
398 Tgt
: Node_Access
:= Target
.First
;
399 Src
: Node_Access
:= Source
.First
;
401 New_Tgt_Node
: Node_Access
;
402 pragma Warnings
(Off
, New_Tgt_Node
);
405 if Target
.Busy
> 0 then
406 raise Program_Error
with
407 "attempt to tamper with cursors (container is busy)";
410 if Target
'Address = Source
'Address then
417 while Src
/= null loop
422 Dst_Node
=> New_Tgt_Node
);
424 Src
:= Tree_Operations
.Next
(Src
);
434 if Is_Less
(Tgt
, Src
) then
435 Tgt
:= Tree_Operations
.Next
(Tgt
);
437 elsif Is_Less
(Src
, Tgt
) then
442 Dst_Node
=> New_Tgt_Node
);
444 Src
:= Tree_Operations
.Next
(Src
);
448 X
: Node_Access
:= Tgt
;
450 Tgt
:= Tree_Operations
.Next
(Tgt
);
451 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
455 Src
:= Tree_Operations
.Next
(Src
);
458 end Symmetric_Difference
;
460 function Symmetric_Difference
(Left
, Right
: Tree_Type
) return Tree_Type
is
463 L_Node
: Node_Access
:= Left
.First
;
464 R_Node
: Node_Access
:= Right
.First
;
466 Dst_Node
: Node_Access
;
467 pragma Warnings
(Off
, Dst_Node
);
470 if Left
'Address = Right
'Address then
471 return Tree
; -- Empty set
474 if Right
.Length
= 0 then
478 if Left
.Length
= 0 then
483 if L_Node
= null then
484 while R_Node
/= null loop
489 Dst_Node
=> Dst_Node
);
490 R_Node
:= Tree_Operations
.Next
(R_Node
);
496 if R_Node
= null then
497 while L_Node
/= null loop
502 Dst_Node
=> Dst_Node
);
504 L_Node
:= Tree_Operations
.Next
(L_Node
);
510 if Is_Less
(L_Node
, R_Node
) then
515 Dst_Node
=> Dst_Node
);
517 L_Node
:= Tree_Operations
.Next
(L_Node
);
519 elsif Is_Less
(R_Node
, L_Node
) then
524 Dst_Node
=> Dst_Node
);
526 R_Node
:= Tree_Operations
.Next
(R_Node
);
529 L_Node
:= Tree_Operations
.Next
(L_Node
);
530 R_Node
:= Tree_Operations
.Next
(R_Node
);
536 Delete_Tree
(Tree
.Root
);
538 end Symmetric_Difference
;
544 procedure Union
(Target
: in out Tree_Type
; Source
: Tree_Type
)
548 procedure Process
(Node
: Node_Access
);
549 pragma Inline
(Process
);
551 procedure Iterate
is new Tree_Operations
.Generic_Iteration
(Process
);
557 procedure Process
(Node
: Node_Access
) is
566 -- Start of processing for Union
569 if Target
'Address = Source
'Address then
573 if Target
.Busy
> 0 then
574 raise Program_Error
with
575 "attempt to tamper with cursors (container is busy)";
581 function Union
(Left
, Right
: Tree_Type
) return Tree_Type
is
583 if Left
'Address = Right
'Address then
587 if Left
.Length
= 0 then
591 if Right
.Length
= 0 then
596 Tree
: Tree_Type
:= Copy
(Left
);
600 procedure Process
(Node
: Node_Access
);
601 pragma Inline
(Process
);
604 new Tree_Operations
.Generic_Iteration
(Process
);
610 procedure Process
(Node
: Node_Access
) is
619 -- Start of processing for Union
627 Delete_Tree
(Tree
.Root
);
633 end Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
;