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-2005, Free Software Foundation, Inc. --
12 -- This specification is derived from the Ada Reference Manual for use with --
13 -- GNAT. The copyright notice above, and the license provisions that follow --
14 -- apply solely to the contents of the part following the private keyword. --
16 -- GNAT is free software; you can redistribute it and/or modify it under --
17 -- terms of the GNU General Public License as published by the Free Soft- --
18 -- ware Foundation; either version 2, or (at your option) any later ver- --
19 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
20 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
21 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
22 -- for more details. You should have received a copy of the GNU General --
23 -- Public License distributed with GNAT; see file COPYING. If not, write --
24 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
25 -- Boston, MA 02110-1301, USA. --
27 -- As a special exception, if other files instantiate generics from this --
28 -- unit, or you link this unit with other files to produce an executable, --
29 -- this unit does not by itself cause the resulting executable to be --
30 -- covered by the GNU General Public License. This exception does not --
31 -- however invalidate any other reasons why the executable file might be --
32 -- covered by the GNU Public License. --
34 -- This unit was originally developed by Matthew J Heaney. --
35 ------------------------------------------------------------------------------
37 with System
; use type System
.Address
;
39 package body Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
is
41 -----------------------
42 -- Local Subprograms --
43 -----------------------
45 procedure Clear
(Tree
: in out Tree_Type
);
47 function Copy
(Source
: Tree_Type
) return Tree_Type
;
53 procedure Clear
(Tree
: in out Tree_Type
) is
54 pragma Assert
(Tree
.Busy
= 0);
55 pragma Assert
(Tree
.Lock
= 0);
57 Root
: Node_Access
:= Tree
.Root
;
72 function Copy
(Source
: Tree_Type
) return Tree_Type
is
76 if Source
.Length
= 0 then
80 Target
.Root
:= Copy_Tree
(Source
.Root
);
81 Target
.First
:= Tree_Operations
.Min
(Target
.Root
);
82 Target
.Last
:= Tree_Operations
.Max
(Target
.Root
);
83 Target
.Length
:= Source
.Length
;
92 procedure Difference
(Target
: in out Tree_Type
; Source
: Tree_Type
) is
93 Tgt
: Node_Access
:= Target
.First
;
94 Src
: Node_Access
:= Source
.First
;
97 if Target
'Address = Source
'Address then
98 if Target
.Busy
> 0 then
99 raise Program_Error
with
100 "attempt to tamper with cursors (container is busy)";
107 if Source
.Length
= 0 then
111 if Target
.Busy
> 0 then
112 raise Program_Error
with
113 "attempt to tamper with cursors (container is busy)";
125 if Is_Less
(Tgt
, Src
) then
126 Tgt
:= Tree_Operations
.Next
(Tgt
);
128 elsif Is_Less
(Src
, Tgt
) then
129 Src
:= Tree_Operations
.Next
(Src
);
133 X
: Node_Access
:= Tgt
;
135 Tgt
:= Tree_Operations
.Next
(Tgt
);
136 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
140 Src
:= Tree_Operations
.Next
(Src
);
145 function Difference
(Left
, Right
: Tree_Type
) return Tree_Type
is
148 L_Node
: Node_Access
:= Left
.First
;
149 R_Node
: Node_Access
:= Right
.First
;
151 Dst_Node
: Node_Access
;
154 if Left
'Address = Right
'Address then
155 return Tree
; -- Empty set
158 if Left
.Length
= 0 then
159 return Tree
; -- Empty set
162 if Right
.Length
= 0 then
167 if L_Node
= null then
171 if R_Node
= null then
172 while L_Node
/= null loop
177 Dst_Node
=> Dst_Node
);
179 L_Node
:= Tree_Operations
.Next
(L_Node
);
186 if Is_Less
(L_Node
, R_Node
) then
191 Dst_Node
=> Dst_Node
);
193 L_Node
:= Tree_Operations
.Next
(L_Node
);
195 elsif Is_Less
(R_Node
, L_Node
) then
196 R_Node
:= Tree_Operations
.Next
(R_Node
);
199 L_Node
:= Tree_Operations
.Next
(L_Node
);
200 R_Node
:= Tree_Operations
.Next
(R_Node
);
206 Delete_Tree
(Tree
.Root
);
214 procedure Intersection
215 (Target
: in out Tree_Type
;
218 Tgt
: Node_Access
:= Target
.First
;
219 Src
: Node_Access
:= Source
.First
;
222 if Target
'Address = Source
'Address then
226 if Target
.Busy
> 0 then
227 raise Program_Error
with
228 "attempt to tamper with cursors (container is busy)";
231 if Source
.Length
= 0 then
239 if Is_Less
(Tgt
, Src
) then
241 X
: Node_Access
:= Tgt
;
243 Tgt
:= Tree_Operations
.Next
(Tgt
);
244 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
248 elsif Is_Less
(Src
, Tgt
) then
249 Src
:= Tree_Operations
.Next
(Src
);
252 Tgt
:= Tree_Operations
.Next
(Tgt
);
253 Src
:= Tree_Operations
.Next
(Src
);
257 while Tgt
/= null loop
259 X
: Node_Access
:= Tgt
;
261 Tgt
:= Tree_Operations
.Next
(Tgt
);
262 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
268 function Intersection
(Left
, Right
: Tree_Type
) return Tree_Type
is
271 L_Node
: Node_Access
:= Left
.First
;
272 R_Node
: Node_Access
:= Right
.First
;
274 Dst_Node
: Node_Access
;
277 if Left
'Address = Right
'Address then
282 if L_Node
= null then
286 if R_Node
= null then
290 if Is_Less
(L_Node
, R_Node
) then
291 L_Node
:= Tree_Operations
.Next
(L_Node
);
293 elsif Is_Less
(R_Node
, L_Node
) then
294 R_Node
:= Tree_Operations
.Next
(R_Node
);
301 Dst_Node
=> Dst_Node
);
303 L_Node
:= Tree_Operations
.Next
(L_Node
);
304 R_Node
:= Tree_Operations
.Next
(R_Node
);
310 Delete_Tree
(Tree
.Root
);
320 Of_Set
: Tree_Type
) return Boolean
323 if Subset
'Address = Of_Set
'Address then
327 if Subset
.Length
> Of_Set
.Length
then
332 Subset_Node
: Node_Access
:= Subset
.First
;
333 Set_Node
: Node_Access
:= Of_Set
.First
;
337 if Set_Node
= null then
338 return Subset_Node
= null;
341 if Subset_Node
= null then
345 if Is_Less
(Subset_Node
, Set_Node
) then
349 if Is_Less
(Set_Node
, Subset_Node
) then
350 Set_Node
:= Tree_Operations
.Next
(Set_Node
);
352 Set_Node
:= Tree_Operations
.Next
(Set_Node
);
353 Subset_Node
:= Tree_Operations
.Next
(Subset_Node
);
363 function Overlap
(Left
, Right
: Tree_Type
) return Boolean is
364 L_Node
: Node_Access
:= Left
.First
;
365 R_Node
: Node_Access
:= Right
.First
;
368 if Left
'Address = Right
'Address then
369 return Left
.Length
/= 0;
374 or else R_Node
= null
379 if Is_Less
(L_Node
, R_Node
) then
380 L_Node
:= Tree_Operations
.Next
(L_Node
);
382 elsif Is_Less
(R_Node
, L_Node
) then
383 R_Node
:= Tree_Operations
.Next
(R_Node
);
391 --------------------------
392 -- Symmetric_Difference --
393 --------------------------
395 procedure Symmetric_Difference
396 (Target
: in out Tree_Type
;
399 Tgt
: Node_Access
:= Target
.First
;
400 Src
: Node_Access
:= Source
.First
;
402 New_Tgt_Node
: Node_Access
;
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
;
469 if Left
'Address = Right
'Address then
470 return Tree
; -- Empty set
473 if Right
.Length
= 0 then
477 if Left
.Length
= 0 then
482 if L_Node
= null then
483 while R_Node
/= null loop
488 Dst_Node
=> Dst_Node
);
489 R_Node
:= Tree_Operations
.Next
(R_Node
);
495 if R_Node
= null then
496 while L_Node
/= null loop
501 Dst_Node
=> Dst_Node
);
503 L_Node
:= Tree_Operations
.Next
(L_Node
);
509 if Is_Less
(L_Node
, R_Node
) then
514 Dst_Node
=> Dst_Node
);
516 L_Node
:= Tree_Operations
.Next
(L_Node
);
518 elsif Is_Less
(R_Node
, L_Node
) then
523 Dst_Node
=> Dst_Node
);
525 R_Node
:= Tree_Operations
.Next
(R_Node
);
528 L_Node
:= Tree_Operations
.Next
(L_Node
);
529 R_Node
:= Tree_Operations
.Next
(R_Node
);
535 Delete_Tree
(Tree
.Root
);
537 end Symmetric_Difference
;
543 procedure Union
(Target
: in out Tree_Type
; Source
: Tree_Type
)
547 procedure Process
(Node
: Node_Access
);
548 pragma Inline
(Process
);
550 procedure Iterate
is new Tree_Operations
.Generic_Iteration
(Process
);
556 procedure Process
(Node
: Node_Access
) is
565 -- Start of processing for Union
568 if Target
'Address = Source
'Address then
572 if Target
.Busy
> 0 then
573 raise Program_Error
with
574 "attempt to tamper with cursors (container is busy)";
580 function Union
(Left
, Right
: Tree_Type
) return Tree_Type
is
582 if Left
'Address = Right
'Address then
586 if Left
.Length
= 0 then
590 if Right
.Length
= 0 then
595 Tree
: Tree_Type
:= Copy
(Left
);
599 procedure Process
(Node
: Node_Access
);
600 pragma Inline
(Process
);
603 new Tree_Operations
.Generic_Iteration
(Process
);
609 procedure Process
(Node
: Node_Access
) is
618 -- Start of processing for Union
626 Delete_Tree
(Tree
.Root
);
632 end Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
;