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
106 if Source
.Length
= 0 then
110 if Target
.Busy
> 0 then
123 if Is_Less
(Tgt
, Src
) then
124 Tgt
:= Tree_Operations
.Next
(Tgt
);
126 elsif Is_Less
(Src
, Tgt
) then
127 Src
:= Tree_Operations
.Next
(Src
);
131 X
: Node_Access
:= Tgt
;
133 Tgt
:= Tree_Operations
.Next
(Tgt
);
134 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
138 Src
:= Tree_Operations
.Next
(Src
);
143 function Difference
(Left
, Right
: Tree_Type
) return Tree_Type
is
146 L_Node
: Node_Access
:= Left
.First
;
147 R_Node
: Node_Access
:= Right
.First
;
149 Dst_Node
: Node_Access
;
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
228 if Source
.Length
= 0 then
236 if Is_Less
(Tgt
, Src
) then
238 X
: Node_Access
:= Tgt
;
240 Tgt
:= Tree_Operations
.Next
(Tgt
);
241 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
245 elsif Is_Less
(Src
, Tgt
) then
246 Src
:= Tree_Operations
.Next
(Src
);
249 Tgt
:= Tree_Operations
.Next
(Tgt
);
250 Src
:= Tree_Operations
.Next
(Src
);
254 while Tgt
/= null loop
256 X
: Node_Access
:= Tgt
;
258 Tgt
:= Tree_Operations
.Next
(Tgt
);
259 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
265 function Intersection
(Left
, Right
: Tree_Type
) return Tree_Type
is
268 L_Node
: Node_Access
:= Left
.First
;
269 R_Node
: Node_Access
:= Right
.First
;
271 Dst_Node
: Node_Access
;
274 if Left
'Address = Right
'Address then
279 if L_Node
= null then
283 if R_Node
= null then
287 if Is_Less
(L_Node
, R_Node
) then
288 L_Node
:= Tree_Operations
.Next
(L_Node
);
290 elsif Is_Less
(R_Node
, L_Node
) then
291 R_Node
:= Tree_Operations
.Next
(R_Node
);
298 Dst_Node
=> Dst_Node
);
300 L_Node
:= Tree_Operations
.Next
(L_Node
);
301 R_Node
:= Tree_Operations
.Next
(R_Node
);
307 Delete_Tree
(Tree
.Root
);
317 Of_Set
: Tree_Type
) return Boolean
320 if Subset
'Address = Of_Set
'Address then
324 if Subset
.Length
> Of_Set
.Length
then
329 Subset_Node
: Node_Access
:= Subset
.First
;
330 Set_Node
: Node_Access
:= Of_Set
.First
;
334 if Set_Node
= null then
335 return Subset_Node
= null;
338 if Subset_Node
= null then
342 if Is_Less
(Subset_Node
, Set_Node
) then
346 if Is_Less
(Set_Node
, Subset_Node
) then
347 Set_Node
:= Tree_Operations
.Next
(Set_Node
);
349 Set_Node
:= Tree_Operations
.Next
(Set_Node
);
350 Subset_Node
:= Tree_Operations
.Next
(Subset_Node
);
360 function Overlap
(Left
, Right
: Tree_Type
) return Boolean is
361 L_Node
: Node_Access
:= Left
.First
;
362 R_Node
: Node_Access
:= Right
.First
;
365 if Left
'Address = Right
'Address then
366 return Left
.Length
/= 0;
371 or else R_Node
= null
376 if Is_Less
(L_Node
, R_Node
) then
377 L_Node
:= Tree_Operations
.Next
(L_Node
);
379 elsif Is_Less
(R_Node
, L_Node
) then
380 R_Node
:= Tree_Operations
.Next
(R_Node
);
388 --------------------------
389 -- Symmetric_Difference --
390 --------------------------
392 procedure Symmetric_Difference
393 (Target
: in out Tree_Type
;
396 Tgt
: Node_Access
:= Target
.First
;
397 Src
: Node_Access
:= Source
.First
;
399 New_Tgt_Node
: Node_Access
;
402 if Target
.Busy
> 0 then
406 if Target
'Address = Source
'Address then
413 while Src
/= null loop
418 Dst_Node
=> New_Tgt_Node
);
420 Src
:= Tree_Operations
.Next
(Src
);
430 if Is_Less
(Tgt
, Src
) then
431 Tgt
:= Tree_Operations
.Next
(Tgt
);
433 elsif Is_Less
(Src
, Tgt
) then
438 Dst_Node
=> New_Tgt_Node
);
440 Src
:= Tree_Operations
.Next
(Src
);
444 X
: Node_Access
:= Tgt
;
446 Tgt
:= Tree_Operations
.Next
(Tgt
);
447 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
451 Src
:= Tree_Operations
.Next
(Src
);
454 end Symmetric_Difference
;
456 function Symmetric_Difference
(Left
, Right
: Tree_Type
) return Tree_Type
is
459 L_Node
: Node_Access
:= Left
.First
;
460 R_Node
: Node_Access
:= Right
.First
;
462 Dst_Node
: Node_Access
;
465 if Left
'Address = Right
'Address then
466 return Tree
; -- Empty set
469 if Right
.Length
= 0 then
473 if Left
.Length
= 0 then
478 if L_Node
= null then
479 while R_Node
/= null loop
484 Dst_Node
=> Dst_Node
);
485 R_Node
:= Tree_Operations
.Next
(R_Node
);
491 if R_Node
= null then
492 while L_Node
/= null loop
497 Dst_Node
=> Dst_Node
);
499 L_Node
:= Tree_Operations
.Next
(L_Node
);
505 if Is_Less
(L_Node
, R_Node
) then
510 Dst_Node
=> Dst_Node
);
512 L_Node
:= Tree_Operations
.Next
(L_Node
);
514 elsif Is_Less
(R_Node
, L_Node
) then
519 Dst_Node
=> Dst_Node
);
521 R_Node
:= Tree_Operations
.Next
(R_Node
);
524 L_Node
:= Tree_Operations
.Next
(L_Node
);
525 R_Node
:= Tree_Operations
.Next
(R_Node
);
531 Delete_Tree
(Tree
.Root
);
533 end Symmetric_Difference
;
539 procedure Union
(Target
: in out Tree_Type
; Source
: Tree_Type
)
543 procedure Process
(Node
: Node_Access
);
544 pragma Inline
(Process
);
546 procedure Iterate
is new Tree_Operations
.Generic_Iteration
(Process
);
552 procedure Process
(Node
: Node_Access
) is
561 -- Start of processing for Union
564 if Target
'Address = Source
'Address then
568 if Target
.Busy
> 0 then
575 function Union
(Left
, Right
: Tree_Type
) return Tree_Type
is
577 if Left
'Address = Right
'Address then
581 if Left
.Length
= 0 then
585 if Right
.Length
= 0 then
590 Tree
: Tree_Type
:= Copy
(Left
);
594 procedure Process
(Node
: Node_Access
);
595 pragma Inline
(Process
);
598 new Tree_Operations
.Generic_Iteration
(Process
);
604 procedure Process
(Node
: Node_Access
) is
613 -- Start of processing for Union
621 Delete_Tree
(Tree
.Root
);
627 end Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
;