modules/fallback/Set/Infinite/Basic.pm

   1 package Set::Infinite::Basic;
   2
   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.
   6
   7 require 5.005_03;
   8 use strict;
   9
  10 require Exporter;
  11 use Carp;
  12 use Data::Dumper;
  13 use vars qw( @ISA @EXPORT_OK @EXPORT );
  14 use vars qw( $Type $tolerance $fixtype $inf $minus_inf @Separators $neg_inf );
  15
  16 @ISA = qw(Exporter);
  17 @EXPORT_OK = qw( INFINITY NEG_INFINITY );
  18 @EXPORT = qw();
  19
  20 use constant INFINITY => 100**100**100;
  21 use constant NEG_INFINITY => - INFINITY;
  22
  23 $inf       = INFINITY;
  24 $minus_inf = $neg_inf = NEG_INFINITY;
  25
  26 use overload
  27     '<=>' => \&spaceship,
  28     qw("" as_string),
  29 ;
  30
  31
  32 # TODO: make this an object _and_ class method
  33 # TODO: POD
  34 sub separators {
  35     shift;
  36     return $Separators[ $_[0] ] if $#_ == 0;
  37     @Separators = @_ if @_;
  38     return @Separators;
  39 }
  40
  41 BEGIN {
  42     __PACKAGE__->separators (
  43         '[', ']',    # a closed interval
  44         '(', ')',    # an open interval
  45         '..',        # number separator
  46         ',',         # list separator
  47         '', '',      # set delimiter  '{' '}'
  48     );
  49     # global defaults for object private vars
  50     $Type = undef;
  51     $tolerance = 0;
  52     $fixtype = 1;
  53 }
  54
  55 # _simple_* set of internal methods: basic processing of "spans"
  56
  57 sub _simple_intersects {
  58     my $tmp1 = $_[0];
  59     my $tmp2 = $_[1];
  60     my ($i_beg, $i_end, $open_beg, $open_end);
  61     my $cmp = $tmp1->{a} <=> $tmp2->{a};
  62     if ($cmp < 0) {
  63         $i_beg       = $tmp2->{a};
  64         $open_beg    = $tmp2->{open_begin};
  65     }
  66     elsif ($cmp > 0) {
  67         $i_beg       = $tmp1->{a};
  68         $open_beg    = $tmp1->{open_begin};
  69     }
  70     else {
  71         $i_beg       = $tmp1->{a};
  72         $open_beg    = $tmp1->{open_begin} || $tmp2->{open_begin};
  73     }
  74     $cmp = $tmp1->{b} <=> $tmp2->{b};
  75     if ($cmp > 0) {
  76         $i_end       = $tmp2->{b};
  77         $open_end    = $tmp2->{open_end};
  78     }
  79     elsif ($cmp < 0) {
  80         $i_end       = $tmp1->{b};
  81         $open_end    = $tmp1->{open_end};
  82     }
  83     else {
  84         $i_end       = $tmp1->{b};
  85         $open_end    = ($tmp1->{open_end} || $tmp2->{open_end});
  86     }
  87     $cmp = $i_beg <=> $i_end;
  88     return 0 if
  89         ( $cmp > 0 ) ||
  90         ( ($cmp == 0) && ($open_beg || $open_end) ) ;
  91     return 1;
  92 }
  93
  94
  95 sub _simple_complement {
  96     my $self = $_[0];
  97     if ($self->{b} == $inf) {
  98         return if $self->{a} == $neg_inf;
  99         return { a => $neg_inf,
 100                  b => $self->{a},
 101                  open_begin => 1,
 102                  open_end => ! $self->{open_begin} };
 103     }
 104     if ($self->{a} == $neg_inf) {
 105         return { a => $self->{b},
 106                  b => $inf,
 107                  open_begin => ! $self->{open_end},
 108                  open_end => 1 };
 109     }
 110     ( { a => $neg_inf,
 111         b => $self->{a},
 112         open_begin => 1,
 113         open_end => ! $self->{open_begin}
 114       },
 115       { a => $self->{b},
 116         b => $inf,
 117         open_begin => ! $self->{open_end},
 118         open_end => 1
 119       }
 120     );
 121 }
 122
 123 sub _simple_union {
 124     my ($tmp2, $tmp1, $tolerance) = @_;
 125     my $cmp;
 126     if ($tolerance) {
 127         # "integer"
 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 ;
 132         # open_end touching?
 133         if ((($tmp1->{b}+$tmp1->{b}) + $b1_open ) <
 134             (($tmp2->{a}+$tmp2->{a}) - $a2_open)) {
 135             # self disjuncts b
 136             return ( $tmp1, $tmp2 );
 137         }
 138         if ((($tmp1->{a}+$tmp1->{a}) - $a1_open ) >
 139             (($tmp2->{b}+$tmp2->{b}) + $b2_open)) {
 140             # self disjuncts b
 141             return ( $tmp2, $tmp1 );
 142         }
 143     }
 144     else {
 145         # "real"
 146         $cmp = $tmp1->{b} <=> $tmp2->{a};
 147         if ( $cmp < 0 ||
 148              ( $cmp == 0 && $tmp1->{open_end} && $tmp2->{open_begin} ) ) {
 149             return ( $tmp1, $tmp2 );
 150         }
 151         $cmp = $tmp1->{a} <=> $tmp2->{b};
 152         if ( $cmp > 0 ||
 153              ( $cmp == 0 && $tmp2->{open_end} && $tmp1->{open_begin} ) ) {
 154             return ( $tmp2, $tmp1 );
 155         }
 156     }
 157
 158     my $tmp;
 159     $cmp = $tmp1->{a} <=> $tmp2->{a};
 160     if ($cmp > 0) {
 161         $tmp->{a} = $tmp2->{a};
 162         $tmp->{open_begin} = $tmp2->{open_begin};
 163     }
 164     elsif ($cmp == 0) {
 165         $tmp->{a} = $tmp1->{a};
 166         $tmp->{open_begin} = $tmp1->{open_begin} ? $tmp2->{open_begin} : 0;
 167     }
 168     else {
 169         $tmp->{a} = $tmp1->{a};
 170         $tmp->{open_begin} = $tmp1->{open_begin};
 171     }
 172
 173     $cmp = $tmp1->{b} <=> $tmp2->{b};
 174     if ($cmp < 0) {
 175         $tmp->{b} = $tmp2->{b};
 176         $tmp->{open_end} = $tmp2->{open_end};
 177     }
 178     elsif ($cmp == 0) {
 179         $tmp->{b} = $tmp1->{b};
 180         $tmp->{open_end} = $tmp1->{open_end} ? $tmp2->{open_end} : 0;
 181     }
 182     else {
 183         $tmp->{b} = $tmp1->{b};
 184         $tmp->{open_end} = $tmp1->{open_end};
 185     }
 186     return $tmp;
 187 }
 188
 189
 190 sub _simple_spaceship {
 191     my ($tmp1, $tmp2, $inverted) = @_;
 192     my $cmp;
 193     if ($inverted) {
 194         $cmp = $tmp2->{a} <=> $tmp1->{a};
 195         return $cmp if $cmp;
 196         $cmp = $tmp1->{open_begin} <=> $tmp2->{open_begin};
 197         return $cmp if $cmp;
 198         $cmp = $tmp2->{b} <=> $tmp1->{b};
 199         return $cmp if $cmp;
 200         return $tmp1->{open_end} <=> $tmp2->{open_end};
 201     }
 202     $cmp = $tmp1->{a} <=> $tmp2->{a};
 203     return $cmp if $cmp;
 204     $cmp = $tmp2->{open_begin} <=> $tmp1->{open_begin};
 205     return $cmp if $cmp;
 206     $cmp = $tmp1->{b} <=> $tmp2->{b};
 207     return $cmp if $cmp;
 208     return $tmp2->{open_end} <=> $tmp1->{open_end};
 209 }
 210
 211
 212 sub _simple_new {
 213     my ($tmp, $tmp2, $type) = @_;
 214     if ($type) {
 215         if ( ref($tmp) ne $type ) {
 216             $tmp = new $type $tmp;
 217         }
 218         if ( ref($tmp2) ne $type ) {
 219             $tmp2 = new $type $tmp2;
 220         }
 221     }
 222     if ($tmp > $tmp2) {
 223         carp "Invalid interval specification: start value is after end";
 224         # ($tmp, $tmp2) = ($tmp2, $tmp);
 225     }
 226     return { a => $tmp , b => $tmp2 , open_begin => 0 , open_end => 0 };
 227 }
 228
 229
 230 sub _simple_as_string {
 231     my $set = shift;
 232     my $self = $_[0];
 233     my $s;
 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' );
 239     $tmp1 = "$tmp1";
 240     my $tmp2 = $self->{b};
 241     $tmp2 = $tmp2->datetime if UNIVERSAL::can( $tmp2, 'datetime' );
 242     $tmp2 = "$tmp2";
 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);
 247     return $s;
 248 }
 249
 250 # end of "_simple_" methods
 251
 252
 253 sub type {
 254     my $self = shift;
 255     unless (@_) {
 256         return ref($self) ? $self->{type} : $Type;
 257     }
 258     my $tmp_type = shift;
 259     eval "use " . $tmp_type;
 260     carp "Warning: can't start $tmp_type : $@" if $@;
 261     if (ref($self))  {
 262         $self->{type} = $tmp_type;
 263         return $self;
 264     }
 265     else {
 266         $Type = $tmp_type;
 267         return $Type;
 268     }
 269 }
 270
 271 sub list {
 272     my $self = shift;
 273     my @b = ();
 274     foreach (@{$self->{list}}) {
 275         push @b, $self->new($_);
 276     }
 277     return @b;
 278 }
 279
 280 sub fixtype {
 281     my $self = shift;
 282     $self = $self->copy;
 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;
 289     }
 290     return $self;
 291 }
 292
 293 sub numeric {
 294     my $self = shift;
 295     return $self unless $self->{fixtype};
 296     $self = $self->copy;
 297     $self->{fixtype} = 0;
 298     foreach (@{$self->{list}}) {
 299         $_->{a} = 0 + $_->{a};
 300         $_->{b} = 0 + $_->{b};
 301     }
 302     return $self;
 303 }
 304
 305 sub _no_cleanup { $_[0] }   # obsolete
 306
 307 sub first {
 308     my $self = $_[0];
 309     if (exists $self->{first} ) {
 310         return wantarray ? @{$self->{first}} : $self->{first}[0];
 311     }
 312     unless ( @{$self->{list}} ) {
 313         return wantarray ? (undef, 0) : undef;
 314     }
 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);
 321 }
 322
 323 sub last {
 324     my $self = $_[0];
 325     if (exists $self->{last} ) {
 326         return wantarray ? @{$self->{last}} : $self->{last}[0];
 327     }
 328     unless ( @{$self->{list}} ) {
 329         return wantarray ? (undef, 0) : undef;
 330     }
 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);
 337 }
 338
 339 sub is_null {
 340     @{$_[0]->{list}} ? 0 : 1;
 341 }
 342
 343 sub is_empty {
 344     $_[0]->is_null;
 345 }
 346
 347 sub is_nonempty {
 348     ! $_[0]->is_null;
 349 }
 350
 351 sub is_span {
 352     ( $#{$_[0]->{list}} == 0 ) ? 1 : 0;
 353 }
 354
 355 sub is_singleton {
 356     ( $#{$_[0]->{list}} == 0 &&
 357       $_[0]->{list}[0]{a} == $_[0]->{list}[0]{b} ) ? 1 : 0;
 358 }
 359
 360 sub is_subset {
 361     my $a1 = shift;
 362     my $b1;
 363     if (ref ($_[0]) eq ref($a1) ) {
 364         $b1 = shift;
 365     }
 366     else {
 367         $b1 = $a1->new(@_);
 368     }
 369     return $b1->contains( $a1 );
 370 }
 371
 372 sub is_proper_subset {
 373     my $a1 = shift;
 374     my $b1;
 375     if (ref ($_[0]) eq ref($a1) ) {
 376         $b1 = shift;
 377     }
 378     else {
 379         $b1 = $a1->new(@_);
 380     }
 381
 382     my $contains = $b1->contains( $a1 );
 383     return $contains unless $contains;
 384
 385     my $equal = ( $a1 == $b1 );
 386     return $equal if !defined $equal || $equal;
 387
 388     return 1;
 389 }
 390
 391 sub is_disjoint {
 392     my $intersects = shift->intersects( @_ );
 393     return ! $intersects if defined $intersects;
 394     return $intersects;
 395 }
 396
 397 sub iterate {
 398     # TODO: options 'no-sort', 'no-merge', 'keep-null' ...
 399     my $a1 = shift;
 400     my $iterate = $a1->empty_set();
 401     my (@tmp, $ia);
 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;
 406     }
 407     return $iterate;
 408 }
 409
 410
 411 sub intersection {
 412     my $a1 = shift;
 413     my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
 414     return _intersection ( 'intersection', $a1, $b1 );
 415 }
 416
 417 sub intersects {
 418     my $a1 = shift;
 419     my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
 420     return _intersection ( 'intersects', $a1, $b1 );
 421 }
 422
 423 sub intersected_spans {
 424     my $a1 = shift;
 425     my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
 426     return _intersection ( 'intersected_spans', $a1, $b1 );
 427 }
 428
 429
 430 sub _intersection {
 431     my ( $op, $a1, $b1 ) = @_;
 432
 433     my $ia;
 434     my ( $a0, $na ) = ( 0, $#{$a1->{list}} );
 435     my ( $tmp1, $tmp1a, $tmp2a, $tmp1b, $tmp2b, $i_beg, $i_end, $open_beg, $open_end );
 436     my ( $cmp1, $cmp2 );
 437     my @a;
 438
 439     # for-loop optimization (makes little difference)
 440     # This was kept for backward compatibility with Date::Set tests
 441     my $self = $a1;
 442     if ($na < $#{ $b1->{list} })
 443     {
 444         $na = $#{ $b1->{list} };
 445         ($a1, $b1) = ($b1, $a1);
 446     }
 447     # ---
 448
 449     B: foreach my $tmp2 ( @{ $b1->{list} } ) {
 450         $tmp2a = $tmp2->{a};
 451         $tmp2b = $tmp2->{b};
 452         A: foreach $ia ($a0 .. $na) {
 453             $tmp1 = $a1->{list}[$ia];
 454             $tmp1b = $tmp1->{b};
 455
 456             if ($tmp1b < $tmp2a) {
 457                 $a0++;
 458                 next A;
 459             }
 460             $tmp1a = $tmp1->{a};
 461             if ($tmp1a > $tmp2b) {
 462                 next B;
 463             }
 464
 465             $cmp1 = $tmp1a <=> $tmp2a;
 466             if ( $cmp1 < 0 ) {
 467                 $tmp1a        = $tmp2a;
 468                 $open_beg     = $tmp2->{open_begin};
 469             }
 470             elsif ( $cmp1 ) {
 471                 $open_beg     = $tmp1->{open_begin};
 472             }
 473             else {
 474                 $open_beg     = $tmp1->{open_begin} || $tmp2->{open_begin};
 475             }
 476
 477             $cmp2 = $tmp1b <=> $tmp2b;
 478             if ( $cmp2 > 0 ) {
 479                 $tmp1b        = $tmp2b;
 480                 $open_end     = $tmp2->{open_end};
 481             }
 482             elsif ( $cmp2 ) {
 483                 $open_end     = $tmp1->{open_end};
 484             }
 485             else {
 486                 $open_end     = $tmp1->{open_end} || $tmp2->{open_end};
 487             }
 488
 489             if ( ( $tmp1a <= $tmp1b ) &&
 490                  ( ($tmp1a != $tmp1b) ||
 491                    (!$open_beg and !$open_end) ||
 492                    ($tmp1a == $inf)   ||               # XXX
 493                    ($tmp1a == $neg_inf)
 494                  )
 495                )
 496             {
 497                 if ( $op eq 'intersection' )
 498                 {
 499                     push @a, {
 500                         a => $tmp1a, b => $tmp1b,
 501                         open_begin => $open_beg, open_end => $open_end } ;
 502                 }
 503                 if ( $op eq 'intersects' )
 504                 {
 505                     return 1;
 506                 }
 507                 if ( $op eq 'intersected_spans' )
 508                 {
 509                     push @a, $tmp1;
 510                     $a0++;
 511                     next A;
 512                 }
 513             }
 514         }
 515     }
 516
 517     return 0 if $op eq 'intersects';
 518
 519     my $intersection = $self->new();
 520     $intersection->{list} = \@a;
 521     return $intersection;
 522 }
 523
 524
 525 sub complement {
 526     my $self = shift;
 527     if (@_) {
 528         my $a1;
 529         if (ref ($_[0]) eq ref($self) ) {
 530             $a1 = shift;
 531         }
 532         else {
 533             $a1 = $self->new(@_);
 534         }
 535         return $self->intersection( $a1->complement );
 536     }
 537
 538     unless ( @{$self->{list}} ) {
 539         return $self->universal_set;
 540     }
 541     my $complement = $self->empty_set();
 542     @{$complement->{list}} = _simple_complement($self->{list}[0]);
 543
 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);
 548     }
 549     return $complement;
 550 }
 551
 552
 553 sub until {
 554     my $a1 = shift;
 555     my $b1;
 556     if (ref ($_[0]) eq ref($a1) ) {
 557         $b1 = shift;
 558     }
 559     else {
 560         $b1 = $a1->new(@_);
 561     }
 562     my @b1_min = $b1->min_a;
 563     my @a1_max = $a1->max_a;
 564
 565     unless (defined $b1_min[0]) {
 566         return $a1->until($inf);
 567     }
 568     unless (defined $a1_max[0]) {
 569         return $a1->new(-$inf)->until($b1);
 570     }
 571
 572     my ($ia, $ib, $begin, $end);
 573     $ia = 0;
 574     $ib = 0;
 575
 576     my $u = $a1->new;
 577     my $last = -$inf;
 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}}, {
 583                 a => $last ,
 584                 b => $end ,
 585                 open_begin => 0 ,
 586                 open_end => 1 };
 587             $ib++;
 588             $last = $end;
 589             next;
 590         }
 591         push @{$u->{list}}, {
 592             a => $begin ,
 593             b => $end ,
 594             open_begin => 0 ,
 595             open_end => 1 };
 596         $ib++;
 597         $ia++;
 598         $last = $end;
 599     }
 600     if ($ia <= $#{$a1->{list}}  &&
 601         $a1->{list}[$ia]{a} >= $last )
 602     {
 603         push @{$u->{list}}, {
 604             a => $a1->{list}[$ia]{a} ,
 605             b => $inf ,
 606             open_begin => 0 ,
 607             open_end => 1 };
 608     }
 609     return $u;
 610 }
 611
 612 sub start_set {
 613     return $_[0]->iterate(
 614         sub { $_[0]->min }
 615     );
 616 }
 617
 618
 619 sub end_set {
 620     return $_[0]->iterate(
 621         sub { $_[0]->max }
 622     );
 623 }
 624
 625 sub union {
 626     my $a1 = shift;
 627     my $b1;
 628     if (ref ($_[0]) eq ref($a1) ) {
 629         $b1 = shift;
 630     }
 631     else {
 632         $b1 = $a1->new(@_);
 633     }
 634     # test for union with empty set
 635     if ( $#{ $a1->{list} } < 0 ) {
 636         return $b1;
 637     }
 638     if ( $#{ $b1->{list} } < 0 ) {
 639         return $a1;
 640     }
 641     my @b1_min = $b1->min_a;
 642     my @a1_max = $a1->max_a;
 643     unless (defined $b1_min[0]) {
 644         return $a1;
 645     }
 646     unless (defined $a1_max[0]) {
 647         return $b1;
 648     }
 649     my ($ia, $ib);
 650     $ia = 0;
 651     $ib = 0;
 652
 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;
 659         return $a1;
 660     }
 661
 662     my @tmp;
 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});
 667             if ($#tmp == 0) {
 668                     $a1->{list}[$ia] = $tmp[0];
 669
 670                     while (1) {
 671                         last if $ia >= $#{$a1->{list}};
 672                         last unless _simple_intersects ( $a1->{list}[$ia], $a1->{list}[$ia + 1] )
 673                             ||    $is_real
 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 );
 679                     }
 680
 681                     next B;
 682             }
 683             if ($a1->{list}[$ia]{a} >= $b_list->[$ib]{a}) {
 684                 splice (@{$a1->{list}}, $ia, 0, $b_list->[$ib]);
 685                 next B;
 686             }
 687         }
 688         push @{$a1->{list}}, $b_list->[$ib];
 689     }
 690     return $a1;
 691 }
 692
 693
 694 # there are some ways to process 'contains':
 695 # A CONTAINS B IF A == ( A UNION B )
 696 #    - faster
 697 # A CONTAINS B IF B == ( A INTERSECTION B )
 698 #    - can backtrack = works for unbounded sets
 699 sub contains {
 700     my $a1 = shift;
 701     my $b1 = $a1->union(@_);
 702     return ($b1 == $a1) ? 1 : 0;
 703 }
 704
 705
 706 sub copy {
 707     my $self = shift;
 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} };
 713         }
 714         else {
 715             $copy->{$key} = $self->{$key};
 716         }
 717     }
 718     return $copy;
 719 }
 720
 721 *clone = \&copy;
 722
 723
 724 sub new {
 725     my $class = shift;
 726     my $self;
 727     if ( ref $class ) {
 728         $self = bless {
 729                     list      => [],
 730                     tolerance => $class->{tolerance},
 731                     type      => $class->{type},
 732                     fixtype   => $class->{fixtype},
 733                 }, ref($class);
 734     }
 735     else {
 736         $self = bless {
 737                     list      => [],
 738                     tolerance => $tolerance ? $tolerance : 0,
 739                     type      => $class->type,
 740                     fixtype   => $fixtype   ? $fixtype : 0,
 741                 }, $class;
 742     }
 743     my ($tmp, $tmp2, $ref);
 744     while (@_) {
 745         $tmp = shift;
 746         $ref = ref($tmp);
 747         if ($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}};
 752                 next;
 753             }
 754             if ($ref eq 'HASH') {
 755                 push @{ $self->{list} }, $tmp;
 756                 next;
 757             }
 758             if ($tmp->isa(__PACKAGE__)) {
 759                 push @{ $self->{list} }, @{$tmp->{list}};
 760                 next;
 761             }
 762         }
 763         if ( @_ ) {
 764             $tmp2 = shift
 765         }
 766         else {
 767             $tmp2 = $tmp
 768         }
 769         push @{ $self->{list} }, _simple_new($tmp,$tmp2, $self->{type} )
 770     }
 771     $self;
 772 }
 773
 774 sub empty_set {
 775     $_[0]->new;
 776 }
 777
 778 sub universal_set {
 779     $_[0]->new( NEG_INFINITY, INFINITY );
 780 }
 781
 782 *minus = \&complement;
 783
 784 *difference = \&complement;
 785
 786 sub symmetric_difference {
 787     my $a1 = shift;
 788     my $b1;
 789     if (ref ($_[0]) eq ref($a1) ) {
 790         $b1 = shift;
 791     }
 792     else {
 793         $b1 = $a1->new(@_);
 794     }
 795
 796     return $a1->complement( $b1 )->union(
 797            $b1->complement( $a1 ) );
 798 }
 799
 800 *simmetric_difference = \&symmetric_difference; # bugfix
 801
 802 sub min {
 803     ($_[0]->min_a)[0];
 804 }
 805
 806 sub min_a {
 807     my $self = $_[0];
 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}) {
 813         $tmp2 = 0;
 814         $tmp += $self->{tolerance};
 815     }
 816     return @{$self->{min}} = ($tmp, $tmp2);
 817 };
 818
 819 sub max {
 820     ($_[0]->max_a)[0];
 821 }
 822
 823 sub max_a {
 824     my $self = $_[0];
 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}) {
 830         $tmp2 = 0;
 831         $tmp -= $self->{tolerance};
 832     }
 833     return @{$self->{max}} = ($tmp, $tmp2);
 834 };
 835
 836 sub count {
 837     1 + $#{$_[0]->{list}};
 838 }
 839
 840 sub size {
 841     my $self = $_[0];
 842     my $size;
 843     foreach( @{$self->{list}} ) {
 844         if ( $size ) {
 845             $size += $_->{b} - $_->{a};
 846         }
 847         else {
 848             $size = $_->{b} - $_->{a};
 849         }
 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};
 854         }
 855     }
 856     return $size;
 857 };
 858
 859 sub span {
 860     my $self = $_[0];
 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];
 867     return $a1;
 868 };
 869
 870 sub spaceship {
 871     my ($tmp1, $tmp2, $inverted) = @_;
 872     if ($inverted) {
 873         ($tmp2, $tmp1) = ($tmp1, $tmp2);
 874     }
 875     foreach(0 .. $#{$tmp1->{list}}) {
 876         my $this  = $tmp1->{list}[$_];
 877         if ($_ > $#{ $tmp2->{list} } ) {
 878             return 1;
 879         }
 880         my $other = $tmp2->{list}[$_];
 881         my $cmp = _simple_spaceship($this, $other);
 882         return $cmp if $cmp;   # this != $other;
 883     }
 884     return $#{ $tmp1->{list} } == $#{ $tmp2->{list} } ? 0 : -1;
 885 }
 886
 887 sub tolerance {
 888     my $self = shift;
 889     my $tmp = pop;
 890     if (ref($self)) {
 891         # local
 892         return $self->{tolerance} unless defined $tmp;
 893         $self = $self->copy;
 894         $self->{tolerance} = $tmp;
 895         delete $self->{max};  # tolerance may change "max"
 896
 897         $_ = 1;
 898         my @tmp;
 899         while ( $_ <= $#{$self->{list}} ) {
 900             @tmp = Set::Infinite::Basic::_simple_union($self->{list}->[$_],
 901                 $self->{list}->[$_ - 1],
 902                 $self->{tolerance});
 903             if ($#tmp == 0) {
 904                 $self->{list}->[$_ - 1] = $tmp[0];
 905                 splice (@{$self->{list}}, $_, 1);
 906             }
 907             else {
 908                 $_ ++;
 909             }
 910         }
 911
 912         return $self;
 913     }
 914     # global
 915     $tolerance = $tmp if defined($tmp);
 916     return $tolerance;
 917 }
 918
 919 sub integer {
 920     $_[0]->tolerance (1);
 921 }
 922
 923 sub real {
 924     $_[0]->tolerance (0);
 925 }
 926
 927 sub as_string {
 928     my $self = shift;
 929     return $self->separators(6) .
 930            join( $self->separators(5),
 931                  map { $self->_simple_as_string($_) } @{$self->{list}} ) .
 932            $self->separators(7),;
 933 }
 934
 935
 936 sub DESTROY {}
 937
 938 1;
 939
 940 __END__
 941
 942 =head1 NAME
 943
 944 Set::Infinite::Basic - Sets of intervals
 945 6
 946 =head1 SYNOPSIS
 947
 948   use Set::Infinite::Basic;
 949
 950   $set = Set::Infinite::Basic->new(1,2);    # [1..2]
 951   print $set->union(5,6);            # [1..2],[5..6]
 952
 953 =head1 DESCRIPTION
 954
 955 Set::Infinite::Basic is a Set Theory module for infinite sets.
 956
 957 It works on reals, integers, and objects.
 958
 959 This module does not support recurrences. Recurrences are implemented in Set::Infinite.
 960
 961 =head1 METHODS
 962
 963 =head2 empty_set
 964
 965 Creates an empty_set.
 966
 967 If called from an existing set, the empty set inherits
 968 the "type" and "density" characteristics.
 969
 970 =head2 universal_set
 971
 972 Creates a set containing "all" possible elements.
 973
 974 If called from an existing set, the universal set inherits
 975 the "type" and "density" characteristics.
 976
 977 =head2 until
 978
 979 Extends a set until another:
 980
 981     0,5,7 -> until 2,6,10
 982
 983 gives
 984
 985     [0..2), [5..6), [7..10)
 986
 987 Note: this function is still experimental.
 988
 989 =head2 copy
 990
 991 =head2 clone
 992
 993 Makes a new object from the object's data.
 994
 995 =head2 Mode functions:
 996
 997     $set = $set->real;
 998
 999     $set = $set->integer;
