3 # Copyright (c) 2001, 2002, 2003, 2004 Flavio Soibelmann Glock.
5 # This program is free software; you can redistribute it and/or
6 # modify it under the same terms as Perl itself.
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 # symmetric_difference is_empty
16 use base qw(Set::Infinite::Basic Exporter);
18 use Set::Infinite::Arithmetic;
24 use vars qw(@EXPORT_OK $VERSION
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
29 $trace_level %level_title );
31 @EXPORT_OK = qw(inf $inf trace_open trace_close);
34 $neg_inf = $minus_inf = -$inf;
37 # obsolete methods - included for backward compatibility
39 sub minus_inf () { $minus_inf }
40 sub no_cleanup { $_[0] }
41 *type = \&Set::Infinite::Basic::type;
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
52 $too_complex = "Too complex";
54 $max_backtrack_depth = 10; # _backtrack()
55 $max_intersection_depth = 5; # first()
58 sub 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;
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";
79 $level_title{$trace_level} = $parm{title};
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} ".
92 "ret ". ( UNIVERSAL::isa($parm{arg}, __PACKAGE__ ) ?
99 " $caller[1]:$caller[2] ]\n";
105 # creates a 'function' object that can be solved by _backtrack()
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} = [ @_ ];
117 # same as _function, but with 2 arguments
119 my ($self, $method, $arg) = (shift, shift, shift);
120 unless ( $self->{too_complex} || $arg->{too_complex} ) {
121 return $self->$method($arg, @_);
123 my $b = $self->empty_set();
124 $b->{too_complex} = 1;
125 $b->{parent} = [ $self, $arg ];
126 $b->{method} = $method;
127 $b->{param} = [ @_ ];
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)) {
141 return $self->_function( 'quantize', @_ );
146 my $b = $self->empty_set();
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};
155 my ($min, $open_begin) = $parent->min_a;
157 unless (defined $min) {
158 $self->trace_close( arg => $b ) if $TRACE;
162 $rule{fixtype} = 1 unless exists $rule{fixtype};
163 $Set::Infinite::Arithmetic::Init_quantizer{$rule{unit}}->(\%rule);
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';
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 };
181 $tmp = Set::Infinite::Basic::_simple_new($this,$next, $rule{type} );
182 $tmp->{open_end} = 1;
184 next if ( $rule{strict} and not $rule{strict}->intersects($tmp));
188 $b->{list} = \@a; # change data
189 $self->trace_close( arg => $b ) if $TRACE;
197 my $tail = $self->copy;
202 ( $first, $tail ) = $tail->first if $tail;
203 push @result, $first;
205 return $tail, @result;
211 my $tail = $self->copy;
216 ( $last, $tail ) = $tail->last if $tail;
217 unshift @result, $last;
219 return $tail, @result;
225 $self->trace_open(title=>"select") if $TRACE;
228 die "select() - parameter 'freq' is deprecated" if exists $param{freq};
233 @by = @{ $param{by} } if exists $param{by};
234 $count = delete $param{count} || $inf;
235 # warn "select: count=$count by=[@by]";
238 $self->trace_close( arg => $res ) if $TRACE;
239 return $self->empty_set();
249 if ( ! $self->is_too_complex )
252 @res = @{ $self->{list} }[ @by ] ;
256 my ( @pos_by, @neg_by );
258 ( $_ < 0 ) ? push @neg_by, $_ :
263 @pos_by = sort { $a <=> $b } @pos_by;
264 ( $tail, @set ) = $self->_first_n( 1 + $pos_by[-1] );
265 @first = @set[ @pos_by ];
269 @neg_by = sort { $a <=> $b } @neg_by;
270 ( $tail, @set ) = $self->_last_n( - $neg_by[0] );
271 @last = @set[ @neg_by ];
273 @res = map { $_->{list}[0] } ( @first , @last );
277 @res = sort { $a->{a} <=> $b->{a} } grep { defined } @res;
281 push @a, $_ if ! $last || $last->{a} != $_->{a};
291 return $res if $count == $inf;
292 my $count_set = $self->empty_set();
293 if ( ! $self->is_too_complex )
296 @a = grep { defined } @{ $res->{list} }[ 0 .. $count - 1 ] ;
297 $count_set->{list} = \@a;
303 ( $first, $res ) = $res->first;
305 last if $last && $last->{a} == $first->{list}[0]{a};
306 $last = $first->{list}[0];
307 push @{$count_set->{list}}, $first->{list}[0];
317 # %_first and %_last hashes are used to backtrack the value
318 # of first() and last() of an infinite set
324 my @parent_min = $self->{parent}->first;
325 unless ( defined $parent_min[0] ) {
328 my $parent_complement;
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];
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];
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
362 my @parent = @{ $self->{parent} };
363 # warn "$method parents @parent";
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;
376 unless ( defined $first[1][0] ) {
377 # warn "don't know first of $method";
378 $self->trace_close( arg => 'undef' ) if $TRACE;
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] ) {
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";
394 # return $first1, undef;
395 $intersection = $first1;
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;
413 if ( $#{ $intersection->{list} } > 0 ) {
415 ($intersection, $tail) = $intersection->first;
416 $parent[$which] = $parent[$which]->union( $tail );
419 if ( defined $parent[$which] and defined $parent[1-$which] ) {
420 $tmp = $parent[$which]->intersection ( $parent[1-$which] );
422 return ($intersection, $tmp);
423 }, # end: first-intersection
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
435 @{$min[0]} = $first[0][0]->min_a;
436 @{$min[1]} = $first[1][0]->min_a;
438 # check min1/min2 for undef
439 unless ( defined $min[0][0] ) {
440 $self->trace_close( arg => "@{$first[1]}" ) if $TRACE;
443 unless ( defined $min[1][0] ) {
444 $self->trace_close( arg => "@{$first[0]}" ) if $TRACE;
448 my $which = ($min[0][0] < $min[1][0]) ? 0 : 1;
449 my $first = $first[$which][0];
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];
458 if (( ! defined $parent1 ) || $parent1->is_null) {
459 # warn "union parent1 tail is null";
463 my $method = $self->{method};
464 $tail = $parent1->$method( $parent2 );
467 if ( $first->intersects( $tail ) ) {
469 ( $first2, $tail ) = $tail->first;
470 $first = $first->union( $first2 );
473 $self->trace_close( arg => "$first $tail" ) if $TRACE;
474 return ($first, $tail);
475 }, # end: first-union
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);
484 ($first, $more) = $first->first if ref($first);
485 $tail = $tail->_function2( 'union', $more ) if defined $more;
486 return ($first, $tail);
491 my ($a1, $b1) = @{ $self->{parent} };
492 $a1->trace( title=>"computing first()" );
493 my @first1 = $a1->first;
494 my @first2 = $b1->first;
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] );
502 $first = $a1->new( $first1[0] )->until( $first2[0] );
503 if ( defined $first1[1] ) {
504 $tail = $first1[1]->_function2( "until", $first2[1] );
510 return ($first, $tail);
515 my ($first, $tail) = $self->{parent}->first;
516 $first = $first->offset( @{$self->{param}} );
517 $tail = $tail->_function( 'offset', @{$self->{param}} );
519 ($first, $more) = $first->first;
520 $tail = $tail->_function2( 'union', $more ) if defined $more;
521 return ($first, $tail);
526 my @min = $self->{parent}->min_a;
527 if ( $min[0] == $neg_inf || $min[0] == $inf ) {
528 return ( $self->new( $min[0] ) , $self->copy );
530 my $first = $self->new( $min[0] )->quantize( @{$self->{param}} );
533 _function2( 'intersection', $first->complement )->
534 _function( 'quantize', @{$self->{param}} ) );
539 my ($first, $tail) = $self->{parent}->first;
540 $first = $first->tolerance( @{$self->{param}} );
541 $tail = $tail->tolerance( @{$self->{param}} );
542 return ($first, $tail);
550 my @parent_max = $self->{parent}->last;
551 unless ( defined $parent_max[0] ) {
554 my $parent_complement;
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];
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];
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);
588 my @parent = @{ $self->{parent} };
589 # TODO: check max1/max2 for undef
592 my (@last, @max, $which, $last1, $intersection);
594 SEARCH: while ($retry_count++ < $max_intersection_depth) {
595 return undef unless defined $parent[0];
596 return undef unless defined $parent[1];
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;
604 unless ( defined $last[1][0] ) {
605 $self->trace_close( arg => 'undef' ) if $TRACE;
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;
616 # $which is the index to the smaller "last".
617 $which = ($max[0][0] > $max[1][0]) ? 1 : 0;
619 for my $which1 ( $which, 1 - $which ) {
620 my $tmp_parent = $parent[$which1];
621 ($last1, $parent[$which1]) = @{ $last[$which1] };
622 if ( $last1->is_null ) {
624 $intersection = $last1;
627 $intersection = $last1->intersection( $parent[1-$which1] );
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;
637 $self->trace( title=>"got an intersection" ) if $TRACE;
644 $self->trace( title=>"exit loop" ) if $TRACE;
645 if ( $#{ $intersection->{list} } > 0 ) {
647 ($intersection, $tail) = $intersection->last;
648 $parent[$which] = $parent[$which]->union( $tail );
651 if ( defined $parent[$which] and defined $parent[1-$which] ) {
652 $tmp = $parent[$which]->intersection ( $parent[1-$which] );
654 return ($intersection, $tmp);
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] ) {
668 unless ( defined $max[1][0] ) {
672 my $which = ($max[0][0] > $max[1][0]) ? 0 : 1;
673 my $last = $last[$which][0];
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];
681 if (( ! defined $parent1 ) || $parent1->is_null) {
685 my $method = $self->{method};
686 $tail = $parent1->$method( $parent2 );
689 if ( $last->intersects( $tail ) ) {
691 ( $last2, $tail ) = $tail->last;
692 $last = $last->union( $last2 );
695 return ($last, $tail);
700 my ($a1, $b1) = @{ $self->{parent} };
701 $a1->trace( title=>"computing last()" );
702 my @last1 = $a1->last;
703 my @last2 = $b1->last;
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] );
711 $last = $a1->new( $last1[0] )->until( $last2[0] );
712 if ( defined $last1[1] ) {
713 $tail = $last1[1]->_function2( "until", $last2[1] );
719 return ($last, $tail);
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);
729 ($last, $more) = $last->last if ref($last);
730 $tail = $tail->_function2( 'union', $more ) if defined $more;
731 return ($last, $tail);
736 my ($last, $tail) = $self->{parent}->last;
737 $last = $last->offset( @{$self->{param}} );
738 $tail = $tail->_function( 'offset', @{$self->{param}} );
740 ($last, $more) = $last->last;
741 $tail = $tail->_function2( 'union', $more ) if defined $more;
742 return ($last, $tail);
747 my @max = $self->{parent}->max_a;
748 if (( $max[0] == $neg_inf ) || ( $max[0] == $inf )) {
749 return ( $self->new( $max[0] ) , $self->copy );
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}} );
757 return ( $last, $self->{parent}->
758 _function2( 'intersection', $last->complement )->
759 _function( 'quantize', @{$self->{param}} ) );
764 my ($last, $tail) = $self->{parent}->last;
765 $last = $last->tolerance( @{$self->{param}} );
766 $tail = $tail->tolerance( @{$self->{param}} );
767 return ($last, $tail);
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);
783 my $redo = $self->{parent}->$method ( @{ $self->{param} } );
784 @{$self->{first}} = $redo->first;
788 return $self->SUPER::first;
791 return wantarray ? @{$self->{first}} : $self->{first}[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);
805 my $redo = $self->{parent}->$method ( @{ $self->{param} } );
806 @{$self->{last}} = $redo->last;
810 return $self->SUPER::last;
813 return wantarray ? @{$self->{last}} : $self->{last}[0];
817 # offset: offsets subsets
820 if ($self->{too_complex}) {
821 return $self->_function( 'offset', @_ );
823 $self->trace_open(title=>"offset") if $TRACE;
827 my $b1 = $self->empty_set();
828 my ($interval, $ia, $i);
829 $param{mode} = 'offset' unless $param{mode};
831 unless (ref($param{value}) eq 'ARRAY') {
832 $param{value} = [0 + $param{value}, 0 + $param{value}];
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}};
839 carp "unknown unit $param{unit} for offset()" unless defined $sub_unit;
840 carp "unknown mode $param{mode} for offset()" unless defined $sub_mode;
843 my ($cmp, $this, $next, $ib, $part, $open_begin, $open_end, $tmp);
846 foreach $j (0 .. $parts) {
847 push @value, [ $param{value}[$j+$j], $param{value}[$j+$j + 1] ];
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) {
861 $open_end = $open_begin;
863 push @a, { a => $this , b => $next ,
864 open_begin => $open_begin , open_end => $open_end };
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};
876 $_[0]->{too_complex} ? 0 : $_[0]->SUPER::is_null;
881 $_[0]->{too_complex} ? 1 : 0;
885 # shows how a 'compacted' set looks like after quantize
889 $self->trace_open(title=>"_quantize_span") if $TRACE;
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 );
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 );
906 # TODO: other methods
908 $res = $self; # ->_function( "_quantize_span", %param );
910 $self->trace_close( arg => $res ) if $TRACE;
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 );
921 $res = $res->iterate (
923 $_[0]->quantize( @{$self->{param}} )->span;
929 $res = $self->iterate ( sub { $_[0] } );
931 $self->trace_close( arg => $res ) if $TRACE;
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 );
951 my ($self, $arg) = @_;
953 if ( defined $self->{backtrack_callback} )
955 return $arg = $self->new( $self->{backtrack_callback}->( $arg ) );
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;
963 return $arg->new( $before, $after );
967 my ($self, $arg) = @_;
968 if ($arg->{too_complex}) {
972 return $arg->quantize( @{$self->{param}} )->_quantize_span;
977 my ($self, $arg) = @_;
978 # offset - apply offset with negative values
979 my %tmp = @{$self->{param}};
980 my @values = sort @{$tmp{value}};
982 my $backtrack_arg2 = $arg->offset(
985 value => [ - $values[-1], - $values[0] ] );
986 return $arg->union( $backtrack_arg2 ); # fixes some problems with 'begin' mode
994 my ($self, $method, $arg) = @_;
995 return $self->$method ($arg) unless $self->{too_complex};
997 $self->trace_open( title => 'backtrack '.$self->{method} ) if $TRACE;
1000 if ( $backtrack_depth > $max_backtrack_depth ) {
1001 carp ( __PACKAGE__ . ": Backtrack too deep " .
1002 "(more than $max_backtrack_depth levels)" );
1005 if (exists $_backtrack{ $self->{method} } ) {
1006 $arg = $_backtrack{ $self->{method} }->( $self, $arg );
1010 if ( ref($self->{parent}) eq 'ARRAY' ) {
1011 # has 2 parents (intersection, union, until)
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};
1019 $method = $self->{method};
1020 if ( $result1->{too_complex} || $result2->{too_complex} ) {
1021 $result = $result1->_function2( $method, $result2 );
1024 $result = $result1->$method ($result2);
1028 # has 1 parent and parameters (offset, select, quantize, iterate)
1030 $result = $self->{parent}->_backtrack( $method, $arg );
1031 $method = $self->{method};
1032 $result = $result->$method ( @{$self->{param}} );
1036 $self->trace_close( arg => $result ) if $TRACE;
1043 my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
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);
1052 if (($a1->{too_complex}) or ($b1->{too_complex})) {
1053 return undef; # we don't know the answer!
1055 return $a1->SUPER::intersects( $b1 );
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' )
1067 ( undef, $backtrack_callback ) = ( shift, shift );
1070 if ($self->{too_complex}) {
1071 $self->trace(title=>"iterate:backtrack") if $TRACE;
1072 $set = $self->_function( 'iterate', $callback, @_ );
1076 $self->trace(title=>"iterate") if $TRACE;
1077 $set = $self->SUPER::iterate( $callback, @_ );
1079 $set->{backtrack_callback} = $backtrack_callback;
1080 # warn "set backtrack_callback" if defined $backtrack_callback;
1087 my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
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;
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};
1105 if ( $a1->{too_complex} || $b1->{too_complex} ) {
1106 $a1->trace_close( ) if $TRACE;
1107 return $a1->_function2( 'intersection', $b1 );
1109 return $a1->SUPER::intersection( $b1 );
1113 sub intersected_spans {
1115 my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
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};
1124 if ( ! $b1->{too_complex} && ! $a1->{too_complex} )
1126 return $a1->SUPER::intersected_spans ( $b1 );
1129 return $b1->iterate(
1131 my $tmp = $a1->intersection( $_[0] );
1132 return $tmp unless defined $tmp->max;
1134 my $before = $a1->intersection( $neg_inf, $tmp->min )->last;
1135 my $after = $a1->intersection( $tmp->max, $inf )->first;
1137 $before = $tmp->union( $before )->first;
1138 $after = $tmp->union( $after )->last;
1140 $tmp = $tmp->union( $before )
1141 if defined $before && $tmp->intersects( $before );
1142 $tmp = $tmp->union( $after )
1143 if defined $after && $tmp->intersects( $after );
1153 # do we have a parameter?
1155 my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
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;
1163 $a1->trace_open(title=>"complement") if $TRACE;
1164 if ($a1->{too_complex}) {
1165 $a1->trace_close( ) if $TRACE;
1166 return $a1->_function( 'complement', @_ );
1168 return $a1->SUPER::complement;
1174 my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
1176 if (($a1->{too_complex}) or ($b1->{too_complex})) {
1177 return $a1->_function2( 'until', $b1 );
1179 return $a1->SUPER::until( $b1 );
1185 my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
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);
1194 return $a1->SUPER::union( $b1 );
1198 # there are some ways to process 'contains':
1199 # A CONTAINS B IF A == ( A UNION B )
1201 # A CONTAINS B IF B == ( A INTERSECTION B )
1202 # - can backtrack = works for unbounded sets
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;
1214 $a1->trace_close( arg => ($b1 == $b0 ? 1 : 0) ) if $TRACE;
1215 return ($b1 == $b0) ? 1 : 0;
1217 my $b1 = $a1->union(@_);
1218 if ( $b1->{too_complex} ) {
1219 $b1->trace_close( arg => 'undef' ) if $TRACE;
1222 $a1->trace_close( arg => ($b1 == $a1 ? 1 : 0) ) if $TRACE;
1223 return ($b1 == $a1) ? 1 : 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);
1235 return $self->SUPER::min_a;
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);
1247 return $self->SUPER::max_a;
1253 # NOTE: subclasses may return "undef" if necessary
1254 return $inf if $self->{too_complex};
1255 return $self->SUPER::count;
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];
1267 return $self->SUPER::size;
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 );
1279 sub _cleanup { @_ } # this subroutine is obsolete
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
1293 return $self->SUPER::tolerance( $tmp );
1296 __PACKAGE__->SUPER::tolerance( $tmp ) if defined($tmp);
1297 return __PACKAGE__->SUPER::tolerance;
1303 return "$self" unless $self->{too_complex};
1304 return $self->{method} . "( " .
1305 ( ref($self->{parent}) eq 'ARRAY' ?
1306 $self->{parent}[0] . ' ; ' . $self->{parent}[1] :
1314 return ( $PRETTY_PRINT ? $self->_pretty_print : $too_complex )
1315 if $self->{too_complex};
1316 return $self->SUPER::as_string;
1329 Set::Infinite - Sets of intervals
1336 $set = Set::Infinite->new(1,2); # [1..2]
1337 print $set->union(5,6); # [1..2],[5..6]
1342 Set::Infinite is a Set Theory module for infinite sets.
1344 A set is a collection of objects.
1345 The objects that belong to a set are called its members, or "elements".
1347 As objects we allow (almost) anything: reals, integers, and objects (such as dates).
1349 We allow sets to be infinite.
1351 There is no account for the order of elements. For example, {1,2} = {2,1}.
1353 There is no account for repetition of elements. For example, {1,2,2} = {1,1,1,2} = {1,2}.
1359 Creates a new set object:
1361 $set = Set::Infinite->new; # empty set
1362 $set = Set::Infinite->new( 10 ); # single element
1363 $set = Set::Infinite->new( 10, 20 ); # single range
1364 $set = Set::Infinite->new(
1365 [ 10, 20 ], [ 50, 70 ] ); # two ranges
1371 $set = Set::Infinite->new;
1373 =item set with a single element
1375 $set = Set::Infinite->new( 10 );
1377 $set = Set::Infinite->new( [ 10 ] );
1379 =item set with a single span
1381 $set = Set::Infinite->new( 10, 20 );
1383 $set = Set::Infinite->new( [ 10, 20 ] );
1386 =item set with a single, open span
1388 $set = Set::Infinite->new(
1390 a => 10, open_begin => 0,
1391 b => 20, open_end => 1,
1396 =item set with multiple spans
1398 $set = Set::Infinite->new( 10, 20, 100, 200 );
1400 $set = Set::Infinite->new( [ 10, 20 ], [ 100, 200 ] );
1402 $set = Set::Infinite->new(
1404 a => 10, open_begin => 0,
1405 b => 20, open_end => 0,
1408 a => 100, open_begin => 0,
1409 b => 200, open_end => 0,
1415 The C<new()> method expects I<ordered> parameters.
1417 If you have unordered ranges, you can build the set using C<union>:
1419 @ranges = ( [ 10, 20 ], [ -10, 1 ] );
1420 $set = Set::Infinite->new;
1421 $set = $set->union( @$_ ) for @ranges;
1423 The data structures passed to C<new> must be I<immutable>.
1424 So this is not good practice:
1426 $set = Set::Infinite->new( $object_a, $object_b );
1427 $object_a->set_value( 10 );
1429 This is the recommended way to do it:
1431 $set = Set::Infinite->new( $object_a->clone, $object_b->clone );
1432 $object_a->set_value( 10 );
1437 Creates a new object, and copy the object data.
1441 Creates an empty set.
1443 If called from an existing set, the empty set inherits
1444 the "type" and "density" characteristics.
1446 =head2 universal_set
1448 Creates a set containing "all" possible elements.
1450 If called from an existing set, the universal set inherits
1451 the "type" and "density" characteristics.
1453 =head1 SET FUNCTIONS
1457 $set = $set->union($b);
1459 Returns the set of all elements from both sets.
1461 This function behaves like an "OR" operation.
1463 $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
1464 $set2 = new Set::Infinite( [ 7, 20 ] );
1465 print $set1->union( $set2 );
1466 # output: [1..4],[7..20]
1470 $set = $set->intersection($b);
1472 Returns the set of elements common to both sets.
1474 This function behaves like an "AND" operation.
1476 $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
1477 $set2 = new Set::Infinite( [ 7, 20 ] );
1478 print $set1->intersection( $set2 );
1487 $set = $set->complement;
1489 Returns the set of all elements that don't belong to the set.
1491 $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
1492 print $set1->complement;
1493 # output: (-inf..1),(4..8),(12..inf)
1495 The complement function might take a parameter:
1497 $set = $set->minus($b);
1499 Returns the set-difference, that is, the elements that don't
1500 belong to the given set.
1502 $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
1503 $set2 = new Set::Infinite( [ 7, 20 ] );
1504 print $set1->minus( $set2 );
1507 =head2 symmetric_difference
1509 Returns a set containing elements that are in either set,
1510 but not in both. This is the "set" version of "XOR".
1512 =head1 DENSITY METHODS
1518 Returns a set with density "0".
1522 $set1 = $set->integer;
1524 Returns a set with density "1".
1526 =head1 LOGIC FUNCTIONS
1530 $logic = $set->intersects($b);
1534 $logic = $set->contains($b);
1540 $logic = $set->is_null;
1544 This set that has at least 1 element.
1548 This set that has a single span or interval.
1552 This set that has a single element.
1554 =head2 is_subset( $set )
1556 Every element of this set is a member of the given set.
1558 =head2 is_proper_subset( $set )
1560 Every element of this set is a member of the given set.
1561 Some members of the given set are not elements of this set.
1563 =head2 is_disjoint( $set )
1565 The given set has no elements in common with this set.
1567 =head2 is_too_complex
1569 Sometimes a set might be too complex to enumerate or print.
1571 This happens with sets that represent infinite recurrences, such as
1572 when you ask for a quantization on a
1573 set bounded by -inf or inf.
1575 See also: C<count> method.
1577 =head1 SCALAR FUNCTIONS
1595 =head1 OVERLOADED OPERATORS
1597 =head2 stringification
1603 See also: C<as_string>.
1611 See also: C<spaceship> method.
1613 =head1 CLASS METHODS
1615 Set::Infinite->separators(@i)
1617 chooses the interval separators for stringification.
1619 default are [ ] ( ) '..' ','.
1623 returns an 'Infinity' number.
1627 returns '-Infinity' number.
1631 type( "My::Class::Name" )
1633 Chooses a default object data type.
1635 Default is none (a normal Perl SCALAR).
1638 =head1 SPECIAL SET FUNCTIONS
1644 Returns the set span.
1648 Extends a set until another:
1650 0,5,7 -> until 2,6,10
1654 [0..2), [5..6), [7..10)
1660 These methods do the inverse of the "until" method.
1664 [0..2), [5..6), [7..10)
1674 =head2 intersected_spans
1676 $set = $set1->intersected_spans( $set2 );
1678 The method returns a new set,
1679 containing all spans that are intersected by the given set.
1681 Unlike the C<intersection> method, the spans are not modified.
1684 set1 [....] [....] [....] [....]
1685 set2 [................]
1687 intersection [.] [....] [.]
1689 intersected_spans [....] [....] [....]
1694 quantize( parameters )
1696 Makes equal-sized subsets.
1698 Returns an ordered set of equal-sized subsets.
1702 $set = Set::Infinite->new([1,3]);
1703 print join (" ", $set->quantize( quant => 1 ) );
1707 [1..2) [2..3) [3..4)
1711 select( parameters )
1713 Selects set spans based on their ordered positions
1715 C<select> has a behaviour similar to an array C<slice>.
1718 count - default=Infinity
1720 0 1 2 3 4 5 6 7 8 # original set
1722 1 6 # by => [ -2, 1 ]
1726 offset ( parameters )
1728 Offsets the subsets. Parameters:
1730 value - default=[0,0]
1731 mode - default='offset'. Possible values are: 'offset', 'begin', 'end'.
1732 unit - type of value. Can be 'days', 'weeks', 'hours', 'minutes', 'seconds'.
1736 iterate ( sub { } , @args )
1738 Iterates on the set spans, over a callback subroutine.
1739 Returns the union of all partial results.
1741 The callback argument C<$_[0]> is a span. If there are additional arguments they are passed to the callback.
1743 The callback can return a span, a hashref (see C<Set::Infinite::Basic>), a scalar, an object, or C<undef>.
1746 C<iterate> accepts an optional C<backtrack_callback> argument.
1747 The purpose of the C<backtrack_callback> is to I<reverse> the
1748 iterate() function, overcoming the limitations of the internal
1749 backtracking algorithm.
1752 iterate ( sub { } , backtrack_callback => sub { }, @args )
1754 The C<backtrack_callback> can return a span, a hashref, a scalar,
1755 an object, or C<undef>.
1757 For example, the following snippet adds a constant to each
1758 element of an unbounded set:
1760 $set1 = $set->iterate(
1761 sub { $_[0]->min + 54, $_[0]->max + 54 },
1762 backtrack_callback =>
1763 sub { $_[0]->min - 54, $_[0]->max - 54 },
1770 In scalar context returns the first or last interval of a set.
1772 In list context returns the first or last interval of a set,
1773 and the remaining set (the 'tail').
1775 See also: C<min>, C<max>, C<min_a>, C<max_a> methods.
1779 type( "My::Class::Name" )
1781 Chooses a default object data type.
1783 default is none (a normal perl SCALAR).
1786 =head1 INTERNAL FUNCTIONS
1790 $set->_backtrack( 'intersection', $b );
1792 Internal function to evaluate recurrences.
1798 Internal function to ignore the set "type".
1799 It is used in some internal optimizations, when it is
1800 possible to use scalar values instead of objects.
1806 Internal function to fix the result of operations
1807 that use the numeric() function.
1811 $set = $set->tolerance(0) # defaults to real sets (default)
1812 $set = $set->tolerance(1) # defaults to integer sets
1814 Internal function for changing the set "density".
1818 ($min, $min_is_open) = $set->min_a;
1822 ($max, $max_is_open) = $set->max_a;
1827 Implements the "stringification" operator.
1829 Stringification of unbounded recurrences is not implemented.
1831 Unbounded recurrences are stringified as "function descriptions",
1832 if the class variable $PRETTY_PRINT is set.
1836 Implements the "comparison" operator.
1838 Comparison of unbounded recurrences is not implemented.
1845 =item * constructor "span" notation
1847 $set = Set::Infinite->new(10,1);
1849 Will be interpreted as [1..10]
1851 =item * constructor "multiple-span" notation
1853 $set = Set::Infinite->new(1,2,3,4);
1855 Will be interpreted as [1..2],[3..4] instead of [1,2,3,4].
1856 You probably want ->new([1],[2],[3],[4]) instead,
1859 =item * "range operator"
1861 $set = Set::Infinite->new(1..3);
1863 Will be interpreted as [1..2],3 instead of [1,2,3].
1864 You probably want ->new(1,3) instead.
1870 The base I<set> object, without recurrences, is a C<Set::Infinite::Basic>.
1872 A I<recurrence-set> is represented by a I<method name>,
1873 one or two I<parent objects>, and extra arguments.
1874 The C<list> key is set to an empty array, and the
1875 C<too_complex> key is set to C<1>.
1877 This is a structure that holds the union of two "complex sets":
1880 too_complex => 1, # "this is a recurrence"
1881 list => [ ], # not used
1882 method => 'union', # function name
1883 parent => [ $set1, $set2 ], # "leaves" in the syntax-tree
1884 param => [ ] # optional arguments for the function
1887 This is a structure that holds the complement of a "complex set":
1890 too_complex => 1, # "this is a recurrence"
1891 list => [ ], # not used
1892 method => 'complement', # function name
1893 parent => $set, # "leaf" in the syntax-tree
1894 param => [ ] # optional arguments for the function
1900 See modules DateTime::Set, DateTime::Event::Recurrence,
1901 DateTime::Event::ICal, DateTime::Event::Cron
1902 for up-to-date information on date-sets.
1904 The perl-date-time project <http://datetime.perl.org>
1909 Flavio S. Glock <fglock@gmail.com>
1913 Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
1914 This program is free software; you can redistribute it and/or modify
1915 it under the same terms as Perl itself.
1917 The full text of the license can be found in the LICENSE file included