File Coverage

blib/lib/Set/Relation/V1.pm
Criterion Covered Total %
statement 629 1922 32.7
branch 134 538 24.9
condition 48 225 21.3
subroutine 73 181 40.3
pod 0 84 0.0
total 884 2950 29.9


line stmt bran cond sub pod time code
1 3     3   170557 use 5.008000;
  3         25  
2 3     3   14 use utf8;
  3         4  
  3         14  
3 3     3   57 use strict;
  3         4  
  3         75  
4 3     3   14 use warnings;
  3         4  
  3         178  
5              
6             ###########################################################################
7             ###########################################################################
8              
9             { package Set::Relation::V1; # class
10             our $VERSION = '0.013002';
11             $VERSION = eval $VERSION;
12              
13 3     3   22 use Carp 'confess';
  3         5  
  3         144  
14 3     3   63 use Scalar::Util 'blessed', 'refaddr';
  3         7  
  3         138  
15 3     3   15 use List::Util 'any', 'all', 'notall', 'uniqstr';
  3         5  
  3         53389  
16              
17             # with Set::Relation::Mutable
18             sub does {
19 47     47 0 82 my ($self, $role_name) = @_;
20 47 50       104 confess q{This does() may only be invoked on an object.}
21             if not blessed $self;
22 47 50       95 confess q{does(): Bad $role_name arg; it must be a defined string.}
23             if !defined $role_name;
24 47 50       112 return 0
25             if !$self->isa( __PACKAGE__ );
26 47 50 33     256 return 1
27             if $role_name eq 'Set::Relation'
28             or $role_name eq 'Set::Relation::Mutable';
29 0         0 return 0;
30             }
31              
32             # has _heading
33             # isa HashRef
34             # One elem per attribute:
35             # hkey is Str attr name
36             # hval is undef+unused
37             # default {}
38             sub _heading {
39 286     286   333 my $self = shift;
40 286 100       497 $self->{_heading} = $_[0] if scalar @_;
41 286         438 return $self->{_heading};
42             }
43             # has _degree
44             # isa Int
45             # default 0
46             sub _degree {
47 140     140   155 my $self = shift;
48 140 100       238 $self->{_degree} = $_[0] if scalar @_;
49 140         190 return $self->{_degree};
50             }
51             sub degree {
52 66     66 0 78 my $self = shift;
53 66         154 return $self->{_degree};
54             }
55              
56             # has _body
57             # isa HashRef
58             # One elem per tuple:
59             # hkey is Str identity generated from all tuple attrs
60             # hval is HashRef that is the coll of separate tuple attrs:
61             # hkey is Str attr name
62             # hval is 2-elem ArrayRef that is the tuple attr value
63             # [0] is actual attr value
64             # [1] is Str identity generated from attr value
65             # default {}
66             sub _body {
67 283     283   313 my $self = shift;
68 283 100       433 $self->{_body} = $_[0] if scalar @_;
69 283         479 return $self->{_body};
70             }
71             # has _cardinality
72             # isa Int
73             # default 0
74             sub _cardinality {
75 138     138   171 my $self = shift;
76 138 50       246 $self->{_cardinality} = $_[0] if scalar @_;
77 138         170 return $self->{_cardinality};
78             }
79             sub cardinality {
80 124     124 0 167 my $self = shift;
81 124         303 return $self->{_cardinality};
82             }
83              
84             # This may only be made defined when _has_frozen_identity is true.
85             # has _which
86             # isa Maybe[Str]
87             # default undef
88             sub _which {
89 68     68   72 my $self = shift;
90 68 100       117 $self->{_which} = $_[0] if scalar @_;
91 68         97 return $self->{_which};
92             }
93              
94             # has _indexes
95             # isa HashRef
96             # One elem per index:
97             # hkey is index name;
98             # - is Str ident gen f head subset tha index ranges ovr
99             # hval is 2-elem ArrayRef that is the index itself + meta
100             # [0] is HashRef of atnms that index ranges over
101             # - structure same as '_heading'
102             # [1] is index itself;
103             # - HashRef; one elem per tup of projection of body
104             # on attrs that index ranges over
105             # hkey is Str ident gen fr distinct projection tupl
106             # hval is set of body tup having projection tuples
107             # in comn; is HashRef; one elem per body tuple
108             # - structure same as '_body', is slice o _body
109             # default {}
110             sub _indexes {
111 80     80   92 my $self = shift;
112 80 100       132 $self->{_indexes} = $_[0] if scalar @_;
113 80         96 return $self->{_indexes};
114             }
115              
116             # has _keys
117             # isa HashRef
118             # One elem per key:
119             # hkey is key name;
120             # - is Str ident gen f head subset tha index ranges ovr
121             # hval is HashRef of atnms that index ranges over
122             # - structure same as '_heading'
123             # default {}
124             sub _keys {
125 105     105   114 my $self = shift;
126 105 100       180 $self->{_keys} = $_[0] if scalar @_;
127 105         144 return $self->{_keys};
128             }
129              
130             # If this is made true, no further mutation of S::R head/body allowed,
131             # and then it can't be made false again.
132             # has _has_frozen_identity
133             # isa Bool
134             # default 0
135             sub _has_frozen_identity {
136 65     65   74 my $self = shift;
137 65 50       193 $self->{_has_frozen_identity} = $_[0] if scalar @_;
138 65         78 return $self->{_has_frozen_identity};
139             }
140             sub has_frozen_identity {
141 0     0 0 0 my $self = shift;
142 0         0 return $self->{_has_frozen_identity};
143             }
144              
145             ###########################################################################
146              
147             sub new {
148 62     62 0 52851 my ($class, @args) = @_;
149 62   33     205 $class = (blessed $class) || $class;
150              
151 62         117 my $params = $class->BUILDARGS( @args );
152              
153 62         122 my $self = bless {}, $class;
154              
155             # Set attribute default values.
156 62         137 $self->_heading( {} );
157 62         119 $self->_degree( 0 );
158 62         126 $self->_body( {} );
159 62         119 $self->_cardinality( 0 );
160 62         126 $self->_which( undef );
161 62         120 $self->_indexes( {} );
162 62         116 $self->_keys( {} );
163 62         108 $self->_has_frozen_identity( 0 );
164              
165 62 50       106 if (exists $params->{has_frozen_identity}) {
166 0 0       0 $self->_has_frozen_identity( $params->{has_frozen_identity} ? 1 : 0 );
167             }
168              
169 62         120 $self->BUILD( $params );
170              
171 62         189 return $self;
172             }
173              
174             ###########################################################################
175              
176             sub BUILDARGS {
177 62     62 0 102 my ($class, @args) = @_;
178 62 100       151 if (@args == 1) {
    50          
179 37 50       75 if (ref $args[0] ne 'HASH') {
180             # Constructor was called with a single positional argument.
181 37         111 return { members => $args[0] };
182             }
183             else {
184             # Constructor was called with (possibly zero) named arguments.
185 0         0 return { %{$args[0]} };
  0         0  
186             }
187             }
188             elsif ((scalar @args % 2) == 0) {
189             # Constructor was called with (possibly zero) named arguments.
190 25         55 return { @args };
191             }
192             else {
193             # Constructor was called with odd number positional arguments >= 3.
194 0         0 confess q{new(): Bad arguments list; it must either have an even}
195             . q{ number of elements or exactly 1 element.};
196             }
197             }
198              
199             ###########################################################################
200              
201             sub BUILD {
202 62     62 0 97 my ($self, $args) = @_;
203 62         75 my ($members, $keys) = @{$args}{'members', 'keys'};
  62         104  
204              
205             # Note, $members may be in all of the same formats as a HDMD_Perl_STD
206             # Relation value literal payload, but with a few extra trivial options.
207              
208 62 100 66     234 if (!defined $members) {
    50 66        
    50 33        
209             # Extra option 1.
210 25         37 $members = [];
211             }
212             elsif (!ref $members) {
213             # Extra option 2.
214 0         0 $members = [$members];
215             }
216             elsif (blessed $members and $members->can( 'does' )
217             and $members->does( 'Set::Relation' )
218             and !$members->isa( __PACKAGE__ )) {
219             # We got a $members that is a Set::Relation-doing class where that
220             # class isn't us; so clone it from a dump using public interface.
221 0         0 $members = $self->_new( $members->export_for_new() );
222             }
223 62 50 33     186 confess q{new(): Bad :$members arg; it must be either undefined}
      66        
224             . q{ or an array-ref or a non-ref or a Set::Relation object.}
225             if ref $members ne 'ARRAY'
226             and not (blessed $members and $members->isa( __PACKAGE__ ));
227              
228             # If we get here, $members is either a Set::Relation::V1 or an ary-ref.
229              
230 62 50       122 if (!defined $keys) {
    0          
231 62         82 $keys = [];
232             }
233             elsif (ref $keys ne 'ARRAY') {
234 0         0 $keys = [$keys];
235             }
236 62 50   0   192 if (any { ref $_ ne 'ARRAY' } @{$keys}) {
  0         0  
  62         198  
237 0         0 $keys = [$keys];
238             }
239 62         139 for my $key (@{$keys}) {
  62         110  
240             confess q{new(): Bad $keys arg; it is not correctly formatted.}
241             if ref $key ne 'ARRAY'
242 0 0 0 0   0 or notall { defined $_ and !ref $_ } @{$key};
  0 0       0  
  0         0  
243             }
244              
245             # If we get here, $keys is an Array of Array of Str.
246              
247 62 100 66     172 if (blessed $members and $members->isa( __PACKAGE__ )) {
    100          
248             # We'll just shallow clone h, copy b of anoth V1 obj's member-set.
249 15         25 $self->_heading( $members->_heading() );
250 15         25 $self->_degree( $members->degree() );
251 15         20 $self->_body( {%{$members->_body()}} );
  15         20  
252 15         25 $self->_cardinality( $members->cardinality() );
253 15         62 $self->_keys( {%{$members->_keys()}} );
  15         57  
254             }
255 47         87 elsif (@{$members} == 0) {
256             # Input specifies zero attrs + zero tuples.
257             # No-op; attr defaults are fine.
258             }
259             else {
260             # Input specifies at least one attr or at least one tuple.
261 21         30 my $member0 = $members->[0];
262 21 50       81 if (!defined $member0) {
    50          
    100          
    50          
263 0         0 confess q{new(): Bad :$members arg; it is an array ref}
264             . q{ but it directly has an undefined element.};
265             }
266             elsif (!ref $member0) {
267             # Input spec at least 1 attr + zero tuples.
268             # Each $members elem is expected to be an atnm.
269             confess q{new(): Bad :$members arg; it has a non-ref elem,}
270             . q{ indicating it should just be a list of attr}
271             . q{ names, but at least one other elem is}
272             . q{ undefined or is a ref.}
273 0 0   0   0 if notall { defined $_ and !ref $_ } @{$members};
  0 0       0  
  0         0  
274             confess q{new(): Bad :$members arg; it specifies a list of}
275             . q{ attr names with at least one duplicated name.}
276 0 0       0 if (uniqstr @{$members}) != @{$members};
  0         0  
  0         0  
277 0         0 $self->_heading( {CORE::map { ($_ => undef) } @{$members}} );
  0         0  
  0         0  
278 0         0 $self->_degree( scalar @{$members} );
  0         0  
279             }
280             elsif (ref $member0 eq 'HASH') {
281             # Input spec at least 1 tuple, in named attr format.
282             my $heading
283 12         16 = {CORE::map { ($_ => undef) } CORE::keys %{$member0}};
  43         77  
  12         30  
284 12         36 my $body = {};
285 12         18 for my $tuple (@{$members}) {
  12         20  
286 44 50 33     132 confess q{new(): Bad :$members arg; it has a hash-ref}
287             . q{ elem, indicating it should just be a list of}
288             . q{ tuples in named-attr format, but at least one}
289             . q{ other elem is not a hash-ref, or the 2 elems}
290             . q{ don't have exactly the same set of hkeys.}
291             if ref $tuple ne 'HASH'
292             or !$self->_is_identical_hkeys( $heading, $tuple );
293 44 50       108 confess q{new(): Bad :$members arg;}
294             . q{ at least one of its hash-ref elems is such}
295             . q{ that there exists circular refs between}
296             . q{ itself or its tuple-valued components.}
297             if $self->_tuple_arg_has_circular_refs( $tuple );
298 44         77 $tuple = $self->_import_nfmt_tuple( $tuple );
299 44         84 $body->{$self->_ident_str( $tuple )} = $tuple;
300             }
301 12         29 $self->_heading( $heading );
302 12         13 $self->_degree( scalar CORE::keys %{$heading} );
  12         31  
303 12         29 $self->_body( $body );
304 12         13 $self->_cardinality( scalar CORE::keys %{$body} );
  12         26  
305             }
306             elsif (ref $member0 eq 'ARRAY') {
307             # Input is in ordered attr format.
308 9         12 my $member1 = $members->[1];
309             confess q{new(): Bad :$members arg; it has an array-ref first}
310             . q{ elem, indicating it should just be a list of}
311             . q{ tuples in ordered-attr format, but either}
312             . q{ :$members doesn't have exactly 2 elements or its}
313             . q{ second element isn't also an array-ref.}
314 9 50 33     11 if @{$members} != 2 or ref $member1 ne 'ARRAY';
  9         39  
315             # Each $member0 elem is expected to be an atnm.
316             confess q{new(): Bad :$members array-ref arg array-ref}
317             . q{ first elem; it should be just be a list of}
318             . q{ attr names, but at least one name}
319             . q{ is undefined or is a ref.}
320 9 50   33   26 if notall { defined $_ and !ref $_ } @{$member0};
  33 50       84  
  9         20  
321             confess q{new(): Bad :$members arg; it specifies a list of}
322             . q{ attr names with at least one duplicated name.}
323 9 50       21 if (uniqstr @{$member0}) != @{$member0};
  9         32  
  9         21  
324 9         17 my $heading = {CORE::map { ($_ => undef) } @{$member0}};
  33         57  
  9         14  
325 9         18 my $body = {};
326 9         10 for my $tuple (@{$member1}) {
  9         17  
327             confess q{new(): Bad :$members array-ref arg array-ref}
328             . q{ second elem; at least one elem isn't an}
329             . q{ array-ref, or that doesn't have the same}
330             . q{ count of elems as the :$members first elem.}
331 35 50 33     77 if ref $tuple ne 'ARRAY' or @{$tuple} != @{$member0};
  35         44  
  35         79  
332             # Each $tuple elem is expected to be an atvl.
333             confess q{new(): Bad :$members arg;}
334             . q{ at least one of its array-ref elems}
335             . q{ is such that there exists circular refs}
336             . q{ between its tuple-valued components.}
337 125 50   125   191 if any { ref $_ eq 'HASH'
338             and $self->_tuple_arg_has_circular_refs( $_ )
339 35 50       90 } (@{$tuple});
  35         63  
340 35         92 $tuple = $self->_import_ofmt_tuple( $member0, $tuple );
341 35         65 $body->{$self->_ident_str( $tuple )} = $tuple;
342             }
343 9         25 $self->_heading( $heading );
344 9         12 $self->_degree( scalar CORE::keys %{$heading} );
  9         31  
345 9         22 $self->_body( $body );
346 9         9 $self->_cardinality( scalar CORE::keys %{$body} );
  9         23  
347             }
348             else {
349 0         0 confess q{new(): Bad :$members arg; it is an array-ref but it}
350             . q{ has an elem that is neither a defined scalar nor}
351             . q{ an array-ref nor a hash-ref.};
352             }
353             }
354              
355 62         104 my $self_h = $self->_heading();
356              
357 62         72 for my $key (@{$keys}) {
  62         87  
358             confess q{new(): At least one of the relation keys defined by the}
359             . q{ $keys arg isn't a subset of the heading of the}
360             . q{ relation defined by the $members arg.}
361 0 0   0   0 if notall { exists $self_h->{$_} } @{$key};
  0         0  
  0         0  
362 0 0       0 confess q{new(): The relation defined by the $members arg violates}
363             . q{ at least one of the candidate unique key constraints}
364 0         0 . qq{ defined by the $members arg: [@{$key}].}
365             if !$self->_has_key( $key );
366             }
367              
368 62         94 return;
369             }
370              
371             ###########################################################################
372              
373             sub _new {
374 40     40   71 my ($self, @args) = @_;
375 40         131 return (blessed $self)->new( @args );
376             }
377              
378             ###########################################################################
379              
380             sub export_for_new {
381 0     0 0 0 my ($self, $want_ord_attrs, $allow_dup_tuples) = @_;
382             return {
383 0         0 'members' => $self->_members(
384             'export_for_new', '$want_ord_attrs', $want_ord_attrs ),
385             'keys' => $self->keys(),
386             # Note, we make an exception by not exporting the
387             # 'has_frozen_identity' object attribute even though the 'new'
388             # constructor can take an argument to user-initialize it;
389             # there doesn't seem to be a point, as if a user wanted an
390             # immutable clone of an immutable object, just use the original;
391             # or if they wanted a mutable clone of a mutable object, then
392             # mutable is what they get by default anyway; more likely they want
393             # a mutable clone of an immutable object.
394             };
395             }
396              
397             ###########################################################################
398              
399             sub which {
400 3     3 0 6 my ($self) = @_;
401 3         15 my $ident_str = $self->_which();
402 3 50       8 if (!defined $ident_str) {
403 3         7 $self->_has_frozen_identity( 1 );
404 3         6 my $hs = $self->_heading_ident_str( $self->_heading() );
405 3         4 my $bs = CORE::join qq{,\n}, sort (CORE::keys %{$self->_body()});
  3         4  
406 3         7 my $vstr = "H=$hs;\nB={$bs}";
407 3         8 $ident_str = 'Relation:' . (length $vstr) . ':{' . $vstr . '}';
408 3         6 $self->_which( $ident_str );
409             }
410 3         5 return $ident_str;
411             }
412              
413             ###########################################################################
414              
415             sub members {
416 33     33 0 3252 my ($self, $want_ord_attrs, $allow_dup_tuples) = @_;
417 33         79 return $self->_members(
418             'members', '$want_ord_attrs', $want_ord_attrs );
419             }
420              
421             sub _members {
422 33     33   62 my ($self, $rtn_nm, $arg_nm, $want_ord_attrs) = @_;
423 33 100       117 if ($want_ord_attrs) {
    50          
424 2         6 my $ord_attr_names = $self->_normalize_true_want_ord_attrs_arg(
425             $rtn_nm, $arg_nm, $want_ord_attrs );
426             return [$ord_attr_names, [CORE::map {
427 5         8 $self->_export_ofmt_tuple( $ord_attr_names, $_ )
428 2         3 } values %{$self->_body()}]];
  2         4  
429             }
430 31         49 elsif ((CORE::keys %{$self->_body()}) == 0) {
431             # We have zero tuples, just export attr names.
432 0         0 return [sort (CORE::keys %{$self->_heading()})];
  0         0  
433             }
434             else {
435             # We have at least one tuple, export in named-attr format.
436 107         165 return [CORE::map { $self->_export_nfmt_tuple( $_ ) }
437 31         43 values %{$self->_body()}];
  31         45  
438             }
439             }
440              
441             ###########################################################################
442              
443             sub heading {
444 1     1 0 3 my ($self) = @_;
445 1         2 return [sort (CORE::keys %{$self->_heading()})];
  1         2  
446             }
447              
448             ###########################################################################
449              
450             sub body {
451 0     0 0 0 my ($self, $want_ord_attrs, $allow_dup_tuples) = @_;
452 0 0       0 if ($want_ord_attrs) {
453 0         0 my $ord_attr_names = $self->_normalize_true_want_ord_attrs_arg(
454             'body', '$want_ord_attrs', $want_ord_attrs );
455 0         0 return [CORE::map { $self->_export_ofmt_tuple(
456 0         0 $ord_attr_names, $_ ) } values %{$self->_body()}];
  0         0  
457             }
458             else {
459 0         0 return [CORE::map { $self->_export_nfmt_tuple( $_ ) }
460 0         0 values %{$self->_body()}];
  0         0  
461             }
462             }
463              
464             ###########################################################################
465              
466             sub _normalize_true_want_ord_attrs_arg {
467 2     2   5 my ($self, $rtn_nm, $arg_nm, $want_ord_attrs) = @_;
468              
469 2         4 my $heading = $self->_heading();
470              
471 2         3 my $attr_names = [CORE::keys %{$heading}];
  2         7  
472             confess qq{$rtn_nm(): Bad $arg_nm arg;}
473             . q{ it must be either undefined|false or the scalar value '1'}
474             . q{ or an array-ref of attr names whose degree and}
475             . q{ elements match the heading of the invocant.}
476             if not (!ref $want_ord_attrs and $want_ord_attrs eq '1'
477             or ref $want_ord_attrs eq 'ARRAY'
478 0         0 and @{$want_ord_attrs} == @{$attr_names}
  0         0  
479 2 0 33 0   11 and all { exists $heading->{$_} } @{$want_ord_attrs});
  0   0     0  
  0   0     0  
      33        
480              
481             return
482 2 50       6 $want_ord_attrs eq '1' ? [sort @{$attr_names}] : $want_ord_attrs;
  2         8  
483             }
484              
485             ###########################################################################
486              
487             sub slice {
488 0     0 0 0 my ($self, $attr_names, $want_ord_attrs, $allow_dup_tuples) = @_;
489              
490 0         0 (my $proj_h, $attr_names)
491             = $self->_atnms_hr_from_assert_valid_atnms_arg(
492             'slice', '$attr_names', $attr_names );
493 0         0 my (undef, undef, $proj_only)
494             = $self->_ptn_conj_and_disj( $self->_heading(), $proj_h );
495             confess q{slice(): Bad $attr_names arg; that attr list}
496             . q{ isn't a subset of the invocant's heading.}
497 0 0       0 if @{$proj_only} > 0;
  0         0  
498              
499 0 0       0 if ($want_ord_attrs) {
500 0 0       0 confess q{slice(): Bad $want_ord_attrs arg; it must be}
501             . q{ either undefined|false or the scalar value '1'.}
502             if $want_ord_attrs ne '1';
503 0         0 return [CORE::map { $self->_export_ofmt_tuple(
504 0         0 $attr_names, $_ ) } values %{$self->_body()}];
  0         0  
505             }
506             else {
507             return [CORE::map {
508 0         0 my $t = $_;
509 0         0 $t = {CORE::map { ($_ => $t->{$_}) } @{$attr_names}};
  0         0  
  0         0  
510 0         0 $self->_export_nfmt_tuple( $t );
511 0         0 } values %{$self->_body()}];
  0         0  
512             }
513             }
514              
515             ###########################################################################
516              
517             sub attr {
518 4     4 0 7 my ($self, $name, $allow_dup_tuples) = @_;
519              
520 4         11 $self->_assert_valid_atnm_arg( 'attr', '$name', $name );
521             confess q{attr(): Bad $name arg; that attr name}
522             . q{ doesn't match an attr of the invocant's heading.}
523 4 50       9 if !exists $self->_heading()->{$name};
524              
525             return [CORE::map {
526 6         10 my $atvl = $_->{$name}->[0];
527 6 50       11 if (ref $atvl eq 'HASH') {
528 0         0 $atvl = $self->_export_nfmt_tuple( $atvl );
529             }
530 6         18 $atvl;
531 4         6 } values %{$self->_body()}];
  4         7  
532             }
533              
534             ###########################################################################
535              
536             sub keys {
537 0     0 0 0 my ($self) = @_;
538 0         0 return [CORE::map { [sort @{$_}] } values %{$self->_keys()}];
  0         0  
  0         0  
  0         0  
539             }
540              
541             ###########################################################################
542              
543             sub _normalize_same_heading_tuples_arg {
544 13     13   18 my ($r, $rtn_nm, $arg_nm, $t) = @_;
545              
546 13         23 my $r_h = $r->_heading();
547              
548 13 50       31 if (ref $t eq 'HASH') {
549 13         18 $t = [$t];
550             }
551 13 50       27 confess qq{$rtn_nm(): Bad $arg_nm arg; it must be}
552             . q{ an array-ref or a hash-ref.}
553             if ref $t ne 'ARRAY';
554 13         14 for my $tuple (@{$t}) {
  13         21  
555 13 50 33     34 confess qq{$rtn_nm(): Bad $arg_nm arg elem;}
556             . q{ it isn't a hash-ref, or it doesn't have exactly the}
557             . q{ same set of attr names as the invocant.}
558             if ref $tuple ne 'HASH'
559             or !$r->_is_identical_hkeys( $r_h, $tuple );
560 13 50       38 confess qq{$rtn_nm(): Bad $arg_nm arg elem;}
561             . q{ it is a hash-ref, and there exist circular refs}
562             . q{ between itself or its tuple-valued components.}
563             if $r->_tuple_arg_has_circular_refs( $tuple );
564             }
565              
566 13         18 return $t;
567             }
568              
569             ###########################################################################
570              
571             sub _tuple_arg_has_circular_refs {
572             # This routine just checks that no Hash which would be treated as
573             # being of a value type contains itself as a component, where the
574             # component and any intermediate components are treated as value types.
575             # It *is* fine for a Hash to contain the same other Hash more than once
576             # such that the other is a sibling/cousin/etc to itself.
577 57     57   88 my ($self, $tuple, $ancs_of_tup_atvls) = @_;
578 57 50       99 $ancs_of_tup_atvls = $ancs_of_tup_atvls ? {%{$ancs_of_tup_atvls}} : {};
  0         0  
579 57         147 $ancs_of_tup_atvls->{refaddr $tuple} = undef;
580 57         73 for my $atvl (values %{$tuple}) {
  57         96  
581 231 50       346 if (ref $atvl eq 'HASH') {
582             return 1
583 0 0       0 if exists $ancs_of_tup_atvls->{refaddr $atvl};
584 0 0       0 return 1
585             if $self->_tuple_arg_has_circular_refs(
586             $atvl, $ancs_of_tup_atvls );
587             }
588             }
589 57         127 return 0;
590             }
591              
592             ###########################################################################
593              
594             sub _self_is_component_of_tuple_arg {
595 0     0   0 my ($self, $tuple) = @_;
596 0         0 for my $atvl (values %{$tuple}) {
  0         0  
597 0 0 0     0 if (blessed $atvl and $atvl->isa( __PACKAGE__ )) {
    0          
598 0 0       0 return 1
599             if refaddr $atvl == refaddr $self;
600             }
601             elsif (ref $atvl eq 'HASH') {
602 0 0       0 return 1
603             if $self->_self_is_component_of_tuple_arg( $atvl );
604             }
605             }
606 0         0 return 0;
607             }
608              
609             ###########################################################################
610              
611             sub _is_identical_hkeys {
612 92     92   146 my ($self, $h1, $h2) = @_;
613 92         100 my $h1_hkeys = [CORE::keys %{$h1}];
  92         212  
614 92         118 my $h2_hkeys = [CORE::keys %{$h2}];
  92         199  
615             return (@{$h1_hkeys} == @{$h2_hkeys}
616 92   33 388   105 and all { exists $h1->{$_} } @{$h2_hkeys});
  388         756  
617             }
618              
619             ###########################################################################
620              
621             sub _heading_ident_str {
622 8     8   14 my ($self, $heading) = @_;
623             my $vstr = CORE::join q{,}, CORE::map {
624 14         39 'Atnm:' . (length $_) . ':<' . $_ . '>'
625 8         11 } sort (CORE::keys %{$heading});
  8         22  
626 8         26 return 'Heading:' . (length $vstr) . ':{' . $vstr . '}';
627             }
628              
629             sub _ident_str {
630             # Note, we assume that any hash-ref arg we get is specifically in
631             # internal tuple format, meaning each hval is a 2-elem array etc,
632             # and that this is recursive for hash-ref hvals of said.
633 507     507   661 my ($self, $value) = @_;
634 507         484 my $ident_str;
635 507 50       884 if (!defined $value) {
    100          
    50          
636             # The Perl undef is equal to itself, distinct from all def values.
637 0         0 $ident_str = 'Undef';
638             }
639             elsif (!ref $value) {
640             # Treat all defined non-ref values as their string representation.
641 356         633 $ident_str = 'Scalar:' . (length $value) . ':<' . $value . '>';
642             }
643             elsif (!blessed $value) {
644             # By default, every non-object reference is distinct, and its
645             # identity is its memory address; the exception is if the reference
646             # is a hash-ref, in which case it is treated as an internal tuple.
647 151 50       228 if (ref $value eq 'HASH') {
648             my $vstr = CORE::join q{,}, CORE::map {
649 507         768 my $atnm = 'Atnm:' . (length $_) . ':<' . $_ . '>';
650 507         612 my $atvl = $value->{$_}->[1];
651 507         939 "N=$atnm;V=$atvl";
652 151         166 } sort (CORE::keys %{$value});
  151         428  
653 151         341 $ident_str = 'Tuple:' . (length $vstr) . ':{' . $vstr . '}';
654             }
655             else {
656 0         0 my $vstr = "$value";
657 0         0 $ident_str = 'Ref:' . (length $vstr) . ':<' . $vstr . '>';
658             }
659             }
660             else {
661             # By default, every object instance is distinct, and its identity
662             # is its memory address; the exception is if the object is a
663             # Set::Relation::V1 or if it overloads stringification.
664 0 0       0 if ($value->isa( __PACKAGE__ )) {
665 0         0 $ident_str = $value->which(); # 'Relation:...'
666             }
667             else {
668 0         0 my $vstr = "$value";
669 0         0 $ident_str = 'Object[' . (blessed $value) . ']:'
670             . (length $vstr) . ':<' . $vstr . '>';
671             }
672             }
673 507         1209 return $ident_str;
674             }
675              
676             ###########################################################################
677              
678             sub _import_nfmt_tuple {
679 57     57   83 my ($self, $tuple) = @_;
680             return {CORE::map {
681 231         244 my $atnm = $_;
682 231         282 my $atvl = $tuple->{$_};
683 231 50 33     604 if (ref $atvl eq 'HASH') {
    50 33        
      0        
684 0         0 $atvl = $self->_import_nfmt_tuple( $atvl );
685             }
686             elsif (blessed $atvl and $atvl->can( 'does' )
687             and $atvl->does( 'Set::Relation' )
688             and !$atvl->isa( __PACKAGE__ )) {
689 0         0 $atvl = $self->_new( $atvl );
690             }
691 231         327 ($atnm => [$atvl, $self->_ident_str( $atvl )]);
692 57         69 } CORE::keys %{$tuple}};
  57         106  
693             }
694              
695             sub _export_nfmt_tuple {
696 181     181   235 my ($self, $tuple) = @_;
697             return {CORE::map {
698 724         721 my $atnm = $_;
699 724         828 my $atvl = $tuple->{$_}->[0];
700 724 50       946 if (ref $atvl eq 'HASH') {
701 0         0 $atvl = $self->_export_nfmt_tuple( $atvl );
702             }
703 724         1331 ($atnm => $atvl);
704 181         190 } CORE::keys %{$tuple}};
  181         276  
705             }
706              
707             sub _import_ofmt_tuple {
708 35     35   58 my ($self, $atnms, $atvls) = @_;
709             return {CORE::map {
710 125         148 my $atnm = $atnms->[$_];
711 125         141 my $atvl = $atvls->[$_];
712 125 50 33     311 if (ref $atvl eq 'HASH') {
    50 33        
      0        
713 0         0 $atvl = $self->_import_nfmt_tuple( $atvl );
714             }
715             elsif (blessed $atvl and $atvl->can( 'does' )
716             and $atvl->does( 'Set::Relation' )
717             and !$atvl->isa( __PACKAGE__ )) {
718 0         0 $atvl = $self->_new( $atvl );
719             }
720 125         179 ($atnm => [$atvl, $self->_ident_str( $atvl )]);
721 35         50 } 0..$#{$atnms}};
  35         79  
722             }
723              
724             sub _export_ofmt_tuple {
725 5     5   8 my ($self, $atnms, $tuple) = @_;
726             return [CORE::map {
727 12         15 my $atvl = $tuple->{$_}->[0];
728 12 50       18 if (ref $atvl eq 'HASH') {
729 0         0 $atvl = $self->_export_nfmt_tuple( $atvl );
730             }
731 12         23 $atvl;
732 5         6 } @{$atnms}];
  5         6  
733             }
734              
735             ###########################################################################
736              
737             sub is_nullary {
738 4     4 0 7 my ($topic) = @_;
739 4         8 return $topic->degree() == 0;
740             }
741              
742             sub has_attrs {
743 0     0 0 0 my ($topic, $attr_names) = @_;
744 0         0 (my $proj_h, $attr_names)
745             = $topic->_atnms_hr_from_assert_valid_atnms_arg(
746             'has_attrs', '$attr_names', $attr_names );
747 0         0 my (undef, undef, $proj_only)
748             = $topic->_ptn_conj_and_disj( $topic->_heading(), $proj_h );
749 0         0 return @{$proj_only} == 0;
  0         0  
750             }
751              
752             sub attr_names {
753 0     0 0 0 my ($topic) = @_;
754 0         0 return [sort (CORE::keys %{$topic->_heading()})];
  0         0  
755             }
756              
757             ###########################################################################
758              
759             sub count {
760 0     0 0 0 my ($self, @args) = @_;
761 0         0 return $self->cardinality( @args );
762             }
763              
764             sub is_empty {
765 43     43 0 58 my ($topic) = @_;
766 43         65 return $topic->cardinality() == 0;
767             }
768              
769             sub has_member {
770 0     0 0 0 my ($r, $t) = @_;
771 0         0 $t = $r->_normalize_same_heading_tuples_arg( 'has_member', '$t', $t );
772 0         0 my $r_b = $r->_body();
773             return all {
774 0     0   0 exists $r_b->{$r->_ident_str( $r->_import_nfmt_tuple( $_ ) )}
775 0         0 } @{$t};
  0         0  
776             }
777              
778             ###########################################################################
779              
780             sub has_key {
781 0     0 0 0 my ($topic, $attr_names) = @_;
782 0         0 (undef, $attr_names) = $topic->_atnms_hr_from_assert_valid_atnms_arg(
783             'has_key', '$attr_names', $attr_names );
784 0         0 my $topic_h = $topic->_heading();
785             confess q{has_key(): Bad $attr_names arg; that attr list}
786             . q{ isn't a subset of the invocant's heading.}
787 0 0   0   0 if notall { exists $topic_h->{$_} } @{$attr_names};
  0         0  
  0         0  
788 0         0 return $topic->_has_key( $attr_names );
789             }
790              
791             sub _has_key {
792 0     0   0 my ($topic, $attr_names) = @_;
793              
794 0         0 my $subheading = {CORE::map { ($_ => undef) } @{$attr_names}};
  0         0  
  0         0  
795 0         0 my $subheading_ident_str = $topic->_heading_ident_str( $subheading );
796 0         0 my $keys = $topic->_keys();
797              
798             return 1
799 0 0       0 if exists $keys->{$subheading_ident_str};
800              
801 0         0 my $index = $topic->_want_index( $attr_names );
802              
803             return 0
804 0 0   0   0 if notall { (CORE::keys %{$_}) == 1 } values %{$index};
  0         0  
  0         0  
  0         0  
805              
806 0         0 $keys->{$subheading_ident_str} = $subheading;
807 0         0 return 1;
808             }
809              
810             ###########################################################################
811              
812             sub empty {
813 17     17 0 27 my ($topic) = @_;
814 17 50       25 if ($topic->is_empty()) {
815 0         0 return $topic;
816             }
817 17         34 my $result = $topic->_new();
818 17         30 $result->_heading( $topic->_heading() );
819 17         28 $result->_degree( $topic->_degree() );
820 17         26 return $result;
821             }
822              
823             sub insertion {
824 13     13 0 19351 my ($r, $t) = @_;
825 13         29 $t = $r->_normalize_same_heading_tuples_arg( 'insertion', '$t', $t );
826 13 50       15 if (@{$t} == 0) {
  13         25  
827 0         0 return $r;
828             }
829 13         23 return $r->_new( $r )->_insert( $t );
830             }
831              
832             sub deletion {
833 0     0 0 0 my ($r, $t) = @_;
834 0         0 $t = $r->_normalize_same_heading_tuples_arg( 'deletion', '$t', $t );
835 0 0       0 if (@{$t} == 0) {
  0         0  
836 0         0 return $r;
837             }
838 0         0 return $r->_new( $r )->_delete( $t );
839             }
840              
841             ###########################################################################
842              
843             sub rename {
844 1     1 0 7802 my ($topic, $map) = @_;
845              
846 1 50       5 confess q{rename(): Bad $map arg; it must be a hash-ref.}
847             if ref $map ne 'HASH';
848             confess q{rename(): Bad $map arg;}
849             . q{ its hash elem values should be just be a list of attr}
850             . q{ names, but at least one name is undefined or isa ref.}
851 1 50   4   5 if notall { defined $_ and !ref $_ } values %{$map};
  4 50       22  
  1         5  
852             confess q{rename(): Bad $map arg;}
853             . q{ its hash elem values specify a list of}
854             . q{ attr names with at least one duplicated name.}
855 1 50       4 if (uniqstr values %{$map}) != (CORE::keys %{$map});
  1         6  
  1         4  
856              
857             my ($topic_attrs_to_ren, $topic_attrs_no_ren, $map_hvals_not_in_topic)
858             = $topic->_ptn_conj_and_disj(
859 1         4 $topic->_heading(), {reverse %{$map}} );
  1         6  
860             confess q{rename(): Bad $map arg; that list of attrs to be renamed,}
861             . q{ the hash values, isn't a subset of th invocant's heading.}
862 1 50       3 if @{$map_hvals_not_in_topic} > 0;
  1         3  
863              
864             my ($map_hkeys_same_as_topic_no_ren, undef, undef)
865             = $topic->_ptn_conj_and_disj(
866 1         2 {CORE::map { ($_ => undef) } @{$topic_attrs_no_ren}}, $map );
  0         0  
  1         2  
867             confess q{rename(): Bad $map arg; at least one key of that hash,}
868             . q{ a new name for an attr of the invocant to rename,}
869             . q{ duplicates an attr of the invocant not being renamed.}
870 1 50       3 if @{$map_hkeys_same_as_topic_no_ren} > 0;
  1         4  
871              
872 1         4 return $topic->_rename( $map );
873             }
874              
875             sub _rename {
876 1     1   2 my ($topic, $map) = @_;
877              
878             # Remove any explicit no-ops of an attr being renamed to the same name.
879 4         7 $map = {CORE::map { ($_ => $map->{$_}) }
880 1         2 grep { $map->{$_} ne $_ } CORE::keys %{$map}};
  4         8  
  1         2  
881              
882 1 50       2 if ((scalar CORE::keys %{$map}) == 0) {
  1         4  
883             # Rename of zero attrs of input yields the input.
884 0         0 return $topic;
885             }
886              
887             # Expand map to specify all topic attrs being renamed to something.
888 1         3 my $inv_map = {reverse %{$map}};
  1         3  
889             $map = {CORE::map { ((
890 4 50       11 exists $inv_map->{$_} ? $inv_map->{$_} : $_
891 1         2 ) => $_) } CORE::keys %{$topic->_heading()}};
  1         2  
892              
893 1         12 my $result = $topic->_new();
894              
895 1         3 $result->_heading( {CORE::map { ($_ => undef) } CORE::keys %{$map}} );
  4         9  
  1         3  
896 1         3 $result->_degree( $topic->degree() );
897              
898 1         2 my $result_b = $result->_body();
899              
900 1         2 for my $topic_t (values %{$topic->_body()}) {
  1         2  
901             my $result_t = {CORE::map {
902 20         31 ($_ => $topic_t->{$map->{$_}})
903 5         6 } CORE::keys %{$map}};
  5         10  
904 5         13 my $result_t_ident_str = $topic->_ident_str( $result_t );
905 5         12 $result_b->{$result_t_ident_str} = $result_t;
906             }
907 1         3 $result->_cardinality( $topic->cardinality() );
908              
909 1         5 return $result;
910             }
911              
912             ###########################################################################
913              
914             sub projection {
915 1     1 0 9 my ($topic, $attr_names) = @_;
916              
917 1         5 (my $proj_h, $attr_names)
918             = $topic->_atnms_hr_from_assert_valid_atnms_arg(
919             'projection', '$attr_names', $attr_names );
920 1         3 my (undef, undef, $proj_only)
921             = $topic->_ptn_conj_and_disj( $topic->_heading(), $proj_h );
922             confess q{projection(): Bad $attr_names arg; that attr list}
923             . q{ isn't a subset of the invocant's heading.}
924 1 50       2 if @{$proj_only} > 0;
  1         3  
925              
926 1         4 return $topic->_projection( $attr_names );
927             }
928              
929             sub _projection {
930 1     1   1 my ($topic, $attr_names) = @_;
931              
932 1 50       2 if (@{$attr_names} == 0) {
  1         3  
933             # Projection of zero attrs yields identity relation zero or one.
934 0 0       0 if ($topic->is_empty()) {
935 0         0 return $topic->_new();
936             }
937             else {
938 0         0 return $topic->_new( [ {} ] );
939             }
940             }
941 1 50       2 if (@{$attr_names} == $topic->degree()) {
  1         4  
942             # Projection of all attrs of input yields the input.
943 0         0 return $topic;
944             }
945              
946 1         3 my $result = $topic->_new();
947              
948 1         3 $result->_heading( {CORE::map { ($_ => undef) } @{$attr_names}} );
  1         5  
  1         2  
949 1         1 $result->_degree( scalar @{$attr_names} );
  1         3  
950              
951 1         2 my $result_b = $result->_body();
952              
953 1         2 for my $topic_t (values %{$topic->_body()}) {
  1         3  
954             my $result_t
955 5         6 = {CORE::map { ($_ => $topic_t->{$_}) } @{$attr_names}};
  5         12  
  5         6  
956 5         9 my $result_t_ident_str = $topic->_ident_str( $result_t );
957 5 100       13 if (!exists $result_b->{$result_t_ident_str}) {
958 3         7 $result_b->{$result_t_ident_str} = $result_t;
959             }
960             }
961 1         1 $result->_cardinality( scalar CORE::keys %{$result_b} );
  1         4  
962              
963 1         4 return $result;
964             }
965              
966             sub cmpl_proj {
967 0     0 0 0 my ($topic, $attr_names) = @_;
968              
969 0         0 my $topic_h = $topic->_heading();
970              
971 0         0 (my $cproj_h, $attr_names)
972             = $topic->_atnms_hr_from_assert_valid_atnms_arg(
973             'cmpl_proj', '$attr_names', $attr_names );
974 0         0 my (undef, undef, $cproj_only)
975             = $topic->_ptn_conj_and_disj( $topic_h, $cproj_h );
976             confess q{cmpl_proj(): Bad $attr_names arg; that attr list}
977             . q{ isn't a subset of the invocant's heading.}
978 0 0       0 if @{$cproj_only} > 0;
  0         0  
979              
980             return $topic->_projection(
981 0         0 [grep { !$cproj_h->{$_} } CORE::keys %{$topic_h}] );
  0         0  
  0         0  
982             }
983              
984             ###########################################################################
985              
986             sub wrap {
987 0     0 0 0 my ($topic, $outer, $inner) = @_;
988              
989 0         0 $topic->_assert_valid_atnm_arg( 'wrap', '$outer', $outer );
990 0         0 (my $inner_h, $inner) = $topic->_atnms_hr_from_assert_valid_atnms_arg(
991             'wrap', '$inner', $inner );
992              
993 0         0 my (undef, $topic_attrs_no_wr, $inner_attrs_not_in_topic)
994             = $topic->_ptn_conj_and_disj( $topic->_heading(), $inner_h );
995             confess q{wrap(): Bad $inner arg; that list of attrs to be wrapped}
996             . q{ isn't a subset of the invocant's heading.}
997 0 0       0 if @{$inner_attrs_not_in_topic} > 0;
  0         0  
998             confess q{wrap(): Bad $outer arg; that name for a new attr to add}
999             . q{ to the invocant, consisting of wrapped invocant attrs,}
1000             . q{ duplicates an attr of the invocant not being wrapped.}
1001 0 0   0   0 if any { $_ eq $outer } @{$topic_attrs_no_wr};
  0         0  
  0         0  
1002              
1003 0         0 return $topic->_wrap( $outer, $inner, $topic_attrs_no_wr );
1004             }
1005              
1006             sub _wrap {
1007 0     0   0 my ($topic, $outer, $inner, $topic_attrs_no_wr) = @_;
1008              
1009 0         0 my $result = $topic->_new();
1010              
1011             $result->_heading(
1012 0         0 {CORE::map { ($_ => undef) } @{$topic_attrs_no_wr}, $outer} );
  0         0  
  0         0  
1013 0         0 $result->_degree( @{$topic_attrs_no_wr} + 1 );
  0         0  
1014              
1015 0         0 my $topic_b = $topic->_body();
1016 0         0 my $result_b = $result->_body();
1017              
1018 0 0       0 if ($topic->is_empty()) {
    0          
    0          
1019             # An empty $topic means an empty result.
1020             # So $result_b is already correct.
1021             }
1022 0         0 elsif (@{$inner} == 0) {
1023             # Wrap zero $topic attrs as new attr.
1024             # So this is a simple static extension of $topic w static $outer.
1025 0         0 my $inner_t = {};
1026 0         0 my $outer_atvl = [$inner_t, $topic->_ident_str( $inner_t )];
1027 0         0 for my $topic_t (values %{$topic_b}) {
  0         0  
1028 0         0 my $result_t = {$outer => $outer_atvl, {%{$topic_t}}};
  0         0  
1029 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1030 0         0 $result_b->{$result_t_ident_str} = $result_t;
1031             }
1032             }
1033 0         0 elsif (@{$topic_attrs_no_wr} == 0) {
1034             # Wrap all $topic attrs as new attr.
1035 0         0 for my $topic_t_ident_str (CORE::keys %{$topic_b}) {
  0         0  
1036 0         0 my $result_t = {$outer => [$topic_b->{$topic_t_ident_str},
1037             $topic_t_ident_str]};
1038 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1039 0         0 $result_b->{$result_t_ident_str} = $result_t;
1040             }
1041             }
1042             else {
1043             # Wrap at least one but not all $topic attrs as new attr.
1044 0         0 for my $topic_t (values %{$topic_b}) {
  0         0  
1045 0         0 my $inner_t = {CORE::map { ($_ => $topic_t->{$_}) } @{$inner}};
  0         0  
  0         0  
1046 0         0 my $outer_atvl = [$inner_t, $topic->_ident_str( $inner_t )];
1047             my $result_t = {
1048             $outer => $outer_atvl,
1049 0         0 CORE::map { ($_ => $topic_t->{$_}) } @{$topic_attrs_no_wr}
  0         0  
  0         0  
1050             };
1051 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1052 0         0 $result_b->{$result_t_ident_str} = $result_t;
1053             }
1054             }
1055 0         0 $result->_cardinality( $topic->cardinality() );
1056              
1057 0         0 return $result;
1058             }
1059              
1060             sub cmpl_wrap {
1061 0     0 0 0 my ($topic, $outer, $cmpl_inner) = @_;
1062              
1063 0         0 $topic->_assert_valid_atnm_arg( 'cmpl_wrap', '$outer', $outer );
1064 0         0 (my $cmpl_inner_h, $cmpl_inner)
1065             = $topic->_atnms_hr_from_assert_valid_atnms_arg(
1066             'cmpl_wrap', '$cmpl_inner', $cmpl_inner );
1067              
1068 0         0 my $topic_h = $topic->_heading();
1069              
1070             confess q{cmpl_wrap(): Bad $cmpl_inner arg; that attr list}
1071             . q{ isn't a subset of the invocant's heading.}
1072 0 0   0   0 if notall { exists $topic_h->{$_} } @{$cmpl_inner};
  0         0  
  0         0  
1073              
1074 0         0 my $inner = [grep { !$cmpl_inner_h->{$_} } CORE::keys %{$topic_h}];
  0         0  
  0         0  
1075 0         0 my $inner_h = {CORE::map { $_ => undef } @{$inner}};
  0         0  
  0         0  
1076              
1077 0         0 my (undef, $topic_attrs_no_wr, undef)
1078             = $topic->_ptn_conj_and_disj( $topic_h, $inner_h );
1079             confess q{cmpl_wrap(): Bad $outer arg; that name for a new attr to add}
1080             . q{ to the invocant, consisting of wrapped invocant attrs,}
1081             . q{ duplicates an attr of the invocant not being wrapped.}
1082 0 0   0   0 if any { $_ eq $outer } @{$topic_attrs_no_wr};
  0         0  
  0         0  
1083              
1084 0         0 return $topic->_wrap( $outer, $inner, $topic_attrs_no_wr );
1085             }
1086              
1087             ###########################################################################
1088              
1089             sub unwrap {
1090 0     0 0 0 my ($topic, $inner, $outer) = @_;
1091              
1092 0         0 (my $inner_h, $inner) = $topic->_atnms_hr_from_assert_valid_atnms_arg(
1093             'unwrap', '$inner', $inner );
1094 0         0 $topic->_assert_valid_atnm_arg( 'unwrap', '$outer', $outer );
1095              
1096 0         0 my $topic_h = $topic->_heading();
1097              
1098             confess q{unwrap(): Bad $outer arg; that attr name}
1099             . q{ doesn't match an attr of the invocant's heading.}
1100 0 0       0 if !exists $topic_h->{$outer};
1101              
1102 0         0 my $topic_h_except_outer = {%{$topic_h}};
  0         0  
1103 0         0 CORE::delete $topic_h_except_outer->{$outer};
1104              
1105 0         0 my ($inner_attrs_dupl_topic, $topic_attrs_no_uwr, undef)
1106             = $topic->_ptn_conj_and_disj( $topic_h_except_outer, $inner_h );
1107             confess q{unwrap(): Bad $inner arg; at least one name in that attr}
1108             . q{ list, which the invocant would be extended with when}
1109             . q{ unwrapping $topic{$outer}, duplicates an attr of the}
1110             . q{ invocant not being unwrapped.}
1111 0 0       0 if @{$inner_attrs_dupl_topic} > 0;
  0         0  
1112              
1113 0         0 my $topic_b = $topic->_body();
1114              
1115 0         0 for my $topic_t (values %{$topic_b}) {
  0         0  
1116 0         0 my $inner_t = $topic_t->{$outer}->[0];
1117 0 0 0     0 confess q{unwrap(): Can't unwrap $topic{$outer} because there is}
1118             . q{ not a same-heading tuple value for the $outer attr of}
1119             . q{ every tuple of $topic whose heading matches $inner.}
1120             if ref $inner_t ne 'HASH'
1121             or !$topic->_is_identical_hkeys( $inner_h, $inner_t );
1122             }
1123              
1124 0         0 my $result = $topic->_new();
1125              
1126 0         0 $result->_heading( {%{$topic_h_except_outer}, %{$inner_h}} );
  0         0  
  0         0  
1127 0         0 $result->_degree( @{$topic_attrs_no_uwr} + @{$inner} );
  0         0  
  0         0  
1128              
1129 0         0 my $result_b = $result->_body();
1130              
1131 0 0       0 if ($topic->is_empty()) {
    0          
    0          
1132             # An empty $topic means an empty result.
1133             # So $result_b is already correct.
1134             }
1135 0         0 elsif (@{$topic_attrs_no_uwr} == 0) {
1136             # Only $topic attr is $outer, all result attrs from $outer unwrap.
1137 0         0 for my $topic_t (values %{$topic_b}) {
  0         0  
1138 0         0 my $outer_atvl = $topic_t->{$outer};
1139 0         0 $result_b->{$outer_atvl->[1]} = $outer_atvl->[0];
1140             }
1141             }
1142 0         0 elsif (@{$inner} == 0) {
1143             # Unwrap of $outer adds zero attrs to $topic.
1144             # So this is a simple projection of $topic excising $outer.
1145 0         0 for my $topic_t (values %{$topic_b}) {
  0         0  
1146             my $result_t = {
1147 0         0 CORE::map { ($_ => $topic_t->{$_}) } @{$topic_attrs_no_uwr}
  0         0  
  0         0  
1148             };
1149 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1150 0         0 $result_b->{$result_t_ident_str} = $result_t;
1151             }
1152             }
1153             else {
1154             # Result has at least 1 attr from $outer, at least 1 not from it.
1155 0         0 for my $topic_t (values %{$topic_b}) {
  0         0  
1156             my $result_t = {
1157 0         0 %{$topic_t->{$outer}->[0]},
1158 0         0 CORE::map { ($_ => $topic_t->{$_}) } @{$topic_attrs_no_uwr}
  0         0  
  0         0  
1159             };
1160 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1161 0         0 $result_b->{$result_t_ident_str} = $result_t;
1162             }
1163             }
1164 0         0 $result->_cardinality( $topic->cardinality() );
1165              
1166 0         0 return $result;
1167             }
1168              
1169             ###########################################################################
1170              
1171             sub group {
1172 1     1 0 77423 my ($topic, $outer, $inner) = @_;
1173              
1174 1         6 $topic->_assert_valid_atnm_arg( 'group', '$outer', $outer );
1175 1         5 (my $inner_h, $inner) = $topic->_atnms_hr_from_assert_valid_atnms_arg(
1176             'group', '$inner', $inner );
1177              
1178 1         4 my (undef, $topic_attrs_no_gr, $inner_attrs_not_in_topic)
1179             = $topic->_ptn_conj_and_disj( $topic->_heading(), $inner_h );
1180             confess q{group(): Bad $inner arg; that list of attrs to be grouped}
1181             . q{ isn't a subset of the invocant's heading.}
1182 1 50       3 if @{$inner_attrs_not_in_topic} > 0;
  1         4  
1183             confess q{group(): Bad $outer arg; that name for a new attr to add}
1184             . q{ to the invocant, consisting of grouped invocant attrs,}
1185             . q{ duplicates an attr of the invocant not being grouped.}
1186 1 50   1   4 if any { $_ eq $outer } @{$topic_attrs_no_gr};
  1         4  
  1         3  
1187              
1188 1         6 return $topic->_group( $outer, $inner, $topic_attrs_no_gr, $inner_h );
1189             }
1190              
1191             sub _group {
1192 1     1   3 my ($topic, $outer, $inner, $topic_attrs_no_gr, $inner_h) = @_;
1193              
1194 1         3 my $result = $topic->_new();
1195              
1196             $result->_heading(
1197 1         2 {CORE::map { ($_ => undef) } @{$topic_attrs_no_gr}, $outer} );
  2         6  
  1         2  
1198 1         2 $result->_degree( @{$topic_attrs_no_gr} + 1 );
  1         3  
1199              
1200 1 50       5 if ($topic->is_empty()) {
    50          
    50          
1201             # An empty $topic means an empty result.
1202             # So result body is already correct.
1203             }
1204 1         3 elsif (@{$inner} == 0) {
1205             # Group zero $topic attrs as new attr.
1206             # So this is a simple static extension of $topic w static $outer.
1207 0         0 my $result_b = $result->_body();
1208 0         0 my $inner_r = $topic->_new( [ {} ] );
1209 0         0 my $outer_atvl = [$inner_r, $inner_r->which()];
1210 0         0 for my $topic_t (values %{$topic->_body()}) {
  0         0  
1211 0         0 my $result_t = {$outer => $outer_atvl, {%{$topic_t}}};
  0         0  
1212 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1213 0         0 $result_b->{$result_t_ident_str} = $result_t;
1214             }
1215 0         0 $result->_cardinality( $topic->cardinality() );
1216             }
1217 1         4 elsif (@{$topic_attrs_no_gr} == 0) {
1218             # Group all $topic attrs as new attr.
1219             # So $topic is just used as sole attr of sole tuple of result.
1220 0         0 my $result_t = {$outer => [$topic, $topic->which()]};
1221 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1222 0         0 $result->_body( {$result_t_ident_str => $result_t} );
1223 0         0 $result->_cardinality( 1 );
1224             }
1225             else {
1226             # Group at least one but not all $topic attrs as new attr.
1227 1         2 my $result_b = $result->_body();
1228 1         4 my $topic_index = $topic->_want_index( $topic_attrs_no_gr );
1229 1         2 for my $matched_topic_b (values %{$topic_index}) {
  1         3  
1230              
1231 3         8 my $inner_r = $topic->_new();
1232 3         7 $inner_r->_heading( $inner_h );
1233 3         4 $inner_r->_degree( scalar @{$inner} );
  3         7  
1234 3         5 my $inner_b = $inner_r->_body();
1235 3         3 for my $topic_t (values %{$matched_topic_b}) {
  3         8  
1236             my $inner_t
1237 5         7 = {CORE::map { ($_ => $topic_t->{$_}) } @{$inner}};
  15         27  
  5         6  
1238 5         13 $inner_b->{$topic->_ident_str( $inner_t )} = $inner_t;
1239             }
1240             $inner_r->_cardinality(
1241 3         4 scalar CORE::keys %{$matched_topic_b} );
  3         9  
1242 3         8 my $outer_atvl = [$inner_r, $inner_r->which()];
1243              
1244 3         5 my $any_mtpt = (values %{$matched_topic_b})[0];
  3         5  
1245              
1246             my $result_t = {
1247             $outer => $outer_atvl,
1248 3         5 CORE::map { ($_ => $any_mtpt->{$_}) } @{$topic_attrs_no_gr}
  3         8  
  3         5  
1249             };
1250 3         7 my $result_t_ident_str = $topic->_ident_str( $result_t );
1251 3         9 $result_b->{$result_t_ident_str} = $result_t;
1252             }
1253 1         3 $result->_cardinality( scalar CORE::keys %{$topic_index} );
  1         4  
1254             }
1255              
1256 1         5 return $result;
1257             }
1258              
1259             sub cmpl_group {
1260 0     0 0 0 my ($topic, $outer, $group_per) = @_;
1261              
1262 0         0 $topic->_assert_valid_atnm_arg( 'cmpl_group', '$outer', $outer );
1263 0         0 (my $group_per_h, $group_per)
1264             = $topic->_atnms_hr_from_assert_valid_atnms_arg(
1265             'cmpl_group', '$group_per', $group_per );
1266              
1267 0         0 my $topic_h = $topic->_heading();
1268              
1269             confess q{cmpl_group(): Bad $group_per arg; that attr list}
1270             . q{ isn't a subset of the invocant's heading.}
1271 0 0   0   0 if notall { exists $topic_h->{$_} } @{$group_per};
  0         0  
  0         0  
1272              
1273 0         0 my $inner = [grep { !$group_per_h->{$_} } CORE::keys %{$topic_h}];
  0         0  
  0         0  
1274 0         0 my $inner_h = {CORE::map { $_ => undef } @{$inner}};
  0         0  
  0         0  
1275              
1276 0         0 my (undef, $topic_attrs_no_gr, undef)
1277             = $topic->_ptn_conj_and_disj( $topic_h, $inner_h );
1278             confess q{cmpl_group(): Bad $outer arg; that name for a new attr to}
1279             . q{ add to th invocant, consisting of grouped invocant attrs,}
1280             . q{ duplicates an attr of the invocant not being grouped.}
1281 0 0   0   0 if any { $_ eq $outer } @{$topic_attrs_no_gr};
  0         0  
  0         0  
1282              
1283 0         0 return $topic->_group( $outer, $inner, $topic_attrs_no_gr, $inner_h );
1284             }
1285              
1286             ###########################################################################
1287              
1288             sub ungroup {
1289 0     0 0 0 my ($topic, $inner, $outer) = @_;
1290              
1291 0         0 (my $inner_h, $inner) = $topic->_atnms_hr_from_assert_valid_atnms_arg(
1292             'ungroup', '$inner', $inner );
1293 0         0 $topic->_assert_valid_atnm_arg( 'ungroup', '$outer', $outer );
1294              
1295 0         0 my $topic_h = $topic->_heading();
1296              
1297             confess q{ungroup(): Bad $outer arg; that attr name}
1298             . q{ doesn't match an attr of the invocant's heading.}
1299 0 0       0 if !exists $topic_h->{$outer};
1300              
1301 0         0 my $topic_h_except_outer = {%{$topic_h}};
  0         0  
1302 0         0 CORE::delete $topic_h_except_outer->{$outer};
1303              
1304 0         0 my ($inner_attrs_dupl_topic, $topic_attrs_no_ugr, undef)
1305             = $topic->_ptn_conj_and_disj( $topic_h_except_outer, $inner_h );
1306             confess q{ungroup(): Bad $inner arg; at least one name in that attr}
1307             . q{ list, which the invocant would be extended with when}
1308             . q{ ungrouping $topic{$outer}, duplicates an attr of the}
1309             . q{ invocant not being ungrouped.}
1310 0 0       0 if @{$inner_attrs_dupl_topic} > 0;
  0         0  
1311              
1312 0         0 my $topic_b = $topic->_body();
1313              
1314 0         0 for my $topic_t (values %{$topic_b}) {
  0         0  
1315 0         0 my $inner_r = $topic_t->{$outer}->[0];
1316 0 0 0     0 confess q{ungroup(): Can't ungroup $topic{$outer} because there is}
      0        
1317             . q{ not a same-heading relation val for the $outer attr}
1318             . q{ of every tuple of $topic whose head matches $inner.}
1319             if !blessed $inner_r or !$inner_r->isa( __PACKAGE__ )
1320             or !$topic->_is_identical_hkeys(
1321             $inner_h, $inner_r->_heading() );
1322             }
1323              
1324 0 0       0 if ($topic->degree() == 1) {
1325             # Ungroup of a unary relation is the N-adic union of its sole
1326             # attribute's value across all tuples.
1327             return $topic->_new( $inner )
1328 0         0 ->_union( [CORE::map { $_->{$outer} } values %{$topic_b}] );
  0         0  
  0         0  
1329             }
1330              
1331             # If we get here, the input relation is not unary.
1332              
1333 0         0 my $result = $topic->_new();
1334              
1335 0         0 $result->_heading( {%{$topic_h_except_outer}, %{$inner_h}} );
  0         0  
  0         0  
1336 0         0 $result->_degree( @{$topic_attrs_no_ugr} + @{$inner} );
  0         0  
  0         0  
1337              
1338             my $topic_tuples_w_nonemp_inn
1339 0         0 = [grep { !$_->{$outer}->is_empty() } values %{$topic_b}];
  0         0  
  0         0  
1340              
1341 0 0       0 if (@{$topic_tuples_w_nonemp_inn} == 0) {
  0 0       0  
1342             # An empty post-basic-filtering $topic means an empty result.
1343             # So result body is already correct.
1344             }
1345 0         0 elsif (@{$inner} == 0) {
1346             # Ungroup of $outer adds zero attrs to $topic.
1347             # So this is a simple proj of post-basic-filt $topic excis $outer.
1348 0         0 my $result_b = $result->_body();
1349 0         0 for my $topic_t (@{$topic_tuples_w_nonemp_inn}) {
  0         0  
1350             my $result_t = {
1351 0         0 CORE::map { ($_ => $topic_t->{$_}) } @{$topic_attrs_no_ugr}
  0         0  
  0         0  
1352             };
1353 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1354 0         0 $result_b->{$result_t_ident_str} = $result_t;
1355             }
1356 0         0 $result->_cardinality( scalar @{$topic_tuples_w_nonemp_inn} );
  0         0  
1357             }
1358             else {
1359             # Result has at least 1 attr from $outer, at least 1 not from it.
1360 0         0 my $result_b = $result->_body();
1361 0         0 for my $topic_t (@{$topic_tuples_w_nonemp_inn}) {
  0         0  
1362 0         0 my $no_ugr_t = {CORE::map { ($_ => $topic_t->{$_}) }
1363 0         0 @{$topic_attrs_no_ugr}};
  0         0  
1364 0         0 my $inner_r = $topic_t->{$outer}->[0];
1365 0         0 for my $inner_t (values %{$inner_r->_body()}) {
  0         0  
1366 0         0 my $result_t = {%{$inner_t}, %{$no_ugr_t}};
  0         0  
  0         0  
1367 0         0 $result_b->{$topic->_ident_str( $result_t )} = $result_t;
1368             }
1369             }
1370 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
1371             }
1372              
1373 0         0 return $result;
1374             }
1375              
1376             ###########################################################################
1377              
1378             sub tclose {
1379 0     0 0 0 my ($topic) = @_;
1380              
1381 0 0       0 confess q{tclose(): This method may only be invoked on a}
1382             . q{ Set::Relation object with exactly 2 (same-typed) attrs.}
1383             if $topic->degree() != 2;
1384              
1385 0 0       0 if ($topic->cardinality() < 2) {
1386             # Can't create paths of 2+ arcs when not more than 1 arc exists.
1387 0         0 return $topic;
1388             }
1389              
1390             # If we get here, there are at least 2 arcs, so there is a chance they
1391             # may connect into longer paths.
1392              
1393 0         0 my ($atnm1, $atnm2) = sort (CORE::keys %{$topic->_heading()});
  0         0  
1394              
1395 0         0 return $topic->_rename( { 'x' => $atnm1, 'y' => $atnm2 } )
1396             ->_tclose_of_xy()
1397             ->_rename( { $atnm1 => 'x', $atnm2 => 'y' } );
1398             }
1399              
1400             # TODO: Reimplement tclose to do all the work internally rather
1401             # than farming out to rename/join/projection/union/etc; this should make
1402             # performance an order of magnitude better and without being complicated.
1403              
1404             sub _tclose_of_xy {
1405 0     0   0 my ($xy) = @_;
1406              
1407 0         0 my $xyz = $xy->_rename( { 'y' => 'x', 'z' => 'y' } )
1408             ->_regular_join( $xy, ['y'], ['z'], ['x'] );
1409              
1410 0 0       0 if ($xyz->is_empty()) {
1411             # No paths of xy connect to any other paths of xy.
1412 0         0 return $xy;
1413             }
1414              
1415             # If we get here, then at least one pair of paths in xy can connect
1416             # to form a longer path.
1417              
1418 0         0 my $ttt = $xyz->_projection( ['x', 'z'] )
1419             ->_rename( { 'y' => 'z' } )
1420             ->_union( [$xy] );
1421              
1422 0 0       0 if ($ttt->_is_identical( $xy )) {
1423             # All the longer paths resulting from conn were already in xy.
1424 0         0 return $xy;
1425             }
1426              
1427             # If we get here, then at least one longer path produced above was not
1428             # already in xy and was added; so now we need to check if any
1429             # yet-longer paths can be made from the just-produced.
1430              
1431 0         0 return $ttt->_tclose_of_xy();
1432             }
1433              
1434             ###########################################################################
1435              
1436             sub restriction {
1437 16     16 0 539 my ($topic, $func, $allow_dup_tuples) = @_;
1438              
1439 16         41 $topic->_assert_valid_func_arg( 'restriction', '$func', $func );
1440              
1441 16 50       30 if ($topic->is_empty()) {
1442 0         0 return $topic;
1443             }
1444              
1445 16         33 my $result = $topic->empty();
1446              
1447 16         26 my $topic_b = $topic->_body();
1448 16         20 my $result_b = $result->_body();
1449              
1450 16         18 for my $topic_t_ident_str (CORE::keys %{$topic_b}) {
  16         38  
1451 74         87 my $topic_t = $topic_b->{$topic_t_ident_str};
1452 74         76 my $is_matched;
1453             {
1454 74         76 local $_ = $topic->_export_nfmt_tuple( $topic_t );
  74         93  
1455 74         126 $is_matched = $func->();
1456             }
1457 74 100       296 if ($is_matched) {
1458 16         30 $result_b->{$topic_t_ident_str} = $topic_t;
1459             }
1460             }
1461 16         21 $result->_cardinality( scalar CORE::keys %{$result_b} );
  16         46  
1462              
1463 16         38 return $result;
1464             }
1465              
1466             sub restr_and_cmpl {
1467 0     0 0 0 my ($topic, $func, $allow_dup_tuples) = @_;
1468 0         0 $topic->_assert_valid_func_arg( 'restr_and_cmpl', '$func', $func );
1469 0         0 return $topic->_restr_and_cmpl( $func );
1470             }
1471              
1472             sub _restr_and_cmpl {
1473 0     0   0 my ($topic, $func) = @_;
1474              
1475 0 0       0 if ($topic->is_empty()) {
1476 0         0 return [$topic, $topic];
1477             }
1478              
1479 0         0 my $pass_result = $topic->empty();
1480 0         0 my $fail_result = $topic->empty();
1481              
1482 0         0 my $topic_b = $topic->_body();
1483 0         0 my $pass_result_b = $pass_result->_body();
1484 0         0 my $fail_result_b = $fail_result->_body();
1485              
1486 0         0 for my $topic_t_ident_str (CORE::keys %{$topic_b}) {
  0         0  
1487 0         0 my $topic_t = $topic_b->{$topic_t_ident_str};
1488 0         0 my $is_matched;
1489             {
1490 0         0 local $_ = $topic->_export_nfmt_tuple( $topic_t );
  0         0  
1491 0         0 $is_matched = $func->();
1492             }
1493 0 0       0 if ($is_matched) {
1494 0         0 $pass_result_b->{$topic_t_ident_str} = $topic_t;
1495             }
1496             else {
1497 0         0 $fail_result_b->{$topic_t_ident_str} = $topic_t;
1498             }
1499             }
1500 0         0 $pass_result->_cardinality( scalar CORE::keys %{$pass_result_b} );
  0         0  
1501 0         0 $fail_result->_cardinality( scalar CORE::keys %{$fail_result_b} );
  0         0  
1502              
1503 0         0 return [$pass_result, $fail_result];
1504             }
1505              
1506             sub cmpl_restr {
1507 0     0 0 0 my ($topic, $func, $allow_dup_tuples) = @_;
1508              
1509 0         0 $topic->_assert_valid_func_arg( 'cmpl_restr', '$func', $func );
1510              
1511 0 0       0 if ($topic->is_empty()) {
1512 0         0 return $topic;
1513             }
1514              
1515 0         0 my $result = $topic->empty();
1516              
1517 0         0 my $topic_b = $topic->_body();
1518 0         0 my $result_b = $result->_body();
1519              
1520 0         0 for my $topic_t_ident_str (CORE::keys %{$topic_b}) {
  0         0  
1521 0         0 my $topic_t = $topic_b->{$topic_t_ident_str};
1522 0         0 my $is_matched;
1523             {
1524 0         0 local $_ = $topic->_export_nfmt_tuple( $topic_t );
  0         0  
1525 0         0 $is_matched = $func->();
1526             }
1527 0 0       0 if (!$is_matched) {
1528 0         0 $result_b->{$topic_t_ident_str} = $topic_t;
1529             }
1530             }
1531 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
1532              
1533 0         0 return $result;
1534             }
1535              
1536             ###########################################################################
1537              
1538             sub classification {
1539 0     0 0 0 my ($topic, $func, $class_attr_name, $group_attr_name,
1540             $allow_dup_tuples) = @_;
1541              
1542 0         0 $topic->_assert_valid_func_arg( 'classification', '$func', $func );
1543 0         0 $topic->_assert_valid_atnm_arg(
1544             'classification', '$class_attr_name', $class_attr_name );
1545 0         0 $topic->_assert_valid_atnm_arg(
1546             'classification', '$group_attr_name', $group_attr_name );
1547              
1548 0         0 my $result = $topic->_new();
1549              
1550 0         0 $result->_heading(
1551             {$class_attr_name => undef, $group_attr_name => undef} );
1552 0         0 $result->_degree( 2 );
1553              
1554 0 0       0 if ($topic->is_empty()) {
1555             # An empty $topic means an empty result.
1556             # So result body is already correct.
1557 0         0 return $result;
1558             }
1559              
1560 0         0 my $topic_h = $topic->_heading();
1561 0         0 my $topic_degree = $topic->degree();
1562 0         0 my $topic_b = $topic->_body();
1563              
1564 0         0 my $tuples_per_class = {};
1565              
1566 0         0 for my $topic_t_ident_str (CORE::keys %{$topic_b}) {
  0         0  
1567 0         0 my $topic_t = $topic_b->{$topic_t_ident_str};
1568 0         0 my $class;
1569             {
1570 0         0 local $_ = $topic->_export_nfmt_tuple( $topic_t );
  0         0  
1571 0         0 $class = $func->();
1572             }
1573 0         0 my $class_ident_str = $topic->_ident_str( $class );
1574 0 0       0 if (!exists $tuples_per_class->{$class_ident_str}) {
1575 0         0 $tuples_per_class->{$class_ident_str} = [$class, []];
1576             }
1577 0         0 push @{$tuples_per_class->{$class_ident_str}->[1]},
  0         0  
1578             [$topic_t, $topic_t_ident_str];
1579             }
1580              
1581 0         0 my $result_b = $result->_body();
1582 0         0 for my $class_ident_str (CORE::keys %{$tuples_per_class}) {
  0         0  
1583             my ($class, $tuples_in_class)
1584 0         0 = @{$tuples_per_class->{$class_ident_str}};
  0         0  
1585              
1586 0         0 my $inner_r = $topic->_new();
1587 0         0 $inner_r->_heading( $topic_h );
1588 0         0 $inner_r->_degree( $topic_degree );
1589 0         0 my $inner_b = $inner_r->_body();
1590 0         0 for my $topic_t_w_ident (@{$tuples_in_class}) {
  0         0  
1591 0         0 my ($topic_t, $topic_t_ident_str) = @{$topic_t_w_ident};
  0         0  
1592 0         0 $inner_b->{$topic_t_ident_str} = $topic_t;
1593             }
1594 0         0 $inner_r->_cardinality( scalar @{$tuples_in_class} );
  0         0  
1595 0         0 my $outer_atvl = [$inner_r, $inner_r->which()];
1596              
1597 0         0 my $result_t = {
1598             $class_attr_name => [$class, $class_ident_str],
1599             $group_attr_name => $outer_atvl,
1600             };
1601 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1602 0         0 $result_b->{$result_t_ident_str} = $result_t;
1603             }
1604 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
1605              
1606 0         0 return $result;
1607             }
1608              
1609             ###########################################################################
1610              
1611             sub extension {
1612 0     0 0 0 my ($topic, $attr_names, $func, $allow_dup_tuples) = @_;
1613              
1614 0         0 (my $exten_h, $attr_names)
1615             = $topic->_atnms_hr_from_assert_valid_atnms_arg(
1616             'extension', '$attr_names', $attr_names );
1617 0         0 $topic->_assert_valid_func_arg( 'extension', '$func', $func );
1618              
1619 0         0 my ($both, undef, undef)
1620             = $topic->_ptn_conj_and_disj( $topic->_heading(), $exten_h );
1621             confess q{extension(): Bad $attr_names arg; that attr list}
1622             . q{ isn't disjoint with the invocant's heading.}
1623 0 0       0 if @{$both} > 0;
  0         0  
1624              
1625 0         0 return $topic->_extension( $attr_names, $func, $exten_h );
1626             }
1627              
1628             sub _extension {
1629 0     0   0 my ($topic, $attr_names, $func, $exten_h) = @_;
1630              
1631 0 0       0 if (@{$attr_names} == 0) {
  0         0  
1632             # Extension of input by zero attrs yields the input.
1633 0         0 return $topic;
1634             }
1635              
1636 0         0 my $result = $topic->_new();
1637              
1638 0         0 $result->_heading( {%{$topic->_heading()}, %{$exten_h}} );
  0         0  
  0         0  
1639 0         0 $result->_degree( $topic->degree() + @{$attr_names} );
  0         0  
1640              
1641 0         0 my $result_b = $result->_body();
1642              
1643 0         0 for my $topic_t (values %{$topic->_body()}) {
  0         0  
1644 0         0 my $exten_t;
1645             {
1646 0         0 local $_ = $topic->_export_nfmt_tuple( $topic_t );
  0         0  
1647 0         0 $exten_t = $func->();
1648             }
1649             $topic->_assert_valid_tuple_result_of_func_arg(
1650 0         0 'extension', '$func', '$attr_names', $exten_t, $exten_h );
1651 0         0 $exten_t = $topic->_import_nfmt_tuple( $exten_t );
1652 0         0 my $result_t = {%{$topic_t}, %{$exten_t}};
  0         0  
  0         0  
1653 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1654 0         0 $result_b->{$result_t_ident_str} = $result_t;
1655             }
1656 0         0 $result->_cardinality( $topic->cardinality() );
1657              
1658 0         0 return $result;
1659             }
1660              
1661             ###########################################################################
1662              
1663             sub static_exten {
1664 0     0 0 0 my ($topic, $attrs) = @_;
1665              
1666 0 0       0 confess q{static_exten(): Bad $attrs arg; it isn't a hash-ref.}
1667             if ref $attrs ne 'HASH';
1668              
1669 0         0 my ($both, undef, undef)
1670             = $topic->_ptn_conj_and_disj( $topic->_heading(), $attrs );
1671             confess q{static_exten(): Bad $attrs arg; that attr list}
1672             . q{ isn't disjoint with the invocant's heading.}
1673 0 0       0 if @{$both} > 0;
  0         0  
1674              
1675 0 0       0 confess q{static_exten(): Bad $attrs arg;}
1676             . q{ it is a hash-ref, and there exist circular refs}
1677             . q{ between itself or its tuple-valued components.}
1678             if $topic->_tuple_arg_has_circular_refs( $attrs );
1679              
1680 0         0 return $topic->_static_exten( $attrs );
1681             }
1682              
1683             sub _static_exten {
1684 0     0   0 my ($topic, $attrs) = @_;
1685              
1686 0 0       0 if ((scalar CORE::keys %{$attrs}) == 0) {
  0         0  
1687             # Extension of input by zero attrs yields the input.
1688 0         0 return $topic;
1689             }
1690              
1691 0         0 $attrs = $topic->_import_nfmt_tuple( $attrs );
1692              
1693 0         0 my $result = $topic->_new();
1694              
1695 0         0 $result->_heading( {%{$topic->_heading()},
1696 0         0 CORE::map { ($_ => undef) } CORE::keys %{$attrs}} );
  0         0  
  0         0  
1697 0         0 $result->_degree( $topic->degree() + (scalar CORE::keys %{$attrs}) );
  0         0  
1698              
1699 0         0 my $result_b = $result->_body();
1700              
1701 0         0 for my $topic_t (values %{$topic->_body()}) {
  0         0  
1702 0         0 my $result_t = {%{$topic_t}, %{$attrs}};
  0         0  
  0         0  
1703 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1704 0         0 $result_b->{$result_t_ident_str} = $result_t;
1705             }
1706 0         0 $result->_cardinality( $topic->cardinality() );
1707              
1708 0         0 return $result;
1709             }
1710              
1711             ###########################################################################
1712              
1713             sub map {
1714 0     0 0 0 my ($topic, $result_attr_names, $func, $allow_dup_tuples) = @_;
1715              
1716 0         0 (my $result_h, $result_attr_names)
1717             = $topic->_atnms_hr_from_assert_valid_atnms_arg(
1718             'map', '$result_attr_names', $result_attr_names );
1719 0         0 $topic->_assert_valid_func_arg( 'map', '$func', $func );
1720              
1721 0 0       0 if (@{$result_attr_names} == 0) {
  0         0  
1722             # Map to zero attrs yields identity relation zero or one.
1723 0 0       0 if ($topic->is_empty()) {
1724 0         0 return $topic->_new();
1725             }
1726             else {
1727 0         0 return $topic->_new( [ {} ] );
1728             }
1729             }
1730              
1731 0         0 my $result = $topic->_new();
1732              
1733 0         0 $result->_heading( $result_h );
1734 0         0 $result->_degree( scalar @{$result_attr_names} );
  0         0  
1735              
1736 0         0 my $result_b = $result->_body();
1737              
1738 0         0 for my $topic_t (values %{$topic->_body()}) {
  0         0  
1739 0         0 my $result_t;
1740             {
1741 0         0 local $_ = $topic->_export_nfmt_tuple( $topic_t );
  0         0  
1742 0         0 $result_t = $func->();
1743             }
1744             $topic->_assert_valid_tuple_result_of_func_arg(
1745 0         0 'map', '$func', '$result_attr_names', $result_t, $result_h );
1746 0         0 $result_t = $topic->_import_nfmt_tuple( $result_t );
1747 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1748 0 0       0 if (!exists $result_b->{$result_t_ident_str}) {
1749 0         0 $result_b->{$result_t_ident_str} = $result_t;
1750             }
1751             }
1752 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
1753              
1754 0         0 return $result;
1755             }
1756              
1757             ###########################################################################
1758              
1759             sub summary {
1760 0     0 0 0 my ($topic, $group_per, $summ_attr_names, $summ_func,
1761             $allow_dup_tuples) = @_;
1762              
1763 0         0 (my $group_per_h, $group_per)
1764             = $topic->_atnms_hr_from_assert_valid_atnms_arg(
1765             'summary', '$group_per', $group_per );
1766 0         0 (my $exten_h, $summ_attr_names)
1767             = $topic->_atnms_hr_from_assert_valid_atnms_arg(
1768             'summary', '$summ_attr_names', $summ_attr_names );
1769 0         0 $topic->_assert_valid_func_arg( 'summary', '$summ_func', $summ_func );
1770              
1771 0         0 my $topic_h = $topic->_heading();
1772              
1773             confess q{summary(): Bad $group_per arg; that attr list}
1774             . q{ isn't a subset of the invocant's heading.}
1775 0 0   0   0 if notall { exists $topic_h->{$_} } @{$group_per};
  0         0  
  0         0  
1776              
1777             confess q{summary(): Bad $summ_attr_names arg; one or more of those}
1778             . q{ names for new summary attrs to add to the invocant }
1779             . q{ duplicates an attr of the invocant not being grouped.}
1780 0 0   0   0 if any { exists $group_per_h->{$_} } @{$summ_attr_names};
  0         0  
  0         0  
1781              
1782 0         0 my $inner = [grep { !$group_per_h->{$_} } CORE::keys %{$topic_h}];
  0         0  
  0         0  
1783 0         0 my $inner_h = {CORE::map { $_ => undef } @{$inner}};
  0         0  
  0         0  
1784              
1785 0         0 my (undef, $topic_attrs_no_gr, undef)
1786             = $topic->_ptn_conj_and_disj( $topic_h, $inner_h );
1787              
1788 0         0 my $result = $topic->_new();
1789              
1790 0         0 $result->_heading( {%{$group_per_h}, %{$exten_h}} );
  0         0  
  0         0  
1791 0         0 $result->_degree( @{$group_per} + @{$summ_attr_names} );
  0         0  
  0         0  
1792              
1793 0 0       0 if ($topic->is_empty()) {
1794             # An empty $topic means an empty result.
1795 0         0 return $result;
1796             }
1797              
1798             # Note: We skipped a number of shortcuts that _group() has for
1799             # brevity, leaving just the general case; they might come back later.
1800              
1801 0         0 my $result_b = $result->_body();
1802 0         0 my $topic_index = $topic->_want_index( $topic_attrs_no_gr );
1803 0         0 for my $matched_topic_b (values %{$topic_index}) {
  0         0  
1804              
1805 0         0 my $inner_r = $topic->_new();
1806 0         0 $inner_r->_heading( $inner_h );
1807 0         0 $inner_r->_degree( scalar @{$inner} );
  0         0  
1808 0         0 my $inner_b = $inner_r->_body();
1809 0         0 for my $topic_t (values %{$matched_topic_b}) {
  0         0  
1810 0         0 my $inner_t = {CORE::map { ($_ => $topic_t->{$_}) } @{$inner}};
  0         0  
  0         0  
1811 0         0 $inner_b->{$topic->_ident_str( $inner_t )} = $inner_t;
1812             }
1813 0         0 $inner_r->_cardinality( scalar CORE::keys %{$matched_topic_b} );
  0         0  
1814              
1815 0         0 my $any_mtpt = (values %{$matched_topic_b})[0];
  0         0  
1816 0         0 my $group_per_t = {CORE::map { ($_ => $any_mtpt->{$_}) }
1817 0         0 @{$topic_attrs_no_gr}};
  0         0  
1818              
1819 0         0 my $exten_t;
1820             {
1821 0         0 local $_ = {
  0         0  
1822             'summarize' => $inner_r,
1823             'per' => $topic->_export_nfmt_tuple( $group_per_t ),
1824             };
1825 0         0 $exten_t = $summ_func->();
1826             }
1827 0         0 $topic->_assert_valid_tuple_result_of_func_arg( 'summary',
1828             '$summ_func', '$summ_attr_names', $exten_t, $exten_h );
1829 0         0 $exten_t = $topic->_import_nfmt_tuple( $exten_t );
1830              
1831 0         0 my $result_t = {%{$group_per_t}, %{$exten_t}};
  0         0  
  0         0  
1832 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1833 0 0       0 if (!exists $result_b->{$result_t_ident_str}) {
1834 0         0 $result_b->{$result_t_ident_str} = $result_t;
1835             }
1836             }
1837 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
1838              
1839 0         0 return $result;
1840             }
1841              
1842             ###########################################################################
1843              
1844             sub cardinality_per_group {
1845 0     0 0 0 my ($topic, $count_attr_name, $group_per, $allow_dup_tuples) = @_;
1846              
1847 0         0 $topic->_assert_valid_atnm_arg(
1848             'cardinality_per_group', '$count_attr_name', $count_attr_name );
1849 0         0 (my $group_per_h, $group_per)
1850             = $topic->_atnms_hr_from_assert_valid_atnms_arg(
1851             'cardinality_per_group', '$group_per', $group_per );
1852              
1853 0         0 my $topic_h = $topic->_heading();
1854              
1855             confess q{cardinality_per_group(): Bad $group_per arg;}
1856             . q{ that attr list isn't a subset of the invocant's heading.}
1857 0 0   0   0 if notall { exists $topic_h->{$_} } @{$group_per};
  0         0  
  0         0  
1858              
1859             confess q{cardinality_per_group(): Bad $count_attr_name arg;}
1860             . q{ that name for a new attr to add to the invocant}
1861             . q{ duplicates an attr of the invocant not being grouped.}
1862 0 0       0 if exists $group_per_h->{$count_attr_name};
1863              
1864 0         0 my $inner = [grep { !$group_per_h->{$_} } CORE::keys %{$topic_h}];
  0         0  
  0         0  
1865 0         0 my $inner_h = {CORE::map { $_ => undef } @{$inner}};
  0         0  
  0         0  
1866              
1867 0         0 my (undef, $topic_attrs_no_gr, undef)
1868             = $topic->_ptn_conj_and_disj( $topic_h, $inner_h );
1869              
1870 0         0 my $result = $topic->_new();
1871              
1872 0         0 $result->_heading( {%{$group_per_h}, $count_attr_name => undef} );
  0         0  
1873 0         0 $result->_degree( @{$group_per} + 1 );
  0         0  
1874              
1875 0 0       0 if ($topic->is_empty()) {
1876             # An empty $topic means an empty result.
1877 0         0 return $result;
1878             }
1879              
1880 0         0 my $result_b = $result->_body();
1881 0         0 my $topic_index = $topic->_want_index( $topic_attrs_no_gr );
1882 0         0 for my $matched_topic_b (values %{$topic_index}) {
  0         0  
1883 0         0 my $count = scalar CORE::keys %{$matched_topic_b};
  0         0  
1884 0         0 my $any_mtpt = (values %{$matched_topic_b})[0];
  0         0  
1885 0         0 my $group_per_t = {CORE::map { ($_ => $any_mtpt->{$_}) }
1886 0         0 @{$topic_attrs_no_gr}};
  0         0  
1887 0         0 my $result_t = {%{$group_per_t}, $count_attr_name => $count};
  0         0  
1888 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
1889 0 0       0 if (!exists $result_b->{$result_t_ident_str}) {
1890 0         0 $result_b->{$result_t_ident_str} = $result_t;
1891             }
1892             }
1893 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
1894              
1895 0         0 return $result;
1896             }
1897              
1898             sub count_per_group {
1899 0     0 0 0 my ($self, @args) = @_;
1900 0         0 return $self->cardinality_per_group( @args );
1901             }
1902              
1903             ###########################################################################
1904              
1905             sub _atnms_hr_from_assert_valid_atnms_arg {
1906 2     2   6 my ($self, $rtn_nm, $arg_nm, $atnms) = @_;
1907              
1908 2 100 66     13 if (defined $atnms and !ref $atnms) {
1909 1         2 $atnms = [$atnms];
1910             }
1911 2 50       9 confess qq{$rtn_nm(): Bad $arg_nm arg;}
1912             . q{ it must be an array-ref or a defined non-ref.}
1913             if ref $atnms ne 'ARRAY';
1914             confess qq{$rtn_nm(): Bad $arg_nm arg;}
1915             . q{ it should be just be a list of attr names,}
1916             . q{ but at least one name is undefined or is a ref.}
1917 2 50   4   9 if notall { defined $_ and !ref $_ } @{$atnms};
  4 50       15  
  2         8  
1918             confess qq{$rtn_nm(): Bad $arg_nm arg;}
1919             . q{ it specifies a list of}
1920             . q{ attr names with at least one duplicated name.}
1921 2 50       8 if (uniqstr @{$atnms}) != @{$atnms};
  2         9  
  2         7  
1922              
1923 2         5 my $heading = {CORE::map { ($_ => undef) } @{$atnms}};
  4         9  
  2         4  
1924 2         7 return ($heading, $atnms);
1925             }
1926              
1927             sub _assert_valid_atnm_arg {
1928 5     5   10 my ($self, $rtn_nm, $arg_nm, $atnm) = @_;
1929 5 50 33     23 confess qq{$rtn_nm(): Bad $arg_nm arg;}
1930             . q{ it should be just be an attr name,}
1931             . q{ but it is undefined or is a ref.}
1932             if !defined $atnm or ref $atnm;
1933             }
1934              
1935             sub _assert_valid_nnint_arg {
1936 0     0   0 my ($self, $rtn_nm, $arg_nm, $atnm) = @_;
1937 0 0 0     0 confess qq{$rtn_nm(): Bad $arg_nm arg;}
      0        
1938             . q{ it should be just be a non-negative integer,}
1939             . q{ but it is undefined or is a ref or is some other scalar.}
1940             if !defined $atnm or ref $atnm or not $atnm =~ /^[0-9]+$/;
1941             }
1942              
1943             sub _assert_valid_func_arg {
1944 16     16   27 my ($self, $rtn_nm, $arg_nm, $func) = @_;
1945 16 50       44 confess qq{$rtn_nm(): Bad $arg_nm arg;}
1946             . q{ it must be a Perl subroutine reference.}
1947             if ref $func ne 'CODE';
1948             }
1949              
1950             sub _assert_valid_tuple_result_of_func_arg {
1951 0     0   0 my ($self, $rtn_nm, $arg_nm_func, $arg_nm_attrs, $result_t, $heading)
1952             = @_;
1953 0 0 0     0 confess qq{$rtn_nm(): Bad $arg_nm_func arg;}
1954             . q{ at least one result of executing that Perl subroutine}
1955             . q{ reference was not a hash-ref or it didn't have the same}
1956             . qq{ set of hkeys as specified by the $arg_nm_attrs arg.}
1957             if ref $result_t ne 'HASH'
1958             or !$self->_is_identical_hkeys( $heading, $result_t );
1959 0 0       0 confess qq{$rtn_nm(): Bad $arg_nm_func arg;}
1960             . q{ at least one result of executing that Perl subroutine}
1961             . q{ reference was a hash-ref, and there exist circular refs}
1962             . q{ between itself or its tuple-valued components.}
1963             if $self->_tuple_arg_has_circular_refs( $result_t );
1964             }
1965              
1966             sub _normalize_same_heading_relation_arg {
1967 0     0   0 my ($self, $rtn_nm, $arg_nm, $other) = @_;
1968 0 0 0     0 if (blessed $other and $other->can( 'does' )
      0        
      0        
1969             and $other->does( 'Set::Relation' )
1970             and !$other->isa( __PACKAGE__ )) {
1971 0         0 $other = $self->_new( $other );
1972             }
1973 0 0 0     0 confess qq{$rtn_nm(): Bad $arg_nm arg; it isn't a Set::Relation}
      0        
1974             . q{ object, or it doesn't have exactly the}
1975             . q{ same set of attr names as the invocant.}
1976             if !blessed $other or !$other->isa( __PACKAGE__ )
1977             or !$self->_is_identical_hkeys(
1978             $self->_heading(), $other->_heading() );
1979 0         0 return $other;
1980             }
1981              
1982             sub _normalize_relation_arg {
1983 22     22   47 my ($self, $rtn_nm, $arg_nm, $other) = @_;
1984 22 50 33     138 if (blessed $other and $other->can( 'does' )
      33        
      33        
1985             and $other->does( 'Set::Relation' )
1986             and !$other->isa( __PACKAGE__ )) {
1987 0         0 $other = $self->_new( $other );
1988             }
1989 22 50 33     94 confess qq{$rtn_nm(): Bad $arg_nm arg;}
1990             . q{ it isn't a Set::Relation object.}
1991             if !blessed $other or !$other->isa( __PACKAGE__ );
1992 22         35 return $other;
1993             }
1994              
1995             ###########################################################################
1996              
1997             sub is_identical {
1998 22     22 0 892 my ($topic, $other) = @_;
1999 22         45 $other = $topic->_normalize_relation_arg(
2000             'is_identical', '$other', $other );
2001 22         45 return $topic->_is_identical( $other );
2002             }
2003              
2004             sub _is_identical {
2005 22     22   33 my ($topic, $other) = @_;
2006 22   66     36 return ($topic->degree() == $other->degree()
2007             and $topic->cardinality() == $other->cardinality()
2008             and $topic->_is_identical_hkeys(
2009             $topic->_heading(), $other->_heading() )
2010             and $topic->_is_identical_hkeys(
2011             $topic->_body(), $other->_body() ));
2012             }
2013              
2014             ###########################################################################
2015              
2016             sub is_subset {
2017 0     0 0 0 my ($topic, $other) = @_;
2018 0         0 $other = $topic->_normalize_same_heading_relation_arg(
2019             'is_subset', '$other', $other );
2020 0         0 my $other_b = $other->_body();
2021 0     0   0 return all { exists $other_b->{$_} }
2022 0         0 CORE::keys %{$topic->_body()};
  0         0  
2023             }
2024              
2025             sub is_superset {
2026 0     0 0 0 my ($topic, $other) = @_;
2027 0         0 $other = $topic->_normalize_same_heading_relation_arg(
2028             'is_superset', '$other', $other );
2029 0         0 my $topic_b = $topic->_body();
2030 0     0   0 return all { exists $topic_b->{$_} }
2031 0         0 CORE::keys %{$other->_body()};
  0         0  
2032             }
2033              
2034             sub is_proper_subset {
2035 0     0 0 0 my ($topic, $other) = @_;
2036 0         0 $other = $topic->_normalize_same_heading_relation_arg(
2037             'is_proper_subset', '$other', $other );
2038 0         0 my $other_b = $other->_body();
2039             return ($topic->cardinality() < $other->cardinality()
2040 0     0   0 and all { exists $other_b->{$_} }
2041 0   0     0 CORE::keys %{$topic->_body()});
2042             }
2043              
2044             sub is_proper_superset {
2045 0     0 0 0 my ($topic, $other) = @_;
2046 0         0 $other = $topic->_normalize_same_heading_relation_arg(
2047             'is_proper_superset', '$other', $other );
2048 0         0 my $topic_b = $topic->_body();
2049             return ($other->cardinality() < $topic->cardinality()
2050 0     0   0 and all { exists $topic_b->{$_} }
2051 0   0     0 CORE::keys %{$other->_body()});
2052             }
2053              
2054             sub is_disjoint {
2055 0     0 0 0 my ($topic, $other) = @_;
2056 0         0 $other = $topic->_normalize_same_heading_relation_arg(
2057             'is_disjoint', '$other', $other );
2058 0         0 return $topic->_intersection( [$other] )->is_empty();
2059             }
2060              
2061             ###########################################################################
2062              
2063             sub union {
2064 2     2 0 10 my ($topic, $others) = @_;
2065 2         9 $others = $topic->_normalize_same_heading_relations_arg(
2066             'union', '$others', $others );
2067 2         19 return $topic->_union( $others );
2068             }
2069              
2070             sub _union {
2071 2     2   4 my ($topic, $others) = @_;
2072              
2073             my $inputs = [
2074 2         6 sort { $b->cardinality() <=> $a->cardinality() }
2075 4         9 grep { !$_->is_empty() } # filter out identity value instances
2076 2         4 $topic, @{$others}];
  2         3  
2077              
2078 2 50       3 if (@{$inputs} == 0) {
  2         6  
2079             # All inputs were the identity value; so is result.
2080 0         0 return $topic->empty();
2081             }
2082 2 50       4 if (@{$inputs} == 1) {
  2         4  
2083             # Only one non-identity value input; so it is the result.
2084 0         0 return $inputs->[0];
2085             }
2086              
2087             # If we get here, there are at least 2 non-empty input relations.
2088              
2089 2         4 my $largest = shift @{$inputs};
  2         3  
2090              
2091 2         5 my $result = $largest->_new( $largest );
2092              
2093 2         3 my $smaller_bs = [CORE::map { $_->_body() } @{$inputs}];
  2         3  
  2         4  
2094 2         5 my $result_b = $result->_body();
2095              
2096 2         3 for my $smaller_b (@{$smaller_bs}) {
  2         4  
2097 2         3 for my $tuple_ident_str (CORE::keys %{$smaller_b}) {
  2         4  
2098 4 100       8 if (!exists $result_b->{$tuple_ident_str}) {
2099             $result_b->{$tuple_ident_str}
2100 2         4 = $smaller_b->{$tuple_ident_str};
2101             }
2102             }
2103             }
2104 2         4 $result->_cardinality( scalar CORE::keys %{$result_b} );
  2         6  
2105              
2106 2         7 return $result;
2107             }
2108              
2109             ###########################################################################
2110              
2111             sub exclusion {
2112             # Also known as symmetric_diff().
2113 0     0 0 0 my ($topic, $others) = @_;
2114              
2115 0         0 $others = $topic->_normalize_same_heading_relations_arg(
2116             'exclusion', '$others', $others );
2117              
2118             my $inputs = [
2119 0         0 sort { $b->cardinality() <=> $a->cardinality() }
2120 0         0 grep { !$_->is_empty() } # filter out identity value instances
2121 0         0 $topic, @{$others}];
  0         0  
2122              
2123 0 0       0 if (@{$inputs} == 0) {
  0         0  
2124             # All inputs were the identity value; so is result.
2125 0         0 return $topic->empty();
2126             }
2127 0 0       0 if (@{$inputs} == 1) {
  0         0  
2128             # Only one non-identity value input; so it is the result.
2129 0         0 return $inputs->[0];
2130             }
2131              
2132             # If we get here, there are at least 2 non-empty input relations.
2133              
2134 0         0 my $largest = shift @{$inputs};
  0         0  
2135              
2136 0         0 my $result = $largest->_new( $largest );
2137              
2138 0         0 my $smaller_bs = [CORE::map { $_->_body() } @{$inputs}];
  0         0  
  0         0  
2139 0         0 my $result_b = $result->_body();
2140              
2141 0         0 for my $smaller_b (@{$smaller_bs}) {
  0         0  
2142 0         0 for my $tuple_ident_str (CORE::keys %{$smaller_b}) {
  0         0  
2143 0 0       0 if (exists $result_b->{$tuple_ident_str}) {
2144 0         0 CORE::delete $result_b->{$tuple_ident_str};
2145             }
2146             else {
2147             $result_b->{$tuple_ident_str}
2148 0         0 = $smaller_b->{$tuple_ident_str};
2149             }
2150             }
2151             }
2152 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
2153              
2154 0         0 return $result;
2155             }
2156              
2157             sub symmetric_diff {
2158 0     0 0 0 my ($self, @args) = @_;
2159 0         0 return $self->exclusion( @args );
2160             }
2161              
2162             ###########################################################################
2163              
2164             sub intersection {
2165 1     1 0 3 my ($topic, $others) = @_;
2166 1         16 $others = $topic->_normalize_same_heading_relations_arg(
2167             'intersection', '$others', $others );
2168 1         4 return $topic->_intersection( $others );
2169             }
2170              
2171             sub _intersection {
2172 1     1   3 my ($topic, $others) = @_;
2173              
2174 1 50       2 if (@{$others} == 0) {
  1         4  
2175 0         0 return $topic;
2176             }
2177              
2178             my $inputs = [
2179 1         4 sort { $a->cardinality() <=> $b->cardinality() }
2180 1         1 $topic, @{$others}];
  1         4  
2181              
2182 1         2 my $smallest = shift @{$inputs};
  1         2  
2183              
2184 1 50       3 if ($smallest->is_empty()) {
2185 0         0 return $smallest;
2186             }
2187              
2188             # If we get here, there are at least 2 non-empty input relations.
2189              
2190 1         4 my $result = $smallest->empty();
2191              
2192 1         3 my $smallest_b = $smallest->_body();
2193 1         2 my $larger_bs = [CORE::map { $_->_body() } @{$inputs}];
  1         2  
  1         2  
2194 1         3 my $result_b = $result->_body();
2195              
2196             TUPLE:
2197 1         3 for my $tuple_ident_str (CORE::keys %{$smallest_b}) {
  1         3  
2198 3         4 for my $larger_b (@{$larger_bs}) {
  3         4  
2199             next TUPLE
2200 3 100       8 if !exists $larger_b->{$tuple_ident_str};
2201             }
2202 2         4 $result_b->{$tuple_ident_str} = $smallest_b->{$tuple_ident_str};
2203             }
2204 1         2 $result->_cardinality( scalar CORE::keys %{$result_b} );
  1         5  
2205              
2206 1         3 return $result;
2207             }
2208              
2209             ###########################################################################
2210              
2211             sub _normalize_same_heading_relations_arg {
2212 3     3   7 my ($self, $rtn_nm, $arg_nm, $others) = @_;
2213              
2214 3         7 my $self_h = $self->_heading();
2215              
2216 3 50 33     25 if (blessed $others and $others->can( 'does' )
      33        
2217             and $others->does( 'Set::Relation' )) {
2218 3         8 $others = [$others];
2219             }
2220 3 50       9 confess qq{$rtn_nm(): Bad $arg_nm arg;}
2221             . q{ it must be an array-ref or a Set::Relation object.}
2222             if ref $others ne 'ARRAY';
2223             $others = [CORE::map {
2224 3         6 my $other = $_;
2225 3 50 33     16 if (blessed $other and $other->can( 'does' )
      33        
      33        
2226             and $other->does( 'Set::Relation' )
2227             and !$other->isa( __PACKAGE__ )) {
2228 0         0 $other = $self->_new( $other );
2229             }
2230 3 50 33     20 confess qq{$rtn_nm(): Bad $arg_nm arg elem;}
      33        
2231             . q{ it isn't a Set::Relation object, or it doesn't have}
2232             . q{ exactly the same set of attr names as the invocant.}
2233             if !blessed $other or !$other->isa( __PACKAGE__ )
2234             or !$self->_is_identical_hkeys(
2235             $self_h, $other->_heading() );
2236 3         11 $other;
2237 3         6 } @{$others}];
  3         5  
2238              
2239 3         7 return $others;
2240             }
2241              
2242             sub _normalize_relations_arg {
2243 2     2   7 my ($self, $rtn_nm, $arg_nm, $others) = @_;
2244              
2245 2 50 33     52 if (blessed $others and $others->can( 'does' )
      33        
2246             and $others->does( 'Set::Relation' )) {
2247 2         6 $others = [$others];
2248             }
2249 2 50       8 confess qq{$rtn_nm(): Bad $arg_nm arg;}
2250             . q{ it must be an array-ref or a Set::Relation object.}
2251             if ref $others ne 'ARRAY';
2252             $others = [CORE::map {
2253 2         3 my $other = $_;
2254 2 50 33     18 if (blessed $other and $other->can( 'does' )
      33        
      33        
2255             and $other->does( 'Set::Relation' )
2256             and !$other->isa( __PACKAGE__ )) {
2257 0         0 $other = $self->_new( $other );
2258             }
2259 2 50 33     17 confess qq{$rtn_nm(): Bad $arg_nm arg elem;}
2260             . q{ it isn't a Set::Relation object.}
2261             if !blessed $other or !$other->isa( __PACKAGE__ );
2262 2         6 $other;
2263 2         5 } @{$others}];
  2         6  
2264              
2265 2         5 return $others;
2266             }
2267              
2268             ###########################################################################
2269              
2270             sub diff {
2271 0     0 0 0 my ($source, $filter) = @_;
2272 0         0 $filter = $source->_normalize_same_heading_relation_arg(
2273             'diff', '$other', $filter );
2274 0         0 return $source->_diff( $filter );
2275             }
2276              
2277             sub _diff {
2278 0     0   0 my ($source, $filter) = @_;
2279 0 0 0     0 if ($source->is_empty() or $filter->is_empty()) {
2280 0         0 return $source;
2281             }
2282 0         0 return $source->_regular_diff( $filter );
2283             }
2284              
2285             sub _regular_diff {
2286 0     0   0 my ($source, $filter) = @_;
2287              
2288 0         0 my $result = $source->empty();
2289              
2290 0         0 my $source_b = $source->_body();
2291 0         0 my $filter_b = $filter->_body();
2292 0         0 my $result_b = $result->_body();
2293              
2294 0         0 for my $tuple_ident_str (CORE::keys %{$source_b}) {
  0         0  
2295 0 0       0 if (!exists $filter_b->{$tuple_ident_str}) {
2296 0         0 $result_b->{$tuple_ident_str} = $source_b->{$tuple_ident_str};
2297             }
2298             }
2299 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
2300              
2301 0         0 return $result;
2302             }
2303              
2304             ###########################################################################
2305              
2306             sub semidiff {
2307 0     0 0 0 my ($source, $filter) = @_;
2308 0         0 $filter = $source->_normalize_relation_arg(
2309             'semidiff', '$filter', $filter );
2310 0 0 0     0 if ($source->is_empty() or $filter->is_empty()) {
2311 0         0 return $source;
2312             }
2313 0         0 return $source->_regular_diff( $source->_semijoin( $filter ) );
2314             }
2315              
2316             sub antijoin {
2317 0     0 0 0 my ($self, @args) = @_;
2318 0         0 return $self->semidiff( @args );
2319             }
2320              
2321             sub semijoin_and_diff {
2322 0     0 0 0 my ($source, $filter) = @_;
2323 0         0 $filter = $source->_normalize_relation_arg(
2324             'semijoin_and_diff', '$filter', $filter );
2325 0         0 return $source->_semijoin_and_diff( $filter );
2326             }
2327              
2328             sub _semijoin_and_diff {
2329 0     0   0 my ($source, $filter) = @_;
2330 0 0       0 if ($source->is_empty()) {
2331 0         0 return [$source, $source];
2332             }
2333 0 0       0 if ($filter->is_empty()) {
2334 0         0 return [$source->empty(), $source];
2335             }
2336 0         0 my $semijoin = $source->_semijoin( $filter );
2337 0         0 return [$semijoin, $source->_regular_diff( $semijoin )];
2338             }
2339              
2340             sub semijoin {
2341 0     0 0 0 my ($source, $filter) = @_;
2342 0         0 $filter = $source->_normalize_relation_arg(
2343             'semijoin', '$filter', $filter );
2344 0         0 return $source->_semijoin( $filter );
2345             }
2346              
2347             sub _semijoin {
2348 0     0   0 my ($source, $filter) = @_;
2349              
2350 0 0       0 if ($source->is_empty()) {
2351 0         0 return $source;
2352             }
2353 0 0       0 if ($filter->is_empty()) {
2354 0         0 return $source->empty();
2355             }
2356              
2357             # If we get here, both inputs have at least one tuple.
2358              
2359 0 0 0     0 if ($source->is_nullary() or $filter->is_nullary()) {
2360 0         0 return $source;
2361             }
2362              
2363             # If we get here, both inputs also have at least one attribute.
2364              
2365 0         0 my ($both, $source_only, $filter_only) = $source->_ptn_conj_and_disj(
2366             $source->_heading(), $filter->_heading() );
2367              
2368 0 0       0 if (@{$both} == 0) {
  0         0  
2369             # The inputs have disjoint headings; result is source.
2370 0         0 return $source;
2371             }
2372 0 0 0     0 if (@{$source_only} == 0 and @{$filter_only} == 0) {
  0         0  
  0         0  
2373             # The inputs have identical headings; result is intersection.
2374 0         0 return $source->_intersection( [$filter] );
2375             }
2376              
2377             # If we get here, the inputs also have overlapping non-ident headings.
2378              
2379 0         0 return $source->_regular_semijoin( $filter, $both );
2380             }
2381              
2382             sub _regular_semijoin {
2383 0     0   0 my ($source, $filter, $both) = @_;
2384              
2385 0         0 my $result = $source->empty();
2386              
2387 0 0       0 my ($sm, $lg) = ($source->cardinality() < $filter->cardinality())
2388             ? ($source, $filter) : ($filter, $source);
2389              
2390 0         0 my $sm_index = $sm->_want_index( $both );
2391 0         0 my $lg_index = $lg->_want_index( $both );
2392 0         0 my $source_index = $source->_want_index( $both );
2393 0         0 my $result_b = $result->_body();
2394              
2395 0         0 for my $subtuple_ident_str (CORE::keys %{$sm_index}) {
  0         0  
2396 0 0       0 if (exists $lg_index->{$subtuple_ident_str}) {
2397 0         0 my $matched_source_b = $source_index->{$subtuple_ident_str};
2398 0         0 for my $tuple_ident_str (CORE::keys %{$matched_source_b}) {
  0         0  
2399             $result_b->{$tuple_ident_str}
2400 0         0 = $matched_source_b->{$tuple_ident_str};
2401             }
2402             }
2403             }
2404 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
2405              
2406 0         0 return $result;
2407             }
2408              
2409             ###########################################################################
2410              
2411             sub join {
2412 2     2 0 5074 my ($topic, $others) = @_;
2413 2         9 $others = $topic->_normalize_relations_arg(
2414             'join', '$others', $others );
2415 2         8 return $topic->_join( $others );
2416             }
2417              
2418             sub _join {
2419 2     2   5 my ($topic, $others) = @_;
2420              
2421 2 50       12 if (@{$others} == 0) {
  2         16  
2422 0         0 return $topic;
2423             }
2424              
2425 2         4 my $inputs = [$topic, @{$others}];
  2         5  
2426              
2427 2 50   4   9 if (any { $_->is_empty() } @{$inputs}) {
  4         17  
  2         8  
2428             # At least one input has zero tuples; so does result.
2429 0         0 my $result = $topic->_new();
2430 0         0 my $result_h = {CORE::map { %{$_->_heading()} } @{$inputs}};
  0         0  
  0         0  
  0         0  
2431 0         0 $result->_heading( $result_h );
2432 0         0 $result->_degree( scalar CORE::keys %{$result_h} );
  0         0  
2433 0         0 return $result;
2434             }
2435              
2436             # If we get here, all inputs have at least one tuple.
2437              
2438             $inputs = [
2439 2         7 sort { $a->cardinality() <=> $b->cardinality() }
2440 4         8 grep { !$_->is_nullary() } # filter out identity value instances
2441 2         7 @{$inputs}];
  2         4  
2442              
2443 2 50       5 if (@{$inputs} == 0) {
  2         6  
2444             # All inputs were the identity value; so is result.
2445 0         0 return $topic;
2446             }
2447 2 50       4 if (@{$inputs} == 1) {
  2         6  
2448             # Only one non-identity value input; so it is the result.
2449 0         0 return $inputs->[0];
2450             }
2451              
2452             # If we get here, there are at least 2 non-empty non-nullary inp rels.
2453              
2454 2         2 my $result = shift @{$inputs};
  2         4  
2455             INPUT:
2456 2         2 for my $input (@{$inputs}) {
  2         5  
2457             # TODO: Optimize this better by determining more strategic order
2458             # to join the various inputs, such as by doing intersections first,
2459             # then semijoins, then regular joins, then cross-products.
2460             # But at least we're going min to max cardinality meanwhile.
2461              
2462 2         5 my ($both, $result_only, $input_only)
2463             = $result->_ptn_conj_and_disj(
2464             $result->_heading(), $input->_heading() );
2465              
2466 2 50       3 if (@{$both} == 0) {
  2         18  
2467             # The inputs have disjoint headings; result is cross-product.
2468 0         0 $result = $result->_regular_product( $input );
2469 0         0 next INPUT;
2470             }
2471 2 50 33     4 if (@{$result_only} == 0 and @{$input_only} == 0) {
  2         9  
  0         0  
2472             # The inputs have identical headings; result is intersection.
2473 0         0 $result = $result->_intersection( [$input] );
2474 0         0 next INPUT;
2475             }
2476              
2477             # If we get here, the inputs also have overlapping non-ident heads.
2478              
2479 2 50       4 if (@{$result_only} == 0) {
  2         7  
2480             # The first input's attrs are a proper subset of the second's;
2481             # result has same heading as second, a subset of sec's tuples.
2482 0         0 $result = $input->_regular_semijoin( $result, $both );
2483 0         0 next INPUT;
2484             }
2485 2 50       3 if (@{$input_only} == 0) {
  2         5  
2486             # The second input's attrs are a proper subset of the first's;
2487             # result has same heading as first, a subset of first's tuples.
2488 0         0 $result = $result->_regular_semijoin( $input, $both );
2489 0         0 next INPUT;
2490             }
2491              
2492             # If we get here, both inputs also have mini one attr of their own.
2493              
2494 2         8 $result = $result->_regular_join(
2495             $input, $both, $result_only, $input_only );
2496             }
2497 2         8 return $result;
2498             }
2499              
2500             sub _regular_join {
2501 2     2   6 my ($topic, $other, $both, $topic_only, $other_only) = @_;
2502              
2503 2         6 my $result = $topic->_new();
2504              
2505 9         54 $result->_heading( {CORE::map { ($_ => undef) }
2506 2         4 @{$both}, @{$topic_only}, @{$other_only}} );
  2         4  
  2         3  
  2         4  
2507 2         4 $result->_degree( @{$both} + @{$topic_only} + @{$other_only} );
  2         4  
  2         3  
  2         6  
2508              
2509 2 50       5 my ($sm, $lg) = ($topic->cardinality() < $other->cardinality())
2510             ? ($topic, $other) : ($other, $topic);
2511              
2512 2         7 my $sm_index = $sm->_want_index( $both );
2513 2         5 my $lg_index = $lg->_want_index( $both );
2514 2         3 my $result_b = {};
2515              
2516 2         4 for my $subtuple_ident_str (CORE::keys %{$sm_index}) {
  2         6  
2517 7 100       16 if (exists $lg_index->{$subtuple_ident_str}) {
2518 5         6 my $matched_sm_b = $sm_index->{$subtuple_ident_str};
2519 5         7 my $matched_lg_b = $lg_index->{$subtuple_ident_str};
2520 5         7 for my $sm_t (values %{$matched_sm_b}) {
  5         9  
2521 5         13 for my $lg_t (values %{$matched_lg_b}) {
  5         17  
2522 14         17 my $result_t = {%{$sm_t}, %{$lg_t}};
  14         21  
  14         40  
2523 14         31 $result_b->{$topic->_ident_str( $result_t )}
2524             = $result_t;
2525             }
2526             }
2527             }
2528             }
2529 2         6 $result->_body( $result_b );
2530 2         3 $result->_cardinality( scalar CORE::keys %{$result_b} );
  2         9  
2531              
2532 2         6 return $result;
2533             }
2534              
2535             ###########################################################################
2536              
2537             sub product {
2538 0     0 0 0 my ($topic, $others) = @_;
2539              
2540 0         0 $others = $topic->_normalize_relations_arg(
2541             'product', '$others', $others );
2542              
2543 0 0       0 if (@{$others} == 0) {
  0         0  
2544 0         0 return $topic;
2545             }
2546              
2547 0         0 my $inputs = [$topic, @{$others}];
  0         0  
2548              
2549             my $attr_names
2550 0         0 = [CORE::map { CORE::keys %{$_->_heading()} } @{$inputs}];
  0         0  
  0         0  
  0         0  
2551              
2552             confess q{product(): Bad $others arg;}
2553             . q{ one of its elems has an attr name duplicated by}
2554             . q{ either the invocant or another $others elem.}
2555 0 0       0 if (uniqstr @{$attr_names}) != @{$attr_names};
  0         0  
  0         0  
2556              
2557 0 0   0   0 if (any { $_->is_empty() } @{$inputs}) {
  0         0  
  0         0  
2558             # At least one input has zero tuples; so does result.
2559 0         0 my $result = $topic->_new();
2560 0         0 $result->_heading( {CORE::map { ($_ => undef) } @{$attr_names}} );
  0         0  
  0         0  
2561 0         0 $result->_degree( scalar @{$attr_names} );
  0         0  
2562 0         0 return $result;
2563             }
2564              
2565             # If we get here, all inputs have at least one tuple.
2566              
2567             $inputs = [
2568 0         0 sort { $a->cardinality() <=> $b->cardinality() }
2569 0         0 grep { !$_->is_nullary() } # filter out identity value instances
2570 0         0 @{$inputs}];
  0         0  
2571              
2572 0 0       0 if (@{$inputs} == 0) {
  0         0  
2573             # All inputs were the identity value; so is result.
2574 0         0 return $topic;
2575             }
2576 0 0       0 if (@{$inputs} == 1) {
  0         0  
2577             # Only one non-identity value input; so it is the result.
2578 0         0 return $inputs->[0];
2579             }
2580              
2581             # If we get here, there are at least 2 non-empty non-nullary inp rels.
2582              
2583 0         0 my $result = shift @{$inputs};
  0         0  
2584 0         0 for my $input (@{$inputs}) {
  0         0  
2585 0         0 $result = $result->_regular_product( $input );
2586             }
2587 0         0 return $result;
2588             }
2589              
2590             sub _regular_product {
2591 0     0   0 my ($topic, $other) = @_;
2592              
2593 0         0 my $result = $topic->_new();
2594              
2595 0         0 $result->_heading( {%{$topic->_heading()}, %{$other->_heading()}} );
  0         0  
  0         0  
2596 0         0 $result->_degree( $topic->degree() + $other->degree() );
2597              
2598 0 0       0 my ($sm, $lg) = ($topic->cardinality() < $other->cardinality())
2599             ? ($topic, $other) : ($other, $topic);
2600              
2601 0         0 my $sm_b = $sm->_body();
2602 0         0 my $lg_b = $lg->_body();
2603 0         0 my $result_b = {};
2604              
2605 0         0 for my $sm_t (values %{$sm_b}) {
  0         0  
2606 0         0 for my $lg_t (values %{$lg_b}) {
  0         0  
2607 0         0 my $result_t = {%{$sm_t}, %{$lg_t}};
  0         0  
  0         0  
2608 0         0 $result_b->{$topic->_ident_str( $result_t )} = $result_t;
2609             }
2610             }
2611 0         0 $result->_body( $result_b );
2612 0         0 $result->_cardinality( $topic->cardinality() * $other->cardinality() );
2613              
2614 0         0 return $result;
2615             }
2616              
2617             ###########################################################################
2618              
2619             sub quotient {
2620 0     0 0 0 my ($dividend, $divisor) = @_;
2621              
2622 0         0 $divisor = $dividend->_normalize_relation_arg(
2623             'quotient', '$divisor', $divisor );
2624              
2625 0         0 my (undef, $dividend_only, $divisor_only)
2626             = $dividend->_ptn_conj_and_disj(
2627             $dividend->_heading(), $divisor->_heading() );
2628              
2629             confess q{quotient(): Bad $divisor arg;}
2630             . q{ its heading isn't a subset of the invocant's heading.}
2631 0 0       0 if @{$divisor_only} > 0;
  0         0  
2632              
2633 0         0 my $proj_of_dividend_only = $dividend->_projection( $dividend_only );
2634              
2635 0 0 0     0 if ($dividend->is_empty() or $divisor->is_empty()) {
2636             # At least one input has zero tup; res has all tup o dividend proj.
2637 0         0 return $proj_of_dividend_only;
2638             }
2639              
2640             # If we get here, both inputs have at least one tuple.
2641              
2642 0 0 0     0 if ($dividend->is_nullary() or $divisor->is_nullary()) {
2643             # Both inputs or just divisor is ident-one rel; result is dividend.
2644 0         0 return $dividend;
2645             }
2646              
2647             # If we get here, divisor has at least one attribute,
2648             # and divisor heading is proper subset of dividend heading.
2649              
2650 0         0 return $proj_of_dividend_only
2651             ->_diff( $proj_of_dividend_only
2652             ->_regular_product( $divisor )
2653             ->_diff( $dividend )
2654             ->_projection( $dividend_only )
2655             );
2656             }
2657              
2658             ###########################################################################
2659              
2660             sub composition {
2661 0     0 0 0 my ($topic, $other) = @_;
2662              
2663 0         0 $other = $topic->_normalize_relation_arg(
2664             'composition', '$other', $other );
2665              
2666 0         0 my ($both, $topic_only, $other_only) = $topic->_ptn_conj_and_disj(
2667             $topic->_heading(), $other->_heading() );
2668              
2669 0 0 0     0 if ($topic->is_empty() or $other->is_empty()) {
2670             # At least one input has zero tuples; so does result.
2671 0         0 return $topic->_new( [@{$topic_only}, @{$other_only}] );
  0         0  
  0         0  
2672             }
2673              
2674             # If we get here, both inputs have at least one tuple.
2675              
2676 0 0       0 if ($topic->is_nullary()) {
2677             # First input is identity-one relation; result is second input.
2678 0         0 return $other;
2679             }
2680 0 0       0 if ($other->is_nullary()) {
2681             # Second input is identity-one relation; result is first input.
2682 0         0 return $topic;
2683             }
2684              
2685             # If we get here, both inputs also have at least one attribute.
2686              
2687 0 0       0 if (@{$both} == 0) {
  0         0  
2688             # The inputs have disjoint headings; result is cross-product.
2689 0         0 return $topic->_regular_product( $other );
2690             }
2691 0 0 0     0 if (@{$topic_only} == 0 and @{$other_only} == 0) {
  0         0  
  0         0  
2692             # The inputs have identical headings; result is ident-one relation.
2693 0         0 return $topic->_new( [ {} ] );
2694             }
2695              
2696             # If we get here, the inputs also have overlapping non-ident headings.
2697              
2698 0 0       0 if (@{$topic_only} == 0) {
  0         0  
2699             # The first input's attributes are a proper subset of the second's;
2700             # result has same heading as second, a subset of second's tuples.
2701 0         0 return $other->_regular_semijoin( $topic, $both )
2702             ->_projection( $other_only );
2703             }
2704 0 0       0 if (@{$other_only} == 0) {
  0         0  
2705             # The second input's attributes are a proper subset of the first's;
2706             # result has same heading as first, a subset of first's tuples.
2707 0         0 return $topic->_regular_semijoin( $other, $both )
2708             ->_projection( $topic_only );
2709             }
2710              
2711             # If we get here, both inputs also have at least one attr of their own.
2712              
2713             return $topic->_regular_join(
2714             $other, $both, $topic_only, $other_only )
2715 0         0 ->_projection( [@{$topic_only}, @{$other_only}] );
  0         0  
  0         0  
2716             }
2717              
2718             ###########################################################################
2719              
2720             sub _ptn_conj_and_disj {
2721             # inputs are hashes, results are arrays
2722 6     6   17 my ($self, $src1, $src2) = @_;
2723 6         10 my $both = [grep { exists $src1->{$_} } CORE::keys %{$src2}];
  17         41  
  6         15  
2724 6         13 my $both_h = {CORE::map { ($_ => undef) } @{$both}};
  10         19  
  6         10  
2725 6         11 my $only1 = [grep { !exists $both_h->{$_} } CORE::keys %{$src1}];
  18         33  
  6         12  
2726 6         11 my $only2 = [grep { !exists $both_h->{$_} } CORE::keys %{$src2}];
  17         29  
  6         11  
2727 6         19 return ($both, $only1, $only2);
2728             }
2729              
2730             ###########################################################################
2731              
2732             sub _want_index {
2733 5     5   10 my ($self, $atnms) = @_;
2734 5         7 my $subheading = {CORE::map { ($_ => undef) } @{$atnms}};
  5         11  
  5         8  
2735 5         24 my $subheading_ident_str = $self->_heading_ident_str( $subheading );
2736 5         16 my $indexes = $self->_indexes();
2737 5 50       22 if (!exists $indexes->{$subheading_ident_str}) {
2738 5         15 my $index_and_meta = $indexes->{$subheading_ident_str}
2739             = [ $subheading, {} ];
2740 5         10 my $index = $index_and_meta->[1];
2741 5         9 my $body = $self->_body();
2742 5         8 for my $tuple_ident_str (CORE::keys %{$body}) {
  5         15  
2743 27         34 my $tuple = $body->{$tuple_ident_str};
2744             my $subtuple_ident_str = $self->_ident_str(
2745 27         32 {CORE::map { ($_ => $tuple->{$_}) } @{$atnms}} );
  27         105  
  27         32  
2746 27   100     84 my $matched_b = $index->{$subtuple_ident_str} ||= {};
2747 27         55 $matched_b->{$tuple_ident_str} = $tuple;
2748             }
2749             }
2750 5         13 return $indexes->{$subheading_ident_str}->[1];
2751             }
2752              
2753             ###########################################################################
2754              
2755             sub join_with_group {
2756 0     0 0 0 my ($primary, $secondary, $group_attr) = @_;
2757              
2758 0         0 $secondary = $primary->_normalize_relation_arg(
2759             'join_with_group', '$secondary', $secondary );
2760 0         0 $primary->_assert_valid_atnm_arg(
2761             'join_with_group', '$group_attr', $group_attr );
2762              
2763 0         0 my $primary_h = $primary->_heading();
2764              
2765             confess q{join_with_group(): Bad $group_attr arg;}
2766             . q{ that name for a new attr to add}
2767             . q{ to $primary, consisting of grouped $secondary-only attrs,}
2768             . q{ duplicates an attr of $primary (not being grouped).}
2769 0 0       0 if exists $primary_h->{$group_attr};
2770              
2771             # TODO: inline+merge what join/group do for better performance.
2772              
2773 0         0 my ($both, $primary_only, $inner) = $primary->_ptn_conj_and_disj(
2774             $primary_h, $secondary->_heading() );
2775 0         0 my $inner_h = {CORE::map { $_ => undef } @{$inner}};
  0         0  
  0         0  
2776              
2777             return $primary
2778             ->_join( [$secondary] )
2779 0         0 ->_group( $group_attr, $inner, [CORE::keys %{$primary_h}],
  0         0  
2780             $inner_h );
2781             }
2782              
2783             ###########################################################################
2784              
2785             sub rank {
2786 0     0 0 0 my ($topic, $name, $ord_func) = @_;
2787              
2788 0         0 my $topic_h = $topic->_heading();
2789              
2790 0         0 $topic->_assert_valid_atnm_arg( 'rank', '$name', $name );
2791             confess q{rank(): Bad $name arg; that name for a new attr to add}
2792             . q{ to the invocant, consisting of each tuple's numeric rank,}
2793             . q{ duplicates an existing attr of the invocant.}
2794 0 0       0 if exists $topic_h->{$name};
2795              
2796 0         0 $topic->_assert_valid_func_arg( 'rank', '$ord_func', $ord_func );
2797              
2798 0         0 my $result = $topic->_new();
2799              
2800 0         0 $result->_heading( {%{$topic_h}, $name => undef} );
  0         0  
2801 0         0 $result->_degree( $topic->degree() + 1 );
2802              
2803 0 0       0 if ($topic->is_empty()) {
2804 0         0 return $result;
2805             }
2806              
2807 0         0 my $ext_topic_tuples = [];
2808 0         0 my $topic_tuples_by_ext_tt_ref = {};
2809              
2810 0         0 for my $topic_t (values %{$topic->_body()}) {
  0         0  
2811 0         0 my $ext_topic_t = $topic->_export_nfmt_tuple( $topic_t );
2812 0         0 push @{$ext_topic_tuples}, $ext_topic_t;
  0         0  
2813 0         0 $topic_tuples_by_ext_tt_ref->{refaddr $ext_topic_t} = $topic_t;
2814             }
2815              
2816             my $sorted_ext_topic_tuples = [sort {
2817 0         0 local $_ = { 'a' => $a, 'b' => $b };
2818 0         0 $ord_func->();
2819 0         0 } @{$ext_topic_tuples}];
  0         0  
2820              
2821 0         0 my $result_b = $result->_body();
2822              
2823 0         0 my $rank = -1;
2824 0         0 for my $ext_topic_t (@{$sorted_ext_topic_tuples}) {
  0         0  
2825 0         0 my $topic_t = $topic_tuples_by_ext_tt_ref->{refaddr $ext_topic_t};
2826 0         0 $rank ++;
2827 0         0 my $rank_atvl = [$rank, $topic->_ident_str( $rank )];
2828 0         0 my $result_t = {$name => $rank_atvl, %{$topic_t}};
  0         0  
2829 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
2830 0         0 $result_b->{$result_t_ident_str} = $result_t;
2831             }
2832 0         0 $result->_cardinality( $topic->cardinality() );
2833              
2834 0         0 return $result;
2835             }
2836              
2837             ###########################################################################
2838              
2839             sub rank_by_attr_names {
2840 0     0 0 0 my ($topic, $name, $order_by) = @_;
2841              
2842 0         0 my $topic_h = $topic->_heading();
2843              
2844 0         0 $topic->_assert_valid_atnm_arg( 'rank_by_attr_names', '$name', $name );
2845             confess q{rank_by_attr_names(): Bad $name arg; that name for a new}
2846             . q{ attr to add to the invocant, consisting of each tuple's}
2847             . q{ numeric rank, duplicates an existing attr of th invocant.}
2848 0 0       0 if exists $topic_h->{$name};
2849              
2850 0         0 $order_by = $topic->_normalize_order_by_arg(
2851             'rank_by_attr_names', '$order_by', $order_by );
2852              
2853 0         0 my $result = $topic->_new();
2854              
2855 0         0 $result->_heading( {%{$topic_h}, $name => undef} );
  0         0  
2856 0         0 $result->_degree( $topic->degree() + 1 );
2857              
2858 0 0       0 if ($topic->is_empty()) {
2859 0         0 return $result;
2860             }
2861              
2862 0         0 my $sort_func = $topic->_sort_func_from_order_by( $order_by );
2863              
2864 0         0 my $result_b = $result->_body();
2865              
2866 0         0 my $rank = -1;
2867 0         0 for my $topic_t (@{$sort_func->( $topic )}) {
  0         0  
2868 0         0 $rank ++;
2869 0         0 my $rank_atvl = [$rank, $topic->_ident_str( $rank )];
2870 0         0 my $result_t = {$name => $rank_atvl, %{$topic_t}};
  0         0  
2871 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
2872 0         0 $result_b->{$result_t_ident_str} = $result_t;
2873             }
2874 0         0 $result->_cardinality( $topic->cardinality() );
2875              
2876 0         0 return $result;
2877             }
2878              
2879             ###########################################################################
2880              
2881             sub _normalize_order_by_arg {
2882 0     0   0 my ($topic, $rtn_nm, $arg_nm, $order_by) = @_;
2883              
2884 0 0 0     0 if (defined $order_by and !ref $order_by) {
2885 0         0 $order_by = [$order_by];
2886             }
2887 0 0       0 confess qq{$rtn_nm(): Bad $arg_nm arg;}
2888             . q{ it must be an array-ref or a defined non-ref.}
2889             if ref $order_by ne 'ARRAY';
2890              
2891             $order_by = [CORE::map {
2892             (ref $_ ne 'ARRAY') ? [$_, 0, 'cmp']
2893 0         0 : (@{$_} == 1) ? [@{$_}, 0, 'cmp']
  0         0  
2894 0 0       0 : (@{$_} == 2) ? [@{$_}, 'cmp']
  0 0       0  
  0 0       0  
2895             : $_
2896 0         0 } @{$order_by}];
  0         0  
2897             confess qq{$rtn_nm(): Bad $arg_nm arg elem;}
2898             . q{ it must be a 1-3 elem array-ref or a defined non-ref,}
2899             . q{ its first elem must be a valid attr name (defin non-ref),}
2900             . q{ and its third elem must be undef or one of 'cmp'|'<=>'.}
2901             if notall {
2902 0 0 0 0   0 ref $_ eq 'ARRAY' and @{$_} == 3
  0   0     0  
      0        
      0        
      0        
2903             and defined $_->[0] and !ref $_->[0]
2904             and (!defined $_->[2]
2905             or $_->[2] eq 'cmp' or $_->[2] eq '<=>')
2906 0 0       0 } @{$order_by};
  0         0  
2907              
2908 0         0 my $atnms = [CORE::map { $_->[0] } @{$order_by}];
  0         0  
  0         0  
2909             confess qq{$rtn_nm(): Bad $arg_nm arg;}
2910             . q{ it specifies a list of}
2911             . q{ attr names with at least one duplicated name.}
2912 0 0       0 if (uniqstr @{$atnms}) != @{$atnms};
  0         0  
  0         0  
2913              
2914 0         0 my $topic_h = $topic->_heading();
2915             confess qq{$rtn_nm(): Bad $arg_nm arg;}
2916             . q{ the list of attr names it specifies isn't a subset of the}
2917             . q{ heading of the relation defined by the $members arg.}
2918 0 0   0   0 if notall { exists $topic_h->{$_} } @{$atnms};
  0         0  
  0         0  
2919              
2920 0         0 return $order_by;
2921             }
2922              
2923             ###########################################################################
2924              
2925             sub _sort_func_from_order_by {
2926 0     0   0 my ($topic, $order_by) = @_;
2927             my $sort_func_perl
2928             = "sub {\n"
2929             . "my (\$topic) = \@_;\n"
2930             . "return [sort {\n"
2931             . (CORE::join ' || ', '0', CORE::map {
2932 0         0 my ($name, $is_reverse_order, $compare_op) = @{$_};
  0         0  
2933 0   0     0 $compare_op ||= 'cmp';
2934 0 0       0 ($is_reverse_order
2935             ? "\$b->{'$name'} $compare_op \$a->{'$name'}"
2936             : "\$a->{'$name'} $compare_op \$b->{'$name'}");
2937 0         0 } @{$order_by}) . "\n"
  0         0  
2938             . "} values \%{\$topic->_body()}];\n"
2939             . "}\n"
2940             ;
2941 0         0 my $sort_func = eval $sort_func_perl;
2942 0 0       0 if (my $err = $@) {
2943 0         0 confess qq{Oops, failed to compile Perl sort func from order by;\n}
2944             . qq{ error message is [[$err]];\n}
2945             . qq{ source code is [[$sort_func_perl]].}
2946             }
2947 0         0 return $sort_func;
2948             }
2949              
2950             ###########################################################################
2951              
2952             sub limit {
2953 0     0 0 0 my ($topic, $ord_func, $min_rank, $max_rank) = @_;
2954              
2955 0         0 $topic->_assert_valid_func_arg( 'limit', '$ord_func', $ord_func );
2956              
2957 0         0 $topic->_assert_valid_nnint_arg( 'limit', '$min_rank', $min_rank );
2958 0         0 $topic->_assert_valid_nnint_arg( 'limit', '$max_rank', $max_rank );
2959 0 0       0 confess q{limit(): The $max_rank arg can't be less than the $min_rank.}
2960             if $max_rank < $min_rank;
2961              
2962 0 0       0 if ($topic->is_empty()) {
2963 0         0 return $topic;
2964             }
2965              
2966 0         0 my $topic_b = $topic->_body();
2967              
2968 0         0 my $ext_topic_tuples = [];
2969 0         0 my $topic_tuples_by_ext_tt_ref = {};
2970              
2971 0         0 for my $topic_t_ident_str (CORE::keys %{$topic_b}) {
  0         0  
2972 0         0 my $topic_t = $topic_b->{$topic_t_ident_str};
2973 0         0 my $ext_topic_t = $topic->_export_nfmt_tuple( $topic_t );
2974 0         0 push @{$ext_topic_tuples}, $ext_topic_t;
  0         0  
2975 0         0 $topic_tuples_by_ext_tt_ref->{refaddr $ext_topic_t}
2976             = $topic_t_ident_str;
2977             }
2978              
2979             my $sorted_ext_topic_tuples = [sort {
2980 0         0 local $_ = { 'a' => $a, 'b' => $b };
2981 0         0 $ord_func->();
2982 0         0 } @{$ext_topic_tuples}];
  0         0  
2983              
2984 0         0 my $result = $topic->empty();
2985              
2986 0         0 my $result_b = $result->_body();
2987              
2988 0         0 for my $ext_topic_t
2989 0         0 (@{$sorted_ext_topic_tuples}[$min_rank..$max_rank]) {
2990             my $topic_t_ident_str
2991 0         0 = $topic_tuples_by_ext_tt_ref->{refaddr $ext_topic_t};
2992 0         0 $result_b->{$topic_t_ident_str} = $topic_b->{$topic_t_ident_str};
2993             }
2994 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
2995              
2996 0         0 return $result;
2997             }
2998              
2999             ###########################################################################
3000              
3001             sub limit_by_attr_names {
3002 0     0 0 0 my ($topic, $order_by, $min_rank, $max_rank) = @_;
3003              
3004 0         0 $order_by = $topic->_normalize_order_by_arg(
3005             'limit_by_attr_names', '$order_by', $order_by );
3006              
3007 0         0 $topic->_assert_valid_nnint_arg(
3008             'limit_by_attr_names', '$min_rank', $min_rank );
3009 0         0 $topic->_assert_valid_nnint_arg(
3010             'limit_by_attr_names', '$max_rank', $max_rank );
3011 0 0       0 confess q{limit_by_attr_names():}
3012             . q{ The $max_rank arg can't be less than the $min_rank.}
3013             if $max_rank < $min_rank;
3014              
3015 0 0       0 if ($topic->is_empty()) {
3016 0         0 return $topic;
3017             }
3018              
3019 0         0 my $sort_func = $topic->_sort_func_from_order_by( $order_by );
3020              
3021 0         0 my $topic_b = $topic->_body();
3022              
3023 0         0 my $topic_tists_by_tt_ref = {};
3024              
3025 0         0 for my $topic_t_ident_str (CORE::keys %{$topic_b}) {
  0         0  
3026 0         0 my $topic_t = $topic_b->{$topic_t_ident_str};
3027 0         0 $topic_tists_by_tt_ref->{refaddr $topic_t} = $topic_t_ident_str;
3028             }
3029              
3030 0         0 my $result = $topic->empty();
3031              
3032 0         0 my $result_b = $result->_body();
3033              
3034 0         0 for my $topic_t (@{$sort_func->( $topic )}[$min_rank..$max_rank]) {
  0         0  
3035 0         0 my $topic_t_ident_str = $topic_tists_by_tt_ref->{refaddr $topic_t};
3036 0         0 $result_b->{$topic_t_ident_str} = $topic_t;
3037             }
3038 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
3039              
3040 0         0 return $result;
3041             }
3042              
3043             ###########################################################################
3044              
3045             sub substitution {
3046 0     0 0 0 my ($topic, $attr_names, $func, $allow_dup_tuples) = @_;
3047 0         0 (my $subst_h, $attr_names)
3048             = $topic->_atnms_hr_from_assert_valid_subst_args(
3049             'substitution', '$attr_names', '$func', $attr_names, $func );
3050 0         0 return $topic->_substitution(
3051             'substitution', '$attr_names', '$func',
3052             $attr_names, $func, $subst_h );
3053             }
3054              
3055             sub _atnms_hr_from_assert_valid_subst_args {
3056 0     0   0 my ($topic, $rtn_nm, $arg_nm_atnms, $arg_nm_func, $atnms, $func) = @_;
3057              
3058 0         0 (my $subst_h, $atnms) = $topic->_atnms_hr_from_assert_valid_atnms_arg(
3059             $rtn_nm, $arg_nm_atnms, $atnms );
3060 0         0 my (undef, undef, $subst_only)
3061             = $topic->_ptn_conj_and_disj( $topic->_heading(), $subst_h );
3062             confess qq{$rtn_nm(): Bad $arg_nm_atnms arg; that attr list}
3063             . q{ isn't a subset of the invocant's heading.}
3064 0 0       0 if @{$subst_only} > 0;
  0         0  
3065              
3066 0         0 $topic->_assert_valid_func_arg( $rtn_nm, $arg_nm_func, $func );
3067              
3068 0         0 return ($subst_h, $atnms);
3069             }
3070              
3071             sub _substitution {
3072 0     0   0 my ($topic, $rtn_nm, $arg_nm_attrs, $arg_nm_func, $attrs, $func,
3073             $subst_h) = @_;
3074              
3075 0 0       0 if ($topic->is_empty()) {
3076 0         0 return $topic;
3077             }
3078 0 0       0 if (@{$attrs} == 0) {
  0         0  
3079             # Substitution in zero attrs of input yields the input.
3080 0         0 return $topic;
3081             }
3082              
3083 0         0 my $result = $topic->empty();
3084              
3085 0         0 my $result_b = $result->_body();
3086              
3087 0         0 for my $topic_t (values %{$topic->_body()}) {
  0         0  
3088 0         0 my $subst_t;
3089             {
3090 0         0 local $_ = $topic->_export_nfmt_tuple( $topic_t );
  0         0  
3091 0         0 $subst_t = $func->();
3092             }
3093             $topic->_assert_valid_tuple_result_of_func_arg(
3094 0         0 $rtn_nm, $arg_nm_func, $arg_nm_attrs, $subst_t, $subst_h );
3095 0         0 $subst_t = $topic->_import_nfmt_tuple( $subst_t );
3096 0         0 my $result_t = {%{$topic_t}, %{$subst_t}};
  0         0  
  0         0  
3097 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
3098 0 0       0 if (!exists $result_b->{$result_t_ident_str}) {
3099 0         0 $result_b->{$result_t_ident_str} = $result_t;
3100             }
3101             }
3102 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
3103              
3104 0         0 return $result;
3105             }
3106              
3107             ###########################################################################
3108              
3109             sub static_subst {
3110 0     0 0 0 my ($topic, $attrs) = @_;
3111 0         0 $topic->_assert_valid_static_subst_args(
3112             'static_subst', '$attrs', $attrs );
3113 0         0 return $topic->_static_subst( $attrs );
3114             }
3115              
3116             sub _assert_valid_static_subst_args {
3117 0     0   0 my ($topic, $rtn_nm, $arg_nm_attrs, $attrs) = @_;
3118              
3119 0 0       0 confess qq{$rtn_nm(): Bad $arg_nm_attrs arg; it isn't a hash-ref.}
3120             if ref $attrs ne 'HASH';
3121              
3122 0         0 my (undef, undef, $subst_only)
3123             = $topic->_ptn_conj_and_disj( $topic->_heading(), $attrs );
3124             confess qq{$rtn_nm(): Bad $arg_nm_attrs arg; that attr list}
3125             . q{ isn't a subset of the invocant's heading.}
3126 0 0       0 if @{$subst_only} > 0;
  0         0  
3127              
3128 0 0       0 confess qq{$rtn_nm(): Bad $arg_nm_attrs arg;}
3129             . q{ it is a hash-ref, and there exist circular refs}
3130             . q{ between itself or its tuple-valued components.}
3131             if $topic->_tuple_arg_has_circular_refs( $attrs );
3132              
3133 0         0 return;
3134             }
3135              
3136             sub _static_subst {
3137 0     0   0 my ($topic, $attrs) = @_;
3138              
3139 0 0       0 if ($topic->is_empty()) {
3140 0         0 return $topic;
3141             }
3142 0 0       0 if ((scalar CORE::keys %{$attrs}) == 0) {
  0         0  
3143             # Substitution in zero attrs of input yields the input.
3144 0         0 return $topic;
3145             }
3146              
3147 0         0 $attrs = $topic->_import_nfmt_tuple( $attrs );
3148              
3149 0         0 my $result = $topic->empty();
3150              
3151 0         0 my $result_b = $result->_body();
3152              
3153 0         0 for my $topic_t (values %{$topic->_body()}) {
  0         0  
3154 0         0 my $result_t = {%{$topic_t}, %{$attrs}};
  0         0  
  0         0  
3155 0         0 my $result_t_ident_str = $topic->_ident_str( $result_t );
3156 0 0       0 if (!exists $result_b->{$result_t_ident_str}) {
3157 0         0 $result_b->{$result_t_ident_str} = $result_t;
3158             }
3159             }
3160 0         0 $result->_cardinality( scalar CORE::keys %{$result_b} );
  0         0  
3161              
3162 0         0 return $result;
3163             }
3164              
3165             ###########################################################################
3166              
3167             sub subst_in_restr {
3168 0     0 0 0 my ($topic, $restr_func, $subst_attr_names, $subst_func,
3169             $allow_dup_tuples) = @_;
3170              
3171 0         0 $topic->_assert_valid_func_arg(
3172             'subst_in_restr', '$restr_func', $restr_func );
3173              
3174 0         0 (my $subst_h, $subst_attr_names) = $topic
3175             ->_atnms_hr_from_assert_valid_subst_args( 'subst_in_restr',
3176             '$subst_attr_names', '$subst_func',
3177             $subst_attr_names, $subst_func );
3178              
3179             my ($topic_to_subst, $topic_no_subst)
3180 0         0 = @{$topic->_restr_and_cmpl( $restr_func )};
  0         0  
3181              
3182 0         0 return $topic_to_subst
3183             ->_substitution( 'subst_in_restr', '$subst_attr_names',
3184             '$subst_func', $subst_attr_names, $subst_func, $subst_h )
3185             ->_union( [$topic_no_subst] );
3186             }
3187              
3188             ###########################################################################
3189              
3190             sub static_subst_in_restr {
3191 0     0 0 0 my ($topic, $restr_func, $subst, $allow_dup_tuples) = @_;
3192              
3193 0         0 $topic->_assert_valid_func_arg(
3194             'static_subst_in_restr', '$restr_func', $restr_func );
3195              
3196 0         0 $topic->_assert_valid_static_subst_args(
3197             'static_subst_in_restr', '$subst', $subst );
3198              
3199             my ($topic_to_subst, $topic_no_subst)
3200 0         0 = @{$topic->_restr_and_cmpl( $restr_func )};
  0         0  
3201              
3202 0         0 return $topic_to_subst
3203             ->_static_subst( $subst )
3204             ->_union( [$topic_no_subst] );
3205             }
3206              
3207             ###########################################################################
3208              
3209             sub subst_in_semijoin {
3210 0     0 0 0 my ($topic, $restr, $subst_attr_names, $subst_func, $allow_dup_tuples)
3211             = @_;
3212              
3213 0         0 $restr = $topic->_normalize_relation_arg(
3214             'subst_in_semijoin', '$restr', $restr );
3215              
3216 0         0 (my $subst_h, $subst_attr_names) = $topic
3217             ->_atnms_hr_from_assert_valid_subst_args( 'subst_in_semijoin',
3218             '$subst_attr_names', '$subst_func',
3219             $subst_attr_names, $subst_func );
3220              
3221             my ($topic_to_subst, $topic_no_subst)
3222 0         0 = @{$topic->_semijoin_and_diff( $restr )};
  0         0  
3223              
3224 0         0 return $topic_to_subst
3225             ->_substitution( 'subst_in_semijoin', '$subst_attr_names',
3226             '$subst_func', $subst_attr_names, $subst_func, $subst_h )
3227             ->_union( [$topic_no_subst] );
3228             }
3229              
3230             ###########################################################################
3231              
3232             sub static_subst_in_semijoin {
3233 0     0 0 0 my ($topic, $restr, $subst) = @_;
3234              
3235 0         0 $restr = $topic->_normalize_relation_arg(
3236             'static_subst_in_semijoin', '$restr', $restr );
3237              
3238 0         0 $topic->_assert_valid_static_subst_args(
3239             'static_subst_in_semijoin', '$subst', $subst );
3240              
3241             my ($topic_to_subst, $topic_no_subst)
3242 0         0 = @{$topic->_semijoin_and_diff( $restr )};
  0         0  
3243              
3244 0         0 return $topic_to_subst
3245             ->_static_subst( $subst )
3246             ->_union( [$topic_no_subst] );
3247             }
3248              
3249             ###########################################################################
3250              
3251             sub outer_join_with_group {
3252 0     0 0 0 my ($primary, $secondary, $group_attr) = @_;
3253              
3254 0         0 $secondary = $primary->_normalize_relation_arg(
3255             'outer_join_with_group', '$secondary', $secondary );
3256 0         0 $primary->_assert_valid_atnm_arg(
3257             'outer_join_with_group', '$group_attr', $group_attr );
3258              
3259 0         0 my $primary_h = $primary->_heading();
3260              
3261             confess q{outer_join_with_group(): Bad $group_attr arg;}
3262             . q{ that name for a new attr to add}
3263             . q{ to $primary, consisting of grouped $secondary-only attrs,}
3264             . q{ duplicates an attr of $primary (not being grouped).}
3265 0 0       0 if exists $primary_h->{$group_attr};
3266              
3267             # TODO: inline+merge what join/group/etc do for better performance.
3268              
3269 0         0 my ($both, $primary_only, $inner) = $primary->_ptn_conj_and_disj(
3270             $primary_h, $secondary->_heading() );
3271 0         0 my $inner_h = {CORE::map { $_ => undef } @{$inner}};
  0         0  
  0         0  
3272              
3273             my ($pri_matched, $pri_nonmatched)
3274 0         0 = @{$primary->_semijoin_and_diff( $secondary )};
  0         0  
3275              
3276             my $result_matched = $pri_matched
3277             ->_join( [$secondary] )
3278 0         0 ->_group( $group_attr, $inner, [CORE::keys %{$primary_h}],
  0         0  
3279             $inner_h );
3280              
3281 0         0 my $result_nonmatched = $pri_nonmatched
3282             ->_static_exten( {$group_attr => $primary->_new( $inner )} );
3283              
3284 0         0 return $result_matched->_union( [$result_nonmatched] );
3285             }
3286              
3287             ###########################################################################
3288              
3289             sub outer_join_with_undefs {
3290 0     0 0 0 my ($primary, $secondary) = @_;
3291              
3292 0         0 $secondary = $primary->_normalize_relation_arg(
3293             'outer_join_with_undefs', '$secondary', $secondary );
3294              
3295 0         0 my (undef, undef, $exten_attrs) = $primary->_ptn_conj_and_disj(
3296             $primary->_heading(), $secondary->_heading() );
3297 0         0 my $filler = {CORE::map { $_ => undef } @{$exten_attrs}};
  0         0  
  0         0  
3298              
3299             my ($pri_matched, $pri_nonmatched)
3300 0         0 = @{$primary->_semijoin_and_diff( $secondary )};
  0         0  
3301              
3302 0         0 my $result_matched = $pri_matched->_join( [$secondary] );
3303              
3304 0         0 my $result_nonmatched = $pri_nonmatched->_static_exten( $filler );
3305              
3306 0         0 return $result_matched->_union( [$result_nonmatched] );
3307             }
3308              
3309             ###########################################################################
3310              
3311             sub outer_join_with_static_exten {
3312 0     0 0 0 my ($primary, $secondary, $filler) = @_;
3313              
3314 0         0 $secondary = $primary->_normalize_relation_arg(
3315             'outer_join_with_static_exten', '$secondary', $secondary );
3316              
3317 0 0       0 confess q{outer_join_with_static_exten(): Bad $filler arg;}
3318             . q{ it isn't a hash-ref.}
3319             if ref $filler ne 'HASH';
3320 0 0       0 confess q{outer_join_with_static_exten(): Bad $filler arg;}
3321             . q{ it is a hash-ref, and there exist circular refs}
3322             . q{ between itself or its tuple-valued components.}
3323             if $primary->_tuple_arg_has_circular_refs( $filler );
3324              
3325 0         0 my (undef, undef, $exten_attrs) = $primary->_ptn_conj_and_disj(
3326             $primary->_heading(), $secondary->_heading() );
3327 0         0 my $exten_h = {CORE::map { $_ => undef } @{$exten_attrs}};
  0         0  
  0         0  
3328              
3329 0 0       0 confess q{outer_join_with_static_exten(): Bad $filler arg elem;}
3330             . q{ it doesn't have exactly the}
3331             . q{ same set of attr names as the sub-heading of $secondary}
3332             . q{ that doesn't overlap with the heading of $primary.}
3333             if !$primary->_is_identical_hkeys( $exten_h, $filler );
3334              
3335             my ($pri_matched, $pri_nonmatched)
3336 0         0 = @{$primary->_semijoin_and_diff( $secondary )};
  0         0  
3337              
3338 0         0 my $result_matched = $pri_matched->_join( [$secondary] );
3339              
3340 0         0 my $result_nonmatched = $pri_nonmatched->_static_exten( $filler );
3341              
3342 0         0 return $result_matched->_union( [$result_nonmatched] );
3343             }
3344              
3345             ###########################################################################
3346              
3347             sub outer_join_with_exten {
3348 0     0 0 0 my ($primary, $secondary, $exten_func, $allow_dup_tuples) = @_;
3349              
3350 0         0 $secondary = $primary->_normalize_relation_arg(
3351             'outer_join_with_exten', '$secondary', $secondary );
3352 0         0 $primary->_assert_valid_func_arg(
3353             'outer_join_with_exten', '$exten_func', $exten_func );
3354              
3355 0         0 my (undef, undef, $exten_attrs) = $primary->_ptn_conj_and_disj(
3356             $primary->_heading(), $secondary->_heading() );
3357 0         0 my $exten_h = {CORE::map { $_ => undef } @{$exten_attrs}};
  0         0  
  0         0  
3358              
3359             my ($pri_matched, $pri_nonmatched)
3360 0         0 = @{$primary->_semijoin_and_diff( $secondary )};
  0         0  
3361              
3362 0         0 my $result_matched = $pri_matched->_join( [$secondary] );
3363              
3364             # Note: if '_extension' dies due to what $exten_func did it would
3365             # state the error is reported by 'extension' and with some wrong
3366             # details; todo fix later; on correct it won't affect users though.
3367 0         0 my $result_nonmatched = $pri_nonmatched
3368             ->_extension( $exten_attrs, $exten_func, $exten_h );
3369              
3370 0         0 return $result_matched->_union( [$result_nonmatched] );
3371             }
3372              
3373             ###########################################################################
3374              
3375             sub clone {
3376 0     0 0 0 my ($self) = @_;
3377 0         0 return $self->_new( $self );
3378             }
3379              
3380             ###########################################################################
3381              
3382             sub freeze_identity {
3383 0     0 0 0 my ($self) = @_;
3384 0         0 $self->_has_frozen_identity( 1 );
3385 0         0 return;
3386             }
3387              
3388             ###########################################################################
3389              
3390             sub evacuate {
3391 0     0 0 0 my ($topic) = @_;
3392 0 0       0 confess q{evacuate(): Can't mutate invocant having a frozen identity.}
3393             if $topic->_has_frozen_identity();
3394 0         0 $topic->_body( {} );
3395 0         0 $topic->_cardinality( 0 );
3396 0         0 return $topic;
3397             }
3398              
3399             ###########################################################################
3400              
3401             sub insert {
3402 0     0 0 0 my ($r, $t) = @_;
3403 0 0       0 confess q{insert(): Can't mutate invocant that has a frozen identity.}
3404             if $r->_has_frozen_identity();
3405 0         0 $t = $r->_normalize_same_heading_tuples_arg( 'insert', '$t', $t );
3406 0         0 for my $tuple (@{$t}) {
  0         0  
3407 0 0       0 confess q{insert(): Bad $t arg; it contains the invocant}
3408             . q{ Set::Relation object as a tuple-valued component,}
3409             . q{ so the invocant would be frozen as a side-effect.}
3410             if $r->_self_is_component_of_tuple_arg( $tuple );
3411             }
3412 0         0 return $r->_insert( $t );
3413             }
3414              
3415             sub _insert {
3416 13     13   23 my ($r, $t) = @_;
3417              
3418 13         21 my $r_b = $r->_body();
3419 13         20 my $r_indexes = $r->_indexes();
3420 13         28 my $r_keys = $r->_keys();
3421              
3422 13         15 for my $tuple (@{$t}) {
  13         17  
3423 13         25 $tuple = $r->_import_nfmt_tuple( $tuple );
3424 13         29 my $tuple_ident_str = $r->_ident_str( $tuple );
3425 13 50       30 if (!exists $r_b->{$tuple_ident_str}) {
3426 13         25 $r_b->{$tuple_ident_str} = $tuple;
3427              
3428 13         14 for my $subheading_ident_str (CORE::keys %{$r_indexes}) {
  13         30  
3429             my ($subheading, $index)
3430 0         0 = @{$r_indexes->{$subheading_ident_str}};
  0         0  
3431             my $subtuple_ident_str = $r->_ident_str(
3432 0         0 {CORE::map { ($_ => $tuple->{$_}) }
3433 0         0 CORE::keys %{$subheading}} );
  0         0  
3434 0   0     0 my $matched_b = $index->{$subtuple_ident_str} ||= {};
3435 0         0 $matched_b->{$tuple_ident_str} = $tuple;
3436              
3437 0 0       0 if (exists $r_keys->{$subheading_ident_str}) {
3438 0 0       0 if ((CORE::keys %{$matched_b}) == 1) {
  0         0  
3439             # A candidate key is still satisfied.
3440 0         0 $r_keys->{$subheading_ident_str} = $subheading;
3441             }
3442             else {
3443             # A candidate key is now violated.
3444 0         0 CORE::delete $r_keys->{$subheading_ident_str};
3445             }
3446             }
3447              
3448             }
3449              
3450             }
3451             }
3452 13         18 $r->_cardinality( scalar CORE::keys %{$r_b} );
  13         48  
3453              
3454 13         77 return $r;
3455             }
3456              
3457             ###########################################################################
3458              
3459             sub delete {
3460 0     0 0   my ($r, $t) = @_;
3461 0 0         confess q{delete(): Can't mutate invocant that has a frozen identity.}
3462             if $r->_has_frozen_identity();
3463 0           $t = $r->_normalize_same_heading_tuples_arg( 'delete', '$t', $t );
3464 0           for my $tuple (@{$t}) {
  0            
3465 0 0         confess q{delete(): Bad $t arg; it contains the invocant}
3466             . q{ Set::Relation object as a tuple-valued component,}
3467             . q{ so the invocant would be frozen as a side-effect.}
3468             if $r->_self_is_component_of_tuple_arg( $tuple );
3469             }
3470 0           return $r->_delete( $t );
3471             }
3472              
3473             sub _delete {
3474 0     0     my ($r, $t) = @_;
3475              
3476 0           my $r_b = $r->_body();
3477 0           my $r_indexes = $r->_indexes();
3478              
3479 0           for my $tuple (@{$t}) {
  0            
3480 0           $tuple = $r->_import_nfmt_tuple( $tuple );
3481 0           my $tuple_ident_str = $r->_ident_str( $tuple );
3482 0 0         if (exists $r_b->{$tuple_ident_str}) {
3483 0           CORE::delete $r_b->{$tuple_ident_str};
3484              
3485 0           for my $subheading_ident_str (CORE::keys %{$r_indexes}) {
  0            
3486             my ($subheading, $index)
3487 0           = @{$r_indexes->{$subheading_ident_str}};
  0            
3488             my $subtuple_ident_str = $r->_ident_str(
3489 0           {CORE::map { ($_ => $tuple->{$_}) }
3490 0           CORE::keys %{$subheading}} );
  0            
3491 0           my $matched_b = $index->{$subtuple_ident_str};
3492 0           CORE::delete $matched_b->{$tuple_ident_str};
3493 0 0         if ((scalar CORE::keys %{$matched_b}) == 0) {
  0            
3494 0           CORE::delete $index->{$subtuple_ident_str};
3495             }
3496             }
3497              
3498             }
3499             }
3500 0           $r->_cardinality( scalar CORE::keys %{$r_b} );
  0            
3501              
3502 0           return $r;
3503             }
3504              
3505             ###########################################################################
3506              
3507             } # class Set::Relation::V1
3508              
3509             ###########################################################################
3510             ###########################################################################
3511              
3512             1;