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-2006, 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
;
68 function Copy
(Source
: Tree_Type
) return Tree_Type
is
72 if Source
.Length
= 0 then
76 Target
.Root
:= Copy_Tree
(Source
.Root
);
77 Target
.First
:= Tree_Operations
.Min
(Target
.Root
);
78 Target
.Last
:= Tree_Operations
.Max
(Target
.Root
);
79 Target
.Length
:= Source
.Length
;
88 procedure Difference
(Target
: in out Tree_Type
; Source
: Tree_Type
) is
89 Tgt
: Node_Access
:= Target
.First
;
90 Src
: Node_Access
:= Source
.First
;
93 if Target
'Address = Source
'Address then
94 if Target
.Busy
> 0 then
95 raise Program_Error
with
96 "attempt to tamper with cursors (container is busy)";
103 if Source
.Length
= 0 then
107 if Target
.Busy
> 0 then
108 raise Program_Error
with
109 "attempt to tamper with cursors (container is busy)";
121 if Is_Less
(Tgt
, Src
) then
122 Tgt
:= Tree_Operations
.Next
(Tgt
);
124 elsif Is_Less
(Src
, Tgt
) then
125 Src
:= Tree_Operations
.Next
(Src
);
129 X
: Node_Access
:= Tgt
;
131 Tgt
:= Tree_Operations
.Next
(Tgt
);
132 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
136 Src
:= Tree_Operations
.Next
(Src
);
141 function Difference
(Left
, Right
: Tree_Type
) return Tree_Type
is
144 L_Node
: Node_Access
:= Left
.First
;
145 R_Node
: Node_Access
:= Right
.First
;
147 Dst_Node
: Node_Access
;
150 if Left
'Address = Right
'Address then
151 return Tree
; -- Empty set
154 if Left
.Length
= 0 then
155 return Tree
; -- Empty set
158 if Right
.Length
= 0 then
163 if L_Node
= null then
167 if R_Node
= null then
168 while L_Node
/= null loop
173 Dst_Node
=> Dst_Node
);
175 L_Node
:= Tree_Operations
.Next
(L_Node
);
182 if Is_Less
(L_Node
, R_Node
) then
187 Dst_Node
=> Dst_Node
);
189 L_Node
:= Tree_Operations
.Next
(L_Node
);
191 elsif Is_Less
(R_Node
, L_Node
) then
192 R_Node
:= Tree_Operations
.Next
(R_Node
);
195 L_Node
:= Tree_Operations
.Next
(L_Node
);
196 R_Node
:= Tree_Operations
.Next
(R_Node
);
202 Delete_Tree
(Tree
.Root
);
210 procedure Intersection
211 (Target
: in out Tree_Type
;
214 Tgt
: Node_Access
:= Target
.First
;
215 Src
: Node_Access
:= Source
.First
;
218 if Target
'Address = Source
'Address then
222 if Target
.Busy
> 0 then
223 raise Program_Error
with
224 "attempt to tamper with cursors (container is busy)";
227 if Source
.Length
= 0 then
235 if Is_Less
(Tgt
, Src
) then
237 X
: Node_Access
:= Tgt
;
239 Tgt
:= Tree_Operations
.Next
(Tgt
);
240 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
244 elsif Is_Less
(Src
, Tgt
) then
245 Src
:= Tree_Operations
.Next
(Src
);
248 Tgt
:= Tree_Operations
.Next
(Tgt
);
249 Src
:= Tree_Operations
.Next
(Src
);
253 while Tgt
/= null loop
255 X
: Node_Access
:= Tgt
;
257 Tgt
:= Tree_Operations
.Next
(Tgt
);
258 Tree_Operations
.Delete_Node_Sans_Free
(Target
, X
);
264 function Intersection
(Left
, Right
: Tree_Type
) return Tree_Type
is
267 L_Node
: Node_Access
:= Left
.First
;
268 R_Node
: Node_Access
:= Right
.First
;
270 Dst_Node
: Node_Access
;
273 if Left
'Address = Right
'Address then
278 if L_Node
= null then
282 if R_Node
= null then
286 if Is_Less
(L_Node
, R_Node
) then
287 L_Node
:= Tree_Operations
.Next
(L_Node
);
289 elsif Is_Less
(R_Node
, L_Node
) then
290 R_Node
:= Tree_Operations
.Next
(R_Node
);
297 Dst_Node
=> Dst_Node
);
299 L_Node
:= Tree_Operations
.Next
(L_Node
);
300 R_Node
:= Tree_Operations
.Next
(R_Node
);
306 Delete_Tree
(Tree
.Root
);
316 Of_Set
: Tree_Type
) return Boolean
319 if Subset
'Address = Of_Set
'Address then
323 if Subset
.Length
> Of_Set
.Length
then
328 Subset_Node
: Node_Access
:= Subset
.First
;
329 Set_Node
: Node_Access
:= Of_Set
.First
;
333 if Set_Node
= null then
334 return Subset_Node
= null;
337 if Subset_Node
= null then
341 if Is_Less
(Subset_Node
, Set_Node
) then
345 if Is_Less
(Set_Node
, Subset_Node
) then
346 Set_Node
:= Tree_Operations
.Next
(Set_Node
);
348 Set_Node
:= Tree_Operations
.Next
(Set_Node
);
349 Subset_Node
:= Tree_Operations
.Next
(Subset_Node
);
359 function Overlap
(Left
, Right
: Tree_Type
) return Boolean is
360 L_Node
: Node_Access
:= Left
.First
;
361 R_Node
: Node_Access
:= Right
.First
;
364 if Left
'Address = Right
'Address then
365 return Left
.Length
/= 0;
370 or else R_Node
= null
375 if Is_Less
(L_Node
, R_Node
) then
376 L_Node
:= Tree_Operations
.Next
(L_Node
);
378 elsif Is_Less
(R_Node
, L_Node
) then
379 R_Node
:= Tree_Operations
.Next
(R_Node
);
387 --------------------------
388 -- Symmetric_Difference --
389 --------------------------
391 procedure Symmetric_Difference
392 (Target
: in out Tree_Type
;
395 Tgt
: Node_Access
:= Target
.First
;
396 Src
: Node_Access
:= Source
.First
;
398 New_Tgt_Node
: Node_Access
;
401 if Target
.Busy
> 0 then
402 raise Program_Error
with
403 "attempt to tamper with cursors (container is busy)";
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
569 raise Program_Error
with
570 "attempt to tamper with cursors (container is busy)";
576 function Union
(Left
, Right
: Tree_Type
) return Tree_Type
is
578 if Left
'Address = Right
'Address then
582 if Left
.Length
= 0 then
586 if Right
.Length
= 0 then
591 Tree
: Tree_Type
:= Copy
(Left
);
595 procedure Process
(Node
: Node_Access
);
596 pragma Inline
(Process
);
599 new Tree_Operations
.Generic_Iteration
(Process
);
605 procedure Process
(Node
: Node_Access
) is
614 -- Start of processing for Union
622 Delete_Tree
(Tree
.Root
);
628 end Ada
.Containers
.Red_Black_Trees
.Generic_Set_Operations
;