modules/fallback/Set/Infinite.pm

   1 package Set::Infinite;
   2
   3 # Copyright (c) 2001, 2002, 2003, 2004 Flavio Soibelmann Glock.
   4 # All rights reserved.
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the same terms as Perl itself.
   7
   8 use 5.005_03;
   9
  10 # These methods are inherited from Set::Infinite::Basic "as-is":
  11 #   type list fixtype numeric min max integer real new span copy
  12 #   start_set end_set universal_set empty_set minus difference
  13 #   symmetric_difference is_empty
  14
  15 use strict;
  16 use base qw(Set::Infinite::Basic Exporter);
  17 use Carp;
  18 use Set::Infinite::Arithmetic;
  19
  20 use overload
  21     '<=>' => \&spaceship,
  22     '""'  => \&as_string;
  23
  24 use vars qw(@EXPORT_OK $VERSION
  25     $TRACE $DEBUG_BT $PRETTY_PRINT $inf $minus_inf $neg_inf
  26     %_first %_last %_backtrack
  27     $too_complex $backtrack_depth
  28     $max_backtrack_depth $max_intersection_depth
  29     $trace_level %level_title );
  30
  31 @EXPORT_OK = qw(inf $inf trace_open trace_close);
  32
  33 $inf     = 100**100**100;
  34 $neg_inf = $minus_inf  = -$inf;
  35
  36
  37 # obsolete methods - included for backward compatibility
  38 sub inf ()            { $inf }
  39 sub minus_inf ()      { $minus_inf }
  40 sub no_cleanup { $_[0] }
  41 *type       = \&Set::Infinite::Basic::type;
  42 sub compact { @_ }
  43
  44
  45 BEGIN {
  46     $VERSION = "0.65";
  47     $TRACE = 0;         # enable basic trace method execution
  48     $DEBUG_BT = 0;      # enable backtrack tracer
  49     $PRETTY_PRINT = 0;  # 0 = print 'Too Complex'; 1 = describe functions
  50     $trace_level = 0;   # indentation level when debugging
  51
  52     $too_complex =    "Too complex";
  53     $backtrack_depth = 0;
  54     $max_backtrack_depth = 10;    # _backtrack()
  55     $max_intersection_depth = 5;  # first()
  56 }
  57
  58 sub trace { # title=>'aaa'
  59     return $_[0] unless $TRACE;
  60     my ($self, %parm) = @_;
  61     my @caller = caller(1);
  62     # print "self $self ". ref($self). "\n";
  63     print "" . ( ' | ' x $trace_level ) .
  64             "$parm{title} ". $self->copy .
  65             ( exists $parm{arg} ? " -- " . $parm{arg}->copy : "" ).
  66             " $caller[1]:$caller[2] ]\n" if $TRACE == 1;
  67     return $self;
  68 }
  69
  70 sub trace_open {
  71     return $_[0] unless $TRACE;
  72     my ($self, %parm) = @_;
  73     my @caller = caller(1);
  74     print "" . ( ' | ' x $trace_level ) .
  75             "\\ $parm{title} ". $self->copy .
  76             ( exists $parm{arg} ? " -- ". $parm{arg}->copy : "" ).
  77             " $caller[1]:$caller[2] ]\n";
  78     $trace_level++;
  79     $level_title{$trace_level} = $parm{title};
  80     return $self;
  81 }
  82
  83 sub trace_close {
  84     return $_[0] unless $TRACE;
  85     my ($self, %parm) = @_;
  86     my @caller = caller(0);
  87     print "" . ( ' | ' x ($trace_level-1) ) .
  88             "\/ $level_title{$trace_level} ".
  89             ( exists $parm{arg} ?
  90                (
  91                   defined $parm{arg} ?
  92                       "ret ". ( UNIVERSAL::isa($parm{arg}, __PACKAGE__ ) ?
  93                            $parm{arg}->copy :
  94                            "<$parm{arg}>" ) :
  95                       "undef"
  96                ) :
  97                ""     # no arg
  98             ).
  99             " $caller[1]:$caller[2] ]\n";
 100     $trace_level--;
 101     return $self;
 102 }
 103
 104
 105 # creates a 'function' object that can be solved by _backtrack()
 106 sub _function {
 107     my ($self, $method) = (shift, shift);
 108     my $b = $self->empty_set();
 109     $b->{too_complex} = 1;
 110     $b->{parent} = $self;
 111     $b->{method} = $method;
 112     $b->{param}  = [ @_ ];
 113     return $b;
 114 }
 115
 116
 117 # same as _function, but with 2 arguments
 118 sub _function2 {
 119     my ($self, $method, $arg) = (shift, shift, shift);
 120     unless ( $self->{too_complex} || $arg->{too_complex} ) {
 121         return $self->$method($arg, @_);
 122     }
 123     my $b = $self->empty_set();
 124     $b->{too_complex} = 1;
 125     $b->{parent} = [ $self, $arg ];
 126     $b->{method} = $method;
 127     $b->{param}  = [ @_ ];
 128     return $b;
 129 }
 130
 131
 132 sub quantize {
 133     my $self = shift;
 134     $self->trace_open(title=>"quantize") if $TRACE;
 135     my @min = $self->min_a;
 136     my @max = $self->max_a;
 137     if (($self->{too_complex}) or
 138         (defined $min[0] && $min[0] == $neg_inf) or
 139         (defined $max[0] && $max[0] == $inf)) {
 140
 141         return $self->_function( 'quantize', @_ );
 142     }
 143
 144     my @a;
 145     my %rule = @_;
 146     my $b = $self->empty_set();
 147     my $parent = $self;
 148
 149     $rule{unit} =   'one' unless $rule{unit};
 150     $rule{quant} =  1     unless $rule{quant};
 151     $rule{parent} = $parent;
 152     $rule{strict} = $parent unless exists $rule{strict};
 153     $rule{type} =   $parent->{type};
 154
 155     my ($min, $open_begin) = $parent->min_a;
 156
 157     unless (defined $min) {
 158         $self->trace_close( arg => $b ) if $TRACE;
 159         return $b;
 160     }
 161
 162     $rule{fixtype} = 1 unless exists $rule{fixtype};
 163     $Set::Infinite::Arithmetic::Init_quantizer{$rule{unit}}->(\%rule);
 164
 165     $rule{sub_unit} = $Set::Infinite::Arithmetic::Offset_to_value{$rule{unit}};
 166     carp "Quantize unit '".$rule{unit}."' not implemented" unless ref( $rule{sub_unit} ) eq 'CODE';
 167
 168     my ($max, $open_end) = $parent->max_a;
 169     $rule{offset} = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $min);
 170     my $last_offset = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $max);
 171     $rule{size} = $last_offset - $rule{offset} + 1;
 172     my ($index, $tmp, $this, $next);
 173     for $index (0 .. $rule{size} ) {
 174         # ($this, $next) = $rule{sub_unit} (\%rule, $index);
 175         ($this, $next) = $rule{sub_unit}->(\%rule, $index);
 176         unless ( $rule{fixtype} ) {
 177                 $tmp = { a => $this , b => $next ,
 178                         open_begin => 0, open_end => 1 };
 179         }
 180         else {
 181                 $tmp = Set::Infinite::Basic::_simple_new($this,$next, $rule{type} );
 182                 $tmp->{open_end} = 1;
 183         }
 184         next if ( $rule{strict} and not $rule{strict}->intersects($tmp));
 185         push @a, $tmp;
 186     }
 187
 188     $b->{list} = \@a;        # change data
 189     $self->trace_close( arg => $b ) if $TRACE;
 190     return $b;
 191 }
 192
 193
 194 sub _first_n {
 195     my $self = shift;
 196     my $n = shift;
 197     my $tail = $self->copy;
 198     my @result;
 199     my $first;
 200     for ( 1 .. $n )
 201     {
 202         ( $first, $tail ) = $tail->first if $tail;
 203         push @result, $first;
 204     }
 205     return $tail, @result;
 206 }
 207
 208 sub _last_n {
 209     my $self = shift;
 210     my $n = shift;
 211     my $tail = $self->copy;
 212     my @result;
 213     my $last;
 214     for ( 1 .. $n )
 215     {
 216         ( $last, $tail ) = $tail->last if $tail;
 217         unshift @result, $last;
 218     }
 219     return $tail, @result;
 220 }
 221
 222
 223 sub select {
 224     my $self = shift;
 225     $self->trace_open(title=>"select") if $TRACE;
 226
 227     my %param = @_;
 228     die "select() - parameter 'freq' is deprecated" if exists $param{freq};
 229
 230     my $res;
 231     my $count;
 232     my @by;
 233     @by = @{ $param{by} } if exists $param{by};
 234     $count = delete $param{count} || $inf;
 235     # warn "select: count=$count by=[@by]";
 236
 237     if ($count <= 0) {
 238         $self->trace_close( arg => $res ) if $TRACE;
 239         return $self->empty_set();
 240     }
 241
 242     my @set;
 243     my $tail;
 244     my $first;
 245     my $last;
 246     if ( @by )
 247     {
 248         my @res;
 249         if ( ! $self->is_too_complex )
 250         {
 251             $res = $self->new;
 252             @res = @{ $self->{list} }[ @by ] ;
 253         }
 254         else
 255         {
 256             my ( @pos_by, @neg_by );
 257             for ( @by ) {
 258                 ( $_ < 0 ) ? push @neg_by, $_ :
 259                              push @pos_by, $_;
 260             }
 261             my @first;
 262             if ( @pos_by ) {
 263                 @pos_by = sort { $a <=> $b } @pos_by;
 264                 ( $tail, @set ) = $self->_first_n( 1 + $pos_by[-1] );
 265                 @first = @set[ @pos_by ];
 266             }
 267             my @last;
 268             if ( @neg_by ) {
 269                 @neg_by = sort { $a <=> $b } @neg_by;
 270                 ( $tail, @set ) = $self->_last_n( - $neg_by[0] );
 271                 @last = @set[ @neg_by ];
 272             }
 273             @res = map { $_->{list}[0] } ( @first , @last );
 274         }
 275
 276         $res = $self->new;
 277         @res = sort { $a->{a} <=> $b->{a} } grep { defined } @res;
 278         my $last;
 279         my @a;
 280         for ( @res ) {
 281             push @a, $_ if ! $last || $last->{a} != $_->{a};
 282             $last = $_;
 283         }
 284         $res->{list} = \@a;
 285     }
 286     else
 287     {
 288         $res = $self;
 289     }
 290
 291     return $res if $count == $inf;
 292     my $count_set = $self->empty_set();
 293     if ( ! $self->is_too_complex )
 294     {
 295         my @a;
 296         @a = grep { defined } @{ $res->{list} }[ 0 .. $count - 1 ] ;
 297         $count_set->{list} = \@a;
 298     }
 299     else
 300     {
 301         my $last;
 302         while ( $res ) {
 303             ( $first, $res ) = $res->first;
 304             last unless $first;
 305             last if $last && $last->{a} == $first->{list}[0]{a};
 306             $last = $first->{list}[0];
 307             push @{$count_set->{list}}, $first->{list}[0];
 308             $count--;
 309             last if $count <= 0;
 310         }
 311     }
 312     return $count_set;
 313 }
 314
 315 BEGIN {
 316
 317   # %_first and %_last hashes are used to backtrack the value
 318   # of first() and last() of an infinite set
 319
 320   %_first = (
 321     'complement' =>
 322         sub {
 323             my $self = $_[0];
 324             my @parent_min = $self->{parent}->first;
 325             unless ( defined $parent_min[0] ) {
 326                 return (undef, 0);
 327             }
 328             my $parent_complement;
 329             my $first;
 330             my @next;
 331             my $parent;
 332             if ( $parent_min[0]->min == $neg_inf ) {
 333                 my @parent_second = $parent_min[1]->first;
 334                 #    (-inf..min)        (second..?)
 335                 #            (min..second)   = complement
 336                 $first = $self->new( $parent_min[0]->complement );
 337                 $first->{list}[0]{b} = $parent_second[0]->{list}[0]{a};
 338                 $first->{list}[0]{open_end} = ! $parent_second[0]->{list}[0]{open_begin};
 339                 @{ $first->{list} } = () if
 340                     ( $first->{list}[0]{a} == $first->{list}[0]{b}) &&
 341                         ( $first->{list}[0]{open_begin} ||
 342                           $first->{list}[0]{open_end} );
 343                 @next = $parent_second[0]->max_a;
 344                 $parent = $parent_second[1];
 345             }
 346             else {
 347                 #            (min..?)
 348                 #    (-inf..min)        = complement
 349                 $parent_complement = $parent_min[0]->complement;
 350                 $first = $self->new( $parent_complement->{list}[0] );
 351                 @next = $parent_min[0]->max_a;
 352                 $parent = $parent_min[1];
 353             }
 354             my @no_tail = $self->new($neg_inf,$next[0]);
 355             $no_tail[0]->{list}[0]{open_end} = $next[1];
 356             my $tail = $parent->union($no_tail[0])->complement;
 357             return ($first, $tail);
 358         },  # end: first-complement
 359     'intersection' =>
 360         sub {
 361             my $self = $_[0];
 362             my @parent = @{ $self->{parent} };
 363             # warn "$method parents @parent";
 364             my $retry_count = 0;
 365             my (@first, @min, $which, $first1, $intersection);
 366             SEARCH: while ($retry_count++ < $max_intersection_depth) {
 367                 return undef unless defined $parent[0];
 368                 return undef unless defined $parent[1];
 369                 @{$first[0]} = $parent[0]->first;
 370                 @{$first[1]} = $parent[1]->first;
 371                 unless ( defined $first[0][0] ) {
 372                     # warn "don't know first of $method";
 373                     $self->trace_close( arg => 'undef' ) if $TRACE;
 374                     return undef;
 375                 }
 376                 unless ( defined $first[1][0] ) {
 377                     # warn "don't know first of $method";
 378                     $self->trace_close( arg => 'undef' ) if $TRACE;
 379                     return undef;
 380                 }
 381                 @{$min[0]} = $first[0][0]->min_a;
 382                 @{$min[1]} = $first[1][0]->min_a;
 383                 unless ( defined $min[0][0] && defined $min[1][0] ) {
 384                     return undef;
 385                 }
 386                 # $which is the index to the bigger "first".
 387                 $which = ($min[0][0] < $min[1][0]) ? 1 : 0;
 388                 for my $which1 ( $which, 1 - $which ) {
 389                   my $tmp_parent = $parent[$which1];
 390                   ($first1, $parent[$which1]) = @{ $first[$which1] };
 391                   if ( $first1->is_empty ) {
 392                     # warn "first1 empty! count $retry_count";
 393                     # trace_close;
 394                     # return $first1, undef;
 395                     $intersection = $first1;
 396                     $which = $which1;
 397                     last SEARCH;
 398                   }
 399                   $intersection = $first1->intersection( $parent[1-$which1] );
 400                   # warn "intersection with $first1 is $intersection";
 401                   unless ( $intersection->is_null ) {
 402                     # $self->trace( title=>"got an intersection" );
 403                     if ( $intersection->is_too_complex ) {
 404                         $parent[$which1] = $tmp_parent;
 405                     }
 406                     else {
 407                         $which = $which1;
 408                         last SEARCH;
 409                     }
 410                   };
 411                 }
 412             }
 413             if ( $#{ $intersection->{list} } > 0 ) {
 414                 my $tail;
 415                 ($intersection, $tail) = $intersection->first;
 416                 $parent[$which] = $parent[$which]->union( $tail );
 417             }
 418             my $tmp;
 419             if ( defined $parent[$which] and defined $parent[1-$which] ) {
 420                 $tmp = $parent[$which]->intersection ( $parent[1-$which] );
 421             }
 422             return ($intersection, $tmp);
 423         }, # end: first-intersection
 424     'union' =>
 425         sub {
 426             my $self = $_[0];
 427             my (@first, @min);
 428             my @parent = @{ $self->{parent} };
 429             @{$first[0]} = $parent[0]->first;
 430             @{$first[1]} = $parent[1]->first;
 431             unless ( defined $first[0][0] ) {
 432                 # looks like one set was empty
 433                 return @{$first[1]};
 434             }
 435             @{$min[0]} = $first[0][0]->min_a;
 436             @{$min[1]} = $first[1][0]->min_a;
 437
 438             # check min1/min2 for undef
 439             unless ( defined $min[0][0] ) {
 440                 $self->trace_close( arg => "@{$first[1]}" ) if $TRACE;
 441                 return @{$first[1]}
 442             }
 443             unless ( defined $min[1][0] ) {
 444                 $self->trace_close( arg => "@{$first[0]}" ) if $TRACE;
 445                 return @{$first[0]}
 446             }
 447
 448             my $which = ($min[0][0] < $min[1][0]) ? 0 : 1;
 449             my $first = $first[$which][0];
 450
 451             # find out the tail
 452             my $parent1 = $first[$which][1];
 453             # warn $self->{parent}[$which]." - $first = $parent1";
 454             my $parent2 = ($min[0][0] == $min[1][0]) ?
 455                 $self->{parent}[1-$which]->complement($first) :
 456                 $self->{parent}[1-$which];
 457             my $tail;
 458             if (( ! defined $parent1 ) || $parent1->is_null) {
 459                 # warn "union parent1 tail is null";
 460                 $tail = $parent2;
 461             }
 462             else {
 463                 my $method = $self->{method};
 464                 $tail = $parent1->$method( $parent2 );
 465             }
 466
 467             if ( $first->intersects( $tail ) ) {
 468                 my $first2;
 469                 ( $first2, $tail ) = $tail->first;
 470                 $first = $first->union( $first2 );
 471             }
 472
 473             $self->trace_close( arg => "$first $tail" ) if $TRACE;
 474             return ($first, $tail);
 475         }, # end: first-union
 476     'iterate' =>
 477         sub {
 478             my $self = $_[0];
 479             my $parent = $self->{parent};
 480             my ($first, $tail) = $parent->first;
 481             $first = $first->iterate( @{$self->{param}} ) if ref($first);
 482             $tail  = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail);
 483             my $more;
 484             ($first, $more) = $first->first if ref($first);
 485             $tail = $tail->_function2( 'union', $more ) if defined $more;
 486             return ($first, $tail);
 487         },
 488     'until' =>
 489         sub {
 490             my $self = $_[0];
 491             my ($a1, $b1) = @{ $self->{parent} };
 492             $a1->trace( title=>"computing first()" );
 493             my @first1 = $a1->first;
 494             my @first2 = $b1->first;
 495             my ($first, $tail);
 496             if ( $first2[0] <= $first1[0] ) {
 497                 # added ->first because it returns 2 spans if $a1 == $a2
 498                 $first = $a1->empty_set()->until( $first2[0] )->first;
 499                 $tail = $a1->_function2( "until", $first2[1] );
 500             }
 501             else {
 502                 $first = $a1->new( $first1[0] )->until( $first2[0] );
 503                 if ( defined $first1[1] ) {
 504                     $tail = $first1[1]->_function2( "until", $first2[1] );
 505                 }
 506                 else {
 507                     $tail = undef;
 508                 }
 509             }
 510             return ($first, $tail);
 511         },
 512     'offset' =>
 513         sub {
 514             my $self = $_[0];
 515             my ($first, $tail) = $self->{parent}->first;
 516             $first = $first->offset( @{$self->{param}} );
 517             $tail  = $tail->_function( 'offset', @{$self->{param}} );
 518             my $more;
 519             ($first, $more) = $first->first;
 520             $tail = $tail->_function2( 'union', $more ) if defined $more;
 521             return ($first, $tail);
 522         },
 523     'quantize' =>
 524         sub {
 525             my $self = $_[0];
 526             my @min = $self->{parent}->min_a;
 527             if ( $min[0] == $neg_inf || $min[0] == $inf ) {
 528                 return ( $self->new( $min[0] ) , $self->copy );
 529             }
 530             my $first = $self->new( $min[0] )->quantize( @{$self->{param}} );
 531             return ( $first,
 532                      $self->{parent}->
 533                         _function2( 'intersection', $first->complement )->
 534                         _function( 'quantize', @{$self->{param}} ) );
 535         },
 536     'tolerance' =>
 537         sub {
 538             my $self = $_[0];
 539             my ($first, $tail) = $self->{parent}->first;
 540             $first = $first->tolerance( @{$self->{param}} );
 541             $tail  = $tail->tolerance( @{$self->{param}} );
 542             return ($first, $tail);
 543         },
 544   );  # %_first
 545
 546   %_last = (
 547     'complement' =>
 548         sub {
 549             my $self = $_[0];
 550             my @parent_max = $self->{parent}->last;
 551             unless ( defined $parent_max[0] ) {
 552                 return (undef, 0);
 553             }
 554             my $parent_complement;
 555             my $last;
 556             my @next;
 557             my $parent;
 558             if ( $parent_max[0]->max == $inf ) {
 559                 #    (inf..min)        (second..?) = parent
 560                 #            (min..second)         = complement
 561                 my @parent_second = $parent_max[1]->last;
 562                 $last = $self->new( $parent_max[0]->complement );
 563                 $last->{list}[0]{a} = $parent_second[0]->{list}[0]{b};
 564                 $last->{list}[0]{open_begin} = ! $parent_second[0]->{list}[0]{open_end};
 565                 @{ $last->{list} } = () if
 566                     ( $last->{list}[0]{a} == $last->{list}[0]{b}) &&
 567                         ( $last->{list}[0]{open_end} ||
 568                           $last->{list}[0]{open_begin} );
 569                 @next = $parent_second[0]->min_a;
 570                 $parent = $parent_second[1];
 571             }
 572             else {
 573                 #            (min..?)
 574                 #    (-inf..min)        = complement
 575                 $parent_complement = $parent_max[0]->complement;
 576                 $last = $self->new( $parent_complement->{list}[-1] );
 577                 @next = $parent_max[0]->min_a;
 578                 $parent = $parent_max[1];
 579             }
 580             my @no_tail = $self->new($next[0], $inf);
 581             $no_tail[0]->{list}[-1]{open_begin} = $next[1];
 582             my $tail = $parent->union($no_tail[-1])->complement;
 583             return ($last, $tail);
 584         },
 585     'intersection' =>
 586         sub {
 587             my $self = $_[0];
 588             my @parent = @{ $self->{parent} };
 589             # TODO: check max1/max2 for undef
 590
 591             my $retry_count = 0;
 592             my (@last, @max, $which, $last1, $intersection);
 593
 594             SEARCH: while ($retry_count++ < $max_intersection_depth) {
 595                 return undef unless defined $parent[0];
 596                 return undef unless defined $parent[1];
 597
 598                 @{$last[0]} = $parent[0]->last;
 599                 @{$last[1]} = $parent[1]->last;
 600                 unless ( defined $last[0][0] ) {
 601                     $self->trace_close( arg => 'undef' ) if $TRACE;
 602                     return undef;
 603                 }
 604                 unless ( defined $last[1][0] ) {
 605                     $self->trace_close( arg => 'undef' ) if $TRACE;
 606                     return undef;
 607                 }
 608                 @{$max[0]} = $last[0][0]->max_a;
 609                 @{$max[1]} = $last[1][0]->max_a;
 610                 unless ( defined $max[0][0] && defined $max[1][0] ) {
 611                     $self->trace( title=>"can't find max()" ) if $TRACE;
 612                     $self->trace_close( arg => 'undef' ) if $TRACE;
 613                     return undef;
 614                 }
 615
 616                 # $which is the index to the smaller "last".
 617                 $which = ($max[0][0] > $max[1][0]) ? 1 : 0;
 618
 619                 for my $which1 ( $which, 1 - $which ) {
 620                   my $tmp_parent = $parent[$which1];
 621                   ($last1, $parent[$which1]) = @{ $last[$which1] };
 622                   if ( $last1->is_null ) {
 623                     $which = $which1;
 624                     $intersection = $last1;
 625                     last SEARCH;
 626                   }
 627                   $intersection = $last1->intersection( $parent[1-$which1] );
 628
 629                   unless ( $intersection->is_null ) {
 630                     # $self->trace( title=>"got an intersection" );
 631                     if ( $intersection->is_too_complex ) {
 632                         $self->trace( title=>"got a too_complex intersection" ) if $TRACE;
 633                         # warn "too complex intersection";
 634                         $parent[$which1] = $tmp_parent;
 635                     }
 636                     else {
 637                         $self->trace( title=>"got an intersection" ) if $TRACE;
 638                         $which = $which1;
 639                         last SEARCH;
 640                     }
 641                   };
 642                 }
 643             }
 644             $self->trace( title=>"exit loop" ) if $TRACE;
 645             if ( $#{ $intersection->{list} } > 0 ) {
 646                 my $tail;
 647                 ($intersection, $tail) = $intersection->last;
 648                 $parent[$which] = $parent[$which]->union( $tail );
 649             }
 650             my $tmp;
 651             if ( defined $parent[$which] and defined $parent[1-$which] ) {
 652                 $tmp = $parent[$which]->intersection ( $parent[1-$which] );
 653             }
 654             return ($intersection, $tmp);
 655         },
 656     'union' =>
 657         sub {
 658             my $self = $_[0];
 659             my (@last, @max);
 660             my @parent = @{ $self->{parent} };
 661             @{$last[0]} = $parent[0]->last;
 662             @{$last[1]} = $parent[1]->last;
 663             @{$max[0]} = $last[0][0]->max_a;
 664             @{$max[1]} = $last[1][0]->max_a;
 665             unless ( defined $max[0][0] ) {
 666                 return @{$last[1]}
 667             }
 668             unless ( defined $max[1][0] ) {
 669                 return @{$last[0]}
 670             }
 671
 672             my $which = ($max[0][0] > $max[1][0]) ? 0 : 1;
 673             my $last = $last[$which][0];
 674             # find out the tail
 675             my $parent1 = $last[$which][1];
 676             # warn $self->{parent}[$which]." - $last = $parent1";
 677             my $parent2 = ($max[0][0] == $max[1][0]) ?
 678                 $self->{parent}[1-$which]->complement($last) :
 679                 $self->{parent}[1-$which];
 680             my $tail;
 681             if (( ! defined $parent1 ) || $parent1->is_null) {
 682                 $tail = $parent2;
 683             }
 684             else {
 685                 my $method = $self->{method};
 686                 $tail = $parent1->$method( $parent2 );
 687             }
 688
 689             if ( $last->intersects( $tail ) ) {
 690                 my $last2;
 691                 ( $last2, $tail ) = $tail->last;
 692                 $last = $last->union( $last2 );
 693             }
 694
 695             return ($last, $tail);
 696         },
 697     'until' =>
 698         sub {
 699             my $self = $_[0];
 700             my ($a1, $b1) = @{ $self->{parent} };
 701             $a1->trace( title=>"computing last()" );
 702             my @last1 = $a1->last;
 703             my @last2 = $b1->last;
 704             my ($last, $tail);
 705             if ( $last2[0] <= $last1[0] ) {
 706                 # added ->last because it returns 2 spans if $a1 == $a2
 707                 $last = $last2[0]->until( $a1 )->last;
 708                 $tail = $a1->_function2( "until", $last2[1] );
 709             }
 710             else {
 711                 $last = $a1->new( $last1[0] )->until( $last2[0] );
 712                 if ( defined $last1[1] ) {
 713                     $tail = $last1[1]->_function2( "until", $last2[1] );
 714                 }
 715                 else {
 716                     $tail = undef;
 717                 }
 718             }
 719             return ($last, $tail);
 720         },
 721     'iterate' =>
 722         sub {
 723             my $self = $_[0];
 724             my $parent = $self->{parent};
 725             my ($last, $tail) = $parent->last;
 726             $last = $last->iterate( @{$self->{param}} ) if ref($last);
 727             $tail = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail);
 728             my $more;
 729             ($last, $more) = $last->last if ref($last);
 730             $tail = $tail->_function2( 'union', $more ) if defined $more;
 731             return ($last, $tail);
 732         },
 733     'offset' =>
 734         sub {
 735             my $self = $_[0];
 736             my ($last, $tail) = $self->{parent}->last;
 737             $last = $last->offset( @{$self->{param}} );
 738             $tail  = $tail->_function( 'offset', @{$self->{param}} );
 739             my $more;
 740             ($last, $more) = $last->last;
 741             $tail = $tail->_function2( 'union', $more ) if defined $more;
 742             return ($last, $tail);
 743         },
 744     'quantize' =>
 745         sub {
 746             my $self = $_[0];
 747             my @max = $self->{parent}->max_a;
 748             if (( $max[0] == $neg_inf ) || ( $max[0] == $inf )) {
 749                 return ( $self->new( $max[0] ) , $self->copy );
 750             }
 751             my $last = $self->new( $max[0] )->quantize( @{$self->{param}} );
 752             if ($max[1]) {  # open_end
 753                     if ( $last->min <= $max[0] ) {
 754                         $last = $self->new( $last->min - 1e-9 )->quantize( @{$self->{param}} );
 755                     }
 756             }
 757             return ( $last, $self->{parent}->
 758                         _function2( 'intersection', $last->complement )->
 759                         _function( 'quantize', @{$self->{param}} ) );
 760         },
 761     'tolerance' =>
 762         sub {
 763             my $self = $_[0];
 764             my ($last, $tail) = $self->{parent}->last;
 765             $last = $last->tolerance( @{$self->{param}} );
 766             $tail  = $tail->tolerance( @{$self->{param}} );
 767             return ($last, $tail);
 768         },
 769   );  # %_last
 770 } # BEGIN
 771
 772 sub first {
 773     my $self = $_[0];
 774     unless ( exists $self->{first} ) {
 775         $self->trace_open(title=>"first") if $TRACE;
 776         if ( $self->{too_complex} ) {
 777             my $method = $self->{method};
 778             # warn "method $method ". ( exists $_first{$method} ? "exists" : "does not exist" );
 779             if ( exists $_first{$method} ) {
 780                 @{$self->{first}} = $_first{$method}->($self);
 781             }
 782             else {
 783                 my $redo = $self->{parent}->$method ( @{ $self->{param} } );
 784                 @{$self->{first}} = $redo->first;
 785             }
 786         }
 787         else {
 788             return $self->SUPER::first;
 789         }
 790     }
 791     return wantarray ? @{$self->{first}} : $self->{first}[0];
 792 }
 793
 794
 795 sub last {
 796     my $self = $_[0];
 797     unless ( exists $self->{last} ) {
 798         $self->trace(title=>"last") if $TRACE;
 799         if ( $self->{too_complex} ) {
 800             my $method = $self->{method};
 801             if ( exists $_last{$method} ) {
 802                 @{$self->{last}} = $_last{$method}->($self);
 803             }
 804             else {
 805                 my $redo = $self->{parent}->$method ( @{ $self->{param} } );
 806                 @{$self->{last}} = $redo->last;
 807             }
 808         }
 809         else {
 810             return $self->SUPER::last;
 811         }
 812     }
 813     return wantarray ? @{$self->{last}} : $self->{last}[0];
 814 }
 815
 816
 817 # offset: offsets subsets
 818 sub offset {
 819     my $self = shift;
 820     if ($self->{too_complex}) {
 821         return $self->_function( 'offset', @_ );
 822     }
 823     $self->trace_open(title=>"offset") if $TRACE;
 824
 825     my @a;
 826     my %param = @_;
 827     my $b1 = $self->empty_set();
 828     my ($interval, $ia, $i);
 829     $param{mode} = 'offset' unless $param{mode};
 830
 831     unless (ref($param{value}) eq 'ARRAY') {
 832         $param{value} = [0 + $param{value}, 0 + $param{value}];
 833     }
 834     $param{unit} =    'one'  unless $param{unit};
 835     my $parts    =    ($#{$param{value}}) / 2;
 836     my $sub_unit =    $Set::Infinite::Arithmetic::subs_offset2{$param{unit}};
 837     my $sub_mode =    $Set::Infinite::Arithmetic::_MODE{$param{mode}};
 838
 839     carp "unknown unit $param{unit} for offset()" unless defined $sub_unit;
 840     carp "unknown mode $param{mode} for offset()" unless defined $sub_mode;
 841
 842     my ($j);
 843     my ($cmp, $this, $next, $ib, $part, $open_begin, $open_end, $tmp);
 844
 845     my @value;
 846     foreach $j (0 .. $parts) {
 847         push @value, [ $param{value}[$j+$j], $param{value}[$j+$j + 1] ];
 848     }
 849
 850     foreach $interval ( @{ $self->{list} } ) {
 851         $ia =         $interval->{a};
 852         $ib =         $interval->{b};
 853         $open_begin = $interval->{open_begin};
 854         $open_end =   $interval->{open_end};
 855         foreach $j (0 .. $parts) {
 856             # print " [ofs($ia,$ib)] ";
 857             ($this, $next) = $sub_mode->( $sub_unit, $ia, $ib, @{$value[$j]} );
 858             next if ($this > $next);    # skip if a > b
 859             if ($this == $next) {
 860                 # TODO: fix this
 861                 $open_end = $open_begin;
 862             }
 863             push @a, { a => $this , b => $next ,
 864                        open_begin => $open_begin , open_end => $open_end };
 865         }  # parts
 866     }  # self
 867     @a = sort { $a->{a} <=> $b->{a} } @a;
 868     $b1->{list} = \@a;        # change data
 869     $self->trace_close( arg => $b1 ) if $TRACE;
 870     $b1 = $b1->fixtype if $self->{fixtype};
 871     return $b1;
 872 }
 873
 874
 875 sub is_null {
 876     $_[0]->{too_complex} ? 0 : $_[0]->SUPER::is_null;
 877 }
 878
 879
 880 sub is_too_complex {
 881     $_[0]->{too_complex} ? 1 : 0;
 882 }
 883
 884
 885 # shows how a 'compacted' set looks like after quantize
 886 sub _quantize_span {
 887     my $self = shift;
 888     my %param = @_;
 889     $self->trace_open(title=>"_quantize_span") if $TRACE;
 890     my $res;
 891     if ($self->{too_complex}) {
 892         $res = $self->{parent};
 893         if ($self->{method} ne 'quantize') {
 894             $self->trace( title => "parent is a ". $self->{method} );
 895             if ( $self->{method} eq 'union' ) {
 896                 my $arg0 = $self->{parent}[0]->_quantize_span(%param);
 897                 my $arg1 = $self->{parent}[1]->_quantize_span(%param);
 898                 $res = $arg0->union( $arg1 );
 899             }
 900             elsif ( $self->{method} eq 'intersection' ) {
 901                 my $arg0 = $self->{parent}[0]->_quantize_span(%param);
 902                 my $arg1 = $self->{parent}[1]->_quantize_span(%param);
 903                 $res = $arg0->intersection( $arg1 );
 904             }
 905
 906             # TODO: other methods
 907             else {
 908                 $res = $self; # ->_function( "_quantize_span", %param );
 909             }
 910             $self->trace_close( arg => $res ) if $TRACE;
 911             return $res;
 912         }
 913
 914         # $res = $self->{parent};
 915         if ($res->{too_complex}) {
 916             $res->trace( title => "parent is complex" );
 917             $res = $res->_quantize_span( %param );
 918             $res = $res->quantize( @{$self->{param}} )->_quantize_span( %param );
 919         }
 920         else {
 921             $res = $res->iterate (
 922                 sub {
 923                     $_[0]->quantize( @{$self->{param}} )->span;
 924                 }
 925             );
 926         }
 927     }
 928     else {
 929         $res = $self->iterate (   sub { $_[0] }   );
 930     }
 931     $self->trace_close( arg => $res ) if $TRACE;
 932     return $res;
 933 }
 934
 935
 936
 937 BEGIN {
 938
 939     %_backtrack = (
 940
 941         until => sub {
 942             my ($self, $arg) = @_;
 943             my $before = $self->{parent}[0]->intersection( $neg_inf, $arg->min )->max;
 944             $before = $arg->min unless $before;
 945             my $after = $self->{parent}[1]->intersection( $arg->max, $inf )->min;
 946             $after = $arg->max unless $after;
 947             return $arg->new( $before, $after );
 948         },
 949
 950         iterate => sub {
 951             my ($self, $arg) = @_;
 952
 953             if ( defined $self->{backtrack_callback} )
 954             {
 955                 return $arg = $self->new( $self->{backtrack_callback}->( $arg ) );
 956             }
 957
 958             my $before = $self->{parent}->intersection( $neg_inf, $arg->min )->max;
 959             $before = $arg->min unless $before;
 960             my $after = $self->{parent}->intersection( $arg->max, $inf )->min;
 961             $after = $arg->max unless $after;
 962
 963             return $arg->new( $before, $after );
 964         },
 965
 966         quantize => sub {
 967             my ($self, $arg) = @_;
 968             if ($arg->{too_complex}) {
 969                 return $arg;
 970             }
 971             else {
 972                 return $arg->quantize( @{$self->{param}} )->_quantize_span;
 973             }
 974         },
 975
 976         offset => sub {
 977             my ($self, $arg) = @_;
 978             # offset - apply offset with negative values
 979             my %tmp = @{$self->{param}};
 980             my @values = sort @{$tmp{value}};
 981
 982             my $backtrack_arg2 = $arg->offset(
 983                    unit => $tmp{unit},
 984                    mode => $tmp{mode},
 985                    value => [ - $values[-1], - $values[0] ] );
 986             return $arg->union( $backtrack_arg2 );   # fixes some problems with 'begin' mode
 987         },
 988
 989     );
 990 }
 991
 992
 993 sub _backtrack {
 994     my ($self, $method, $arg) = @_;
 995     return $self->$method ($arg) unless $self->{too_complex};
 996
 997     $self->trace_open( title => 'backtrack '.$self->{method} ) if $TRACE;
 998
 999     $backtrack_depth++;
1000     if ( $backtrack_depth > $max_backtrack_depth ) {
1001         carp ( __PACKAGE__ . ": Backtrack too deep " .
1002                "(more than $max_backtrack_depth levels)" );
1003     }
1004
1005     if (exists $_backtrack{ $self->{method} } ) {
1006         $arg = $_backtrack{ $self->{method} }->( $self, $arg );
1007     }
1008
1009     my $result;
1010     if ( ref($self->{parent}) eq 'ARRAY' ) {
1011         # has 2 parents (intersection, union, until)
1012
1013         my ( $result1, $result2 ) = @{$self->{parent}};
1014         $result1 = $result1->_backtrack( $method, $arg )
1015             if $result1->{too_complex};
1016         $result2 = $result2->_backtrack( $method, $arg )
1017             if $result2->{too_complex};
1018
1019         $method = $self->{method};
1020         if ( $result1->{too_complex} || $result2->{too_complex} ) {
1021             $result = $result1->_function2( $method, $result2 );
1022         }
1023         else {
1024             $result = $result1->$method ($result2);
1025         }
1026     }
1027     else {
1028         # has 1 parent and parameters (offset, select, quantize, iterate)
1029
1030         $result = $self->{parent}->_backtrack( $method, $arg );
1031         $method = $self->{method};
1032         $result = $result->$method ( @{$self->{param}} );
1033     }
1034
1035     $backtrack_depth--;
1036     $self->trace_close( arg => $result ) if $TRACE;
1037     return $result;
1038 }
1039
1040
1041 sub intersects {
1042     my $a1 = shift;
1043     my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
1044
1045     $a1->trace(title=>"intersects");
1046     if ($a1->{too_complex}) {
1047         $a1 = $a1->_backtrack('intersection', $b1 );
1048     }  # don't put 'else' here
1049     if ($b1->{too_complex}) {
1050         $b1 = $b1->_backtrack('intersection', $a1);
1051     }
1052     if (($a1->{too_complex}) or ($b1->{too_complex})) {
1053         return undef;   # we don't know the answer!
1054     }
1055     return $a1->SUPER::intersects( $b1 );
1056 }
1057
1058
1059 sub iterate {
1060     my $self = shift;
1061     my $callback = shift;
1062     die "First argument to iterate() must be a subroutine reference"
1063         unless ref( $callback ) eq 'CODE';
1064     my $backtrack_callback;
1065     if ( @_ && $_[0] eq 'backtrack_callback' )
1066     {
1067         ( undef, $backtrack_callback ) = ( shift, shift );
1068     }
1069     my $set;
1070     if ($self->{too_complex}) {
1071         $self->trace(title=>"iterate:backtrack") if $TRACE;
1072         $set = $self->_function( 'iterate', $callback, @_ );
1073     }
1074     else
1075     {
1076         $self->trace(title=>"iterate") if $TRACE;
1077         $set = $self->SUPER::iterate( $callback, @_ );
1078     }
1079     $set->{backtrack_callback} = $backtrack_callback;
1080     # warn "set backtrack_callback" if defined $backtrack_callback;
1081     return $set;
1082 }
1083
1084
1085 sub intersection {
1086     my $a1 = shift;
1087     my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
1088
1089     $a1->trace_open(title=>"intersection", arg => $b1) if $TRACE;
1090     if (($a1->{too_complex}) or ($b1->{too_complex})) {
1091         my $arg0 = $a1->_quantize_span;
1092         my $arg1 = $b1->_quantize_span;
1093         unless (($arg0->{too_complex}) or ($arg1->{too_complex})) {
1094             my $res = $arg0->intersection( $arg1 );
1095             $a1->trace_close( arg => $res ) if $TRACE;
1096             return $res;
1097         }
1098     }
1099     if ($a1->{too_complex}) {
1100         $a1 = $a1->_backtrack('intersection', $b1) unless $b1->{too_complex};
1101     }  # don't put 'else' here
1102     if ($b1->{too_complex}) {
1103         $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex};
1104     }
1105     if ( $a1->{too_complex} || $b1->{too_complex} ) {
1106         $a1->trace_close( ) if $TRACE;
1107         return $a1->_function2( 'intersection', $b1 );
1108     }
1109     return $a1->SUPER::intersection( $b1 );
1110 }
1111
1112
1113 sub intersected_spans {
1114     my $a1 = shift;
1115     my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
1116
1117     if ($a1->{too_complex}) {
1118         $a1 = $a1->_backtrack('intersection', $b1 ) unless $b1->{too_complex};
1119     }  # don't put 'else' here
1120     if ($b1->{too_complex}) {
1121         $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex};
1122     }
1123
1124     if ( ! $b1->{too_complex} && ! $a1->{too_complex} )
1125     {
1126         return $a1->SUPER::intersected_spans ( $b1 );
1127     }
1128
1129     return $b1->iterate(
1130         sub {
1131             my $tmp = $a1->intersection( $_[0] );
1132             return $tmp unless defined $tmp->max;
1133
1134             my $before = $a1->intersection( $neg_inf, $tmp->min )->last;
1135             my $after =  $a1->intersection( $tmp->max, $inf )->first;
1136
1137             $before = $tmp->union( $before )->first;
1138             $after  = $tmp->union( $after )->last;
1139
1140             $tmp = $tmp->union( $before )
1141                 if defined $before && $tmp->intersects( $before );
1142             $tmp = $tmp->union( $after )
1143                 if defined $after && $tmp->intersects( $after );
1144             return $tmp;
1145         }
1146     );
1147
1148 }
1149
1150
1151 sub complement {
1152     my $a1 = shift;
1153     # do we have a parameter?
1154     if (@_) {
1155         my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
1156
1157         $a1->trace_open(title=>"complement", arg => $b1) if $TRACE;
1158         $b1 = $b1->complement;
1159         my $tmp =$a1->intersection($b1);
1160         $a1->trace_close( arg => $tmp ) if $TRACE;
1161         return $tmp;
1162     }
1163     $a1->trace_open(title=>"complement") if $TRACE;
1164     if ($a1->{too_complex}) {
1165         $a1->trace_close( ) if $TRACE;
1166         return $a1->_function( 'complement', @_ );
1167     }
1168     return $a1->SUPER::complement;
1169 }
1170
1171
1172 sub until {
1173     my $a1 = shift;
1174     my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
1175
1176     if (($a1->{too_complex}) or ($b1->{too_complex})) {
1177         return $a1->_function2( 'until', $b1 );
1178     }
1179     return $a1->SUPER::until( $b1 );
1180 }
1181
1182
1183 sub union {
1184     my $a1 = shift;
1185     my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
1186
1187     $a1->trace_open(title=>"union", arg => $b1) if $TRACE;
1188     if (($a1->{too_complex}) or ($b1->{too_complex})) {
1189         $a1->trace_close( ) if $TRACE;
1190         return $a1 if $b1->is_null;
1191         return $b1 if $a1->is_null;
1192         return $a1->_function2( 'union', $b1);
1193     }
1194     return $a1->SUPER::union( $b1 );
1195 }
1196
1197
1198 # there are some ways to process 'contains':
1199 # A CONTAINS B IF A == ( A UNION B )
1200 #    - faster
1201 # A CONTAINS B IF B == ( A INTERSECTION B )
1202 #    - can backtrack = works for unbounded sets
1203 sub contains {
1204     my $a1 = shift;
1205     $a1->trace_open(title=>"contains") if $TRACE;
1206     if ( $a1->{too_complex} ) {
1207         # we use intersection because it is better for backtracking
1208         my $b0 = (ref $_[0] eq ref $a1) ? shift : $a1->new(@_);
1209         my $b1 = $a1->intersection($b0);
1210         if ( $b1->{too_complex} ) {
1211             $b1->trace_close( arg => 'undef' ) if $TRACE;
1212             return undef;
1213         }
1214         $a1->trace_close( arg => ($b1 == $b0 ? 1 : 0) ) if $TRACE;
1215         return ($b1 == $b0) ? 1 : 0;
1216     }
1217     my $b1 = $a1->union(@_);
1218     if ( $b1->{too_complex} ) {
1219         $b1->trace_close( arg => 'undef' ) if $TRACE;
1220         return undef;
1221     }
1222     $a1->trace_close( arg => ($b1 == $a1 ? 1 : 0) ) if $TRACE;
1223     return ($b1 == $a1) ? 1 : 0;
1224 }
1225
1226
1227 sub min_a {
1228     my $self = $_[0];
1229     return @{$self->{min}} if exists $self->{min};
1230     if ($self->{too_complex}) {
1231         my @first = $self->first;
1232         return @{$self->{min}} = $first[0]->min_a if defined $first[0];
1233         return @{$self->{min}} = (undef, 0);
1234     }
1235     return $self->SUPER::min_a;
1236 };
1237
1238
1239 sub max_a {
1240     my $self = $_[0];
1241     return @{$self->{max}} if exists $self->{max};
1242     if ($self->{too_complex}) {
1243         my @last = $self->last;
1244         return @{$self->{max}} = $last[0]->max_a if defined $last[0];
1245         return @{$self->{max}} = (undef, 0);
1246     }
1247     return $self->SUPER::max_a;
1248 };
1249
1250
1251 sub count {
1252     my $self = $_[0];
1253     # NOTE: subclasses may return "undef" if necessary
1254     return $inf if $self->{too_complex};
1255     return $self->SUPER::count;
1256 }
1257
1258
1259 sub size {
1260     my $self = $_[0];
1261     if ($self->{too_complex}) {
1262         my @min = $self->min_a;
1263         my @max = $self->max_a;
1264         return undef unless defined $max[0] && defined $min[0];
1265         return $max[0] - $min[0];
1266     }
1267     return $self->SUPER::size;
1268 };
1269
1270
1271 sub spaceship {
1272     my ($tmp1, $tmp2, $inverted) = @_;
1273     carp "Can't compare unbounded sets"
1274         if $tmp1->{too_complex} or $tmp2->{too_complex};
1275     return $tmp1->SUPER::spaceship( $tmp2, $inverted );
1276 }
1277
1278
1279 sub _cleanup { @_ }    # this subroutine is obsolete
1280
1281
1282 sub tolerance {
1283     my $self = shift;
1284     my $tmp = pop;
1285     if (ref($self)) {
1286         # local
1287         return $self->{tolerance} unless defined $tmp;
1288         if ($self->{too_complex}) {
1289             my $b1 = $self->_function( 'tolerance', $tmp );
1290             $b1->{tolerance} = $tmp;   # for max/min processing
1291             return $b1;
1292         }
1293         return $self->SUPER::tolerance( $tmp );
1294     }
1295     # class method
1296     __PACKAGE__->SUPER::tolerance( $tmp ) if defined($tmp);
1297     return __PACKAGE__->SUPER::tolerance;
1298 }
1299
1300
1301 sub _pretty_print {
1302     my $self = shift;
1303     return "$self" unless $self->{too_complex};
1304     return $self->{method} . "( " .
1305                ( ref($self->{parent}) eq 'ARRAY' ?
1306                    $self->{parent}[0] . ' ; ' . $self->{parent}[1] :
1307                    $self->{parent} ) .
1308            " )";
1309 }
1310
1311
1312 sub as_string {
1313     my $self = shift;
1314     return ( $PRETTY_PRINT ? $self->_pretty_print : $too_complex )
1315         if $self->{too_complex};
1316     return $self->SUPER::as_string;
1317 }
1318
1319
1320 sub DESTROY {}
1321
1322 1;
1323
1324 __END__
1325
1326
1327 =head1 NAME
1328
1329 Set::Infinite - Sets of intervals
1330
1331
1332 =head1 SYNOPSIS
1333
1334   use Set::Infinite;
1335
1336   $set = Set::Infinite->new(1,2);    # [1..2]
1337   print $set->union(5,6);            # [1..2],[5..6]
1338
1339
1340 =head1 DESCRIPTION
1341
1342 Set::Infinite is a Set Theory module for infinite sets.
1343
1344 A set is a collection of objects.
1345 The objects that belong to a set are called its members, or "elements".
1346
1347 As objects we allow (almost) anything:  reals, integers, and objects (such as dates).
1348
1349 We allow sets to be infinite.
1350
1351 There is no account for the order of elements. For example, {1,2} = {2,1}.
1352
1353 There is no account for repetition of elements. For example, {1,2,2} = {1,1,1,2} = {1,2}.
1354
1355 =head1 CONSTRUCTOR
1356
1357 =head2 new
1358
1359 Creates a new set object:
1360
1361     $set = Set::Infinite->new;             # empty set
1362     $set = Set::Infinite->new( 10 );       # single element
1363     $set = Set::Infinite->new( 10, 20 );   # single range
1364     $set = Set::Infinite->new(
1365               [ 10, 20 ], [ 50, 70 ] );    # two ranges
1366
1367 =over 4
1368
1369 =item empty set
1370
1371     $set = Set::Infinite->new;
1372
1373 =item set with a single element
1374
1375     $set = Set::Infinite->new( 10 );
1376
1377     $set = Set::Infinite->new( [ 10 ] );
1378
1379 =item set with a single span
1380
1381     $set = Set::Infinite->new( 10, 20 );
1382
1383     $set = Set::Infinite->new( [ 10, 20 ] );
1384     # 10 <= x <= 20
1385
1386 =item set with a single, open span
1387
1388     $set = Set::Infinite->new(
1389         {
1390             a => 10, open_begin => 0,
1391             b => 20, open_end => 1,
1392         }
1393     );
1394     # 10 <= x < 20
1395
1396 =item set with multiple spans
1397
1398     $set = Set::Infinite->new( 10, 20,  100, 200 );
1399
1400     $set = Set::Infinite->new( [ 10, 20 ], [ 100, 200 ] );
1401
1402     $set = Set::Infinite->new(
1403         {
1404             a => 10, open_begin => 0,
1405             b => 20, open_end => 0,
1406         },
1407         {
1408             a => 100, open_begin => 0,
1409             b => 200, open_end => 0,
1410         }
1411     );
1412
1413 =back
1414
1415 The C<new()> method expects I<ordered> parameters.
1416
1417 If you have unordered ranges, you can build the set using C<union>:
1418
1419     @ranges = ( [ 10, 20 ], [ -10, 1 ] );
1420     $set = Set::Infinite->new;
1421     $set = $set->union( @$_ ) for @ranges;
1422
1423 The data structures passed to C<new> must be I<immutable>.
1424 So this is not good practice:
1425
1426     $set = Set::Infinite->new( $object_a, $object_b );
1427     $object_a->set_value( 10 );
1428
1429 This is the recommended way to do it:
1430
1431     $set = Set::Infinite->new( $object_a->clone, $object_b->clone );
1432     $object_a->set_value( 10 );
1433
1434
1435 =head2 clone / copy
1436
1437 Creates a new object, and copy the object data.
1438
1439 =head2 empty_set
1440
1441 Creates an empty set.
1442
1443 If called from an existing set, the empty set inherits
1444 the "type" and "density" characteristics.
1445
1446 =head2 universal_set
1447
1448 Creates a set containing "all" possible elements.
1449
1450 If called from an existing set, the universal set inherits
1451 the "type" and "density" characteristics.
1452
1453 =head1 SET FUNCTIONS
1454
1455 =head2 union
1456
1457     $set = $set->union($b);
1458
1459 Returns the set of all elements from both sets.
1460
1461 This function behaves like an "OR" operation.
1462
1463     $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
1464     $set2 = new Set::Infinite( [ 7, 20 ] );
1465     print $set1->union( $set2 );
1466     # output: [1..4],[7..20]
1467
1468 =head2 intersection
1469
1470     $set = $set->intersection($b);
1471
1472 Returns the set of elements common to both sets.
1473
1474 This function behaves like an "AND" operation.
1475
1476     $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
1477     $set2 = new Set::Infinite( [ 7, 20 ] );
1478     print $set1->intersection( $set2 );
1479     # output: [8..12]
1480
1481 =head2 complement
1482
1483 =head2 minus
1484
1485 =head2 difference
1486
1487     $set = $set->complement;
1488
1489 Returns the set of all elements that don't belong to the set.
1490
1491     $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
1492     print $set1->complement;
1493     # output: (-inf..1),(4..8),(12..inf)
1494
1495 The complement function might take a parameter:
1496
1497     $set = $set->minus($b);
1498
1499 Returns the set-difference, that is, the elements that don't
1500 belong to the given set.
1501
1502     $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
1503     $set2 = new Set::Infinite( [ 7, 20 ] );
1504     print $set1->minus( $set2 );
1505     # output: [1..4]
1506
1507 =head2 symmetric_difference
1508
1509 Returns a set containing elements that are in either set,
1510 but not in both. This is the "set" version of "XOR".
1511
1512 =head1 DENSITY METHODS
1513
1514 =head2 real
1515
1516     $set1 = $set->real;
1517
1518 Returns a set with density "0".
1519
1520 =head2 integer
1521
1522     $set1 = $set->integer;
1523
1524 Returns a set with density "1".
1525
1526 =head1 LOGIC FUNCTIONS
1527
1528 =head2 intersects
1529
1530     $logic = $set->intersects($b);
1531
1532 =head2 contains
1533
1534     $logic = $set->contains($b);
1535
1536 =head2 is_empty
1537
1538 =head2 is_null
1539
1540     $logic = $set->is_null;
1541
1542 =head2 is_nonempty
1543
1544 This set that has at least 1 element.
1545
1546 =head2 is_span
1547
1548 This set that has a single span or interval.
1549
1550 =head2 is_singleton
1551
1552 This set that has a single element.
1553
1554 =head2 is_subset( $set )
1555
1556 Every element of this set is a member of the given set.
1557
1558 =head2 is_proper_subset( $set )
1559
1560 Every element of this set is a member of the given set.
1561 Some members of the given set are not elements of this set.
1562
1563 =head2 is_disjoint( $set )
1564
1565 The given set has no elements in common with this set.
1566
1567 =head2 is_too_complex
1568
1569 Sometimes a set might be too complex to enumerate or print.
1570
1571 This happens with sets that represent infinite recurrences, such as
1572 when you ask for a quantization on a
1573 set bounded by -inf or inf.
1574
1575 See also: C<count> method.
1576
1577 =head1 SCALAR FUNCTIONS
1578
1579 =head2 min
1580
1581     $i = $set->min;
1582
1583 =head2 max
1584
1585     $i = $set->max;
1586
1587 =head2 size
1588
1589     $i = $set->size;
1590
1591 =head2 count
1592
1593     $i = $set->count;
1594
1595 =head1 OVERLOADED OPERATORS
1596
1597 =head2 stringification
1598
1599     print $set;
1600
1601     $str = "$set";
1602
1603 See also: C<as_string>.
1604
1605 =head2 comparison
1606
1607     sort
1608
1609     > < == >= <= <=>
1610
1611 See also: C<spaceship> method.
1612
1613 =head1 CLASS METHODS
1614
1615     Set::Infinite->separators(@i)
1616
1617         chooses the interval separators for stringification.
1618
1619         default are [ ] ( ) '..' ','.
1620
1621     inf
1622
1623         returns an 'Infinity' number.
1624
1625     minus_inf
1626
1627         returns '-Infinity' number.
1628
1629 =head2 type
1630
1631     type( "My::Class::Name" )
1632
1633 Chooses a default object data type.
1634
1635 Default is none (a normal Perl SCALAR).
1636
1637
1638 =head1 SPECIAL SET FUNCTIONS
1639
1640 =head2 span
1641
1642     $set1 = $set->span;
1643
1644 Returns the set span.
1645
1646 =head2 until
1647
1648 Extends a set until another:
1649
1650     0,5,7 -> until 2,6,10
1651
1652 gives
1653
1654     [0..2), [5..6), [7..10)
1655
1656 =head2 start_set
1657
1658 =head2 end_set
1659
1660 These methods do the inverse of the "until" method.
1661
1662 Given:
1663
1664     [0..2), [5..6), [7..10)
1665
1666 start_set is:
1667
1668     0,5,7
1669
1670 end_set is:
1671
1672     2,6,10
1673
1674 =head2 intersected_spans
1675
1676     $set = $set1->intersected_spans( $set2 );
1677
1678 The method returns a new set,
1679 containing all spans that are intersected by the given set.
1680
1681 Unlike the C<intersection> method, the spans are not modified.
1682 See diagram below:
1683
1684                set1   [....]   [....]   [....]   [....]
1685                set2      [................]
1686
1687        intersection      [.]   [....]   [.]
1688
1689   intersected_spans   [....]   [....]   [....]
1690
1691
1692 =head2 quantize
1693
1694     quantize( parameters )
1695
1696         Makes equal-sized subsets.
1697
1698         Returns an ordered set of equal-sized subsets.
1699
1700         Example:
1701
1702             $set = Set::Infinite->new([1,3]);
1703             print join (" ", $set->quantize( quant => 1 ) );
1704
1705         Gives:
1706
1707             [1..2) [2..3) [3..4)
1708
1709 =head2 select
1710
1711     select( parameters )
1712
1713 Selects set spans based on their ordered positions
1714
1715 C<select> has a behaviour similar to an array C<slice>.
1716
1717             by       - default=All
1718             count    - default=Infinity
1719
1720  0  1  2  3  4  5  6  7  8      # original set
1721  0  1  2                        # count => 3
1722     1              6            # by => [ -2, 1 ]
1723
1724 =head2 offset
1725
1726     offset ( parameters )
1727
1728 Offsets the subsets. Parameters:
1729
1730     value   - default=[0,0]
1731     mode    - default='offset'. Possible values are: 'offset', 'begin', 'end'.
1732     unit    - type of value. Can be 'days', 'weeks', 'hours', 'minutes', 'seconds'.
1733
1734 =head2 iterate
1735
1736     iterate ( sub { } , @args )
1737
1738 Iterates on the set spans, over a callback subroutine.
1739 Returns the union of all partial results.
1740
1741 The callback argument C<$_[0]> is a span. If there are additional arguments they are passed to the callback.
1742
1743 The callback can return a span, a hashref (see C<Set::Infinite::Basic>), a scalar, an object, or C<undef>.
1744
1745 [EXPERIMENTAL]
1746 C<iterate> accepts an optional C<backtrack_callback> argument.
1747 The purpose of the C<backtrack_callback> is to I<reverse> the
1748 iterate() function, overcoming the limitations of the internal
1749 backtracking algorithm.
1750 The syntax is:
1751
1752     iterate ( sub { } , backtrack_callback => sub { }, @args )
1753
1754 The C<backtrack_callback> can return a span, a hashref, a scalar,
1755 an object, or C<undef>.
1756
1757 For example, the following snippet adds a constant to each
1758 element of an unbounded set:
1759
1760     $set1 = $set->iterate(
1761                  sub { $_[0]->min + 54, $_[0]->max + 54 },
1762               backtrack_callback =>
1763                  sub { $_[0]->min - 54, $_[0]->max - 54 },
1764               );
1765
1766 =head2 first / last
1767
1768     first / last
1769
1770 In scalar context returns the first or last interval of a set.
1771
1772 In list context returns the first or last interval of a set,
1773 and the remaining set (the 'tail').
1774
1775 See also: C<min>, C<max>, C<min_a>, C<max_a> methods.
1776
1777 =head2 type
1778
1779     type( "My::Class::Name" )
1780
1781 Chooses a default object data type.
1782
1783 default is none (a normal perl SCALAR).
1784
1785
1786 =head1 INTERNAL FUNCTIONS
1787
1788 =head2 _backtrack
1789
1790     $set->_backtrack( 'intersection', $b );
1791
1792 Internal function to evaluate recurrences.
1793
1794 =head2 numeric
1795
1796     $set->numeric;
1797
1798 Internal function to ignore the set "type".
1799 It is used in some internal optimizations, when it is
1800 possible to use scalar values instead of objects.
1801
1802 =head2 fixtype
1803
1804     $set->fixtype;
1805
1806 Internal function to fix the result of operations
1807 that use the numeric() function.
1808
1809 =head2 tolerance
1810
1811     $set = $set->tolerance(0)    # defaults to real sets (default)
1812     $set = $set->tolerance(1)    # defaults to integer sets
1813
1814 Internal function for changing the set "density".
1815
1816 =head2 min_a
1817
1818     ($min, $min_is_open) = $set->min_a;
1819
1820 =head2 max_a
1821
1822     ($max, $max_is_open) = $set->max_a;
1823
1824
1825 =head2 as_string
1826
1827 Implements the "stringification" operator.
1828
1829 Stringification of unbounded recurrences is not implemented.
1830
1831 Unbounded recurrences are stringified as "function descriptions",
1832 if the class variable $PRETTY_PRINT is set.
1833
1834 =head2 spaceship
1835
1836 Implements the "comparison" operator.
1837
1838 Comparison of unbounded recurrences is not implemented.
1839
1840
1841 =head1 CAVEATS
1842
1843 =over 4
1844
1845 =item * constructor "span" notation
1846
1847     $set = Set::Infinite->new(10,1);
1848
1849 Will be interpreted as [1..10]
1850
1851 =item * constructor "multiple-span" notation
1852
1853     $set = Set::Infinite->new(1,2,3,4);
1854
1855 Will be interpreted as [1..2],[3..4] instead of [1,2,3,4].
1856 You probably want ->new([1],[2],[3],[4]) instead,
1857 or maybe ->new(1,4)
1858
1859 =item * "range operator"
1860
1861     $set = Set::Infinite->new(1..3);
1862
1863 Will be interpreted as [1..2],3 instead of [1,2,3].
1864 You probably want ->new(1,3) instead.
1865
1866 =back
1867
1868 =head1 INTERNALS
1869
1870 The base I<set> object, without recurrences, is a C<Set::Infinite::Basic>.
1871
1872 A I<recurrence-set> is represented by a I<method name>,
1873 one or two I<parent objects>, and extra arguments.
1874 The C<list> key is set to an empty array, and the
1875 C<too_complex> key is set to C<1>.
1876
1877 This is a structure that holds the union of two "complex sets":
1878
1879   {
1880     too_complex => 1,             # "this is a recurrence"
1881     list   => [ ],                # not used
1882     method => 'union',            # function name
1883     parent => [ $set1, $set2 ],   # "leaves" in the syntax-tree
1884     param  => [ ]                 # optional arguments for the function
1885   }
1886
1887 This is a structure that holds the complement of a "complex set":
1888
1889   {
1890     too_complex => 1,             # "this is a recurrence"
1891     list   => [ ],                # not used
1892     method => 'complement',       # function name
1893     parent => $set,               # "leaf" in the syntax-tree
1894     param  => [ ]                 # optional arguments for the function
1895   }
1896
1897
1898 =head1 SEE ALSO
1899
1900 See modules DateTime::Set, DateTime::Event::Recurrence,
1901 DateTime::Event::ICal, DateTime::Event::Cron
1902 for up-to-date information on date-sets.
1903
1904 The perl-date-time project <http://datetime.perl.org>
1905
1906
1907 =head1 AUTHOR
1908
1909 Flavio S. Glock <fglock@gmail.com>
1910
1911 =head1 COPYRIGHT
1912
1913 Copyright (c) 2003 Flavio Soibelmann Glock.  All rights reserved.
1914 This program is free software; you can redistribute it and/or modify
1915 it under the same terms as Perl itself.
1916
1917 The full text of the license can be found in the LICENSE file included
1918 with this module.
1919
1920 =cut
1921