1 package Set::Infinite::Basic;
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.
13 use vars qw( @ISA @EXPORT_OK @EXPORT );
14 use vars qw( $Type $tolerance $fixtype $inf $minus_inf @Separators $neg_inf );
17 @EXPORT_OK = qw( INFINITY NEG_INFINITY );
20 use constant INFINITY => 100**100**100;
21 use constant NEG_INFINITY => - INFINITY;
24 $minus_inf = $neg_inf = NEG_INFINITY;
32 # TODO: make this an object _and_ class method
36 return $Separators[ $_[0] ] if $#_ == 0;
37 @Separators = @_ if @_;
42 __PACKAGE__->separators (
43 '[', ']', # a closed interval
44 '(', ')', # an open interval
45 '..', # number separator
47 '', '', # set delimiter '{' '}'
49 # global defaults for object private vars
55 # _simple_* set of internal methods: basic processing of "spans"
57 sub _simple_intersects {
60 my ($i_beg, $i_end, $open_beg, $open_end);
61 my $cmp = $tmp1->{a} <=> $tmp2->{a};
64 $open_beg = $tmp2->{open_begin};
68 $open_beg = $tmp1->{open_begin};
72 $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin};
74 $cmp = $tmp1->{b} <=> $tmp2->{b};
77 $open_end = $tmp2->{open_end};
81 $open_end = $tmp1->{open_end};
85 $open_end = ($tmp1->{open_end} || $tmp2->{open_end});
87 $cmp = $i_beg <=> $i_end;
90 ( ($cmp == 0) && ($open_beg || $open_end) ) ;
95 sub _simple_complement {
97 if ($self->{b} == $inf) {
98 return if $self->{a} == $neg_inf;
99 return { a => $neg_inf,
102 open_end => ! $self->{open_begin} };
104 if ($self->{a} == $neg_inf) {
105 return { a => $self->{b},
107 open_begin => ! $self->{open_end},
113 open_end => ! $self->{open_begin}
117 open_begin => ! $self->{open_end},
124 my ($tmp2, $tmp1, $tolerance) = @_;
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 ;
133 if ((($tmp1->{b}+$tmp1->{b}) + $b1_open ) <
134 (($tmp2->{a}+$tmp2->{a}) - $a2_open)) {
136 return ( $tmp1, $tmp2 );
138 if ((($tmp1->{a}+$tmp1->{a}) - $a1_open ) >
139 (($tmp2->{b}+$tmp2->{b}) + $b2_open)) {
141 return ( $tmp2, $tmp1 );
146 $cmp = $tmp1->{b} <=> $tmp2->{a};
148 ( $cmp == 0 && $tmp1->{open_end} && $tmp2->{open_begin} ) ) {
149 return ( $tmp1, $tmp2 );
151 $cmp = $tmp1->{a} <=> $tmp2->{b};
153 ( $cmp == 0 && $tmp2->{open_end} && $tmp1->{open_begin} ) ) {
154 return ( $tmp2, $tmp1 );
159 $cmp = $tmp1->{a} <=> $tmp2->{a};
161 $tmp->{a} = $tmp2->{a};
162 $tmp->{open_begin} = $tmp2->{open_begin};
165 $tmp->{a} = $tmp1->{a};
166 $tmp->{open_begin} = $tmp1->{open_begin} ? $tmp2->{open_begin} : 0;
169 $tmp->{a} = $tmp1->{a};
170 $tmp->{open_begin} = $tmp1->{open_begin};
173 $cmp = $tmp1->{b} <=> $tmp2->{b};
175 $tmp->{b} = $tmp2->{b};
176 $tmp->{open_end} = $tmp2->{open_end};
179 $tmp->{b} = $tmp1->{b};
180 $tmp->{open_end} = $tmp1->{open_end} ? $tmp2->{open_end} : 0;
183 $tmp->{b} = $tmp1->{b};
184 $tmp->{open_end} = $tmp1->{open_end};
190 sub _simple_spaceship {
191 my ($tmp1, $tmp2, $inverted) = @_;
194 $cmp = $tmp2->{a} <=> $tmp1->{a};
196 $cmp = $tmp1->{open_begin} <=> $tmp2->{open_begin};
198 $cmp = $tmp2->{b} <=> $tmp1->{b};
200 return $tmp1->{open_end} <=> $tmp2->{open_end};
202 $cmp = $tmp1->{a} <=> $tmp2->{a};
204 $cmp = $tmp2->{open_begin} <=> $tmp1->{open_begin};
206 $cmp = $tmp1->{b} <=> $tmp2->{b};
208 return $tmp2->{open_end} <=> $tmp1->{open_end};
213 my ($tmp, $tmp2, $type) = @_;
215 if ( ref($tmp) ne $type ) {
216 $tmp = new $type $tmp;
218 if ( ref($tmp2) ne $type ) {
219 $tmp2 = new $type $tmp2;
223 carp "Invalid interval specification: start value is after end";
224 # ($tmp, $tmp2) = ($tmp2, $tmp);
226 return { a => $tmp , b => $tmp2 , open_begin => 0 , open_end => 0 };
230 sub _simple_as_string {
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' );
240 my $tmp2 = $self->{b};
241 $tmp2 = $tmp2->datetime if UNIVERSAL::can( $tmp2, 'datetime' );
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);
250 # end of "_simple_" methods
256 return ref($self) ? $self->{type} : $Type;
258 my $tmp_type = shift;
259 eval "use " . $tmp_type;
260 carp "Warning: can't start $tmp_type : $@" if $@;
262 $self->{type} = $tmp_type;
274 foreach (@{$self->{list}}) {
275 push @b, $self->new($_);
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;
295 return $self unless $self->{fixtype};
297 $self->{fixtype} = 0;
298 foreach (@{$self->{list}}) {
299 $_->{a} = 0 + $_->{a};
300 $_->{b} = 0 + $_->{b};
305 sub _no_cleanup { $_[0] } # obsolete
309 if (exists $self->{first} ) {
310 return wantarray ? @{$self->{first}} : $self->{first}[0];
312 unless ( @{$self->{list}} ) {
313 return wantarray ? (undef, 0) : undef;
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);
325 if (exists $self->{last} ) {
326 return wantarray ? @{$self->{last}} : $self->{last}[0];
328 unless ( @{$self->{list}} ) {
329 return wantarray ? (undef, 0) : undef;
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);
340 @{$_[0]->{list}} ? 0 : 1;
352 ( $#{$_[0]->{list}} == 0 ) ? 1 : 0;
356 ( $#{$_[0]->{list}} == 0 &&
357 $_[0]->{list}[0]{a} == $_[0]->{list}[0]{b} ) ? 1 : 0;
363 if (ref ($_[0]) eq ref($a1) ) {
369 return $b1->contains( $a1 );
372 sub is_proper_subset {
375 if (ref ($_[0]) eq ref($a1) ) {
382 my $contains = $b1->contains( $a1 );
383 return $contains unless $contains;
385 my $equal = ( $a1 == $b1 );
386 return $equal if !defined $equal || $equal;
392 my $intersects = shift->intersects( @_ );
393 return ! $intersects if defined $intersects;
398 # TODO: options 'no-sort', 'no-merge', 'keep-null' ...
400 my $iterate = $a1->empty_set();
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;
413 my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
414 return _intersection ( 'intersection', $a1, $b1 );
419 my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
420 return _intersection ( 'intersects', $a1, $b1 );
423 sub intersected_spans {
425 my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
426 return _intersection ( 'intersected_spans', $a1, $b1 );
431 my ( $op, $a1, $b1 ) = @_;
434 my ( $a0, $na ) = ( 0, $#{$a1->{list}} );
435 my ( $tmp1, $tmp1a, $tmp2a, $tmp1b, $tmp2b, $i_beg, $i_end, $open_beg, $open_end );
439 # for-loop optimization (makes little difference)
440 # This was kept for backward compatibility with Date::Set tests
442 if ($na < $#{ $b1->{list} })
444 $na = $#{ $b1->{list} };
445 ($a1, $b1) = ($b1, $a1);
449 B: foreach my $tmp2 ( @{ $b1->{list} } ) {
452 A: foreach $ia ($a0 .. $na) {
453 $tmp1 = $a1->{list}[$ia];
456 if ($tmp1b < $tmp2a) {
461 if ($tmp1a > $tmp2b) {
465 $cmp1 = $tmp1a <=> $tmp2a;
468 $open_beg = $tmp2->{open_begin};
471 $open_beg = $tmp1->{open_begin};
474 $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin};
477 $cmp2 = $tmp1b <=> $tmp2b;
480 $open_end = $tmp2->{open_end};
483 $open_end = $tmp1->{open_end};
486 $open_end = $tmp1->{open_end} || $tmp2->{open_end};
489 if ( ( $tmp1a <= $tmp1b ) &&
490 ( ($tmp1a != $tmp1b) ||
491 (!$open_beg and !$open_end) ||
492 ($tmp1a == $inf) || # XXX
497 if ( $op eq 'intersection' )
500 a => $tmp1a, b => $tmp1b,
501 open_begin => $open_beg, open_end => $open_end } ;
503 if ( $op eq 'intersects' )
507 if ( $op eq 'intersected_spans' )
517 return 0 if $op eq 'intersects';
519 my $intersection = $self->new();
520 $intersection->{list} = \@a;
521 return $intersection;
529 if (ref ($_[0]) eq ref($self) ) {
533 $a1 = $self->new(@_);
535 return $self->intersection( $a1->complement );
538 unless ( @{$self->{list}} ) {
539 return $self->universal_set;
541 my $complement = $self->empty_set();
542 @{$complement->{list}} = _simple_complement($self->{list}[0]);
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);
556 if (ref ($_[0]) eq ref($a1) ) {
562 my @b1_min = $b1->min_a;
563 my @a1_max = $a1->max_a;
565 unless (defined $b1_min[0]) {
566 return $a1->until($inf);
568 unless (defined $a1_max[0]) {
569 return $a1->new(-$inf)->until($b1);
572 my ($ia, $ib, $begin, $end);
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}}, {
591 push @{$u->{list}}, {
600 if ($ia <= $#{$a1->{list}} &&
601 $a1->{list}[$ia]{a} >= $last )
603 push @{$u->{list}}, {
604 a => $a1->{list}[$ia]{a} ,
613 return $_[0]->iterate(
620 return $_[0]->iterate(
628 if (ref ($_[0]) eq ref($a1) ) {
634 # test for union with empty set
635 if ( $#{ $a1->{list} } < 0 ) {
638 if ( $#{ $b1->{list} } < 0 ) {
641 my @b1_min = $b1->min_a;
642 my @a1_max = $a1->max_a;
643 unless (defined $b1_min[0]) {
646 unless (defined $a1_max[0]) {
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;
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});
668 $a1->{list}[$ia] = $tmp[0];
671 last if $ia >= $#{$a1->{list}};
672 last unless _simple_intersects ( $a1->{list}[$ia], $a1->{list}[$ia + 1] )
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 );
683 if ($a1->{list}[$ia]{a} >= $b_list->[$ib]{a}) {
684 splice (@{$a1->{list}}, $ia, 0, $b_list->[$ib]);
688 push @{$a1->{list}}, $b_list->[$ib];
694 # there are some ways to process 'contains':
695 # A CONTAINS B IF A == ( A UNION B )
697 # A CONTAINS B IF B == ( A INTERSECTION B )
698 # - can backtrack = works for unbounded sets
701 my $b1 = $a1->union(@_);
702 return ($b1 == $a1) ? 1 : 0;
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} };
715 $copy->{$key} = $self->{$key};
730 tolerance => $class->{tolerance},
731 type => $class->{type},
732 fixtype => $class->{fixtype},
738 tolerance => $tolerance ? $tolerance : 0,
739 type => $class->type,
740 fixtype => $fixtype ? $fixtype : 0,
743 my ($tmp, $tmp2, $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}};
754 if ($ref eq 'HASH') {
755 push @{ $self->{list} }, $tmp;
758 if ($tmp->isa(__PACKAGE__)) {
759 push @{ $self->{list} }, @{$tmp->{list}};
769 push @{ $self->{list} }, _simple_new($tmp,$tmp2, $self->{type} )
779 $_[0]->new( NEG_INFINITY, INFINITY );
782 *minus = \∁
784 *difference = \∁
786 sub symmetric_difference {
789 if (ref ($_[0]) eq ref($a1) ) {
796 return $a1->complement( $b1 )->union(
797 $b1->complement( $a1 ) );
800 *simmetric_difference = \&symmetric_difference; # bugfix
808 return @{$self->{min}} if exists $self->{min};
809 return @{$self->{min}} = (undef, 0) unless @{$self->{list}};
810 my $tmp = $self->{list}[0]{a};
811 my $tmp2 = $self->{list}[0]{open_begin} || 0;
812 if ($tmp2 && $self->{tolerance}) {
814 $tmp += $self->{tolerance};
816 return @{$self->{min}} = ($tmp, $tmp2);
825 return @{$self->{max}} if exists $self->{max};
826 return @{$self->{max}} = (undef, 0) unless @{$self->{list}};
827 my $tmp = $self->{list}[-1]{b};
828 my $tmp2 = $self->{list}[-1]{open_end} || 0;
829 if ($tmp2 && $self->{tolerance}) {
831 $tmp -= $self->{tolerance};
833 return @{$self->{max}} = ($tmp, $tmp2);
837 1 + $#{$_[0]->{list}};
843 foreach( @{$self->{list}} ) {
845 $size += $_->{b} - $_->{a};
848 $size = $_->{b} - $_->{a};
850 if ( $self->{tolerance} ) {
851 $size += $self->{tolerance} unless $_->{open_end};
852 $size -= $self->{tolerance} if $_->{open_begin};
853 $size -= $self->{tolerance} if $_->{open_end};
861 my @max = $self->max_a;
862 my @min = $self->min_a;
863 return undef unless defined $min[0] && defined $max[0];
864 my $a1 = $self->new($min[0], $max[0]);
865 $a1->{list}[0]{open_end} = $max[1];
866 $a1->{list}[0]{open_begin} = $min[1];
871 my ($tmp1, $tmp2, $inverted) = @_;
873 ($tmp2, $tmp1) = ($tmp1, $tmp2);
875 foreach(0 .. $#{$tmp1->{list}}) {
876 my $this = $tmp1->{list}[$_];
877 if ($_ > $#{ $tmp2->{list} } ) {
880 my $other = $tmp2->{list}[$_];
881 my $cmp = _simple_spaceship($this, $other);
882 return $cmp if $cmp; # this != $other;
884 return $#{ $tmp1->{list} } == $#{ $tmp2->{list} } ? 0 : -1;
892 return $self->{tolerance} unless defined $tmp;
894 $self->{tolerance} = $tmp;
895 delete $self->{max}; # tolerance may change "max"
899 while ( $_ <= $#{$self->{list}} ) {
900 @tmp = Set::Infinite::Basic::_simple_union($self->{list}->[$_],
901 $self->{list}->[$_ - 1],
904 $self->{list}->[$_ - 1] = $tmp[0];
905 splice (@{$self->{list}}, $_, 1);
915 $tolerance = $tmp if defined($tmp);
920 $_[0]->tolerance (1);
924 $_[0]->tolerance (0);
929 return $self->separators(6) .
930 join( $self->separators(5),
931 map { $self->_simple_as_string($_) } @{$self->{list}} ) .
932 $self->separators(7),;
944 Set::Infinite::Basic - Sets of intervals
948 use Set::Infinite::Basic;
950 $set = Set::Infinite::Basic->new(1,2); # [1..2]
951 print $set->union(5,6); # [1..2],[5..6]
955 Set::Infinite::Basic is a Set Theory module for infinite sets.
957 It works on reals, integers, and objects.
959 This module does not support recurrences. Recurrences are implemented in Set::Infinite.
965 Creates an empty_set.
967 If called from an existing set, the empty set inherits
968 the "type" and "density" characteristics.
972 Creates a set containing "all" possible elements.
974 If called from an existing set, the universal set inherits
975 the "type" and "density" characteristics.
979 Extends a set until another:
981 0,5,7 -> until 2,6,10
985 [0..2), [5..6), [7..10)
987 Note: this function is still experimental.
993 Makes a new object from the object's data.
995 =head2 Mode functions:
999 $set = $set->integer;
1001 =head2 Logic functions:
1003 $logic = $set->intersects($b);
1005 $logic = $set->contains($b);
1007 $logic = $set->is_null; # also called "is_empty"
1009 =head2 Set functions:
1011 $set = $set->union($b);
1013 $set = $set->intersection($b);
1015 $set = $set->complement;
1016 $set = $set->complement($b); # can also be called "minus" or "difference"
1018 $set = $set->symmetric_difference( $b );
1022 result is (min .. max)
1024 =head2 Scalar functions:
1032 $i = $set->count; # number of spans
1034 =head2 Overloaded Perl functions:
1040 =head2 Global functions:
1044 chooses the interval separators.
1046 default are [ ] ( ) '..' ','.
1050 returns an 'Infinity' number.
1054 returns a '-Infinity' number.
1058 Iterates over a subroutine.
1059 Returns the union of partial results.
1063 In scalar context returns the first interval of a set.
1065 In list context returns the first interval of a set, and the
1068 Works in unbounded sets
1072 chooses an object data type.
1074 default is none (a normal perl SCALAR).
1078 type('Math::BigFloat');
1079 type('Math::BigInt');
1080 type('Set::Infinite::Date');
1081 See notes on Set::Infinite::Date below.
1083 tolerance(0) defaults to real sets (default)
1084 tolerance(1) defaults to integer sets
1086 real defaults to real sets (default)
1088 integer defaults to integer sets
1090 =head2 Internal functions:
1098 $set = Set::Infinite->new(10,1);
1099 Will be interpreted as [1..10]
1101 $set = Set::Infinite->new(1,2,3,4);
1102 Will be interpreted as [1..2],[3..4] instead of [1,2,3,4].
1103 You probably want ->new([1],[2],[3],[4]) instead,
1106 $set = Set::Infinite->new(1..3);
1107 Will be interpreted as [1..2],3 instead of [1,2,3].
1108 You probably want ->new(1,3) instead.
1112 The internal representation of a I<span> is a hash:
1114 { a => start of span,
1116 open_begin => '0' the span starts in 'a'
1117 '1' the span starts after 'a'
1118 open_end => '0' the span ends in 'b'
1119 '1' the span ends before 'b'
1122 For example, this set:
1124 [100..200),300,(400..infinity)
1126 is represented by the array of hashes:
1129 { a => 100, b => 200, open_begin => 0, open_end => 1 },
1130 { a => 300, b => 300, open_begin => 0, open_end => 0 },
1131 { a => 400, b => infinity, open_begin => 0, open_end => 1 },
1134 The I<density> of a set is stored in the C<tolerance> variable:
1136 tolerance => 0; # the set is made of real numbers.
1138 tolerance => 1; # the set is made of integers.
1140 The C<type> variable stores the I<class> of objects that will be stored in the set.
1142 type => 'DateTime'; # this is a set of DateTime objects
1144 The I<infinity> value is generated by Perl, when it finds a numerical overflow:
1146 $inf = 100**100**100;
1154 Flavio S. Glock <fglock@gmail.com>