1package 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 8use 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 15use strict; 16use base qw(Set::Infinite::Basic Exporter); 17use Carp; 18use Set::Infinite::Arithmetic; 19 20use overload 21 '<=>' => \&spaceship, 22 '""' => \&as_string; 23 24use 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 38sub inf () { $inf } 39sub minus_inf () { $minus_inf } 40sub no_cleanup { $_[0] } 41*type = \&Set::Infinite::Basic::type; 42sub compact { @_ } 43 44 45BEGIN { 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 58sub 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 70sub 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 83sub 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() 106sub _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 118sub _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 132sub 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 194sub _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 208sub _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 223sub 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 315BEGIN { 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 772sub 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 795sub 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 818sub 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 875sub is_null { 876 $_[0]->{too_complex} ? 0 : $_[0]->SUPER::is_null; 877} 878 879 880sub is_too_complex { 881 $_[0]->{too_complex} ? 1 : 0; 882} 883 884 885# shows how a 'compacted' set looks like after quantize 886sub _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 937BEGIN { 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 993sub _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 1041sub 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 1059sub 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 1085sub 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 1113sub 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 1151sub 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 1172sub 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 1183sub 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 1203sub 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 1227sub 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 1239sub 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 1251sub 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 1259sub 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 1271sub 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 1279sub _cleanup { @_ } # this subroutine is obsolete 1280 1281 1282sub 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 1301sub _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 1312sub 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 1320sub DESTROY {} 1321 13221; 1323 1324__END__ 1325 1326 1327=head1 NAME 1328 1329Set::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 1342Set::Infinite is a Set Theory module for infinite sets. 1343 1344A set is a collection of objects. 1345The objects that belong to a set are called its members, or "elements". 1346 1347As objects we allow (almost) anything: reals, integers, and objects (such as dates). 1348 1349We allow sets to be infinite. 1350 1351There is no account for the order of elements. For example, {1,2} = {2,1}. 1352 1353There 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 1359Creates 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 1415The C<new()> method expects I<ordered> parameters. 1416 1417If 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 1423The data structures passed to C<new> must be I<immutable>. 1424So this is not good practice: 1425 1426 $set = Set::Infinite->new( $object_a, $object_b ); 1427 $object_a->set_value( 10 ); 1428 1429This 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 1437Creates a new object, and copy the object data. 1438 1439=head2 empty_set 1440 1441Creates an empty set. 1442 1443If called from an existing set, the empty set inherits 1444the "type" and "density" characteristics. 1445 1446=head2 universal_set 1447 1448Creates a set containing "all" possible elements. 1449 1450If called from an existing set, the universal set inherits 1451the "type" and "density" characteristics. 1452 1453=head1 SET FUNCTIONS 1454 1455=head2 union 1456 1457 $set = $set->union($b); 1458 1459Returns the set of all elements from both sets. 1460 1461This 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 1472Returns the set of elements common to both sets. 1473 1474This 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 1489Returns 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 1495The complement function might take a parameter: 1496 1497 $set = $set->minus($b); 1498 1499Returns the set-difference, that is, the elements that don't 1500belong 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 1509Returns a set containing elements that are in either set, 1510but 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 1518Returns a set with density "0". 1519 1520=head2 integer 1521 1522 $set1 = $set->integer; 1523 1524Returns 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 1544This set that has at least 1 element. 1545 1546=head2 is_span 1547 1548This set that has a single span or interval. 1549 1550=head2 is_singleton 1551 1552This set that has a single element. 1553 1554=head2 is_subset( $set ) 1555 1556Every element of this set is a member of the given set. 1557 1558=head2 is_proper_subset( $set ) 1559 1560Every element of this set is a member of the given set. 1561Some members of the given set are not elements of this set. 1562 1563=head2 is_disjoint( $set ) 1564 1565The given set has no elements in common with this set. 1566 1567=head2 is_too_complex 1568 1569Sometimes a set might be too complex to enumerate or print. 1570 1571This happens with sets that represent infinite recurrences, such as 1572when you ask for a quantization on a 1573set bounded by -inf or inf. 1574 1575See 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 1603See also: C<as_string>. 1604 1605=head2 comparison 1606 1607 sort 1608 1609 > < == >= <= <=> 1610 1611See 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 1633Chooses a default object data type. 1634 1635Default is none (a normal Perl SCALAR). 1636 1637 1638=head1 SPECIAL SET FUNCTIONS 1639 1640=head2 span 1641 1642 $set1 = $set->span; 1643 1644Returns the set span. 1645 1646=head2 until 1647 1648Extends a set until another: 1649 1650 0,5,7 -> until 2,6,10 1651 1652gives 1653 1654 [0..2), [5..6), [7..10) 1655 1656=head2 start_set 1657 1658=head2 end_set 1659 1660These methods do the inverse of the "until" method. 1661 1662Given: 1663 1664 [0..2), [5..6), [7..10) 1665 1666start_set is: 1667 1668 0,5,7 1669 1670end_set is: 1671 1672 2,6,10 1673 1674=head2 intersected_spans 1675 1676 $set = $set1->intersected_spans( $set2 ); 1677 1678The method returns a new set, 1679containing all spans that are intersected by the given set. 1680 1681Unlike the C<intersection> method, the spans are not modified. 1682See 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 1713Selects set spans based on their ordered positions 1714 1715C<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 1728Offsets 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 1738Iterates on the set spans, over a callback subroutine. 1739Returns the union of all partial results. 1740 1741The callback argument C<$_[0]> is a span. If there are additional arguments they are passed to the callback. 1742 1743The callback can return a span, a hashref (see C<Set::Infinite::Basic>), a scalar, an object, or C<undef>. 1744 1745[EXPERIMENTAL] 1746C<iterate> accepts an optional C<backtrack_callback> argument. 1747The purpose of the C<backtrack_callback> is to I<reverse> the 1748iterate() function, overcoming the limitations of the internal 1749backtracking algorithm. 1750The syntax is: 1751 1752 iterate ( sub { } , backtrack_callback => sub { }, @args ) 1753 1754The C<backtrack_callback> can return a span, a hashref, a scalar, 1755an object, or C<undef>. 1756 1757For example, the following snippet adds a constant to each 1758element 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 1770In scalar context returns the first or last interval of a set. 1771 1772In list context returns the first or last interval of a set, 1773and the remaining set (the 'tail'). 1774 1775See also: C<min>, C<max>, C<min_a>, C<max_a> methods. 1776 1777=head2 type 1778 1779 type( "My::Class::Name" ) 1780 1781Chooses a default object data type. 1782 1783default is none (a normal perl SCALAR). 1784 1785 1786=head1 INTERNAL FUNCTIONS 1787 1788=head2 _backtrack 1789 1790 $set->_backtrack( 'intersection', $b ); 1791 1792Internal function to evaluate recurrences. 1793 1794=head2 numeric 1795 1796 $set->numeric; 1797 1798Internal function to ignore the set "type". 1799It is used in some internal optimizations, when it is 1800possible to use scalar values instead of objects. 1801 1802=head2 fixtype 1803 1804 $set->fixtype; 1805 1806Internal function to fix the result of operations 1807that 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 1814Internal 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 1827Implements the "stringification" operator. 1828 1829Stringification of unbounded recurrences is not implemented. 1830 1831Unbounded recurrences are stringified as "function descriptions", 1832if the class variable $PRETTY_PRINT is set. 1833 1834=head2 spaceship 1835 1836Implements the "comparison" operator. 1837 1838Comparison 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 1849Will be interpreted as [1..10] 1850 1851=item * constructor "multiple-span" notation 1852 1853 $set = Set::Infinite->new(1,2,3,4); 1854 1855Will be interpreted as [1..2],[3..4] instead of [1,2,3,4]. 1856You probably want ->new([1],[2],[3],[4]) instead, 1857or maybe ->new(1,4) 1858 1859=item * "range operator" 1860 1861 $set = Set::Infinite->new(1..3); 1862 1863Will be interpreted as [1..2],3 instead of [1,2,3]. 1864You probably want ->new(1,3) instead. 1865 1866=back 1867 1868=head1 INTERNALS 1869 1870The base I<set> object, without recurrences, is a C<Set::Infinite::Basic>. 1871 1872A I<recurrence-set> is represented by a I<method name>, 1873one or two I<parent objects>, and extra arguments. 1874The C<list> key is set to an empty array, and the 1875C<too_complex> key is set to C<1>. 1876 1877This 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 1887This 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 1900See modules DateTime::Set, DateTime::Event::Recurrence, 1901DateTime::Event::ICal, DateTime::Event::Cron 1902for up-to-date information on date-sets. 1903 1904The perl-date-time project <http://datetime.perl.org> 1905 1906 1907=head1 AUTHOR 1908 1909Flavio S. Glock <fglock@gmail.com> 1910 1911=head1 COPYRIGHT 1912 1913Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved. 1914This program is free software; you can redistribute it and/or modify 1915it under the same terms as Perl itself. 1916 1917The full text of the license can be found in the LICENSE file included 1918with this module. 1919 1920=cut 1921 1922