X-Git-Url: http://wagnertech.de/gitweb/gitweb.cgi/kivitendo-erp.git/blobdiff_plain/deb4d2dbb676d7d6f69dfe7815d6e0cb09bd4a44..53593baa211863fbf66540cf1bcc36c8fb37257f:/modules/fallback/Set/Infinite/Basic.pm diff --git a/modules/fallback/Set/Infinite/Basic.pm b/modules/fallback/Set/Infinite/Basic.pm deleted file mode 100644 index b917bfbe8..000000000 --- a/modules/fallback/Set/Infinite/Basic.pm +++ /dev/null @@ -1,1157 +0,0 @@ -package Set::Infinite::Basic; - -# Copyright (c) 2001, 2002, 2003 Flavio Soibelmann Glock. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -require 5.005_03; -use strict; - -require Exporter; -use Carp; -use Data::Dumper; -use vars qw( @ISA @EXPORT_OK @EXPORT ); -use vars qw( $Type $tolerance $fixtype $inf $minus_inf @Separators $neg_inf ); - -@ISA = qw(Exporter); -@EXPORT_OK = qw( INFINITY NEG_INFINITY ); -@EXPORT = qw(); - -use constant INFINITY => 100**100**100; -use constant NEG_INFINITY => - INFINITY; - -$inf = INFINITY; -$minus_inf = $neg_inf = NEG_INFINITY; - -use overload - '<=>' => \&spaceship, - qw("" as_string), -; - - -# TODO: make this an object _and_ class method -# TODO: POD -sub separators { - shift; - return $Separators[ $_[0] ] if $#_ == 0; - @Separators = @_ if @_; - return @Separators; -} - -BEGIN { - __PACKAGE__->separators ( - '[', ']', # a closed interval - '(', ')', # an open interval - '..', # number separator - ',', # list separator - '', '', # set delimiter '{' '}' - ); - # global defaults for object private vars - $Type = undef; - $tolerance = 0; - $fixtype = 1; -} - -# _simple_* set of internal methods: basic processing of "spans" - -sub _simple_intersects { - my $tmp1 = $_[0]; - my $tmp2 = $_[1]; - my ($i_beg, $i_end, $open_beg, $open_end); - my $cmp = $tmp1->{a} <=> $tmp2->{a}; - if ($cmp < 0) { - $i_beg = $tmp2->{a}; - $open_beg = $tmp2->{open_begin}; - } - elsif ($cmp > 0) { - $i_beg = $tmp1->{a}; - $open_beg = $tmp1->{open_begin}; - } - else { - $i_beg = $tmp1->{a}; - $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin}; - } - $cmp = $tmp1->{b} <=> $tmp2->{b}; - if ($cmp > 0) { - $i_end = $tmp2->{b}; - $open_end = $tmp2->{open_end}; - } - elsif ($cmp < 0) { - $i_end = $tmp1->{b}; - $open_end = $tmp1->{open_end}; - } - else { - $i_end = $tmp1->{b}; - $open_end = ($tmp1->{open_end} || $tmp2->{open_end}); - } - $cmp = $i_beg <=> $i_end; - return 0 if - ( $cmp > 0 ) || - ( ($cmp == 0) && ($open_beg || $open_end) ) ; - return 1; -} - - -sub _simple_complement { - my $self = $_[0]; - if ($self->{b} == $inf) { - return if $self->{a} == $neg_inf; - return { a => $neg_inf, - b => $self->{a}, - open_begin => 1, - open_end => ! $self->{open_begin} }; - } - if ($self->{a} == $neg_inf) { - return { a => $self->{b}, - b => $inf, - open_begin => ! $self->{open_end}, - open_end => 1 }; - } - ( { a => $neg_inf, - b => $self->{a}, - open_begin => 1, - open_end => ! $self->{open_begin} - }, - { a => $self->{b}, - b => $inf, - open_begin => ! $self->{open_end}, - open_end => 1 - } - ); -} - -sub _simple_union { - my ($tmp2, $tmp1, $tolerance) = @_; - my $cmp; - if ($tolerance) { - # "integer" - my $a1_open = $tmp1->{open_begin} ? -$tolerance : $tolerance ; - my $b1_open = $tmp1->{open_end} ? -$tolerance : $tolerance ; - my $a2_open = $tmp2->{open_begin} ? -$tolerance : $tolerance ; - my $b2_open = $tmp2->{open_end} ? -$tolerance : $tolerance ; - # open_end touching? - if ((($tmp1->{b}+$tmp1->{b}) + $b1_open ) < - (($tmp2->{a}+$tmp2->{a}) - $a2_open)) { - # self disjuncts b - return ( $tmp1, $tmp2 ); - } - if ((($tmp1->{a}+$tmp1->{a}) - $a1_open ) > - (($tmp2->{b}+$tmp2->{b}) + $b2_open)) { - # self disjuncts b - return ( $tmp2, $tmp1 ); - } - } - else { - # "real" - $cmp = $tmp1->{b} <=> $tmp2->{a}; - if ( $cmp < 0 || - ( $cmp == 0 && $tmp1->{open_end} && $tmp2->{open_begin} ) ) { - return ( $tmp1, $tmp2 ); - } - $cmp = $tmp1->{a} <=> $tmp2->{b}; - if ( $cmp > 0 || - ( $cmp == 0 && $tmp2->{open_end} && $tmp1->{open_begin} ) ) { - return ( $tmp2, $tmp1 ); - } - } - - my $tmp; - $cmp = $tmp1->{a} <=> $tmp2->{a}; - if ($cmp > 0) { - $tmp->{a} = $tmp2->{a}; - $tmp->{open_begin} = $tmp2->{open_begin}; - } - elsif ($cmp == 0) { - $tmp->{a} = $tmp1->{a}; - $tmp->{open_begin} = $tmp1->{open_begin} ? $tmp2->{open_begin} : 0; - } - else { - $tmp->{a} = $tmp1->{a}; - $tmp->{open_begin} = $tmp1->{open_begin}; - } - - $cmp = $tmp1->{b} <=> $tmp2->{b}; - if ($cmp < 0) { - $tmp->{b} = $tmp2->{b}; - $tmp->{open_end} = $tmp2->{open_end}; - } - elsif ($cmp == 0) { - $tmp->{b} = $tmp1->{b}; - $tmp->{open_end} = $tmp1->{open_end} ? $tmp2->{open_end} : 0; - } - else { - $tmp->{b} = $tmp1->{b}; - $tmp->{open_end} = $tmp1->{open_end}; - } - return $tmp; -} - - -sub _simple_spaceship { - my ($tmp1, $tmp2, $inverted) = @_; - my $cmp; - if ($inverted) { - $cmp = $tmp2->{a} <=> $tmp1->{a}; - return $cmp if $cmp; - $cmp = $tmp1->{open_begin} <=> $tmp2->{open_begin}; - return $cmp if $cmp; - $cmp = $tmp2->{b} <=> $tmp1->{b}; - return $cmp if $cmp; - return $tmp1->{open_end} <=> $tmp2->{open_end}; - } - $cmp = $tmp1->{a} <=> $tmp2->{a}; - return $cmp if $cmp; - $cmp = $tmp2->{open_begin} <=> $tmp1->{open_begin}; - return $cmp if $cmp; - $cmp = $tmp1->{b} <=> $tmp2->{b}; - return $cmp if $cmp; - return $tmp2->{open_end} <=> $tmp1->{open_end}; -} - - -sub _simple_new { - my ($tmp, $tmp2, $type) = @_; - if ($type) { - if ( ref($tmp) ne $type ) { - $tmp = new $type $tmp; - } - if ( ref($tmp2) ne $type ) { - $tmp2 = new $type $tmp2; - } - } - if ($tmp > $tmp2) { - carp "Invalid interval specification: start value is after end"; - # ($tmp, $tmp2) = ($tmp2, $tmp); - } - return { a => $tmp , b => $tmp2 , open_begin => 0 , open_end => 0 }; -} - - -sub _simple_as_string { - my $set = shift; - my $self = $_[0]; - my $s; - return "" unless defined $self; - $self->{open_begin} = 1 if ($self->{a} == -$inf ); - $self->{open_end} = 1 if ($self->{b} == $inf ); - my $tmp1 = $self->{a}; - $tmp1 = $tmp1->datetime if UNIVERSAL::can( $tmp1, 'datetime' ); - $tmp1 = "$tmp1"; - my $tmp2 = $self->{b}; - $tmp2 = $tmp2->datetime if UNIVERSAL::can( $tmp2, 'datetime' ); - $tmp2 = "$tmp2"; - return $tmp1 if $tmp1 eq $tmp2; - $s = $self->{open_begin} ? $set->separators(2) : $set->separators(0); - $s .= $tmp1 . $set->separators(4) . $tmp2; - $s .= $self->{open_end} ? $set->separators(3) : $set->separators(1); - return $s; -} - -# end of "_simple_" methods - - -sub type { - my $self = shift; - unless (@_) { - return ref($self) ? $self->{type} : $Type; - } - my $tmp_type = shift; - eval "use " . $tmp_type; - carp "Warning: can't start $tmp_type : $@" if $@; - if (ref($self)) { - $self->{type} = $tmp_type; - return $self; - } - else { - $Type = $tmp_type; - return $Type; - } -} - -sub list { - my $self = shift; - my @b = (); - foreach (@{$self->{list}}) { - push @b, $self->new($_); - } - return @b; -} - -sub fixtype { - my $self = shift; - $self = $self->copy; - $self->{fixtype} = 1; - my $type = $self->type; - return $self unless $type; - foreach (@{$self->{list}}) { - $_->{a} = $type->new($_->{a}) unless ref($_->{a}) eq $type; - $_->{b} = $type->new($_->{b}) unless ref($_->{b}) eq $type; - } - return $self; -} - -sub numeric { - my $self = shift; - return $self unless $self->{fixtype}; - $self = $self->copy; - $self->{fixtype} = 0; - foreach (@{$self->{list}}) { - $_->{a} = 0 + $_->{a}; - $_->{b} = 0 + $_->{b}; - } - return $self; -} - -sub _no_cleanup { $_[0] } # obsolete - -sub first { - my $self = $_[0]; - if (exists $self->{first} ) { - return wantarray ? @{$self->{first}} : $self->{first}[0]; - } - unless ( @{$self->{list}} ) { - return wantarray ? (undef, 0) : undef; - } - my $first = $self->new( $self->{list}[0] ); - return $first unless wantarray; - my $res = $self->new; - push @{$res->{list}}, @{$self->{list}}[1 .. $#{$self->{list}}]; - return @{$self->{first}} = ($first) if $res->is_null; - return @{$self->{first}} = ($first, $res); -} - -sub last { - my $self = $_[0]; - if (exists $self->{last} ) { - return wantarray ? @{$self->{last}} : $self->{last}[0]; - } - unless ( @{$self->{list}} ) { - return wantarray ? (undef, 0) : undef; - } - my $last = $self->new( $self->{list}[-1] ); - return $last unless wantarray; - my $res = $self->new; - push @{$res->{list}}, @{$self->{list}}[0 .. $#{$self->{list}}-1]; - return @{$self->{last}} = ($last) if $res->is_null; - return @{$self->{last}} = ($last, $res); -} - -sub is_null { - @{$_[0]->{list}} ? 0 : 1; -} - -sub is_empty { - $_[0]->is_null; -} - -sub is_nonempty { - ! $_[0]->is_null; -} - -sub is_span { - ( $#{$_[0]->{list}} == 0 ) ? 1 : 0; -} - -sub is_singleton { - ( $#{$_[0]->{list}} == 0 && - $_[0]->{list}[0]{a} == $_[0]->{list}[0]{b} ) ? 1 : 0; -} - -sub is_subset { - my $a1 = shift; - my $b1; - if (ref ($_[0]) eq ref($a1) ) { - $b1 = shift; - } - else { - $b1 = $a1->new(@_); - } - return $b1->contains( $a1 ); -} - -sub is_proper_subset { - my $a1 = shift; - my $b1; - if (ref ($_[0]) eq ref($a1) ) { - $b1 = shift; - } - else { - $b1 = $a1->new(@_); - } - - my $contains = $b1->contains( $a1 ); - return $contains unless $contains; - - my $equal = ( $a1 == $b1 ); - return $equal if !defined $equal || $equal; - - return 1; -} - -sub is_disjoint { - my $intersects = shift->intersects( @_ ); - return ! $intersects if defined $intersects; - return $intersects; -} - -sub iterate { - # TODO: options 'no-sort', 'no-merge', 'keep-null' ... - my $a1 = shift; - my $iterate = $a1->empty_set(); - my (@tmp, $ia); - my $subroutine = shift; - foreach $ia (0 .. $#{$a1->{list}}) { - @tmp = $subroutine->( $a1->new($a1->{list}[$ia]), @_ ); - $iterate = $iterate->union(@tmp) if @tmp; - } - return $iterate; -} - - -sub intersection { - my $a1 = shift; - my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_); - return _intersection ( 'intersection', $a1, $b1 ); -} - -sub intersects { - my $a1 = shift; - my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_); - return _intersection ( 'intersects', $a1, $b1 ); -} - -sub intersected_spans { - my $a1 = shift; - my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_); - return _intersection ( 'intersected_spans', $a1, $b1 ); -} - - -sub _intersection { - my ( $op, $a1, $b1 ) = @_; - - my $ia; - my ( $a0, $na ) = ( 0, $#{$a1->{list}} ); - my ( $tmp1, $tmp1a, $tmp2a, $tmp1b, $tmp2b, $i_beg, $i_end, $open_beg, $open_end ); - my ( $cmp1, $cmp2 ); - my @a; - - # for-loop optimization (makes little difference) - # This was kept for backward compatibility with Date::Set tests - my $self = $a1; - if ($na < $#{ $b1->{list} }) - { - $na = $#{ $b1->{list} }; - ($a1, $b1) = ($b1, $a1); - } - # --- - - B: foreach my $tmp2 ( @{ $b1->{list} } ) { - $tmp2a = $tmp2->{a}; - $tmp2b = $tmp2->{b}; - A: foreach $ia ($a0 .. $na) { - $tmp1 = $a1->{list}[$ia]; - $tmp1b = $tmp1->{b}; - - if ($tmp1b < $tmp2a) { - $a0++; - next A; - } - $tmp1a = $tmp1->{a}; - if ($tmp1a > $tmp2b) { - next B; - } - - $cmp1 = $tmp1a <=> $tmp2a; - if ( $cmp1 < 0 ) { - $tmp1a = $tmp2a; - $open_beg = $tmp2->{open_begin}; - } - elsif ( $cmp1 ) { - $open_beg = $tmp1->{open_begin}; - } - else { - $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin}; - } - - $cmp2 = $tmp1b <=> $tmp2b; - if ( $cmp2 > 0 ) { - $tmp1b = $tmp2b; - $open_end = $tmp2->{open_end}; - } - elsif ( $cmp2 ) { - $open_end = $tmp1->{open_end}; - } - else { - $open_end = $tmp1->{open_end} || $tmp2->{open_end}; - } - - if ( ( $tmp1a <= $tmp1b ) && - ( ($tmp1a != $tmp1b) || - (!$open_beg and !$open_end) || - ($tmp1a == $inf) || # XXX - ($tmp1a == $neg_inf) - ) - ) - { - if ( $op eq 'intersection' ) - { - push @a, { - a => $tmp1a, b => $tmp1b, - open_begin => $open_beg, open_end => $open_end } ; - } - if ( $op eq 'intersects' ) - { - return 1; - } - if ( $op eq 'intersected_spans' ) - { - push @a, $tmp1; - $a0++; - next A; - } - } - } - } - - return 0 if $op eq 'intersects'; - - my $intersection = $self->new(); - $intersection->{list} = \@a; - return $intersection; -} - - -sub complement { - my $self = shift; - if (@_) { - my $a1; - if (ref ($_[0]) eq ref($self) ) { - $a1 = shift; - } - else { - $a1 = $self->new(@_); - } - return $self->intersection( $a1->complement ); - } - - unless ( @{$self->{list}} ) { - return $self->universal_set; - } - my $complement = $self->empty_set(); - @{$complement->{list}} = _simple_complement($self->{list}[0]); - - my $tmp = $self->empty_set(); - foreach my $ia (1 .. $#{$self->{list}}) { - @{$tmp->{list}} = _simple_complement($self->{list}[$ia]); - $complement = $complement->intersection($tmp); - } - return $complement; -} - - -sub until { - my $a1 = shift; - my $b1; - if (ref ($_[0]) eq ref($a1) ) { - $b1 = shift; - } - else { - $b1 = $a1->new(@_); - } - my @b1_min = $b1->min_a; - my @a1_max = $a1->max_a; - - unless (defined $b1_min[0]) { - return $a1->until($inf); - } - unless (defined $a1_max[0]) { - return $a1->new(-$inf)->until($b1); - } - - my ($ia, $ib, $begin, $end); - $ia = 0; - $ib = 0; - - my $u = $a1->new; - my $last = -$inf; - while ( ($ia <= $#{$a1->{list}}) && ($ib <= $#{$b1->{list}})) { - $begin = $a1->{list}[$ia]{a}; - $end = $b1->{list}[$ib]{b}; - if ( $end <= $begin ) { - push @{$u->{list}}, { - a => $last , - b => $end , - open_begin => 0 , - open_end => 1 }; - $ib++; - $last = $end; - next; - } - push @{$u->{list}}, { - a => $begin , - b => $end , - open_begin => 0 , - open_end => 1 }; - $ib++; - $ia++; - $last = $end; - } - if ($ia <= $#{$a1->{list}} && - $a1->{list}[$ia]{a} >= $last ) - { - push @{$u->{list}}, { - a => $a1->{list}[$ia]{a} , - b => $inf , - open_begin => 0 , - open_end => 1 }; - } - return $u; -} - -sub start_set { - return $_[0]->iterate( - sub { $_[0]->min } - ); -} - - -sub end_set { - return $_[0]->iterate( - sub { $_[0]->max } - ); -} - -sub union { - my $a1 = shift; - my $b1; - if (ref ($_[0]) eq ref($a1) ) { - $b1 = shift; - } - else { - $b1 = $a1->new(@_); - } - # test for union with empty set - if ( $#{ $a1->{list} } < 0 ) { - return $b1; - } - if ( $#{ $b1->{list} } < 0 ) { - return $a1; - } - my @b1_min = $b1->min_a; - my @a1_max = $a1->max_a; - unless (defined $b1_min[0]) { - return $a1; - } - unless (defined $a1_max[0]) { - return $b1; - } - my ($ia, $ib); - $ia = 0; - $ib = 0; - - # size+order matters on speed - $a1 = $a1->new($a1); # don't modify ourselves - my $b_list = $b1->{list}; - # -- frequent case - $b1 is after $a1 - if ($b1_min[0] > $a1_max[0]) { - push @{$a1->{list}}, @$b_list; - return $a1; - } - - my @tmp; - my $is_real = !$a1->tolerance && !$b1->tolerance; - B: foreach $ib ($ib .. $#{$b_list}) { - foreach $ia ($ia .. $#{$a1->{list}}) { - @tmp = _simple_union($a1->{list}[$ia], $b_list->[$ib], $a1->{tolerance}); - if ($#tmp == 0) { - $a1->{list}[$ia] = $tmp[0]; - - while (1) { - last if $ia >= $#{$a1->{list}}; - last unless _simple_intersects ( $a1->{list}[$ia], $a1->{list}[$ia + 1] ) - || $is_real - && $a1->{list}[$ia]{b} == $a1->{list}[$ia + 1]{a}; - @tmp = _simple_union($a1->{list}[$ia], $a1->{list}[$ia + 1], $a1->{tolerance}); - last unless @tmp == 1; - $a1->{list}[$ia] = $tmp[0]; - splice( @{$a1->{list}}, $ia + 1, 1 ); - } - - next B; - } - if ($a1->{list}[$ia]{a} >= $b_list->[$ib]{a}) { - splice (@{$a1->{list}}, $ia, 0, $b_list->[$ib]); - next B; - } - } - push @{$a1->{list}}, $b_list->[$ib]; - } - return $a1; -} - - -# there are some ways to process 'contains': -# A CONTAINS B IF A == ( A UNION B ) -# - faster -# A CONTAINS B IF B == ( A INTERSECTION B ) -# - can backtrack = works for unbounded sets -sub contains { - my $a1 = shift; - my $b1 = $a1->union(@_); - return ($b1 == $a1) ? 1 : 0; -} - - -sub copy { - my $self = shift; - my $copy = $self->empty_set(); - ## return $copy unless ref($self); # constructor! - foreach my $key (keys %{$self}) { - if ( ref( $self->{$key} ) eq 'ARRAY' ) { - @{ $copy->{$key} } = @{ $self->{$key} }; - } - else { - $copy->{$key} = $self->{$key}; - } - } - return $copy; -} - -*clone = \© - - -sub new { - my $class = shift; - my $self; - if ( ref $class ) { - $self = bless { - list => [], - tolerance => $class->{tolerance}, - type => $class->{type}, - fixtype => $class->{fixtype}, - }, ref($class); - } - else { - $self = bless { - list => [], - tolerance => $tolerance ? $tolerance : 0, - type => $class->type, - fixtype => $fixtype ? $fixtype : 0, - }, $class; - } - my ($tmp, $tmp2, $ref); - while (@_) { - $tmp = shift; - $ref = ref($tmp); - if ($ref) { - if ($ref eq 'ARRAY') { - # allows arrays of arrays - $tmp = $class->new(@$tmp); # call new() recursively - push @{ $self->{list} }, @{$tmp->{list}}; - next; - } - if ($ref eq 'HASH') { - push @{ $self->{list} }, $tmp; - next; - } - if ($tmp->isa(__PACKAGE__)) { - push @{ $self->{list} }, @{$tmp->{list}}; - next; - } - } - if ( @_ ) { - $tmp2 = shift - } - else { - $tmp2 = $tmp - } - push @{ $self->{list} }, _simple_new($tmp,$tmp2, $self->{type} ) - } - $self; -} - -sub empty_set { - $_[0]->new; -} - -sub universal_set { - $_[0]->new( NEG_INFINITY, INFINITY ); -} - -*minus = \∁ - -*difference = \∁ - -sub symmetric_difference { - my $a1 = shift; - my $b1; - if (ref ($_[0]) eq ref($a1) ) { - $b1 = shift; - } - else { - $b1 = $a1->new(@_); - } - - return $a1->complement( $b1 )->union( - $b1->complement( $a1 ) ); -} - -*simmetric_difference = \&symmetric_difference; # bugfix - -sub min { - ($_[0]->min_a)[0]; -} - -sub min_a { - my $self = $_[0]; - return @{$self->{min}} if exists $self->{min}; - return @{$self->{min}} = (undef, 0) unless @{$self->{list}}; - my $tmp = $self->{list}[0]{a}; - my $tmp2 = $self->{list}[0]{open_begin} || 0; - if ($tmp2 && $self->{tolerance}) { - $tmp2 = 0; - $tmp += $self->{tolerance}; - } - return @{$self->{min}} = ($tmp, $tmp2); -}; - -sub max { - ($_[0]->max_a)[0]; -} - -sub max_a { - my $self = $_[0]; - return @{$self->{max}} if exists $self->{max}; - return @{$self->{max}} = (undef, 0) unless @{$self->{list}}; - my $tmp = $self->{list}[-1]{b}; - my $tmp2 = $self->{list}[-1]{open_end} || 0; - if ($tmp2 && $self->{tolerance}) { - $tmp2 = 0; - $tmp -= $self->{tolerance}; - } - return @{$self->{max}} = ($tmp, $tmp2); -}; - -sub count { - 1 + $#{$_[0]->{list}}; -} - -sub size { - my $self = $_[0]; - my $size; - foreach( @{$self->{list}} ) { - if ( $size ) { - $size += $_->{b} - $_->{a}; - } - else { - $size = $_->{b} - $_->{a}; - } - if ( $self->{tolerance} ) { - $size += $self->{tolerance} unless $_->{open_end}; - $size -= $self->{tolerance} if $_->{open_begin}; - $size -= $self->{tolerance} if $_->{open_end}; - } - } - return $size; -}; - -sub span { - my $self = $_[0]; - my @max = $self->max_a; - my @min = $self->min_a; - return undef unless defined $min[0] && defined $max[0]; - my $a1 = $self->new($min[0], $max[0]); - $a1->{list}[0]{open_end} = $max[1]; - $a1->{list}[0]{open_begin} = $min[1]; - return $a1; -}; - -sub spaceship { - my ($tmp1, $tmp2, $inverted) = @_; - if ($inverted) { - ($tmp2, $tmp1) = ($tmp1, $tmp2); - } - foreach(0 .. $#{$tmp1->{list}}) { - my $this = $tmp1->{list}[$_]; - if ($_ > $#{ $tmp2->{list} } ) { - return 1; - } - my $other = $tmp2->{list}[$_]; - my $cmp = _simple_spaceship($this, $other); - return $cmp if $cmp; # this != $other; - } - return $#{ $tmp1->{list} } == $#{ $tmp2->{list} } ? 0 : -1; -} - -sub tolerance { - my $self = shift; - my $tmp = pop; - if (ref($self)) { - # local - return $self->{tolerance} unless defined $tmp; - $self = $self->copy; - $self->{tolerance} = $tmp; - delete $self->{max}; # tolerance may change "max" - - $_ = 1; - my @tmp; - while ( $_ <= $#{$self->{list}} ) { - @tmp = Set::Infinite::Basic::_simple_union($self->{list}->[$_], - $self->{list}->[$_ - 1], - $self->{tolerance}); - if ($#tmp == 0) { - $self->{list}->[$_ - 1] = $tmp[0]; - splice (@{$self->{list}}, $_, 1); - } - else { - $_ ++; - } - } - - return $self; - } - # global - $tolerance = $tmp if defined($tmp); - return $tolerance; -} - -sub integer { - $_[0]->tolerance (1); -} - -sub real { - $_[0]->tolerance (0); -} - -sub as_string { - my $self = shift; - return $self->separators(6) . - join( $self->separators(5), - map { $self->_simple_as_string($_) } @{$self->{list}} ) . - $self->separators(7),; -} - - -sub DESTROY {} - -1; - -__END__ - -=head1 NAME - -Set::Infinite::Basic - Sets of intervals -6 -=head1 SYNOPSIS - - use Set::Infinite::Basic; - - $set = Set::Infinite::Basic->new(1,2); # [1..2] - print $set->union(5,6); # [1..2],[5..6] - -=head1 DESCRIPTION - -Set::Infinite::Basic is a Set Theory module for infinite sets. - -It works on reals, integers, and objects. - -This module does not support recurrences. Recurrences are implemented in Set::Infinite. - -=head1 METHODS - -=head2 empty_set - -Creates an empty_set. - -If called from an existing set, the empty set inherits -the "type" and "density" characteristics. - -=head2 universal_set - -Creates a set containing "all" possible elements. - -If called from an existing set, the universal set inherits -the "type" and "density" characteristics. - -=head2 until - -Extends a set until another: - - 0,5,7 -> until 2,6,10 - -gives - - [0..2), [5..6), [7..10) - -Note: this function is still experimental. - -=head2 copy - -=head2 clone - -Makes a new object from the object's data. - -=head2 Mode functions: - - $set = $set->real; - - $set = $set->integer; - -=head2 Logic functions: - - $logic = $set->intersects($b); - - $logic = $set->contains($b); - - $logic = $set->is_null; # also called "is_empty" - -=head2 Set functions: - - $set = $set->union($b); - - $set = $set->intersection($b); - - $set = $set->complement; - $set = $set->complement($b); # can also be called "minus" or "difference" - - $set = $set->symmetric_difference( $b ); - - $set = $set->span; - - result is (min .. max) - -=head2 Scalar functions: - - $i = $set->min; - - $i = $set->max; - - $i = $set->size; - - $i = $set->count; # number of spans - -=head2 Overloaded Perl functions: - - print - - sort, <=> - -=head2 Global functions: - - separators(@i) - - chooses the interval separators. - - default are [ ] ( ) '..' ','. - - INFINITY - - returns an 'Infinity' number. - - NEG_INFINITY - - returns a '-Infinity' number. - - iterate ( sub { } ) - - Iterates over a subroutine. - Returns the union of partial results. - - first - - In scalar context returns the first interval of a set. - - In list context returns the first interval of a set, and the - 'tail'. - - Works in unbounded sets - - type($i) - - chooses an object data type. - - default is none (a normal perl SCALAR). - - examples: - - type('Math::BigFloat'); - type('Math::BigInt'); - type('Set::Infinite::Date'); - See notes on Set::Infinite::Date below. - - tolerance(0) defaults to real sets (default) - tolerance(1) defaults to integer sets - - real defaults to real sets (default) - - integer defaults to integer sets - -=head2 Internal functions: - - $set->fixtype; - - $set->numeric; - -=head1 CAVEATS - - $set = Set::Infinite->new(10,1); - Will be interpreted as [1..10] - - $set = Set::Infinite->new(1,2,3,4); - Will be interpreted as [1..2],[3..4] instead of [1,2,3,4]. - You probably want ->new([1],[2],[3],[4]) instead, - or maybe ->new(1,4) - - $set = Set::Infinite->new(1..3); - Will be interpreted as [1..2],3 instead of [1,2,3]. - You probably want ->new(1,3) instead. - -=head1 INTERNALS - -The internal representation of a I is a hash: - - { a => start of span, - b => end of span, - open_begin => '0' the span starts in 'a' - '1' the span starts after 'a' - open_end => '0' the span ends in 'b' - '1' the span ends before 'b' - } - -For example, this set: - - [100..200),300,(400..infinity) - -is represented by the array of hashes: - - list => [ - { a => 100, b => 200, open_begin => 0, open_end => 1 }, - { a => 300, b => 300, open_begin => 0, open_end => 0 }, - { a => 400, b => infinity, open_begin => 0, open_end => 1 }, - ] - -The I of a set is stored in the C variable: - - tolerance => 0; # the set is made of real numbers. - - tolerance => 1; # the set is made of integers. - -The C variable stores the I of objects that will be stored in the set. - - type => 'DateTime'; # this is a set of DateTime objects - -The I value is generated by Perl, when it finds a numerical overflow: - - $inf = 100**100**100; - -=head1 SEE ALSO - - Set::Infinite - -=head1 AUTHOR - - Flavio S. Glock - -=cut -