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