← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 11:58:52 2013
Reported on Tue Oct 15 12:01:07 2013

Filename/usr/share/perl5/Set/Infinite.pm
StatementsExecuted 38 statements in 9.21ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1112.57ms3.28msSet::Infinite::::BEGIN@18Set::Infinite::BEGIN@18
11195µs95µsSet::Infinite::::BEGIN@315Set::Infinite::BEGIN@315
11134µs34µsSet::Infinite::::BEGIN@8Set::Infinite::BEGIN@8
11131µs92µsSet::Infinite::::BEGIN@21Set::Infinite::BEGIN@21
11125µs25µsSet::Infinite::::BEGIN@937Set::Infinite::BEGIN@937
11116µs250µsSet::Infinite::::BEGIN@24Set::Infinite::BEGIN@24
11112µs6.04msSet::Infinite::::BEGIN@16Set::Infinite::BEGIN@16
11112µs58µsSet::Infinite::::BEGIN@17Set::Infinite::BEGIN@17
11111µs16µsSet::Infinite::::BEGIN@15Set::Infinite::BEGIN@15
1118µs8µsSet::Infinite::::BEGIN@45Set::Infinite::BEGIN@45
0000s0sSet::Infinite::::DESTROYSet::Infinite::DESTROY
0000s0sSet::Infinite::::__ANON__[:1145]Set::Infinite::__ANON__[:1145]
0000s0sSet::Infinite::::__ANON__[:358]Set::Infinite::__ANON__[:358]
0000s0sSet::Infinite::::__ANON__[:423]Set::Infinite::__ANON__[:423]
0000s0sSet::Infinite::::__ANON__[:475]Set::Infinite::__ANON__[:475]
0000s0sSet::Infinite::::__ANON__[:487]Set::Infinite::__ANON__[:487]
0000s0sSet::Infinite::::__ANON__[:511]Set::Infinite::__ANON__[:511]
0000s0sSet::Infinite::::__ANON__[:522]Set::Infinite::__ANON__[:522]
0000s0sSet::Infinite::::__ANON__[:535]Set::Infinite::__ANON__[:535]
0000s0sSet::Infinite::::__ANON__[:543]Set::Infinite::__ANON__[:543]
0000s0sSet::Infinite::::__ANON__[:584]Set::Infinite::__ANON__[:584]
0000s0sSet::Infinite::::__ANON__[:655]Set::Infinite::__ANON__[:655]
0000s0sSet::Infinite::::__ANON__[:696]Set::Infinite::__ANON__[:696]
0000s0sSet::Infinite::::__ANON__[:720]Set::Infinite::__ANON__[:720]
0000s0sSet::Infinite::::__ANON__[:732]Set::Infinite::__ANON__[:732]
0000s0sSet::Infinite::::__ANON__[:743]Set::Infinite::__ANON__[:743]
0000s0sSet::Infinite::::__ANON__[:760]Set::Infinite::__ANON__[:760]
0000s0sSet::Infinite::::__ANON__[:768]Set::Infinite::__ANON__[:768]
0000s0sSet::Infinite::::__ANON__[:924]Set::Infinite::__ANON__[:924]
0000s0sSet::Infinite::::__ANON__[:929]Set::Infinite::__ANON__[:929]
0000s0sSet::Infinite::::__ANON__[:948]Set::Infinite::__ANON__[:948]
0000s0sSet::Infinite::::__ANON__[:964]Set::Infinite::__ANON__[:964]
0000s0sSet::Infinite::::__ANON__[:974]Set::Infinite::__ANON__[:974]
0000s0sSet::Infinite::::__ANON__[:987]Set::Infinite::__ANON__[:987]
0000s0sSet::Infinite::::_backtrackSet::Infinite::_backtrack
0000s0sSet::Infinite::::_cleanupSet::Infinite::_cleanup
0000s0sSet::Infinite::::_first_nSet::Infinite::_first_n
0000s0sSet::Infinite::::_functionSet::Infinite::_function
0000s0sSet::Infinite::::_function2Set::Infinite::_function2
0000s0sSet::Infinite::::_last_nSet::Infinite::_last_n
0000s0sSet::Infinite::::_pretty_printSet::Infinite::_pretty_print
0000s0sSet::Infinite::::_quantize_spanSet::Infinite::_quantize_span
0000s0sSet::Infinite::::as_stringSet::Infinite::as_string
0000s0sSet::Infinite::::compactSet::Infinite::compact
0000s0sSet::Infinite::::complementSet::Infinite::complement
0000s0sSet::Infinite::::containsSet::Infinite::contains
0000s0sSet::Infinite::::countSet::Infinite::count
0000s0sSet::Infinite::::firstSet::Infinite::first
0000s0sSet::Infinite::::infSet::Infinite::inf
0000s0sSet::Infinite::::intersected_spansSet::Infinite::intersected_spans
0000s0sSet::Infinite::::intersectionSet::Infinite::intersection
0000s0sSet::Infinite::::intersectsSet::Infinite::intersects
0000s0sSet::Infinite::::is_nullSet::Infinite::is_null
0000s0sSet::Infinite::::is_too_complexSet::Infinite::is_too_complex
0000s0sSet::Infinite::::iterateSet::Infinite::iterate
0000s0sSet::Infinite::::lastSet::Infinite::last
0000s0sSet::Infinite::::max_aSet::Infinite::max_a
0000s0sSet::Infinite::::min_aSet::Infinite::min_a
0000s0sSet::Infinite::::minus_infSet::Infinite::minus_inf
0000s0sSet::Infinite::::no_cleanupSet::Infinite::no_cleanup
0000s0sSet::Infinite::::offsetSet::Infinite::offset
0000s0sSet::Infinite::::quantizeSet::Infinite::quantize
0000s0sSet::Infinite::::selectSet::Infinite::select
0000s0sSet::Infinite::::sizeSet::Infinite::size
0000s0sSet::Infinite::::spaceshipSet::Infinite::spaceship
0000s0sSet::Infinite::::toleranceSet::Infinite::tolerance
0000s0sSet::Infinite::::traceSet::Infinite::trace
0000s0sSet::Infinite::::trace_closeSet::Infinite::trace_close
0000s0sSet::Infinite::::trace_openSet::Infinite::trace_open
0000s0sSet::Infinite::::unionSet::Infinite::union
0000s0sSet::Infinite::::untilSet::Infinite::until
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Set::Infinite;
2
3# Copyright (c) 2001, 2002, 2003, 2004 Flavio Soibelmann Glock.
4# All rights reserved.
5# This program is free software; you can redistribute it and/or
6# modify it under the same terms as Perl itself.
7
8354µs134µs
# spent 34µs within Set::Infinite::BEGIN@8 which was called: # once (34µs+0s) by DateTime::Set::BEGIN@10 at line 8
use 5.005_03;
# spent 34µs making 1 call to Set::Infinite::BEGIN@8
9
10# These methods are inherited from Set::Infinite::Basic "as-is":
11# type list fixtype numeric min max integer real new span copy
12# start_set end_set universal_set empty_set minus difference
13# simmetric_difference is_empty
14
15329µs221µs
# spent 16µs (11+5) within Set::Infinite::BEGIN@15 which was called: # once (11µs+5µs) by DateTime::Set::BEGIN@10 at line 15
use strict;
# spent 16µs making 1 call to Set::Infinite::BEGIN@15 # spent 5µs making 1 call to strict::import
16341µs212.1ms
# spent 6.04ms (12µs+6.03) within Set::Infinite::BEGIN@16 which was called: # once (12µs+6.03ms) by DateTime::Set::BEGIN@10 at line 16
use base qw(Set::Infinite::Basic Exporter);
# spent 6.04ms making 1 call to Set::Infinite::BEGIN@16 # spent 6.03ms making 1 call to base::import
17331µs2104µs
# spent 58µs (12+46) within Set::Infinite::BEGIN@17 which was called: # once (12µs+46µs) by DateTime::Set::BEGIN@10 at line 17
use Carp;
# spent 58µs making 1 call to Set::Infinite::BEGIN@17 # spent 46µs making 1 call to Exporter::import
183257µs13.28ms
# spent 3.28ms (2.57+709µs) within Set::Infinite::BEGIN@18 which was called: # once (2.57ms+709µs) by DateTime::Set::BEGIN@10 at line 18
use Set::Infinite::Arithmetic;
# spent 3.28ms making 1 call to Set::Infinite::BEGIN@18
19
20use overload
21161µs
# spent 92µs (31+61) within Set::Infinite::BEGIN@21 which was called: # once (31µs+61µs) by DateTime::Set::BEGIN@10 at line 22
'<=>' => \&spaceship,
# spent 61µs making 1 call to overload::import
22392µs192µs '""' => \&as_string;
# spent 92µs making 1 call to Set::Infinite::BEGIN@21
23
241234µs
# spent 250µs (16+234) within Set::Infinite::BEGIN@24 which was called: # once (16µs+234µs) by DateTime::Set::BEGIN@10 at line 29
use vars qw(@EXPORT_OK $VERSION
# spent 234µs making 1 call to vars::import
25 $TRACE $DEBUG_BT $PRETTY_PRINT $inf $minus_inf $neg_inf
26 %_first %_last %_backtrack
27 $too_complex $backtrack_depth
28 $max_backtrack_depth $max_intersection_depth
293170µs1250µs $trace_level %level_title );
# spent 250µs making 1 call to Set::Infinite::BEGIN@24
30
3113µs@EXPORT_OK = qw(inf $inf trace_open trace_close);
32
331500ns$inf = 100**100**100;
3411µs$neg_inf = $minus_inf = -$inf;
35
36
37# obsolete methods - included for backward compatibility
38sub inf () { $inf }
39sub minus_inf () { $minus_inf }
40sub no_cleanup { $_[0] }
4114µs*type = \&Set::Infinite::Basic::type;
42sub compact { @_ }
43
44
45
# spent 8µs within Set::Infinite::BEGIN@45 which was called: # once (8µs+0s) by DateTime::Set::BEGIN@10 at line 56
BEGIN {
4699µs $VERSION = "0.63";
47 $TRACE = 0; # enable basic trace method execution
48 $DEBUG_BT = 0; # enable backtrack tracer
49 $PRETTY_PRINT = 0; # 0 = print 'Too Complex'; 1 = describe functions
50 $trace_level = 0; # indentation level when debugging
51
52 $too_complex = "Too complex";
53 $backtrack_depth = 0;
54 $max_backtrack_depth = 10; # _backtrack()
55 $max_intersection_depth = 5; # first()
5614.88ms18µs}
# spent 8µs making 1 call to Set::Infinite::BEGIN@45
57
58sub trace { # title=>'aaa'
59 return $_[0] unless $TRACE;
60 my ($self, %parm) = @_;
61 my @caller = caller(1);
62 # print "self $self ". ref($self). "\n";
63 print "" . ( ' | ' x $trace_level ) .
64 "$parm{title} ". $self->copy .
65 ( exists $parm{arg} ? " -- " . $parm{arg}->copy : "" ).
66 " $caller[1]:$caller[2] ]\n" if $TRACE == 1;
67 return $self;
68}
69
70sub trace_open {
71 return $_[0] unless $TRACE;
72 my ($self, %parm) = @_;
73 my @caller = caller(1);
74 print "" . ( ' | ' x $trace_level ) .
75 "\\ $parm{title} ". $self->copy .
76 ( exists $parm{arg} ? " -- ". $parm{arg}->copy : "" ).
77 " $caller[1]:$caller[2] ]\n";
78 $trace_level++;
79 $level_title{$trace_level} = $parm{title};
80 return $self;
81}
82
83sub trace_close {
84 return $_[0] unless $TRACE;
85 my ($self, %parm) = @_;
86 my @caller = caller(0);
87 print "" . ( ' | ' x ($trace_level-1) ) .
88 "\/ $level_title{$trace_level} ".
89 ( exists $parm{arg} ?
90 (
91 defined $parm{arg} ?
92 "ret ". ( UNIVERSAL::isa($parm{arg}, __PACKAGE__ ) ?
93 $parm{arg}->copy :
94 "<$parm{arg}>" ) :
95 "undef"
96 ) :
97 "" # no arg
98 ).
99 " $caller[1]:$caller[2] ]\n";
100 $trace_level--;
101 return $self;
102}
103
104
105# creates a 'function' object that can be solved by _backtrack()
106sub _function {
107 my ($self, $method) = (shift, shift);
108 my $b = $self->empty_set();
109 $b->{too_complex} = 1;
110 $b->{parent} = $self;
111 $b->{method} = $method;
112 $b->{param} = [ @_ ];
113 return $b;
114}
115
116
117# same as _function, but with 2 arguments
118sub _function2 {
119 my ($self, $method, $arg) = (shift, shift, shift);
120 unless ( $self->{too_complex} || $arg->{too_complex} ) {
121 return $self->$method($arg, @_);
122 }
123 my $b = $self->empty_set();
124 $b->{too_complex} = 1;
125 $b->{parent} = [ $self, $arg ];
126 $b->{method} = $method;
127 $b->{param} = [ @_ ];
128 return $b;
129}
130
131
132sub quantize {
133 my $self = shift;
134 $self->trace_open(title=>"quantize") if $TRACE;
135 my @min = $self->min_a;
136 my @max = $self->max_a;
137 if (($self->{too_complex}) or
138 (defined $min[0] && $min[0] == $neg_inf) or
139 (defined $max[0] && $max[0] == $inf)) {
140
141 return $self->_function( 'quantize', @_ );
142 }
143
144 my @a;
145 my %rule = @_;
146 my $b = $self->empty_set();
147 my $parent = $self;
148
149 $rule{unit} = 'one' unless $rule{unit};
150 $rule{quant} = 1 unless $rule{quant};
151 $rule{parent} = $parent;
152 $rule{strict} = $parent unless exists $rule{strict};
153 $rule{type} = $parent->{type};
154
155 my ($min, $open_begin) = $parent->min_a;
156
157 unless (defined $min) {
158 $self->trace_close( arg => $b ) if $TRACE;
159 return $b;
160 }
161
162 $rule{fixtype} = 1 unless exists $rule{fixtype};
163 $Set::Infinite::Arithmetic::Init_quantizer{$rule{unit}}->(\%rule);
164
165 $rule{sub_unit} = $Set::Infinite::Arithmetic::Offset_to_value{$rule{unit}};
166 carp "Quantize unit '".$rule{unit}."' not implemented" unless ref( $rule{sub_unit} ) eq 'CODE';
167
168 my ($max, $open_end) = $parent->max_a;
169 $rule{offset} = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $min);
170 my $last_offset = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $max);
171 $rule{size} = $last_offset - $rule{offset} + 1;
172 my ($index, $tmp, $this, $next);
173 for $index (0 .. $rule{size} ) {
174 # ($this, $next) = $rule{sub_unit} (\%rule, $index);
175 ($this, $next) = $rule{sub_unit}->(\%rule, $index);
176 unless ( $rule{fixtype} ) {
177 $tmp = { a => $this , b => $next ,
178 open_begin => 0, open_end => 1 };
179 }
180 else {
181 $tmp = Set::Infinite::Basic::_simple_new($this,$next, $rule{type} );
182 $tmp->{open_end} = 1;
183 }
184 next if ( $rule{strict} and not $rule{strict}->intersects($tmp));
185 push @a, $tmp;
186 }
187
188 $b->{list} = \@a; # change data
189 $self->trace_close( arg => $b ) if $TRACE;
190 return $b;
191}
192
193
194sub _first_n {
195 my $self = shift;
196 my $n = shift;
197 my $tail = $self->copy;
198 my @result;
199 my $first;
200 for ( 1 .. $n )
201 {
202 ( $first, $tail ) = $tail->first if $tail;
203 push @result, $first;
204 }
205 return $tail, @result;
206}
207
208sub _last_n {
209 my $self = shift;
210 my $n = shift;
211 my $tail = $self->copy;
212 my @result;
213 my $last;
214 for ( 1 .. $n )
215 {
216 ( $last, $tail ) = $tail->last if $tail;
217 unshift @result, $last;
218 }
219 return $tail, @result;
220}
221
222
223sub select {
224 my $self = shift;
225 $self->trace_open(title=>"select") if $TRACE;
226
227 my %param = @_;
228 die "select() - parameter 'freq' is deprecated" if exists $param{freq};
229
230 my $res;
231 my $count;
232 my @by;
233 @by = @{ $param{by} } if exists $param{by};
234 $count = delete $param{count} || $inf;
235 # warn "select: count=$count by=[@by]";
236
237 if ($count <= 0) {
238 $self->trace_close( arg => $res ) if $TRACE;
239 return $self->empty_set();
240 }
241
242 my @set;
243 my $tail;
244 my $first;
245 my $last;
246 if ( @by )
247 {
248 my @res;
249 if ( ! $self->is_too_complex )
250 {
251 $res = $self->new;
252 @res = @{ $self->{list} }[ @by ] ;
253 }
254 else
255 {
256 my ( @pos_by, @neg_by );
257 for ( @by ) {
258 ( $_ < 0 ) ? push @neg_by, $_ :
259 push @pos_by, $_;
260 }
261 my @first;
262 if ( @pos_by ) {
263 @pos_by = sort { $a <=> $b } @pos_by;
264 ( $tail, @set ) = $self->_first_n( 1 + $pos_by[-1] );
265 @first = @set[ @pos_by ];
266 }
267 my @last;
268 if ( @neg_by ) {
269 @neg_by = sort { $a <=> $b } @neg_by;
270 ( $tail, @set ) = $self->_last_n( - $neg_by[0] );
271 @last = @set[ @neg_by ];
272 }
273 @res = map { $_->{list}[0] } ( @first , @last );
274 }
275
276 $res = $self->new;
277 @res = sort { $a->{a} <=> $b->{a} } grep { defined } @res;
278 my $last;
279 my @a;
280 for ( @res ) {
281 push @a, $_ if ! $last || $last->{a} != $_->{a};
282 $last = $_;
283 }
284 $res->{list} = \@a;
285 }
286 else
287 {
288 $res = $self;
289 }
290
291 return $res if $count == $inf;
292 my $count_set = $self->empty_set();
293 if ( ! $self->is_too_complex )
294 {
295 my @a;
296 @a = grep { defined } @{ $res->{list} }[ 0 .. $count - 1 ] ;
297 $count_set->{list} = \@a;
298 }
299 else
300 {
301 my $last;
302 while ( $res ) {
303 ( $first, $res ) = $res->first;
304 last unless $first;
305 last if $last && $last->{a} == $first->{list}[0]{a};
306 $last = $first->{list}[0];
307 push @{$count_set->{list}}, $first->{list}[0];
308 $count--;
309 last if $count <= 0;
310 }
311 }
312 return $count_set;
313}
314
315
# spent 95µs within Set::Infinite::BEGIN@315 which was called: # once (95µs+0s) by DateTime::Set::BEGIN@10 at line 770
BEGIN {
316
317 # %_first and %_last hashes are used to backtrack the value
318 # of first() and last() of an infinite set
319
320 %_first = (
321 'complement' =>
322 sub {
323 my $self = $_[0];
324 my @parent_min = $self->{parent}->first;
325 unless ( defined $parent_min[0] ) {
326 return (undef, 0);
327 }
328 my $parent_complement;
329 my $first;
330 my @next;
331 my $parent;
332 if ( $parent_min[0]->min == $neg_inf ) {
333 my @parent_second = $parent_min[1]->first;
334 # (-inf..min) (second..?)
335 # (min..second) = complement
336 $first = $self->new( $parent_min[0]->complement );
337 $first->{list}[0]{b} = $parent_second[0]->{list}[0]{a};
338 $first->{list}[0]{open_end} = ! $parent_second[0]->{list}[0]{open_begin};
339 @{ $first->{list} } = () if
340 ( $first->{list}[0]{a} == $first->{list}[0]{b}) &&
341 ( $first->{list}[0]{open_begin} ||
342 $first->{list}[0]{open_end} );
343 @next = $parent_second[0]->max_a;
344 $parent = $parent_second[1];
345 }
346 else {
347 # (min..?)
348 # (-inf..min) = complement
349 $parent_complement = $parent_min[0]->complement;
350 $first = $self->new( $parent_complement->{list}[0] );
351 @next = $parent_min[0]->max_a;
352 $parent = $parent_min[1];
353 }
354 my @no_tail = $self->new($neg_inf,$next[0]);
355 $no_tail[0]->{list}[0]{open_end} = $next[1];
356 my $tail = $parent->union($no_tail[0])->complement;
357 return ($first, $tail);
358 }, # end: first-complement
359 'intersection' =>
360 sub {
361 my $self = $_[0];
362 my @parent = @{ $self->{parent} };
363 # warn "$method parents @parent";
364 my $retry_count = 0;
365 my (@first, @min, $which, $first1, $intersection);
366 SEARCH: while ($retry_count++ < $max_intersection_depth) {
367 return undef unless defined $parent[0];
368 return undef unless defined $parent[1];
369 @{$first[0]} = $parent[0]->first;
370 @{$first[1]} = $parent[1]->first;
371 unless ( defined $first[0][0] ) {
372 # warn "don't know first of $method";
373 $self->trace_close( arg => 'undef' ) if $TRACE;
374 return undef;
375 }
376 unless ( defined $first[1][0] ) {
377 # warn "don't know first of $method";
378 $self->trace_close( arg => 'undef' ) if $TRACE;
379 return undef;
380 }
381 @{$min[0]} = $first[0][0]->min_a;
382 @{$min[1]} = $first[1][0]->min_a;
383 unless ( defined $min[0][0] && defined $min[1][0] ) {
384 return undef;
385 }
386 # $which is the index to the bigger "first".
387 $which = ($min[0][0] < $min[1][0]) ? 1 : 0;
388 for my $which1 ( $which, 1 - $which ) {
389 my $tmp_parent = $parent[$which1];
390 ($first1, $parent[$which1]) = @{ $first[$which1] };
391 if ( $first1->is_empty ) {
392 # warn "first1 empty! count $retry_count";
393 # trace_close;
394 # return $first1, undef;
395 $intersection = $first1;
396 $which = $which1;
397 last SEARCH;
398 }
399 $intersection = $first1->intersection( $parent[1-$which1] );
400 # warn "intersection with $first1 is $intersection";
401 unless ( $intersection->is_null ) {
402 # $self->trace( title=>"got an intersection" );
403 if ( $intersection->is_too_complex ) {
404 $parent[$which1] = $tmp_parent;
405 }
406 else {
407 $which = $which1;
408 last SEARCH;
409 }
410 };
411 }
412 }
413 if ( $#{ $intersection->{list} } > 0 ) {
414 my $tail;
415 ($intersection, $tail) = $intersection->first;
416 $parent[$which] = $parent[$which]->union( $tail );
417 }
418 my $tmp;
419 if ( defined $parent[$which] and defined $parent[1-$which] ) {
420 $tmp = $parent[$which]->intersection ( $parent[1-$which] );
421 }
422 return ($intersection, $tmp);
423 }, # end: first-intersection
424 'union' =>
425 sub {
426 my $self = $_[0];
427 my (@first, @min);
428 my @parent = @{ $self->{parent} };
429 @{$first[0]} = $parent[0]->first;
430 @{$first[1]} = $parent[1]->first;
431 unless ( defined $first[0][0] ) {
432 # looks like one set was empty
433 return @{$first[1]};
434 }
435 @{$min[0]} = $first[0][0]->min_a;
436 @{$min[1]} = $first[1][0]->min_a;
437
438 # check min1/min2 for undef
439 unless ( defined $min[0][0] ) {
440 $self->trace_close( arg => "@{$first[1]}" ) if $TRACE;
441 return @{$first[1]}
442 }
443 unless ( defined $min[1][0] ) {
444 $self->trace_close( arg => "@{$first[0]}" ) if $TRACE;
445 return @{$first[0]}
446 }
447
448 my $which = ($min[0][0] < $min[1][0]) ? 0 : 1;
449 my $first = $first[$which][0];
450
451 # find out the tail
452 my $parent1 = $first[$which][1];
453 # warn $self->{parent}[$which]." - $first = $parent1";
454 my $parent2 = ($min[0][0] == $min[1][0]) ?
455 $self->{parent}[1-$which]->complement($first) :
456 $self->{parent}[1-$which];
457 my $tail;
458 if (( ! defined $parent1 ) || $parent1->is_null) {
459 # warn "union parent1 tail is null";
460 $tail = $parent2;
461 }
462 else {
463 my $method = $self->{method};
464 $tail = $parent1->$method( $parent2 );
465 }
466
467 if ( $first->intersects( $tail ) ) {
468 my $first2;
469 ( $first2, $tail ) = $tail->first;
470 $first = $first->union( $first2 );
471 }
472
473 $self->trace_close( arg => "$first $tail" ) if $TRACE;
474 return ($first, $tail);
475 }, # end: first-union
476 'iterate' =>
477 sub {
478 my $self = $_[0];
479 my $parent = $self->{parent};
480 my ($first, $tail) = $parent->first;
481 $first = $first->iterate( @{$self->{param}} ) if ref($first);
482 $tail = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail);
483 my $more;
484 ($first, $more) = $first->first if ref($first);
485 $tail = $tail->_function2( 'union', $more ) if defined $more;
486 return ($first, $tail);
487 },
488 'until' =>
489 sub {
490 my $self = $_[0];
491 my ($a1, $b1) = @{ $self->{parent} };
492 $a1->trace( title=>"computing first()" );
493 my @first1 = $a1->first;
494 my @first2 = $b1->first;
495 my ($first, $tail);
496 if ( $first2[0] <= $first1[0] ) {
497 # added ->first because it returns 2 spans if $a1 == $a2
498 $first = $a1->empty_set()->until( $first2[0] )->first;
499 $tail = $a1->_function2( "until", $first2[1] );
500 }
501 else {
502 $first = $a1->new( $first1[0] )->until( $first2[0] );
503 if ( defined $first1[1] ) {
504 $tail = $first1[1]->_function2( "until", $first2[1] );
505 }
506 else {
507 $tail = undef;
508 }
509 }
510 return ($first, $tail);
511 },
512 'offset' =>
513 sub {
514 my $self = $_[0];
515 my ($first, $tail) = $self->{parent}->first;
516 $first = $first->offset( @{$self->{param}} );
517 $tail = $tail->_function( 'offset', @{$self->{param}} );
518 my $more;
519 ($first, $more) = $first->first;
520 $tail = $tail->_function2( 'union', $more ) if defined $more;
521 return ($first, $tail);
522 },
523 'quantize' =>
524 sub {
525 my $self = $_[0];
526 my @min = $self->{parent}->min_a;
527 if ( $min[0] == $neg_inf || $min[0] == $inf ) {
528 return ( $self->new( $min[0] ) , $self->copy );
529 }
530 my $first = $self->new( $min[0] )->quantize( @{$self->{param}} );
531 return ( $first,
532 $self->{parent}->
533 _function2( 'intersection', $first->complement )->
534 _function( 'quantize', @{$self->{param}} ) );
535 },
536 'tolerance' =>
537 sub {
538 my $self = $_[0];
539 my ($first, $tail) = $self->{parent}->first;
540 $first = $first->tolerance( @{$self->{param}} );
541 $tail = $tail->tolerance( @{$self->{param}} );
542 return ($first, $tail);
543 },
544298µs ); # %_first
545
546 %_last = (
547 'complement' =>
548 sub {
549 my $self = $_[0];
550 my @parent_max = $self->{parent}->last;
551 unless ( defined $parent_max[0] ) {
552 return (undef, 0);
553 }
554 my $parent_complement;
555 my $last;
556 my @next;
557 my $parent;
558 if ( $parent_max[0]->max == $inf ) {
559 # (inf..min) (second..?) = parent
560 # (min..second) = complement
561 my @parent_second = $parent_max[1]->last;
562 $last = $self->new( $parent_max[0]->complement );
563 $last->{list}[0]{a} = $parent_second[0]->{list}[0]{b};
564 $last->{list}[0]{open_begin} = ! $parent_second[0]->{list}[0]{open_end};
565 @{ $last->{list} } = () if
566 ( $last->{list}[0]{a} == $last->{list}[0]{b}) &&
567 ( $last->{list}[0]{open_end} ||
568 $last->{list}[0]{open_begin} );
569 @next = $parent_second[0]->min_a;
570 $parent = $parent_second[1];
571 }
572 else {
573 # (min..?)
574 # (-inf..min) = complement
575 $parent_complement = $parent_max[0]->complement;
576 $last = $self->new( $parent_complement->{list}[-1] );
577 @next = $parent_max[0]->min_a;
578 $parent = $parent_max[1];
579 }
580 my @no_tail = $self->new($next[0], $inf);
581 $no_tail[0]->{list}[-1]{open_begin} = $next[1];
582 my $tail = $parent->union($no_tail[-1])->complement;
583 return ($last, $tail);
584 },
585 'intersection' =>
586 sub {
587 my $self = $_[0];
588 my @parent = @{ $self->{parent} };
589 # TODO: check max1/max2 for undef
590
591 my $retry_count = 0;
592 my (@last, @max, $which, $last1, $intersection);
593
594 SEARCH: while ($retry_count++ < $max_intersection_depth) {
595 return undef unless defined $parent[0];
596 return undef unless defined $parent[1];
597
598 @{$last[0]} = $parent[0]->last;
599 @{$last[1]} = $parent[1]->last;
600 unless ( defined $last[0][0] ) {
601 $self->trace_close( arg => 'undef' ) if $TRACE;
602 return undef;
603 }
604 unless ( defined $last[1][0] ) {
605 $self->trace_close( arg => 'undef' ) if $TRACE;
606 return undef;
607 }
608 @{$max[0]} = $last[0][0]->max_a;
609 @{$max[1]} = $last[1][0]->max_a;
610 unless ( defined $max[0][0] && defined $max[1][0] ) {
611 $self->trace( title=>"can't find max()" ) if $TRACE;
612 $self->trace_close( arg => 'undef' ) if $TRACE;
613 return undef;
614 }
615
616 # $which is the index to the smaller "last".
617 $which = ($max[0][0] > $max[1][0]) ? 1 : 0;
618
619 for my $which1 ( $which, 1 - $which ) {
620 my $tmp_parent = $parent[$which1];
621 ($last1, $parent[$which1]) = @{ $last[$which1] };
622 if ( $last1->is_null ) {
623 $which = $which1;
624 $intersection = $last1;
625 last SEARCH;
626 }
627 $intersection = $last1->intersection( $parent[1-$which1] );
628
629 unless ( $intersection->is_null ) {
630 # $self->trace( title=>"got an intersection" );
631 if ( $intersection->is_too_complex ) {
632 $self->trace( title=>"got a too_complex intersection" ) if $TRACE;
633 # warn "too complex intersection";
634 $parent[$which1] = $tmp_parent;
635 }
636 else {
637 $self->trace( title=>"got an intersection" ) if $TRACE;
638 $which = $which1;
639 last SEARCH;
640 }
641 };
642 }
643 }
644 $self->trace( title=>"exit loop" ) if $TRACE;
645 if ( $#{ $intersection->{list} } > 0 ) {
646 my $tail;
647 ($intersection, $tail) = $intersection->last;
648 $parent[$which] = $parent[$which]->union( $tail );
649 }
650 my $tmp;
651 if ( defined $parent[$which] and defined $parent[1-$which] ) {
652 $tmp = $parent[$which]->intersection ( $parent[1-$which] );
653 }
654 return ($intersection, $tmp);
655 },
656 'union' =>
657 sub {
658 my $self = $_[0];
659 my (@last, @max);
660 my @parent = @{ $self->{parent} };
661 @{$last[0]} = $parent[0]->last;
662 @{$last[1]} = $parent[1]->last;
663 @{$max[0]} = $last[0][0]->max_a;
664 @{$max[1]} = $last[1][0]->max_a;
665 unless ( defined $max[0][0] ) {
666 return @{$last[1]}
667 }
668 unless ( defined $max[1][0] ) {
669 return @{$last[0]}
670 }
671
672 my $which = ($max[0][0] > $max[1][0]) ? 0 : 1;
673 my $last = $last[$which][0];
674 # find out the tail
675 my $parent1 = $last[$which][1];
676 # warn $self->{parent}[$which]." - $last = $parent1";
677 my $parent2 = ($max[0][0] == $max[1][0]) ?
678 $self->{parent}[1-$which]->complement($last) :
679 $self->{parent}[1-$which];
680 my $tail;
681 if (( ! defined $parent1 ) || $parent1->is_null) {
682 $tail = $parent2;
683 }
684 else {
685 my $method = $self->{method};
686 $tail = $parent1->$method( $parent2 );
687 }
688
689 if ( $last->intersects( $tail ) ) {
690 my $last2;
691 ( $last2, $tail ) = $tail->last;
692 $last = $last->union( $last2 );
693 }
694
695 return ($last, $tail);
696 },
697 'until' =>
698 sub {
699 my $self = $_[0];
700 my ($a1, $b1) = @{ $self->{parent} };
701 $a1->trace( title=>"computing last()" );
702 my @last1 = $a1->last;
703 my @last2 = $b1->last;
704 my ($last, $tail);
705 if ( $last2[0] <= $last1[0] ) {
706 # added ->last because it returns 2 spans if $a1 == $a2
707 $last = $last2[0]->until( $a1 )->last;
708 $tail = $a1->_function2( "until", $last2[1] );
709 }
710 else {
711 $last = $a1->new( $last1[0] )->until( $last2[0] );
712 if ( defined $last1[1] ) {
713 $tail = $last1[1]->_function2( "until", $last2[1] );
714 }
715 else {
716 $tail = undef;
717 }
718 }
719 return ($last, $tail);
720 },
721 'iterate' =>
722 sub {
723 my $self = $_[0];
724 my $parent = $self->{parent};
725 my ($last, $tail) = $parent->last;
726 $last = $last->iterate( @{$self->{param}} ) if ref($last);
727 $tail = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail);
728 my $more;
729 ($last, $more) = $last->last if ref($last);
730 $tail = $tail->_function2( 'union', $more ) if defined $more;
731 return ($last, $tail);
732 },
733 'offset' =>
734 sub {
735 my $self = $_[0];
736 my ($last, $tail) = $self->{parent}->last;
737 $last = $last->offset( @{$self->{param}} );
738 $tail = $tail->_function( 'offset', @{$self->{param}} );
739 my $more;
740 ($last, $more) = $last->last;
741 $tail = $tail->_function2( 'union', $more ) if defined $more;
742 return ($last, $tail);
743 },
744 'quantize' =>
745 sub {
746 my $self = $_[0];
747 my @max = $self->{parent}->max_a;
748 if (( $max[0] == $neg_inf ) || ( $max[0] == $inf )) {
749 return ( $self->new( $max[0] ) , $self->copy );
750 }
751 my $last = $self->new( $max[0] )->quantize( @{$self->{param}} );
752 if ($max[1]) { # open_end
753 if ( $last->min <= $max[0] ) {
754 $last = $self->new( $last->min - 1e-9 )->quantize( @{$self->{param}} );
755 }
756 }
757 return ( $last, $self->{parent}->
758 _function2( 'intersection', $last->complement )->
759 _function( 'quantize', @{$self->{param}} ) );
760 },
761 'tolerance' =>
762 sub {
763 my $self = $_[0];
764 my ($last, $tail) = $self->{parent}->last;
765 $last = $last->tolerance( @{$self->{param}} );
766 $tail = $tail->tolerance( @{$self->{param}} );
767 return ($last, $tail);
768 },
769 ); # %_last
77011.42ms195µs} # BEGIN
# spent 95µs making 1 call to Set::Infinite::BEGIN@315
771
772sub first {
773 my $self = $_[0];
774 unless ( exists $self->{first} ) {
775 $self->trace_open(title=>"first") if $TRACE;
776 if ( $self->{too_complex} ) {
777 my $method = $self->{method};
778 # warn "method $method ". ( exists $_first{$method} ? "exists" : "does not exist" );
779 if ( exists $_first{$method} ) {
780 @{$self->{first}} = $_first{$method}->($self);
781 }
782 else {
783 my $redo = $self->{parent}->$method ( @{ $self->{param} } );
784 @{$self->{first}} = $redo->first;
785 }
786 }
787 else {
788 return $self->SUPER::first;
789 }
790 }
791 return wantarray ? @{$self->{first}} : $self->{first}[0];
792}
793
794
795sub last {
796 my $self = $_[0];
797 unless ( exists $self->{last} ) {
798 $self->trace(title=>"last") if $TRACE;
799 if ( $self->{too_complex} ) {
800 my $method = $self->{method};
801 if ( exists $_last{$method} ) {
802 @{$self->{last}} = $_last{$method}->($self);
803 }
804 else {
805 my $redo = $self->{parent}->$method ( @{ $self->{param} } );
806 @{$self->{last}} = $redo->last;
807 }
808 }
809 else {
810 return $self->SUPER::last;
811 }
812 }
813 return wantarray ? @{$self->{last}} : $self->{last}[0];
814}
815
816
817# offset: offsets subsets
818sub offset {
819 my $self = shift;
820 if ($self->{too_complex}) {
821 return $self->_function( 'offset', @_ );
822 }
823 $self->trace_open(title=>"offset") if $TRACE;
824
825 my @a;
826 my %param = @_;
827 my $b1 = $self->empty_set();
828 my ($interval, $ia, $i);
829 $param{mode} = 'offset' unless $param{mode};
830
831 unless (ref($param{value}) eq 'ARRAY') {
832 $param{value} = [0 + $param{value}, 0 + $param{value}];
833 }
834 $param{unit} = 'one' unless $param{unit};
835 my $parts = ($#{$param{value}}) / 2;
836 my $sub_unit = $Set::Infinite::Arithmetic::subs_offset2{$param{unit}};
837 my $sub_mode = $Set::Infinite::Arithmetic::_MODE{$param{mode}};
838
839 carp "unknown unit $param{unit} for offset()" unless defined $sub_unit;
840 carp "unknown mode $param{mode} for offset()" unless defined $sub_mode;
841
842 my ($j);
843 my ($cmp, $this, $next, $ib, $part, $open_begin, $open_end, $tmp);
844
845 my @value;
846 foreach $j (0 .. $parts) {
847 push @value, [ $param{value}[$j+$j], $param{value}[$j+$j + 1] ];
848 }
849
850 foreach $interval ( @{ $self->{list} } ) {
851 $ia = $interval->{a};
852 $ib = $interval->{b};
853 $open_begin = $interval->{open_begin};
854 $open_end = $interval->{open_end};
855 foreach $j (0 .. $parts) {
856 # print " [ofs($ia,$ib)] ";
857 ($this, $next) = $sub_mode->( $sub_unit, $ia, $ib, @{$value[$j]} );
858 next if ($this > $next); # skip if a > b
859 if ($this == $next) {
860 # TODO: fix this
861 $open_end = $open_begin;
862 }
863 push @a, { a => $this , b => $next ,
864 open_begin => $open_begin , open_end => $open_end };
865 } # parts
866 } # self
867 @a = sort { $a->{a} <=> $b->{a} } @a;
868 $b1->{list} = \@a; # change data
869 $self->trace_close( arg => $b1 ) if $TRACE;
870 $b1 = $b1->fixtype if $self->{fixtype};
871 return $b1;
872}
873
874
875sub is_null {
876 $_[0]->{too_complex} ? 0 : $_[0]->SUPER::is_null;
877}
878
879
880sub is_too_complex {
881 $_[0]->{too_complex} ? 1 : 0;
882}
883
884
885# shows how a 'compacted' set looks like after quantize
886sub _quantize_span {
887 my $self = shift;
888 my %param = @_;
889 $self->trace_open(title=>"_quantize_span") if $TRACE;
890 my $res;
891 if ($self->{too_complex}) {
892 $res = $self->{parent};
893 if ($self->{method} ne 'quantize') {
894 $self->trace( title => "parent is a ". $self->{method} );
895 if ( $self->{method} eq 'union' ) {
896 my $arg0 = $self->{parent}[0]->_quantize_span(%param);
897 my $arg1 = $self->{parent}[1]->_quantize_span(%param);
898 $res = $arg0->union( $arg1 );
899 }
900 elsif ( $self->{method} eq 'intersection' ) {
901 my $arg0 = $self->{parent}[0]->_quantize_span(%param);
902 my $arg1 = $self->{parent}[1]->_quantize_span(%param);
903 $res = $arg0->intersection( $arg1 );
904 }
905
906 # TODO: other methods
907 else {
908 $res = $self; # ->_function( "_quantize_span", %param );
909 }
910 $self->trace_close( arg => $res ) if $TRACE;
911 return $res;
912 }
913
914 # $res = $self->{parent};
915 if ($res->{too_complex}) {
916 $res->trace( title => "parent is complex" );
917 $res = $res->_quantize_span( %param );
918 $res = $res->quantize( @{$self->{param}} )->_quantize_span( %param );
919 }
920 else {
921 $res = $res->iterate (
922 sub {
923 $_[0]->quantize( @{$self->{param}} )->span;
924 }
925 );
926 }
927 }
928 else {
929 $res = $self->iterate ( sub { $_[0] } );
930 }
931 $self->trace_close( arg => $res ) if $TRACE;
932 return $res;
933}
934
- -
937
# spent 25µs within Set::Infinite::BEGIN@937 which was called: # once (25µs+0s) by DateTime::Set::BEGIN@10 at line 990
BEGIN {
938
939 %_backtrack = (
940
941 until => sub {
942 my ($self, $arg) = @_;
943 my $before = $self->{parent}[0]->intersection( $neg_inf, $arg->min )->max;
944 $before = $arg->min unless $before;
945 my $after = $self->{parent}[1]->intersection( $arg->max, $inf )->min;
946 $after = $arg->max unless $after;
947 return $arg->new( $before, $after );
948 },
949
950 iterate => sub {
951 my ($self, $arg) = @_;
952
953 if ( defined $self->{backtrack_callback} )
954 {
955 return $arg = $self->new( $self->{backtrack_callback}->( $arg ) );
956 }
957
958 my $before = $self->{parent}->intersection( $neg_inf, $arg->min )->max;
959 $before = $arg->min unless $before;
960 my $after = $self->{parent}->intersection( $arg->max, $inf )->min;
961 $after = $arg->max unless $after;
962
963 return $arg->new( $before, $after );
964 },
965
966 quantize => sub {
967 my ($self, $arg) = @_;
968 if ($arg->{too_complex}) {
969 return $arg;
970 }
971 else {
972 return $arg->quantize( @{$self->{param}} )->_quantize_span;
973 }
974 },
975
976 offset => sub {
977 my ($self, $arg) = @_;
978 # offset - apply offset with negative values
979 my %tmp = @{$self->{param}};
980 my @values = sort @{$tmp{value}};
981
982 my $backtrack_arg2 = $arg->offset(
983 unit => $tmp{unit},
984 mode => $tmp{mode},
985 value => [ - $values[-1], - $values[0] ] );
986 return $arg->union( $backtrack_arg2 ); # fixes some problems with 'begin' mode
987 },
988
989126µs );
99012.08ms125µs}
# spent 25µs making 1 call to Set::Infinite::BEGIN@937
991
992
993sub _backtrack {
994 my ($self, $method, $arg) = @_;
995 return $self->$method ($arg) unless $self->{too_complex};
996
997 $self->trace_open( title => 'backtrack '.$self->{method} ) if $TRACE;
998
999 $backtrack_depth++;
1000 if ( $backtrack_depth > $max_backtrack_depth ) {
1001 carp ( __PACKAGE__ . ": Backtrack too deep " .
1002 "(more than $max_backtrack_depth levels)" );
1003 }
1004
1005 if (exists $_backtrack{ $self->{method} } ) {
1006 $arg = $_backtrack{ $self->{method} }->( $self, $arg );
1007 }
1008
1009 my $result;
1010 if ( ref($self->{parent}) eq 'ARRAY' ) {
1011 # has 2 parents (intersection, union, until)
1012
1013 my ( $result1, $result2 ) = @{$self->{parent}};
1014 $result1 = $result1->_backtrack( $method, $arg )
1015 if $result1->{too_complex};
1016 $result2 = $result2->_backtrack( $method, $arg )
1017 if $result2->{too_complex};
1018
1019 $method = $self->{method};
1020 if ( $result1->{too_complex} || $result2->{too_complex} ) {
1021 $result = $result1->_function2( $method, $result2 );
1022 }
1023 else {
1024 $result = $result1->$method ($result2);
1025 }
1026 }
1027 else {
1028 # has 1 parent and parameters (offset, select, quantize, iterate)
1029
1030 $result = $self->{parent}->_backtrack( $method, $arg );
1031 $method = $self->{method};
1032 $result = $result->$method ( @{$self->{param}} );
1033 }
1034
1035 $backtrack_depth--;
1036 $self->trace_close( arg => $result ) if $TRACE;
1037 return $result;
1038}
1039
1040
1041sub intersects {
1042 my $a1 = shift;
1043 my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
1044
1045 $a1->trace(title=>"intersects");
1046 if ($a1->{too_complex}) {
1047 $a1 = $a1->_backtrack('intersection', $b1 );
1048 } # don't put 'else' here
1049 if ($b1->{too_complex}) {
1050 $b1 = $b1->_backtrack('intersection', $a1);
1051 }
1052 if (($a1->{too_complex}) or ($b1->{too_complex})) {
1053 return undef; # we don't know the answer!
1054 }
1055 return $a1->SUPER::intersects( $b1 );
1056}
1057
1058
1059sub iterate {
1060 my $self = shift;
1061 my $callback = shift;
1062 die "First argument to iterate() must be a subroutine reference"
1063 unless ref( $callback ) eq 'CODE';
1064 my $backtrack_callback;
1065 if ( @_ && $_[0] eq 'backtrack_callback' )
1066 {
1067 ( undef, $backtrack_callback ) = ( shift, shift );
1068 }
1069 my $set;
1070 if ($self->{too_complex}) {
1071 $self->trace(title=>"iterate:backtrack") if $TRACE;
1072 $set = $self->_function( 'iterate', $callback, @_ );
1073 }
1074 else
1075 {
1076 $self->trace(title=>"iterate") if $TRACE;
1077 $set = $self->SUPER::iterate( $callback, @_ );
1078 }
1079 $set->{backtrack_callback} = $backtrack_callback;
1080 # warn "set backtrack_callback" if defined $backtrack_callback;
1081 return $set;
1082}
1083
1084
1085sub intersection {
1086 my $a1 = shift;
1087 my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
1088
1089 $a1->trace_open(title=>"intersection", arg => $b1) if $TRACE;
1090 if (($a1->{too_complex}) or ($b1->{too_complex})) {
1091 my $arg0 = $a1->_quantize_span;
1092 my $arg1 = $b1->_quantize_span;
1093 unless (($arg0->{too_complex}) or ($arg1->{too_complex})) {
1094 my $res = $arg0->intersection( $arg1 );
1095 $a1->trace_close( arg => $res ) if $TRACE;
1096 return $res;
1097 }
1098 }
1099 if ($a1->{too_complex}) {
1100 $a1 = $a1->_backtrack('intersection', $b1) unless $b1->{too_complex};
1101 } # don't put 'else' here
1102 if ($b1->{too_complex}) {
1103 $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex};
1104 }
1105 if ( $a1->{too_complex} || $b1->{too_complex} ) {
1106 $a1->trace_close( ) if $TRACE;
1107 return $a1->_function2( 'intersection', $b1 );
1108 }
1109 return $a1->SUPER::intersection( $b1 );
1110}
1111
1112
1113sub intersected_spans {
1114 my $a1 = shift;
1115 my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
1116
1117 if ($a1->{too_complex}) {
1118 $a1 = $a1->_backtrack('intersection', $b1 ) unless $b1->{too_complex};
1119 } # don't put 'else' here
1120 if ($b1->{too_complex}) {
1121 $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex};
1122 }
1123
1124 if ( ! $b1->{too_complex} && ! $a1->{too_complex} )
1125 {
1126 return $a1->SUPER::intersected_spans ( $b1 );
1127 }
1128
1129 return $b1->iterate(
1130 sub {
1131 my $tmp = $a1->intersection( $_[0] );
1132 return $tmp unless defined $tmp->max;
1133
1134 my $before = $a1->intersection( $neg_inf, $tmp->min )->last;
1135 my $after = $a1->intersection( $tmp->max, $inf )->first;
1136
1137 $before = $tmp->union( $before )->first;
1138 $after = $tmp->union( $after )->last;
1139
1140 $tmp = $tmp->union( $before )
1141 if defined $before && $tmp->intersects( $before );
1142 $tmp = $tmp->union( $after )
1143 if defined $after && $tmp->intersects( $after );
1144 return $tmp;
1145 }
1146 );
1147
1148}
1149
1150
1151sub complement {
1152 my $a1 = shift;
1153 # do we have a parameter?
1154 if (@_) {
1155 my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
1156
1157 $a1->trace_open(title=>"complement", arg => $b1) if $TRACE;
1158 $b1 = $b1->complement;
1159 my $tmp =$a1->intersection($b1);
1160 $a1->trace_close( arg => $tmp ) if $TRACE;
1161 return $tmp;
1162 }
1163 $a1->trace_open(title=>"complement") if $TRACE;
1164 if ($a1->{too_complex}) {
1165 $a1->trace_close( ) if $TRACE;
1166 return $a1->_function( 'complement', @_ );
1167 }
1168 return $a1->SUPER::complement;
1169}
1170
1171
1172sub until {
1173 my $a1 = shift;
1174 my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
1175
1176 if (($a1->{too_complex}) or ($b1->{too_complex})) {
1177 return $a1->_function2( 'until', $b1 );
1178 }
1179 return $a1->SUPER::until( $b1 );
1180}
1181
1182
1183sub union {
1184 my $a1 = shift;
1185 my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
1186
1187 $a1->trace_open(title=>"union", arg => $b1) if $TRACE;
1188 if (($a1->{too_complex}) or ($b1->{too_complex})) {
1189 $a1->trace_close( ) if $TRACE;
1190 return $a1 if $b1->is_null;
1191 return $b1 if $a1->is_null;
1192 return $a1->_function2( 'union', $b1);
1193 }
1194 return $a1->SUPER::union( $b1 );
1195}
1196
1197
1198# there are some ways to process 'contains':
1199# A CONTAINS B IF A == ( A UNION B )
1200# - faster
1201# A CONTAINS B IF B == ( A INTERSECTION B )
1202# - can backtrack = works for unbounded sets
1203sub contains {
1204 my $a1 = shift;
1205 $a1->trace_open(title=>"contains") if $TRACE;
1206 if ( $a1->{too_complex} ) {
1207 # we use intersection because it is better for backtracking
1208 my $b0 = (ref $_[0] eq ref $a1) ? shift : $a1->new(@_);
1209 my $b1 = $a1->intersection($b0);
1210 if ( $b1->{too_complex} ) {
1211 $b1->trace_close( arg => 'undef' ) if $TRACE;
1212 return undef;
1213 }
1214 $a1->trace_close( arg => ($b1 == $b0 ? 1 : 0) ) if $TRACE;
1215 return ($b1 == $b0) ? 1 : 0;
1216 }
1217 my $b1 = $a1->union(@_);
1218 if ( $b1->{too_complex} ) {
1219 $b1->trace_close( arg => 'undef' ) if $TRACE;
1220 return undef;
1221 }
1222 $a1->trace_close( arg => ($b1 == $a1 ? 1 : 0) ) if $TRACE;
1223 return ($b1 == $a1) ? 1 : 0;
1224}
1225
1226
1227sub min_a {
1228 my $self = $_[0];
1229 return @{$self->{min}} if exists $self->{min};
1230 if ($self->{too_complex}) {
1231 my @first = $self->first;
1232 return @{$self->{min}} = $first[0]->min_a if defined $first[0];
1233 return @{$self->{min}} = (undef, 0);
1234 }
1235 return $self->SUPER::min_a;
1236};
1237
1238
1239sub max_a {
1240 my $self = $_[0];
1241 return @{$self->{max}} if exists $self->{max};
1242 if ($self->{too_complex}) {
1243 my @last = $self->last;
1244 return @{$self->{max}} = $last[0]->max_a if defined $last[0];
1245 return @{$self->{max}} = (undef, 0);
1246 }
1247 return $self->SUPER::max_a;
1248};
1249
1250
1251sub count {
1252 my $self = $_[0];
1253 # NOTE: subclasses may return "undef" if necessary
1254 return $inf if $self->{too_complex};
1255 return $self->SUPER::count;
1256}
1257
1258
1259sub size {
1260 my $self = $_[0];
1261 if ($self->{too_complex}) {
1262 my @min = $self->min_a;
1263 my @max = $self->max_a;
1264 return undef unless defined $max[0] && defined $min[0];
1265 return $max[0] - $min[0];
1266 }
1267 return $self->SUPER::size;
1268};
1269
1270
1271sub spaceship {
1272 my ($tmp1, $tmp2, $inverted) = @_;
1273 carp "Can't compare unbounded sets"
1274 if $tmp1->{too_complex} or $tmp2->{too_complex};
1275 return $tmp1->SUPER::spaceship( $tmp2, $inverted );
1276}
1277
1278
1279sub _cleanup { @_ } # this subroutine is obsolete
1280
1281
1282sub tolerance {
1283 my $self = shift;
1284 my $tmp = pop;
1285 if (ref($self)) {
1286 # local
1287 return $self->{tolerance} unless defined $tmp;
1288 if ($self->{too_complex}) {
1289 my $b1 = $self->_function( 'tolerance', $tmp );
1290 $b1->{tolerance} = $tmp; # for max/min processing
1291 return $b1;
1292 }
1293 return $self->SUPER::tolerance( $tmp );
1294 }
1295 # class method
1296 __PACKAGE__->SUPER::tolerance( $tmp ) if defined($tmp);
1297 return __PACKAGE__->SUPER::tolerance;
1298}
1299
1300
1301sub _pretty_print {
1302 my $self = shift;
1303 return "$self" unless $self->{too_complex};
1304 return $self->{method} . "( " .
1305 ( ref($self->{parent}) eq 'ARRAY' ?
1306 $self->{parent}[0] . ' ; ' . $self->{parent}[1] :
1307 $self->{parent} ) .
1308 " )";
1309}
1310
1311
1312sub as_string {
1313 my $self = shift;
1314 return ( $PRETTY_PRINT ? $self->_pretty_print : $too_complex )
1315 if $self->{too_complex};
1316 return $self->SUPER::as_string;
1317}
1318
1319
1320sub DESTROY {}
1321
1322112µs1;
1323
1324__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.