1000
1001 =head2 Logic functions:
1002
1003     $logic = $set->intersects($b);
1004
1005     $logic = $set->contains($b);
1006
1007     $logic = $set->is_null;  # also called "is_empty"
1008
1009 =head2 Set functions:
1010
1011     $set = $set->union($b);
1012
1013     $set = $set->intersection($b);
1014
1015     $set = $set->complement;
1016     $set = $set->complement($b);   # can also be called "minus" or "difference"
1017
1018     $set = $set->symmetric_difference( $b );
1019
1020     $set = $set->span;
1021
1022         result is (min .. max)
1023
1024 =head2 Scalar functions:
1025
1026     $i = $set->min;
1027
1028     $i = $set->max;
1029
1030     $i = $set->size;
1031
1032     $i = $set->count;  # number of spans
1033
1034 =head2 Overloaded Perl functions:
1035
1036     print
1037
1038     sort, <=>
1039
1040 =head2 Global functions:
1041
1042     separators(@i)
1043
1044         chooses the interval separators.
1045
1046         default are [ ] ( ) '..' ','.
1047
1048     INFINITY
1049
1050         returns an 'Infinity' number.
1051
1052     NEG_INFINITY
1053
1054         returns a '-Infinity' number.
1055
1056     iterate ( sub { } )
1057
1058         Iterates over a subroutine.
1059         Returns the union of partial results.
1060
1061     first
1062
1063         In scalar context returns the first interval of a set.
1064
1065         In list context returns the first interval of a set, and the
1066         'tail'.
1067
1068         Works in unbounded sets
1069
1070     type($i)
1071
1072         chooses an object data type.
1073
1074         default is none (a normal perl SCALAR).
1075
1076         examples:
1077
1078         type('Math::BigFloat');
1079         type('Math::BigInt');
1080         type('Set::Infinite::Date');
1081             See notes on Set::Infinite::Date below.
1082
1083     tolerance(0)    defaults to real sets (default)
1084     tolerance(1)    defaults to integer sets
1085
1086     real            defaults to real sets (default)
1087
1088     integer         defaults to integer sets
1089
1090 =head2 Internal functions:
1091
1092     $set->fixtype;
1093
1094     $set->numeric;
1095
1096 =head1 CAVEATS
1097
1098     $set = Set::Infinite->new(10,1);
1099         Will be interpreted as [1..10]
1100
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,
1104         or maybe ->new(1,4)
1105
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.
1109
1110 =head1 INTERNALS
1111
1112 The internal representation of a I<span> is a hash:
1113
1114     { a =>   start of span,
1115       b =>   end 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'
1120     }
1121
1122 For example, this set:
1123
1124     [100..200),300,(400..infinity)
1125
1126 is represented by the array of hashes:
1127
1128     list => [
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 },
1132     ]
1133
1134 The I<density> of a set is stored in the C<tolerance> variable:
1135
1136     tolerance => 0;  # the set is made of real numbers.
1137
1138     tolerance => 1;  # the set is made of integers.
1139
1140 The C<type> variable stores the I<class> of objects that will be stored in the set.
1141
1142     type => 'DateTime';   # this is a set of DateTime objects
1143
1144 The I<infinity> value is generated by Perl, when it finds a numerical overflow:
1145
1146     $inf = 100**100**100;
1147
1148 =head1 SEE ALSO
1149
1150     Set::Infinite
1151
1152 =head1 AUTHOR
1153
1154     Flavio S. Glock <fglock@gmail.com>
1155
1156 =cut
1157