--- /dev/null
+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<span> 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<density> of a set is stored in the C<tolerance> variable:
+
+ tolerance => 0; # the set is made of real numbers.
+
+ tolerance => 1; # the set is made of integers.
+
+The C<type> variable stores the I<class> of objects that will be stored in the set.
+
+ type => 'DateTime'; # this is a set of DateTime objects
+
+The I<infinity> 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 <fglock@gmail.com>
+
+=cut
+
projects / kivitendo-erp.git / blobdiff