← 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:02:21 2013

Filename/usr/share/perl5/Set/Infinite/Basic.pm
StatementsExecuted 43 statements in 5.28ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11164µs134µsSet::Infinite::Basic::::BEGIN@13Set::Infinite::Basic::BEGIN@13
11119µs76µsSet::Infinite::Basic::::BEGIN@27Set::Infinite::Basic::BEGIN@27
11118µs21µsSet::Infinite::Basic::::BEGIN@8Set::Infinite::Basic::BEGIN@8
11112µs50µsSet::Infinite::Basic::::BEGIN@12Set::Infinite::Basic::BEGIN@12
11111µs106µsSet::Infinite::Basic::::BEGIN@14Set::Infinite::Basic::BEGIN@14
11111µs70µsSet::Infinite::Basic::::BEGIN@20Set::Infinite::Basic::BEGIN@20
11111µs19µsSet::Infinite::Basic::::BEGIN@41Set::Infinite::Basic::BEGIN@41
11110µs44µsSet::Infinite::Basic::::BEGIN@21Set::Infinite::Basic::BEGIN@21
1119µs56µsSet::Infinite::Basic::::BEGIN@11Set::Infinite::Basic::BEGIN@11
1118µs8µsSet::Infinite::Basic::::separatorsSet::Infinite::Basic::separators
0000s0sSet::Infinite::Basic::::DESTROYSet::Infinite::Basic::DESTROY
0000s0sSet::Infinite::Basic::::__ANON__[:614]Set::Infinite::Basic::__ANON__[:614]
0000s0sSet::Infinite::Basic::::__ANON__[:621]Set::Infinite::Basic::__ANON__[:621]
0000s0sSet::Infinite::Basic::::_intersectionSet::Infinite::Basic::_intersection
0000s0sSet::Infinite::Basic::::_no_cleanupSet::Infinite::Basic::_no_cleanup
0000s0sSet::Infinite::Basic::::_simple_as_stringSet::Infinite::Basic::_simple_as_string
0000s0sSet::Infinite::Basic::::_simple_complementSet::Infinite::Basic::_simple_complement
0000s0sSet::Infinite::Basic::::_simple_intersectsSet::Infinite::Basic::_simple_intersects
0000s0sSet::Infinite::Basic::::_simple_newSet::Infinite::Basic::_simple_new
0000s0sSet::Infinite::Basic::::_simple_spaceshipSet::Infinite::Basic::_simple_spaceship
0000s0sSet::Infinite::Basic::::_simple_unionSet::Infinite::Basic::_simple_union
0000s0sSet::Infinite::Basic::::as_stringSet::Infinite::Basic::as_string
0000s0sSet::Infinite::Basic::::complementSet::Infinite::Basic::complement
0000s0sSet::Infinite::Basic::::containsSet::Infinite::Basic::contains
0000s0sSet::Infinite::Basic::::copySet::Infinite::Basic::copy
0000s0sSet::Infinite::Basic::::countSet::Infinite::Basic::count
0000s0sSet::Infinite::Basic::::empty_setSet::Infinite::Basic::empty_set
0000s0sSet::Infinite::Basic::::end_setSet::Infinite::Basic::end_set
0000s0sSet::Infinite::Basic::::firstSet::Infinite::Basic::first
0000s0sSet::Infinite::Basic::::fixtypeSet::Infinite::Basic::fixtype
0000s0sSet::Infinite::Basic::::integerSet::Infinite::Basic::integer
0000s0sSet::Infinite::Basic::::intersected_spansSet::Infinite::Basic::intersected_spans
0000s0sSet::Infinite::Basic::::intersectionSet::Infinite::Basic::intersection
0000s0sSet::Infinite::Basic::::intersectsSet::Infinite::Basic::intersects
0000s0sSet::Infinite::Basic::::is_disjointSet::Infinite::Basic::is_disjoint
0000s0sSet::Infinite::Basic::::is_emptySet::Infinite::Basic::is_empty
0000s0sSet::Infinite::Basic::::is_nonemptySet::Infinite::Basic::is_nonempty
0000s0sSet::Infinite::Basic::::is_nullSet::Infinite::Basic::is_null
0000s0sSet::Infinite::Basic::::is_proper_subsetSet::Infinite::Basic::is_proper_subset
0000s0sSet::Infinite::Basic::::is_singletonSet::Infinite::Basic::is_singleton
0000s0sSet::Infinite::Basic::::is_spanSet::Infinite::Basic::is_span
0000s0sSet::Infinite::Basic::::is_subsetSet::Infinite::Basic::is_subset
0000s0sSet::Infinite::Basic::::iterateSet::Infinite::Basic::iterate
0000s0sSet::Infinite::Basic::::lastSet::Infinite::Basic::last
0000s0sSet::Infinite::Basic::::listSet::Infinite::Basic::list
0000s0sSet::Infinite::Basic::::maxSet::Infinite::Basic::max
0000s0sSet::Infinite::Basic::::max_aSet::Infinite::Basic::max_a
0000s0sSet::Infinite::Basic::::minSet::Infinite::Basic::min
0000s0sSet::Infinite::Basic::::min_aSet::Infinite::Basic::min_a
0000s0sSet::Infinite::Basic::::newSet::Infinite::Basic::new
0000s0sSet::Infinite::Basic::::numericSet::Infinite::Basic::numeric
0000s0sSet::Infinite::Basic::::realSet::Infinite::Basic::real
0000s0sSet::Infinite::Basic::::simmetric_differenceSet::Infinite::Basic::simmetric_difference
0000s0sSet::Infinite::Basic::::sizeSet::Infinite::Basic::size
0000s0sSet::Infinite::Basic::::spaceshipSet::Infinite::Basic::spaceship
0000s0sSet::Infinite::Basic::::spanSet::Infinite::Basic::span
0000s0sSet::Infinite::Basic::::start_setSet::Infinite::Basic::start_set
0000s0sSet::Infinite::Basic::::toleranceSet::Infinite::Basic::tolerance
0000s0sSet::Infinite::Basic::::typeSet::Infinite::Basic::type
0000s0sSet::Infinite::Basic::::unionSet::Infinite::Basic::union
0000s0sSet::Infinite::Basic::::universal_setSet::Infinite::Basic::universal_set
0000s0sSet::Infinite::Basic::::untilSet::Infinite::Basic::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::Basic;
2
3# Copyright (c) 2001, 2002, 2003 Flavio Soibelmann Glock. All rights reserved.
4# This program is free software; you can redistribute it and/or
5# modify it under the same terms as Perl itself.
6
7145µsrequire 5.005_03;
8331µs225µs
# spent 21µs (18+4) within Set::Infinite::Basic::BEGIN@8 which was called: # once (18µs+4µs) by base::import at line 8
use strict;
# spent 21µs making 1 call to Set::Infinite::Basic::BEGIN@8 # spent 4µs making 1 call to strict::import
9
101900nsrequire Exporter;
11334µs2102µs
# spent 56µs (9+47) within Set::Infinite::Basic::BEGIN@11 which was called: # once (9µs+47µs) by base::import at line 11
use Carp;
# spent 56µs making 1 call to Set::Infinite::Basic::BEGIN@11 # spent 47µs making 1 call to Exporter::import
12343µs288µs
# spent 50µs (12+38) within Set::Infinite::Basic::BEGIN@12 which was called: # once (12µs+38µs) by base::import at line 12
use Data::Dumper;
# spent 50µs making 1 call to Set::Infinite::Basic::BEGIN@12 # spent 38µs making 1 call to Exporter::import
13353µs2204µs
# spent 134µs (64+70) within Set::Infinite::Basic::BEGIN@13 which was called: # once (64µs+70µs) by base::import at line 13
use vars qw( @ISA @EXPORT_OK @EXPORT );
# spent 134µs making 1 call to Set::Infinite::Basic::BEGIN@13 # spent 70µs making 1 call to vars::import
14362µs2202µs
# spent 106µs (11+95) within Set::Infinite::Basic::BEGIN@14 which was called: # once (11µs+95µs) by base::import at line 14
use vars qw( $Type $tolerance $fixtype $inf $minus_inf @Separators $neg_inf );
# spent 106µs making 1 call to Set::Infinite::Basic::BEGIN@14 # spent 95µs making 1 call to vars::import
15
1619µs@ISA = qw(Exporter);
171900ns@EXPORT_OK = qw( INFINITY NEG_INFINITY );
181300ns@EXPORT = qw();
19
20338µs2129µs
# spent 70µs (11+59) within Set::Infinite::Basic::BEGIN@20 which was called: # once (11µs+59µs) by base::import at line 20
use constant INFINITY => 100**100**100;
# spent 70µs making 1 call to Set::Infinite::Basic::BEGIN@20 # spent 59µs making 1 call to constant::import
21358µs279µs
# spent 44µs (10+35) within Set::Infinite::Basic::BEGIN@21 which was called: # once (10µs+35µs) by base::import at line 21
use constant NEG_INFINITY => - INFINITY;
# spent 44µs making 1 call to Set::Infinite::Basic::BEGIN@21 # spent 34µs making 1 call to constant::import
22
231400ns$inf = INFINITY;
241300ns$minus_inf = $neg_inf = NEG_INFINITY;
25
26use overload
27114µs157µs
# spent 76µs (19+57) within Set::Infinite::Basic::BEGIN@27 which was called: # once (19µs+57µs) by base::import at line 29
'<=>' => \&spaceship,
# spent 57µs making 1 call to overload::import
28 qw("" as_string),
292102µs176µs;
# spent 76µs making 1 call to Set::Infinite::Basic::BEGIN@27
30
31
32# TODO: make this an object _and_ class method
33# TODO: POD
34
# spent 8µs within Set::Infinite::Basic::separators which was called: # once (8µs+0s) by Set::Infinite::Basic::BEGIN@41 at line 42
sub separators {
351500ns shift;
3612µs return $Separators[ $_[0] ] if $#_ == 0;
3713µs @Separators = @_ if @_;
3815µs return @Separators;
39}
40
41
# spent 19µs (11+8) within Set::Infinite::Basic::BEGIN@41 which was called: # once (11µs+8µs) by base::import at line 53
BEGIN {
4212µs18µs __PACKAGE__->separators (
# spent 8µs making 1 call to Set::Infinite::Basic::separators
43 '[', ']', # a closed interval
44 '(', ')', # an open interval
45 '..', # number separator
46 ',', # list separator
47 '', '', # set delimiter '{' '}'
48 );
49 # global defaults for object private vars
501300ns $Type = undef;
511300ns $tolerance = 0;
5213µs $fixtype = 1;
5314.76ms119µs}
# spent 19µs making 1 call to Set::Infinite::Basic::BEGIN@41
54
55# _simple_* set of internal methods: basic processing of "spans"
56
57sub _simple_intersects {
58 my $tmp1 = $_[0];
59 my $tmp2 = $_[1];
60 my ($i_beg, $i_end, $open_beg, $open_end);
61 my $cmp = $tmp1->{a} <=> $tmp2->{a};
62 if ($cmp < 0) {
63 $i_beg = $tmp2->{a};
64 $open_beg = $tmp2->{open_begin};
65 }
66 elsif ($cmp > 0) {
67 $i_beg = $tmp1->{a};
68 $open_beg = $tmp1->{open_begin};
69 }
70 else {
71 $i_beg = $tmp1->{a};
72 $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin};
73 }
74 $cmp = $tmp1->{b} <=> $tmp2->{b};
75 if ($cmp > 0) {
76 $i_end = $tmp2->{b};
77 $open_end = $tmp2->{open_end};
78 }
79 elsif ($cmp < 0) {
80 $i_end = $tmp1->{b};
81 $open_end = $tmp1->{open_end};
82 }
83 else {
84 $i_end = $tmp1->{b};
85 $open_end = ($tmp1->{open_end} || $tmp2->{open_end});
86 }
87 $cmp = $i_beg <=> $i_end;
88 return 0 if
89 ( $cmp > 0 ) ||
90 ( ($cmp == 0) && ($open_beg || $open_end) ) ;
91 return 1;
92}
93
94
95sub _simple_complement {
96 my $self = $_[0];
97 if ($self->{b} == $inf) {
98 return if $self->{a} == $neg_inf;
99 return { a => $neg_inf,
100 b => $self->{a},
101 open_begin => 1,
102 open_end => ! $self->{open_begin} };
103 }
104 if ($self->{a} == $neg_inf) {
105 return { a => $self->{b},
106 b => $inf,
107 open_begin => ! $self->{open_end},
108 open_end => 1 };
109 }
110 ( { a => $neg_inf,
111 b => $self->{a},
112 open_begin => 1,
113 open_end => ! $self->{open_begin}
114 },
115 { a => $self->{b},
116 b => $inf,
117 open_begin => ! $self->{open_end},
118 open_end => 1
119 }
120 );
121}
122
123sub _simple_union {
124 my ($tmp2, $tmp1, $tolerance) = @_;
125 my $cmp;
126 if ($tolerance) {
127 # "integer"
128 my $a1_open = $tmp1->{open_begin} ? -$tolerance : $tolerance ;
129 my $b1_open = $tmp1->{open_end} ? -$tolerance : $tolerance ;
130 my $a2_open = $tmp2->{open_begin} ? -$tolerance : $tolerance ;
131 my $b2_open = $tmp2->{open_end} ? -$tolerance : $tolerance ;
132 # open_end touching?
133 if ((($tmp1->{b}+$tmp1->{b}) + $b1_open ) <
134 (($tmp2->{a}+$tmp2->{a}) - $a2_open)) {
135 # self disjuncts b
136 return ( $tmp1, $tmp2 );
137 }
138 if ((($tmp1->{a}+$tmp1->{a}) - $a1_open ) >
139 (($tmp2->{b}+$tmp2->{b}) + $b2_open)) {
140 # self disjuncts b
141 return ( $tmp2, $tmp1 );
142 }
143 }
144 else {
145 # "real"
146 $cmp = $tmp1->{b} <=> $tmp2->{a};
147 if ( $cmp < 0 ||
148 ( $cmp == 0 && $tmp1->{open_end} && $tmp2->{open_begin} ) ) {
149 return ( $tmp1, $tmp2 );
150 }
151 $cmp = $tmp1->{a} <=> $tmp2->{b};
152 if ( $cmp > 0 ||
153 ( $cmp == 0 && $tmp2->{open_end} && $tmp1->{open_begin} ) ) {
154 return ( $tmp2, $tmp1 );
155 }
156 }
157
158 my $tmp;
159 $cmp = $tmp1->{a} <=> $tmp2->{a};
160 if ($cmp > 0) {
161 $tmp->{a} = $tmp2->{a};
162 $tmp->{open_begin} = $tmp2->{open_begin};
163 }
164 elsif ($cmp == 0) {
165 $tmp->{a} = $tmp1->{a};
166 $tmp->{open_begin} = $tmp1->{open_begin} ? $tmp2->{open_begin} : 0;
167 }
168 else {
169 $tmp->{a} = $tmp1->{a};
170 $tmp->{open_begin} = $tmp1->{open_begin};
171 }
172
173 $cmp = $tmp1->{b} <=> $tmp2->{b};
174 if ($cmp < 0) {
175 $tmp->{b} = $tmp2->{b};
176 $tmp->{open_end} = $tmp2->{open_end};
177 }
178 elsif ($cmp == 0) {
179 $tmp->{b} = $tmp1->{b};
180 $tmp->{open_end} = $tmp1->{open_end} ? $tmp2->{open_end} : 0;
181 }
182 else {
183 $tmp->{b} = $tmp1->{b};
184 $tmp->{open_end} = $tmp1->{open_end};
185 }
186 return $tmp;
187}
188
189
190sub _simple_spaceship {
191 my ($tmp1, $tmp2, $inverted) = @_;
192 my $cmp;
193 if ($inverted) {
194 $cmp = $tmp2->{a} <=> $tmp1->{a};
195 return $cmp if $cmp;
196 $cmp = $tmp1->{open_begin} <=> $tmp2->{open_begin};
197 return $cmp if $cmp;
198 $cmp = $tmp2->{b} <=> $tmp1->{b};
199 return $cmp if $cmp;
200 return $tmp1->{open_end} <=> $tmp2->{open_end};
201 }
202 $cmp = $tmp1->{a} <=> $tmp2->{a};
203 return $cmp if $cmp;
204 $cmp = $tmp2->{open_begin} <=> $tmp1->{open_begin};
205 return $cmp if $cmp;
206 $cmp = $tmp1->{b} <=> $tmp2->{b};
207 return $cmp if $cmp;
208 return $tmp2->{open_end} <=> $tmp1->{open_end};
209}
210
211
212sub _simple_new {
213 my ($tmp, $tmp2, $type) = @_;
214 if ($type) {
215 if ( ref($tmp) ne $type ) {
216 $tmp = new $type $tmp;
217 }
218 if ( ref($tmp2) ne $type ) {
219 $tmp2 = new $type $tmp2;
220 }
221 }
222 if ($tmp > $tmp2) {
223 carp "Invalid interval specification: start value is after end";
224 # ($tmp, $tmp2) = ($tmp2, $tmp);
225 }
226 return { a => $tmp , b => $tmp2 , open_begin => 0 , open_end => 0 };
227}
228
229
230sub _simple_as_string {
231 my $set = shift;
232 my $self = $_[0];
233 my $s;
234 return "" unless defined $self;
235 $self->{open_begin} = 1 if ($self->{a} == -$inf );
236 $self->{open_end} = 1 if ($self->{b} == $inf );
237 my $tmp1 = $self->{a};
238 $tmp1 = $tmp1->datetime if UNIVERSAL::can( $tmp1, 'datetime' );
239 $tmp1 = "$tmp1";
240 my $tmp2 = $self->{b};
241 $tmp2 = $tmp2->datetime if UNIVERSAL::can( $tmp2, 'datetime' );
242 $tmp2 = "$tmp2";
243 return $tmp1 if $tmp1 eq $tmp2;
244 $s = $self->{open_begin} ? $set->separators(2) : $set->separators(0);
245 $s .= $tmp1 . $set->separators(4) . $tmp2;
246 $s .= $self->{open_end} ? $set->separators(3) : $set->separators(1);
247 return $s;
248}
249
250# end of "_simple_" methods
251
252
253sub type {
254 my $self = shift;
255 unless (@_) {
256 return ref($self) ? $self->{type} : $Type;
257 }
258 my $tmp_type = shift;
259 eval "use " . $tmp_type;
260 carp "Warning: can't start $tmp_type : $@" if $@;
261 if (ref($self)) {
262 $self->{type} = $tmp_type;
263 return $self;
264 }
265 else {
266 $Type = $tmp_type;
267 return $Type;
268 }
269}
270
271sub list {
272 my $self = shift;
273 my @b = ();
274 foreach (@{$self->{list}}) {
275 push @b, $self->new($_);
276 }
277 return @b;
278}
279
280sub fixtype {
281 my $self = shift;
282 $self = $self->copy;
283 $self->{fixtype} = 1;
284 my $type = $self->type;
285 return $self unless $type;
286 foreach (@{$self->{list}}) {
287 $_->{a} = $type->new($_->{a}) unless ref($_->{a}) eq $type;
288 $_->{b} = $type->new($_->{b}) unless ref($_->{b}) eq $type;
289 }
290 return $self;
291}
292
293sub numeric {
294 my $self = shift;
295 return $self unless $self->{fixtype};
296 $self = $self->copy;
297 $self->{fixtype} = 0;
298 foreach (@{$self->{list}}) {
299 $_->{a} = 0 + $_->{a};
300 $_->{b} = 0 + $_->{b};
301 }
302 return $self;
303}
304
305sub _no_cleanup { $_[0] } # obsolete
306
307sub first {
308 my $self = $_[0];
309 if (exists $self->{first} ) {
310 return wantarray ? @{$self->{first}} : $self->{first}[0];
311 }
312 unless ( @{$self->{list}} ) {
313 return wantarray ? (undef, 0) : undef;
314 }
315 my $first = $self->new( $self->{list}[0] );
316 return $first unless wantarray;
317 my $res = $self->new;
318 push @{$res->{list}}, @{$self->{list}}[1 .. $#{$self->{list}}];
319 return @{$self->{first}} = ($first) if $res->is_null;
320 return @{$self->{first}} = ($first, $res);
321}
322
323sub last {
324 my $self = $_[0];
325 if (exists $self->{last} ) {
326 return wantarray ? @{$self->{last}} : $self->{last}[0];
327 }
328 unless ( @{$self->{list}} ) {
329 return wantarray ? (undef, 0) : undef;
330 }
331 my $last = $self->new( $self->{list}[-1] );
332 return $last unless wantarray;
333 my $res = $self->new;
334 push @{$res->{list}}, @{$self->{list}}[0 .. $#{$self->{list}}-1];
335 return @{$self->{last}} = ($last) if $res->is_null;
336 return @{$self->{last}} = ($last, $res);
337}
338
339sub is_null {
340 @{$_[0]->{list}} ? 0 : 1;
341}
342
343sub is_empty {
344 $_[0]->is_null;
345}
346
347sub is_nonempty {
348 ! $_[0]->is_null;
349}
350
351sub is_span {
352 ( $#{$_[0]->{list}} == 0 ) ? 1 : 0;
353}
354
355sub is_singleton {
356 ( $#{$_[0]->{list}} == 0 &&
357 $_[0]->{list}[0]{a} == $_[0]->{list}[0]{b} ) ? 1 : 0;
358}
359
360sub is_subset {
361 my $a1 = shift;
362 my $b1;
363 if (ref ($_[0]) eq ref($a1) ) {
364 $b1 = shift;
365 }
366 else {
367 $b1 = $a1->new(@_);
368 }
369 return $b1->contains( $a1 );
370}
371
372sub is_proper_subset {
373 my $a1 = shift;
374 my $b1;
375 if (ref ($_[0]) eq ref($a1) ) {
376 $b1 = shift;
377 }
378 else {
379 $b1 = $a1->new(@_);
380 }
381
382 my $contains = $b1->contains( $a1 );
383 return $contains unless $contains;
384
385 my $equal = ( $a1 == $b1 );
386 return $equal if !defined $equal || $equal;
387
388 return 1;
389}
390
391sub is_disjoint {
392 my $intersects = shift->intersects( @_ );
393 return ! $intersects if defined $intersects;
394 return $intersects;
395}
396
397sub iterate {
398 # TODO: options 'no-sort', 'no-merge', 'keep-null' ...
399 my $a1 = shift;
400 my $iterate = $a1->empty_set();
401 my (@tmp, $ia);
402 my $subroutine = shift;
403 foreach $ia (0 .. $#{$a1->{list}}) {
404 @tmp = $subroutine->( $a1->new($a1->{list}[$ia]), @_ );
405 $iterate = $iterate->union(@tmp) if @tmp;
406 }
407 return $iterate;
408}
409
410
411sub intersection {
412 my $a1 = shift;
413 my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
414 return _intersection ( 'intersection', $a1, $b1 );
415}
416
417sub intersects {
418 my $a1 = shift;
419 my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
420 return _intersection ( 'intersects', $a1, $b1 );
421}
422
423sub intersected_spans {
424 my $a1 = shift;
425 my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
426 return _intersection ( 'intersected_spans', $a1, $b1 );
427}
428
429
430sub _intersection {
431 my ( $op, $a1, $b1 ) = @_;
432
433 my $ia;
434 my ( $a0, $na ) = ( 0, $#{$a1->{list}} );
435 my ( $tmp1, $tmp1a, $tmp2a, $tmp1b, $tmp2b, $i_beg, $i_end, $open_beg, $open_end );
436 my ( $cmp1, $cmp2 );
437 my @a;
438
439 # for-loop optimization (makes little difference)
440 # This was kept for backward compatibility with Date::Set tests
441 my $self = $a1;
442 if ($na < $#{ $b1->{list} })
443 {
444 $na = $#{ $b1->{list} };
445 ($a1, $b1) = ($b1, $a1);
446 }
447 # ---
448
449 B: foreach my $tmp2 ( @{ $b1->{list} } ) {
450 $tmp2a = $tmp2->{a};
451 $tmp2b = $tmp2->{b};
452 A: foreach $ia ($a0 .. $na) {
453 $tmp1 = $a1->{list}[$ia];
454 $tmp1b = $tmp1->{b};
455
456 if ($tmp1b < $tmp2a) {
457 $a0++;
458 next A;
459 }
460 $tmp1a = $tmp1->{a};
461 if ($tmp1a > $tmp2b) {
462 next B;
463 }
464
465 $cmp1 = $tmp1a <=> $tmp2a;
466 if ( $cmp1 < 0 ) {
467 $tmp1a = $tmp2a;
468 $open_beg = $tmp2->{open_begin};
469 }
470 elsif ( $cmp1 ) {
471 $open_beg = $tmp1->{open_begin};
472 }
473 else {
474 $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin};
475 }
476
477 $cmp2 = $tmp1b <=> $tmp2b;
478 if ( $cmp2 > 0 ) {
479 $tmp1b = $tmp2b;
480 $open_end = $tmp2->{open_end};
481 }
482 elsif ( $cmp2 ) {
483 $open_end = $tmp1->{open_end};
484 }
485 else {
486 $open_end = $tmp1->{open_end} || $tmp2->{open_end};
487 }
488
489 if ( ( $tmp1a <= $tmp1b ) &&
490 ( ($tmp1a != $tmp1b) ||
491 (!$open_beg and !$open_end) ||
492 ($tmp1a == $inf) || # XXX
493 ($tmp1a == $neg_inf)
494 )
495 )
496 {
497 if ( $op eq 'intersection' )
498 {
499 push @a, {
500 a => $tmp1a, b => $tmp1b,
501 open_begin => $open_beg, open_end => $open_end } ;
502 }
503 if ( $op eq 'intersects' )
504 {
505 return 1;
506 }
507 if ( $op eq 'intersected_spans' )
508 {
509 push @a, $tmp1;
510 $a0++;
511 next A;
512 }
513 }
514 }
515 }
516
517 return 0 if $op eq 'intersects';
518
519 my $intersection = $self->new();
520 $intersection->{list} = \@a;
521 return $intersection;
522}
523
524
525sub complement {
526 my $self = shift;
527 if (@_) {
528 my $a1;
529 if (ref ($_[0]) eq ref($self) ) {
530 $a1 = shift;
531 }
532 else {
533 $a1 = $self->new(@_);
534 }
535 return $self->intersection( $a1->complement );
536 }
537
538 unless ( @{$self->{list}} ) {
539 return $self->universal_set;
540 }
541 my $complement = $self->empty_set();
542 @{$complement->{list}} = _simple_complement($self->{list}[0]);
543
544 my $tmp = $self->empty_set();
545 foreach my $ia (1 .. $#{$self->{list}}) {
546 @{$tmp->{list}} = _simple_complement($self->{list}[$ia]);
547 $complement = $complement->intersection($tmp);
548 }
549 return $complement;
550}
551
552
553sub until {
554 my $a1 = shift;
555 my $b1;
556 if (ref ($_[0]) eq ref($a1) ) {
557 $b1 = shift;
558 }
559 else {
560 $b1 = $a1->new(@_);
561 }
562 my @b1_min = $b1->min_a;
563 my @a1_max = $a1->max_a;
564
565 unless (defined $b1_min[0]) {
566 return $a1->until($inf);
567 }
568 unless (defined $a1_max[0]) {
569 return $a1->new(-$inf)->until($b1);
570 }
571
572 my ($ia, $ib, $begin, $end);
573 $ia = 0;
574 $ib = 0;
575
576 my $u = $a1->new;
577 my $last = -$inf;
578 while ( ($ia <= $#{$a1->{list}}) && ($ib <= $#{$b1->{list}})) {
579 $begin = $a1->{list}[$ia]{a};
580 $end = $b1->{list}[$ib]{b};
581 if ( $end <= $begin ) {
582 push @{$u->{list}}, {
583 a => $last ,
584 b => $end ,
585 open_begin => 0 ,
586 open_end => 1 };
587 $ib++;
588 $last = $end;
589 next;
590 }
591 push @{$u->{list}}, {
592 a => $begin ,
593 b => $end ,
594 open_begin => 0 ,
595 open_end => 1 };
596 $ib++;
597 $ia++;
598 $last = $end;
599 }
600 if ($ia <= $#{$a1->{list}} &&
601 $a1->{list}[$ia]{a} >= $last )
602 {
603 push @{$u->{list}}, {
604 a => $a1->{list}[$ia]{a} ,
605 b => $inf ,
606 open_begin => 0 ,
607 open_end => 1 };
608 }
609 return $u;
610}
611
612sub start_set {
613 return $_[0]->iterate(
614 sub { $_[0]->min }
615 );
616}
617
618
619sub end_set {
620 return $_[0]->iterate(
621 sub { $_[0]->max }
622 );
623}
624
625sub union {
626 my $a1 = shift;
627 my $b1;
628 if (ref ($_[0]) eq ref($a1) ) {
629 $b1 = shift;
630 }
631 else {
632 $b1 = $a1->new(@_);
633 }
634 # test for union with empty set
635 if ( $#{ $a1->{list} } < 0 ) {
636 return $b1;
637 }
638 if ( $#{ $b1->{list} } < 0 ) {
639 return $a1;
640 }
641 my @b1_min = $b1->min_a;
642 my @a1_max = $a1->max_a;
643 unless (defined $b1_min[0]) {
644 return $a1;
645 }
646 unless (defined $a1_max[0]) {
647 return $b1;
648 }
649 my ($ia, $ib);
650 $ia = 0;
651 $ib = 0;
652
653 # size+order matters on speed
654 $a1 = $a1->new($a1); # don't modify ourselves
655 my $b_list = $b1->{list};
656 # -- frequent case - $b1 is after $a1
657 if ($b1_min[0] > $a1_max[0]) {
658 push @{$a1->{list}}, @$b_list;
659 return $a1;
660 }
661
662 my @tmp;
663 my $is_real = !$a1->tolerance && !$b1->tolerance;
664 B: foreach $ib ($ib .. $#{$b_list}) {
665 foreach $ia ($ia .. $#{$a1->{list}}) {
666 @tmp = _simple_union($a1->{list}[$ia], $b_list->[$ib], $a1->{tolerance});
667 if ($#tmp == 0) {
668 $a1->{list}[$ia] = $tmp[0];
669
670 while (1) {
671 last if $ia >= $#{$a1->{list}};
672 last unless _simple_intersects ( $a1->{list}[$ia], $a1->{list}[$ia + 1] )
673 || $is_real
674 && $a1->{list}[$ia]{b} == $a1->{list}[$ia + 1]{a};
675 @tmp = _simple_union($a1->{list}[$ia], $a1->{list}[$ia + 1], $a1->{tolerance});
676 last unless @tmp == 1;
677 $a1->{list}[$ia] = $tmp[0];
678 splice( @{$a1->{list}}, $ia + 1, 1 );
679 }
680
681 next B;
682 }
683 if ($a1->{list}[$ia]{a} >= $b_list->[$ib]{a}) {
684 splice (@{$a1->{list}}, $ia, 0, $b_list->[$ib]);
685 next B;
686 }
687 }
688 push @{$a1->{list}}, $b_list->[$ib];
689 }
690 return $a1;
691}
692
693
694# there are some ways to process 'contains':
695# A CONTAINS B IF A == ( A UNION B )
696# - faster
697# A CONTAINS B IF B == ( A INTERSECTION B )
698# - can backtrack = works for unbounded sets
699sub contains {
700 my $a1 = shift;
701 my $b1 = $a1->union(@_);
702 return ($b1 == $a1) ? 1 : 0;
703}
704
705
706sub copy {
707 my $self = shift;
708 my $copy = $self->empty_set();
709 ## return $copy unless ref($self); # constructor!
710 foreach my $key (keys %{$self}) {
711 if ( ref( $self->{$key} ) eq 'ARRAY' ) {
712 @{ $copy->{$key} } = @{ $self->{$key} };
713 }
714 else {
715 $copy->{$key} = $self->{$key};
716 }
717 }
718 return $copy;
719}
720
72112µs*clone = \&copy;
722
723
724sub new {
725 my $class = shift;
726 my $self;
727 if ( ref $class ) {
728 $self = bless {
729 list => [],
730 tolerance => $class->{tolerance},
731 type => $class->{type},
732 fixtype => $class->{fixtype},
733 }, ref($class);
734 }
735 else {
736 $self = bless {
737 list => [],
738 tolerance => $tolerance ? $tolerance : 0,
739 type => $class->type,
740 fixtype => $fixtype ? $fixtype : 0,
741 }, $class;
742 }
743 my ($tmp, $tmp2, $ref);
744 while (@_) {
745 $tmp = shift;
746 $ref = ref($tmp);
747 if ($ref) {
748 if ($ref eq 'ARRAY') {
749 # allows arrays of arrays
750 $tmp = $class->new(@$tmp); # call new() recursively
751 push @{ $self->{list} }, @{$tmp->{list}};
752 next;
753 }
754 if ($ref eq 'HASH') {
755 push @{ $self->{list} }, $tmp;
756 next;
757 }
758 if ($tmp->isa(__PACKAGE__)) {
759 push @{ $self->{list} }, @{$tmp->{list}};
760 next;
761 }
762 }
763 if ( @_ ) {
764 $tmp2 = shift
765 }
766 else {
767 $tmp2 = $tmp
768 }
769 push @{ $self->{list} }, _simple_new($tmp,$tmp2, $self->{type} )
770 }
771 $self;
772}
773
774sub empty_set {
775 $_[0]->new;
776}
777
778sub universal_set {
779 $_[0]->new( NEG_INFINITY, INFINITY );
780}
781
7821800ns*minus = \&complement;
783
7841400ns*difference = \&complement;
785
786sub simmetric_difference {
787 my $a1 = shift;
788 my $b1;
789 if (ref ($_[0]) eq ref($a1) ) {
790 $b1 = shift;
791 }
792 else {
793 $b1 = $a1->new(@_);
794 }
795
796 return $a1->complement( $b1 )->union(
797 $b1->complement( $a1 ) );
798}
799
800sub min {
801 ($_[0]->min_a)[0];
802}
803
804sub min_a {
805 my $self = $_[0];
806 return @{$self->{min}} if exists $self->{min};
807 return @{$self->{min}} = (undef, 0) unless @{$self->{list}};
808 my $tmp = $self->{list}[0]{a};
809 my $tmp2 = $self->{list}[0]{open_begin} || 0;
810 if ($tmp2 && $self->{tolerance}) {
811 $tmp2 = 0;
812 $tmp += $self->{tolerance};
813 }
814 return @{$self->{min}} = ($tmp, $tmp2);
815};
816
817sub max {
818 ($_[0]->max_a)[0];
819}
820
821sub max_a {
822 my $self = $_[0];
823 return @{$self->{max}} if exists $self->{max};
824 return @{$self->{max}} = (undef, 0) unless @{$self->{list}};
825 my $tmp = $self->{list}[-1]{b};
826 my $tmp2 = $self->{list}[-1]{open_end} || 0;
827 if ($tmp2 && $self->{tolerance}) {
828 $tmp2 = 0;
829 $tmp -= $self->{tolerance};
830 }
831 return @{$self->{max}} = ($tmp, $tmp2);
832};
833
834sub count {
835 1 + $#{$_[0]->{list}};
836}
837
838sub size {
839 my $self = $_[0];
840 my $size;
841 foreach( @{$self->{list}} ) {
842 if ( $size ) {
843 $size += $_->{b} - $_->{a};
844 }
845 else {
846 $size = $_->{b} - $_->{a};
847 }
848 if ( $self->{tolerance} ) {
849 $size += $self->{tolerance} unless $_->{open_end};
850 $size -= $self->{tolerance} if $_->{open_begin};
851 $size -= $self->{tolerance} if $_->{open_end};
852 }
853 }
854 return $size;
855};
856
857sub span {
858 my $self = $_[0];
859 my @max = $self->max_a;
860 my @min = $self->min_a;
861 return undef unless defined $min[0] && defined $max[0];
862 my $a1 = $self->new($min[0], $max[0]);
863 $a1->{list}[0]{open_end} = $max[1];
864 $a1->{list}[0]{open_begin} = $min[1];
865 return $a1;
866};
867
868sub spaceship {
869 my ($tmp1, $tmp2, $inverted) = @_;
870 if ($inverted) {
871 ($tmp2, $tmp1) = ($tmp1, $tmp2);
872 }
873 foreach(0 .. $#{$tmp1->{list}}) {
874 my $this = $tmp1->{list}[$_];
875 if ($_ > $#{ $tmp2->{list} } ) {
876 return 1;
877 }
878 my $other = $tmp2->{list}[$_];
879 my $cmp = _simple_spaceship($this, $other);
880 return $cmp if $cmp; # this != $other;
881 }
882 return $#{ $tmp1->{list} } == $#{ $tmp2->{list} } ? 0 : -1;
883}
884
885sub tolerance {
886 my $self = shift;
887 my $tmp = pop;
888 if (ref($self)) {
889 # local
890 return $self->{tolerance} unless defined $tmp;
891 $self = $self->copy;
892 $self->{tolerance} = $tmp;
893 delete $self->{max}; # tolerance may change "max"
894
895 $_ = 1;
896 my @tmp;
897 while ( $_ <= $#{$self->{list}} ) {
898 @tmp = Set::Infinite::Basic::_simple_union($self->{list}->[$_],
899 $self->{list}->[$_ - 1],
900 $self->{tolerance});
901 if ($#tmp == 0) {
902 $self->{list}->[$_ - 1] = $tmp[0];
903 splice (@{$self->{list}}, $_, 1);
904 }
905 else {
906 $_ ++;
907 }
908 }
909
910 return $self;
911 }
912 # global
913 $tolerance = $tmp if defined($tmp);
914 return $tolerance;
915}
916
917sub integer {
918 $_[0]->tolerance (1);
919}
920
921sub real {
922 $_[0]->tolerance (0);
923}
924
925sub as_string {
926 my $self = shift;
927 return $self->separators(6) .
928 join( $self->separators(5),
929 map { $self->_simple_as_string($_) } @{$self->{list}} ) .
930 $self->separators(7),;
931}
932
933
934sub DESTROY {}
935
93618µs1;
937
938__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.