Set-Infinite-0.65/0000755000076500000240000000000011365356335014137 5ustar flavioglockstaffSet-Infinite-0.65/_todo/0000755000076500000240000000000011365356335015243 5ustar flavioglockstaffSet-Infinite-0.65/_todo/bigfloat.t0000644000076500000240000001600411027127720017205 0ustar flavioglockstaff#/bin/perl # Copyright (c) 2001 Flavio Soibelmann Glock. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Tests for Set::Infinite # This is work in progress # BEGIN { $| = 1; print "1..74\n"; } END {$test++; print "not ok $test\n" unless $loaded;} use Set::Infinite; $loaded = 1; use Math::BigFloat; my $errors = 0; my $test = 0; sub test { my ($header, $sub, $expected) = @_; $test++; print "\t# $header \n"; $result = eval $sub; if ("$expected" eq "$result") { print "ok $test"; } else { print "not ok $test\n\t# expected \"$expected\" got \"$result\""; $errors++; } print " \n"; } sub stats { if ($errors) { print "\n\t# Errors: $errors\n"; } else { print "\n\t# No errors.\n"; } } Set::Infinite->type('Math::BigFloat'); Set::Infinite->real; print "\t# Add element:\n"; $a = Set::Infinite->new(1,2); $a = $a->union(3,4); test (" (1,2) (3,4) : ",'$a',"[1...2.],[3...4.]"); print "\t# Parameter passing:\n"; test (" complement : ",'$a->complement',"(-inf..1.),(2...3.),(4...inf)"); test (" complement (1.5,2.5) : ",'$a->complement(1.5,2.5)',"[1...1.5),[3...4.]"); test (" union (1.5,2.5) : ",'$a->union(1.5,2.5)',"[1...2.5],[3...4.]"); test (" intersection (1.5,2.5) : ",'$a->intersection(1.5,2.5)',"[1.5..2.]"); test (" intersects (1.5,2.5) : ",'$a->intersects(1.5,2.5)',"1"); $a = Set::Infinite->new(Set::Infinite->new(1,2)); $a->add(3, 4); $a->add(-1, 0); $b = Set::Infinite->new($a); $b->cleanup; test ("Interval: (1,2) (3, 4) (-1, 0) : $b \n"); $a = $b; $a->add(0, 1); $a->add(7, 8); $a->add(6, 7.5); $a->cleanup; test ("Interval: add (0, 1) (7, 8) (6, 7.5) : $a \n"); print "\t# Integer + cleanup:\n"; $a->integer; $a->cleanup; test ("Interval: integer",'$a',"[-1...4.],[6...8.]"); print "\t# Operations on open sets\n"; $a = Set::Infinite->new(1,'inf'); test ("set : ", '$a', "[1...inf)"); $a = $a->complement; test ("[-inf,1) : ", '$a', "(-inf..1.)"); $b = $a; test ("copy : ",'$b',"(-inf..1.)"); test ("complement : ",$a->complement,""); test ("union [-1...0] : ", '$a->union(-1,0)', "(-inf..1.)"); test ("union [0...1] : ", '$a->union(0,1)', "(-inf..1.]"); test ("union [1...2] : ", '$a->union(1,2)', "(-inf..2.]"); test ("union [2...3] : ", '$a->union(2,3)', "(-inf..1.),[2...3.]"); $b = Set::Infinite->new(-inf,1)->complement; #test ("set : ", '$a, ""); $c = $a->union($b); test ("union $b : ", '$c', "(-inf..1.),(1...inf)"); test (" complement : ", '$c->complement',"1."); test ("union $c [1...inf) ", '$c->union(1,inf)', "(-inf..inf)"); test ("union $b [1...inf) ", '$b->union(1,inf)', "[1...inf)"); print "\t# Testing 'null' and (0...0)\n"; $a = Set::Infinite->new(); test ("null : ",$a,"null"); $a = Set::Infinite->new('null'); test ("null : ",$a,"null"); $a = Set::Infinite->new(undef); test ("null : ",$a,"null"); $a = Set::Infinite->new(); test ("(0,0) intersects to null : ",$a->intersects(0,0),"0"); test ("(0,0) intersection to null : ",$a->intersection(0,0),"null"); $a = Set::Infinite->new(0,0); test ("(0,0) intersects to null : ",$a->intersects(),"0"); test ("(0,0) intersection to null : ",$a->intersection(),"null"); test ("(0,0) intersects to 0 : ",$a->intersects(0),"1"); test ("(0,0) intersection to 0 : ",$a->intersection(0),"0"); $a = Set::Infinite->new(); test ("(0,0) union to null : ",$a->union(0,0),"0"); $a = Set::Infinite->new(0,0); test ("(0,0) union to null : ",$a->union(),"0"); $a = Set::Infinite->new(0,0); test ("(0,0) intersects to (1,1) : ",$a->intersects(1,1),"0"); test ("(0,0) intersection to (1,1) : ",$a->intersection(1,1)->as_string,"null"); print "\t# New:\n"; $a = Set::Infinite->new(1,2); $b = Set::Infinite->new([4,5],[7,8]); $x = Set::Infinite->new(10,11); $c = Set::Infinite->new($x); # $d = Set::Infinite->new( a => 13, b => 14 ); #print "\t# a : $a\n b : $b\n c : $c\n"; # d : $d\n"; $abcd = ' '; $abcd = Set::Infinite->new([$a],[$b],[$c]); #print " abcd $abcd\n"; test ("abcd",'$abcd',"[1...2.],[4...5.],[7...8.],[10...11.]"); print "\t# Contains\n"; $a = Set::Infinite->new([3,6],[12,18]); test ("set : ", '$a', "[3...6.],[12...18.]"); test ("contains (4,5) : ", '$a->contains(4,5)', "1"); test ("contains (3,5) : ", '$a->contains(3,5)', "1"); test ("contains (2,5) : ", '$a->contains(2,5)', "0"); test ("contains (4,15) : ", '$a->contains(4,15)', "0"); test ("contains (15,16) : ", '$a->contains(15,16)', "1"); test ("contains (4,5),(15,16) : ", '$a->contains([4,5],[15,16])', "1"); test ("contains (4,5),(15,20) : ", '$a->contains([4,5],[15,20])', "0"); print "\t# Intersects:\n"; $a = Set::Infinite->new(2,1); test ("Interval:",'$a',"[1...2.]"); test ("intersects 2.5 : ", '$a->intersects(2.5)', "0"); test ("intersects 1.5 : ", '$a->intersects(1.5)', "1"); test ("intersects 0.5 : ", '$a->intersects(0.5)', "0"); test ("intersects 0.1 ... 0.3 : ", '$a->intersects(Set::Infinite->new(0.1,0.3))', "0"); test ("intersects 0.1 ... 1.3 : ", '$a->intersects(Set::Infinite->new(0.1,1.3))', "1"); test ("intersects 1.1 ... 1.3 : ", '$a->intersects(Set::Infinite->new(1.1,1.3))', "1"); test ("intersects 1.1 ... 2.3 : ", '$a->intersects(Set::Infinite->new(1.1,2.3))', "1"); test ("intersects 2.1 ... 2.3 : ", '$a->intersects(Set::Infinite->new(2.1,2.3))', "0"); test ("intersects 0.0 ... 4.0 : ", '$a->intersects(Set::Infinite->new(0.0,4.0))', "1"); print "\t# Other:\n"; test ("Union 2.0 : ", '$a->union(2.0)', "[1...2.]"); test ("Union 2.5 ", '$a->union(2.5)', "[1...2.],2.5"); test ("Union 2.0 ... 2.5 : ", '$a->union(Set::Infinite->new(2.0,2.5))', "[1...2.5]"); test ("Union 0.5 ... 1.5 : ", '$a->union(Set::Infinite->new(0.5,1.5))', "[.5..2.]"); test ("Union 3.0 ... 4.0 : ", '$a->union(Set::Infinite->new(3.0,4.0))', "[1...2.],[3...4.]"); test ("Union 0.0 ... 4.0 5 ... 6 : ", '$a->union(Set::Infinite->new([0.0,4.0],[5.0,6.0]))', "[0...4.],[5...6.]"); $a = Set::Infinite->new(2,1); test ("Interval",'$a',"[1...2.]"); test ("intersection 2.5 : ", '$a->intersection(2.5)', "null"); test ("intersection 1.5 : ", '$a->intersection(1.5)', "1.5"); test ("intersection 0.5 : ", '$a->intersection(0.5)', "null"); test ("intersection 0.1 ... 0.3 : ", '$a->intersection(Set::Infinite->new(0.1,0.3))', "null"); test ("intersection 0.1 ... 1.3 : ", '$a->intersection(Set::Infinite->new(0.1,1.3))', "[1...1.3]"); test ("intersection 1.1 ... 1.3 : ", '$a->intersection(Set::Infinite->new(1.1,1.3))', "[1.1..1.3]"); test ("intersection 1.1 ... 2.3 : ", '$a->intersection(Set::Infinite->new(1.1,2.3))', "[1.1..2.]"); test ("intersection 2.1 ... 2.3 : ", '$a->intersection(Set::Infinite->new(2.1,2.3))', "null"); test ("Union 5.5 : ", '$a->union(5.5)', "[1...2.],5.5"); test ("intersection 0.0 ... 4.0 5 ... 6 : ", '$a->intersection(Set::Infinite->new([0.0,4.0],[5.0,6.0]))', "[1...2.]"); $a = Set::Infinite->new(2,1,4,5); $b = Set::Infinite->new(2.1,1.1,4.1,5.1); test ("intersection $a with $b", '$a->intersection($b)', "[1.1..2.],[4.1..5.]"); test ("size of $b is : ", '$b->size', "2."); test ("span of $b is : ", '$b->span', "[1.1..5.1]"); tie $a, 'Set::Infinite', [1,2], [9,10]; test ("tied: ",'$a',"[1...2.],[9...10.]"); stats; 1; Set-Infinite-0.65/_todo/bigint.t0000644000076500000240000001566311027127720016704 0ustar flavioglockstaff#/bin/perl # Copyright (c) 2001 Flavio Soibelmann Glock. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Tests for Set::Infinite # This is work in progress # use Set::Infinite qw(inf); my $errors = 0; my $test = 0; print "1..74\n"; sub test { my ($header, $sub, $expected) = @_; $test++; #print "\t# $header \n"; $result = eval $sub; if ("$expected" eq "$result") { print "ok $test"; } else { print "not ok $test"; print "\n\t# expected \"$expected\" got \"$result\""; # $result = foreach(0..length($result)) { print substr($expected,$_,1),substr($result,$_,1)," "; } print "\n"; $errors++; } print " \n"; } sub stats { if ($errors) { #print "\n\t# Errors: $errors\n"; } else { #print "\n\t# No errors.\n"; } } use Set::Infinite; Set::Infinite->type('Math::BigInt'); Set::Infinite->integer; # print "Union\n"; $a = Set::Infinite->new(1,inf); $a = $a->complement; #print " A is ", $a, "\n"; test ("union A [2..3] : ", '$a->union(2,3)', "(-inf..+1),[+2..+3]"); $b = Set::Infinite->new(- inf,1)->complement; test ("union $b : ", '$a->union($b)', "(-inf..+1),(+1..inf)"); $a = Set::Infinite->new(10, 13); # print " a is ", $a, "\n"; test ("$a union (16..17) ", '$a->union(16, 17)', "[+10..+13],[+16..+17]"); $a = Set::Infinite->new(16, 17); # print " a is ", $a, "\n"; test ("$a union (10..13) ", '$a->union(10, 13)', "[+10..+13],[+16..+17]"); # print "Operations on open sets\n"; $a = Set::Infinite->new(1,inf); test ("set : ", '$a', "[+1..inf)"); $a = $a->complement; test ("[-inf,1) : ", '$a', "(-inf..+1)"); $b = $a; test ("copy : ", '$b',"(-inf..+1)"); test ("complement : ", '$a->complement',"[+1..inf)"); test ("union [-1..0] : ", '$a->union(-1,0)', "(-inf..+1)"); test ("union [0..1] : ", '$a->union(0,1)', "(-inf..+1]"); test ("union [1..2] : ", '$a->union(1,2)', "(-inf..+2]"); test ("union [2..3] : ", '$a->union(2,3)', "(-inf..+1),[+2..+3]"); $b = Set::Infinite->new(- inf,1)->complement; #test ("set : ", '$a, ""); $c = $a->union($b); test ("union $b : ", '$c', "(-inf..+1),(+1..inf)"); test (" complement : ", '$c->complement',"+1"); test ("union $c [1..inf) ", '$c->union(1,inf)', "(-inf..inf)"); test ("union $b [1..inf) ", '$b->union(1,inf)', "[+1..inf)"); # print "Testing 'null' and (0..0)\n"; $a = Set::Infinite->new(); test ("null : ",'$a',"null"); $a = Set::Infinite->new('null'); test ("null : ",'$a',"null"); $a = Set::Infinite->new(undef); test ("null : ",'$a',"null"); $a = Set::Infinite->new(); test ("(0,0) intersects to null : ",'$a->intersects(0,0)',"0"); test ("(0,0) intersection to null : ",'$a->intersection(0,0)',"null"); $a = Set::Infinite->new(0,0); test ("(0,0) intersects to null : ",'$a->intersects()',"0"); test ("(0,0) intersection to null : ",'$a->intersection()',"null"); test ("(0,0) intersects to 0 : ",'$a->intersects(0)',"1"); test ("(0,0) intersection to 0 : ",'$a->intersection(0)',"+0"); $a = Set::Infinite->new(); test ("(0,0) union to null : ",'$a->union(0,0)',"+0"); $a = Set::Infinite->new(0,0); test ("(0,0) union to null : ",'$a->union()',"+0"); $a = Set::Infinite->new(0,0); test ("(0,0) intersects to (1,1) : ",'$a->intersects(1,1)',"0"); test ("(0,0) intersection to (1,1) : ",'$a->intersection(1,1)->as_string',"null"); #print "New:\n"; $a = Set::Infinite->new(1,2); $b = Set::Infinite->new([4,5],[7,8]); $x = Set::Infinite->new(10,11); $c = Set::Infinite->new($x); # $d = Set::Infinite->new( a => 13, b => 14 ); #print " a : $a\n b : $b\n c : $c\n d : $d\n"; $abcd = Set::Infinite->new([$a],[$b],[$c]); #print " abcd $abcd\n"; test ("abcd",'$abcd',"[+1..+2],[+4..+5],[+7..+8],[+10..+11]"); $abcd = ''; #print "Contains\n"; $a = Set::Infinite->new([3,6],[12,18]); test ("set : ", '$a', "[+3..+6],[+12..+18]"); test ("contains (4,5) : ", '$a->contains(4,5)', "1"); test ("contains (3,5) : ", '$a->contains(3,5)', "1"); test ("contains (2,5) : ", '$a->contains(2,5)', "0"); test ("contains (4,15) : ", '$a->contains(4,15)', "0"); test ("contains (15,16) : ", '$a->contains(15,16)', "1"); test ("contains (4,5),(15,16) : ", '$a->contains([4,5],[15,16])', "1"); test ("contains (4,5),(15,20) : ", '$a->contains([4,5],[15,20])', "0"); #print "Add element:\n"; $a = Set::Infinite->new(1,2); $a->add(3,4); test (" (1,2) (3,4) : ",'$a',"[+1..+4]"); #print "Parameter passing:\n"; test (" complement : ",'$a->complement',"(-inf..+1),(+4..inf)"); test (" complement (0,3) : ",'$a->complement(0,3)',"(+3..+4]"); test (" union (0,3) : ",'$a->union(0,3)',"[+0..+4]"); test (" intersection (0,3) : ",'$a->intersection(0,3)',"[+1..+3]"); test (" intersects (0,3) : ",'$a->intersects(0,3)',"1"); $a = Set::Infinite->new(Set::Infinite->new(1,2)); $a->add(3, 4); $a->add(-1, 0); $b = Set::Infinite->new($a); $b->cleanup; test ("Interval: (1,2) (3, 4) (-1, 0) : ",'$b',"[-1..+4]"); $a = $b; $a->add(0, 1); $a->add(7, 9); $a->add(6, 8); test ("Interval: integer",'$a',"[-1..+4],[+6..+9]"); #print "Intersects:\n"; $a = Set::Infinite->new(2,1); test ("Interval:",'$a',"[+1..+2]"); test ("intersects 3 : ", '$a->intersects(3)', "0"); test ("intersects 2 : ", '$a->intersects(2)', "1"); test ("intersects 1 : ", '$a->intersects(1)', "1"); test ("intersects 0 : ", '$a->intersects(0)', "0"); test ("intersects -1..0 : ", '$a->intersects(Set::Infinite->new(-1,0))', "0"); test ("intersects 0..1 : ", '$a->intersects(Set::Infinite->new(0,1))', "1"); test ("intersects 1..2 : ", '$a->intersects(Set::Infinite->new(1,2))', "1"); test ("intersects 1..3 : ", '$a->intersects(Set::Infinite->new(1,3))', "1"); test ("intersects 2..3 : ", '$a->intersects(Set::Infinite->new(2,3))', "1"); test ("intersects 0..4 : ", '$a->intersects(Set::Infinite->new(0,4))', "1"); #print "Other:\n"; test ("Union 2 : ", '$a->union(2)', "[+1..+2]"); test ("Union 3 ", '$a->union(3)', "[+1..+3]"); test ("Union 0 .. 1 : ", '$a->union(Set::Infinite->new(0,1))', "[+0..+2]"); test ("Union 3 .. 4 : ", '$a->union(Set::Infinite->new(3.0,4.0))', "[+1..+4]"); test ("Union 0 .. 4 5 .. 6 : ", '$a->union(Set::Infinite->new([0.0,4.0],[5.0,6.0]))', "[+0..+6]"); $a = Set::Infinite->new(2,1); test ("Interval",'$a',"[+1..+2]"); test ("intersection 2 : ", '$a->intersection(2)', "+2"); test ("intersection 1 : ", '$a->intersection(1)', "+1"); test ("intersection 0 : ", '$a->intersection(0)', "null"); test ("intersection 0..0 : ", '$a->intersection(Set::Infinite->new(0,0))', "null"); test ("intersection 0..1 : ", '$a->intersection(Set::Infinite->new(0,1))', "+1"); test ("intersection 1..1 : ", '$a->intersection(Set::Infinite->new(1,1))', "+1"); test ("intersection 1..2 : ", '$a->intersection(Set::Infinite->new(1,2))', "[+1..+2]"); test ("intersection 2..2 : ", '$a->intersection(Set::Infinite->new(2,2))', "+2"); test ("Union 5 : ", '$a->union(5)', "[+1..+2],+5"); test ("intersection 0.0 .. 4.0 5 .. 6 : ", '$a->intersection(Set::Infinite->new([0.0,4.0],[5.0,6.0]))', "[+1..+2]"); tie $a, 'Set::Infinite', [1,2], [9,10]; test ("tied: ",'$a',"[+1..+2],[+9..+10]"); stats; 1; Set-Infinite-0.65/Changes0000644000076500000240000003731111365356332015434 0ustar flavioglockstaffRevision history for Perl extension Set::Infinite. 0.65 2010-04-26 - documentation fix 0.64 2010-04-26 - s/simmetric/symmetric/ reported by Richard Jelinek 0.63 2008-07-21 - minor tweak in union(); added tests 0.62 2008-07-20 - fixed a problem in union() that caused first() to return a wrong result. reported by David Gang 0.61 2004-11-03 - some optimization of intersected_spans() - bugfix: complement of the universal set is the empty set 0.60 2004-10-28 - _cleanup() / _no_cleanup() are obsolete - easier syntax to iterate() 0.59 2004-07-01 - added experimental argument "backtrack_callback" to iterate() 0.58 2004-06-14 - intersected_spans was wrong when intersecting with an open set. bug report & tests by Peter Oliver 0.57 2004-04-03 - CPAN update 0.5602 2004-03-25 - fixed a test in t/select.t - Reported by David Dyck. - simplified "offset"; fixed "fixtype" - added "separators" test in t/infinite.t - is_proper_subset / is_disjoint may return 'undef' - variables $a, $b renamed 0.5601 2004-03-20 - iterate() first/last can deal with multiple spans - removed todo: "provide a constructor to build open sets" because this is already documented in new(). - fixed "separators" OO - New methods: is_span is_singleton is_subset is_proper_subset is_disjoint universal_set empty_set minus / difference (same as "complement") simmetric_difference 0.56 2004-03-17 - New method: clone (same as "copy") - More tests & fixes: intersected_spans 0.5503 2004-03-15 - New method: intersected_spans Suggested by Reinhold May Name suggested by Dave Rolsky - bugfix: first/last() of a union will try harder not to split spans. 0.5502 2004-03-14 - New methods: start_set / end_set These are the inverse of the "until" method. Suggested by Reinhold May 0.5501 refactored _backtrack method 0.55 2003-11-16 - bug fix: $set = Set::Infinite->new( -10, 0 ); created a set with "-10" instead of [-10..0] - documents that the parameters to new() must be sorted. Reported by Jim Cromie 0.5401 2003-10-21 specifying start > end in a constructor is a fatal error. 0.54 0.5308 2003-10-16 clears mod_perl warnings - change the order of modules and constants. Patch by Dan Kubb 0.5307 backtracking "iterate" uses a larger span 0.5306 fix bug in test "inf" -> "$inf". Thanks Kingpin 0.5305 %_first and %_last are declared with 'use vars' 0.5304 added more tests: intersects/until/select optimized select() refactored quantize() 0.5303 removed Set::Infinite::Date removed /_eg directory simplified README 0.5302 select( freq => $n ) is removed. - breaks Date::Set 0.28 (Date::Set 0.29 is ok) select( by => [] ) default is changed to 'All'. - in order to have the same behaviour as when 'freq' was omitted. 0.5301 refactored methods: min, max, first, last, until, iterate, offset removed obsolete method: compact renamed internal methods with _underline removed obsolete 'date' docs 0.53 2003-09-05 fixes a test that fails under 5.00503 does not export 'new' 0.52 2003-09-04 change tests to run under (a broken) Perl 5.9.0 - infinity string contains spaces 0.51 2003-09-02 passes all tests under 5.00503. - changed ' $var=\@_ ' to ' $var=[@_] ' compiles under Perl 5.00503. Patch by Mathieu Arnold. 0.50 count() fixed: size() does not try to add 'zero' to object. tests for count() and size() 0.49 fixed: "first/last" of intersection between recurrences 0.48 fixed: backtracking on a partially defined set. fixed: first of a union with an empty set. 0.47 until allows start_set == end_set 0.46_01 upload to perl-date-time CVS 0.46 more docs 0.45 last works, but not for union/quantize/select/offset 0.44_03 last() can union/intersect/complement/offset 0.44_02 last() can iterate/complement 0.44_01 first(n) deprecated S::I::Basic::last() enabled 0.44 CPAN release 0.43_01 'iterate' generates 'first' code 0.43 CPAN release implemented max() of 'iterate' 0.42_05 implemented min() of 'iterate' fixed complex union with empty set 0.42_04 finished removing 'our' 0.42_03 / 0.42_02 (idem) 0.42_01 more methods inherited from Set::Infinite::Basic 0.42_00 Set::Infinite.pm refactored into Set::Infinite::Basic Set::Infinite::_Simple removed. 0.41_03 can intersects() to an object (it checks the reference type) 0.41_02 fixed copy() - copying array refs 0.41_01 Fixed type() inheritance problems as a side effect, type() must be called with '->' syntax Fixed eg/recurring.pl 0.41 'todo' directory renamed to _todo for Win* compatibility (clashes with TODO) 0.40 LICENSE file 0.39_05 fixed 'until' test warnings (caused by malformed offset() output) 0.39_04 'until' works with empty sets 'until' has first() 0.39_03 'until' backtracks (slowly) left a hack in max() - might remove it when last() works... 0.39_02 'offset' has 'first' 'until' has '_quantize_span' 0.39_01 new method 'until' -- makes it possible to join RRULEs in Date::Set::Timezone hacked a fix a problem when offset-begin backtracks (offset-begin reduces a set to a single element, which backtracks wrongly if the set were quantized) better handling of backtrack-offset values fixed spaceship (again) contains works better for unbounded sets 0.39 fixed a bug in spaceship() that affected Date::Set::Timezone 0.38 - changes to 0.37: new method first() min() and max() improved fixed some bugs: intersection -inf with (-inf..15); "<=>"; more tests new $PRETTY_PRINT global option; better TRACE about 20% faster than 0.37; uses less memoization 0.37_71 trace works on a copy of the variables, so that autovivification and cleanups don't interfere with the program. 0.37_69 new method _quantize_span helps some internal calculations 0.37_68 fixed a bug in intersection -inf with (-inf..15) 0.37_67 t/first.t passes all tests first-select is leaking 0.37_63 last-quantize started 0.37_62 all tests pass fixed Element_Inf dependency in Set::Infinite::Date.pm 0.37_61 tests pass select should use count=> to bound set 0.37_60 first/unknown/union recursion fixed 0.37_59 first() has a cache 0.37_57 new $PRETTY_PRINT global option 0.37_54 quantize() is 'first-compatible' 0.37_51 min is 'more exact' first-intersection uses limited recursion 0.37_49 trace() has 'tab-levels' - trace_open/trace_close 0.37_48 first complement/intersection works last() removed 0.37_47 started last() started first/last + complement new t/first.t 0.37_44 fixed a bug in <=> 0.37_43 first/intersection code started (commented out) 0.37_42 allows inherited methods to use first() 0.37_41 passes tests 0.37_40 select/first works with freq+count or count (some tests fail) 0.37_38 first works for union/select/quantize 0.37_37 first for union() 0.37_36 select() freq default is 1 if we have a count 0.37_35 first/tail works for quantize(), select(by[]) 0.37_26 compact() is a no-op 0.37_23 quantize() is no longer tied; no longer generates 'undef' subset values. 3 tests didn't pass; removed! (expected null subset values) Quantize_Date.pm removed Function.pm removed 0.37_19 removed global-cache in quantize (access was too difficult, took too much time). 0.37_18 removed cacheing in Set::Infinite::Date (problems with 'mode' internal variable). 0.37_16 quantize 'weekyears' internal indexes fixed new tests added 0.37_11 Set::Infinite::Arithmetic docs revised 0.37_10 select() is no longer "tied" lib\Set\Infinite\Select.pm removed. offset doesn't use gmtime if doesn't have to. 0.37_06 Backtracks on complement() EXCLUDE_EXT string/array correction in Makefile.PL (thanks Mark Veltzer for pointing this out) 0.37_05 Offset.pm moved into Arithmetic.pm 0.37_04 removed eg/ical.pl (thanks Mike Castle for pointing these out) changed obsolete 'add' method to 'union' in eg/*.pl removed null() docs 0.37_03 faster Offset.pm 0.37 0.36_50 use warnings in Set::Infinite::_Simple 0.36_49 remove module Set::Infinite::Element_Inf 0.36_48 uses native "Infinity" stringification 0.36_47 fixed some warnings 0.36_46 size return correct value for open integer sets intersects/contains return undef if too_complex 0.36_45 min/max are cached min/max work with union/intersection select(), complement() not implemented (should carp!) 0.36_43 integer/real/tolerance are functions min/max work with integer() 0.36_42 min/max work for offset(); 0.36_41 min/max fixed for quantize() t/backtrack.t tests 2,3 fixed; more tests new methods (undocumented): min_a(), max_a() return a list: (value, open-state) 0.36_40 internal inf == Perl Inf 0.36_36 complement backtracks, although not it might fail for some sets (not tested at all!) min/max/span/size are estimated for complex sets might work for select() too. list(), <=> carp for unbounded sets 0.36_11 backtrack method call is cleaner 0.36_10 _simple_intersection removed. _simple_complement with parameter removed. 0.36_09 offset strict option removed. Was never used. 0.36_08 Set::Infinite::ICalset and S::I::ICal removed. use Date::Set instead. 0.36_07 Simple class renamed to _Simple; creates methods inside Set::Infinite $self->new() creates an empty set, and copies private variables from $self. This makes new() inheritance easier. 0.36 added 'copy' in order to allow 'subroutine-style' programming instead of only 'functional' programming added 'is_too_complex' obsoleted modules: Set::Infinite::Date, Set::Infinite::ICal, Set::Infinite::ICalSet use Date::Set instead. added make_htmldoc.pl and make_readme.pl 0.34 added 'weekdays' option to 'offset' 0.31-0.33 some optimizations offset is no longer 'tied' in order to try to make it faster offset now *always* return an ordered set quantize has better memoization control 0.30 optimized 'is_null' - avoids converting data to string fixed examples - foreach needs ->list fixed tests - thanks CPAN testers! move 'type', 'tolerance', 'real', 'integer' from Simple.pm to Set::Infinite.pm simpler 'contains' removed tie code from Infinite.pm and Infinite::Simple.pm 0.29 new method 'compact' offset option 'mode=>circle' new method 'list' new method 'no_cleanup' offset can handle months, years offset value must be array with even number of elements select 'freq' default is set-size instead of 1. removed internal 'compact_array' join (" ", $a) no longer works. use join (" ", $a->list) instead. quantize(10) no longer works. use quantize(quant=>10) instead. ical_2: BYMONTHDAY did not instantiate in ical_2 unless 'print' -- offset can't return array. 0.28 'strict' option in offset, select. 'strict=>0' option in quantize. offset can handle 'negative counts from end' 0.27 offset 'value' can handle multiple value-pairs optimized $class->new() instead of $class->new($self) in select, offset, quantize. 0.26 lots of problems due to $a->{list}->[$ia]->{a} -- used a temp variable to split in smaller parts new eg/ical.pl oo demo marked 'select{interval}' option to be deleted in next release select now properly handles negative by[]; checks parent index boundaries masked errors in select by using a dummy variable. cache Quantize_Date::FETCH (local to object) user can 'push' new methods into 'quantize' new 'iterate' method better oo in Infinite.pm - most methods can now be overriden array syntax corrected in Infinite.pm new TRACE/trace and DEBUG_BT to help debug 0.25 backtracking fully implemented in: intersection, intersects, union, offset. backtracking partially implemented in: quantize, select backtracking is NOT implemented in: complement, size, span, max, min See: backtrack.t 'epoch' support in core module. Doesn't need Date or ICal. intersection was missing 'my $b;' Date::sub propagates {mode} use hash-subs to initialize quantize units 'quantize_date' uses 'one' as default unit doesn't use Quantize.pm anymore, since Quantize_Date.pm is a superset. doesn't need 'quantizer, selector, offsetter' either. remove 'cmp' (thanks Martijn) internal cache for Date and ICal object 0.24 offset has 'unit' parameter 'epoch' removed. use 0+ instead. Quantize_Date is an extension of Quantize. quantize, select, offset return a compact array of Set::Infinite instead of a sparse array of Set::Infinite::Simple - no longer needs to test for null elements. 0.23 changed localtime to gmtime everywhere new object type: ICal. Requires Date::ICal; marked as experimental This module will not be tested if it can't find Date::ICal new date method: epoch 0.22.05 doesn't need HTTP::Date offset supports hours, in 'Date' type put "eg/recurring.pl" in distribution. (should be there since 0.21) new "Function.pm" base class for functions. Used Funtion.pm for "Select.pm" and "Offset.pm" Much better algorithm for "Select.pm" stricter language for "quantize" - only hash allowed. reduced "Simple.pm" - may be deprecated someday Faster cleanup, max, min Cleaner (faster?) union 0.21 new methods: "select" and "offset". syntax changed: "quantize": quantize( 1 ); # old syntax, still works quantize( quant => 1 ); quantize( 'months', 1 ); # old syntax for quantize_date, still works quantize( unit => 'seconds', quant => 1 ); # quantize_date internal: quantize parameter order is different. fixed: Quantize_Date returned Set::Infinite instead of Set::Infinite::Simple fixed: Date::Add lost format new: Set::Infinite::Date::day_size() added: recursive test for quantize changed: empty return value for quantize is "null" instead of ""; then changed "null" name to "" :) 0.20 local "type" 0.18, 0.19 Set::Infinite::Element not used anymore. 2.3x speed improvement in tests over version 0.14. 0.17 Correction in Simple.pm line-ending, and TODO filename on Windows Element_Inf and Date.pm test for undefined parameters on OpenBSD 0.16 40% speed improvement in tests over version 0.14. 0.15 20% speed improvement in tests over version 0.14. bigint.t fails; moved to 'todo' directory. `Date' fails in OpenBSD. Doesn't fail in linux or Windows. 0.14 Problems with Bigfloat tests - can't fix them. Moved to `todo' directory. Fixed Bigint tests and warnings in other tests. 0.13 Simple.pm and Element.pm: Corrected many warnings related to testing undef values on hash Quantize.pm and Quantize_Date.pm work on real sized chunks too - don't use `%' integer module operation. Infinite.pm quantize returns tied array. It can be used directly with `foreach'. Pod and tests corrected. Infinite.pm Accepts slices as input. There are syntax problems - see "CAVEATS" in pod. tests added. Simple.pm Will not cleanup if acessed as tied array, until both a and b are defined or a method is called, so that we can set a, then b. 0.12 Correction in Set::Infinite::Simple::intersection [5..5) is null New function: quantize 0.11 Set::Infinite Copyright message Set::Infinite Line 8: # use AutoLoader qw(AUTOLOAD); Deep recursion on subroutine "Set::Infinite::add" at h:/util/Perl/site/lib/Set/Infinite.pm line 318. Deep recursion on subroutine "Set::Infinite::Simple::new" at h:/util/Perl/site/lib/Set/Infinite.pm line 184. solution: Set::Infinite::Element->type and Set::Infinite::Date->date_format use `pop' instead of `shift', or read parameters 0.01 Mon May 14 14:43:09 2001 - made Makefile.PL; v.0.010 Set-Infinite-0.65/lib/0000755000076500000240000000000011365356335014705 5ustar flavioglockstaffSet-Infinite-0.65/lib/Set/0000755000076500000240000000000011365356335015440 5ustar flavioglockstaffSet-Infinite-0.65/lib/Set/Infinite/0000755000076500000240000000000011365356335017205 5ustar flavioglockstaffSet-Infinite-0.65/lib/Set/Infinite/Arithmetic.pm0000644000076500000240000002556111027127720021632 0ustar flavioglockstaffpackage Set::Infinite::Arithmetic; # Copyright (c) 2001 Flavio Soibelmann Glock. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. use strict; # use warnings; require Exporter; use Carp; use Time::Local; use POSIX qw(floor); use vars qw( @EXPORT @EXPORT_OK $inf ); @EXPORT = qw(); @EXPORT_OK = qw(); # @EXPORT_OK = qw( %subs_offset2 %Offset_to_value %Value_to_offset %Init_quantizer ); $inf = 100**100**100; # $Set::Infinite::inf; doesn't work! (why?) =head2 NAME Set::Infinite::Arithmetic - Scalar operations used by quantize() and offset() =head2 AUTHOR Flavio Soibelmann Glock - fglock@pucrs.br =cut use vars qw( $day_size $hour_size $minute_size $second_size ); $day_size = timegm(0,0,0,2,3,2001) - timegm(0,0,0,1,3,2001); $hour_size = $day_size / 24; $minute_size = $hour_size / 60; $second_size = $minute_size / 60; use vars qw( %_MODE %subs_offset2 %Offset_to_value @week_start %Init_quantizer %Value_to_offset %Offset_to_value ); =head2 %_MODE hash of subs $a->offset ( value => [1,2], mode => 'offset', unit => 'days' ); $a->offset ( value => [1,2, -5,-4], mode => 'offset', unit => 'days' ); note: if mode = circle, then "-5" counts from end (like a Perl negative array index). $a->offset ( value => [1,2], mode => 'offset', unit => 'days', strict => $a ); option 'strict' will return intersection($a,offset). Default: none. =cut # return value = ($this, $next, $cmp) %_MODE = ( circle => sub { if ($_[3] >= 0) { &{ $_[0] } ($_[1], $_[3], $_[4] ) } else { &{ $_[0] } ($_[2], $_[3], $_[4] ) } }, begin => sub { &{ $_[0] } ($_[1], $_[3], $_[4] ) }, end => sub { &{ $_[0] } ($_[2], $_[3], $_[4] ) }, offset => sub { my ($this, undef) = &{ $_[0] } ($_[1], $_[3], $_[4] ); my (undef, $next) = &{ $_[0] } ($_[2], $_[3], $_[4] ); ($this, $next); } ); =head2 %subs_offset2($object, $offset1, $offset2) &{ $subs_offset2{$unit} } ($object, $offset1, $offset2); A hash of functions that return: ($object+$offset1, $object+$offset2) in $unit context. Returned $object+$offset1, $object+$offset2 may be scalars or objects. =cut %subs_offset2 = ( weekdays => sub { # offsets to week-day specified # 0 = first sunday from today (or today if today is sunday) # 1 = first monday from today (or today if today is monday) # 6 = first friday from today (or today if today is friday) # 13 = second friday from today # -1 = last saturday from today (not today, even if today were saturday) # -2 = last friday my ($self, $index1, $index2) = @_; return ($self, $self) if $self == $inf; # my $class = ref($self); my @date = gmtime( $self ); my $wday = $date[6]; my ($tmp1, $tmp2); $tmp1 = $index1 - $wday; if ($index1 >= 0) { $tmp1 += 7 if $tmp1 < 0; # it will only happen next week } else { $tmp1 += 7 if $tmp1 < -7; # if will happen this week } $tmp2 = $index2 - $wday; if ($index2 >= 0) { $tmp2 += 7 if $tmp2 < 0; # it will only happen next week } else { $tmp2 += 7 if $tmp2 < -7; # if will happen this week } # print " [ OFS:weekday $self $tmp1 $tmp2 ] \n"; # $date[3] += $tmp1; $tmp1 = $self + $tmp1 * $day_size; # $date[3] += $tmp2 - $tmp1; $tmp2 = $self + $tmp2 * $day_size; ($tmp1, $tmp2); }, years => sub { my ($self, $index, $index2) = @_; return ($self, $self) if $self == $inf; # my $class = ref($self); # print " [ofs:year:$self -- $index]\n"; my @date = gmtime( $self ); $date[5] += 1900 + $index; my $tmp = timegm(@date); $date[5] += $index2 - $index; my $tmp2 = timegm(@date); ($tmp, $tmp2); }, months => sub { my ($self, $index, $index2) = @_; # carp " [ofs:month:$self -- $index -- $inf]"; return ($self, $self) if $self == $inf; # my $class = ref($self); my @date = gmtime( $self ); my $mon = $date[4] + $index; my $year = $date[5] + 1900; # print " [OFS: month: from $year$mon ]\n"; if (($mon > 11) or ($mon < 0)) { my $addyear = floor($mon / 12); $mon = $mon - 12 * $addyear; $year += $addyear; } my $mon2 = $date[4] + $index2; my $year2 = $date[5] + 1900; if (($mon2 > 11) or ($mon2 < 0)) { my $addyear2 = floor($mon2 / 12); $mon2 = $mon2 - 12 * $addyear2; $year2 += $addyear2; } # print " [OFS: month: to $year $mon ]\n"; $date[4] = $mon; $date[5] = $year; my $tmp = timegm(@date); $date[4] = $mon2; $date[5] = $year2; my $tmp2 = timegm(@date); ($tmp, $tmp2); }, days => sub { ( $_[0] + $_[1] * $day_size, $_[0] + $_[2] * $day_size, ) }, weeks => sub { ( $_[0] + $_[1] * (7 * $day_size), $_[0] + $_[2] * (7 * $day_size), ) }, hours => sub { # carp " [ $_[0]+$_[1] hour = ".( $_[0] + $_[1] * $hour_size )." mode=".($_[0]->{mode})." ]"; ( $_[0] + $_[1] * $hour_size, $_[0] + $_[2] * $hour_size, ) }, minutes => sub { ( $_[0] + $_[1] * $minute_size, $_[0] + $_[2] * $minute_size, ) }, seconds => sub { ( $_[0] + $_[1] * $second_size, $_[0] + $_[2] * $second_size, ) }, one => sub { ( $_[0] + $_[1], $_[0] + $_[2], ) }, ); @week_start = ( 0, -1, -2, -3, 3, 2, 1, 0, -1, -2, -3, 3, 2, 1, 0 ); =head2 %Offset_to_value($object, $offset) =head2 %Init_quantizer($object) $Offset_to_value{$unit} ($object, $offset); $Init_quantizer{$unit} ($object); Maps an 'offset value' to a 'value' A hash of functions that return ( int($object) + $offset ) in $unit context. Init_quantizer subroutines must be called before using subs_offset1 functions. int(object)+offset is a scalar. Offset_to_value is optimized for calling it multiple times on the same object, with different offsets. That's why there is a separate initialization subroutine. $self->{offset} is created on initialization. It is an index used by the memoization cache. =cut %Offset_to_value = ( weekyears => sub { my ($self, $index) = @_; my $epoch = timegm( 0,0,0, 1,0,$self->{offset} + $self->{quant} * $index); my @time = gmtime($epoch); # print " [QT_D:weekyears:$self->{offset} + $self->{quant} * $index]\n"; # year modulo week # print " [QT:weekyears: time = ",join(";", @time )," ]\n"; $epoch += ( $week_start[$time[6] + 7 - $self->{wkst}] ) * $day_size; # print " [QT:weekyears: week=",join(";", gmtime($epoch) )," wkst=$self->{wkst} tbl[",$time[6] + 7 - $self->{wkst},"]=",$week_start[$time[6] + 7 - $self->{wkst}]," ]\n\n"; my $epoch2 = timegm( 0,0,0, 1,0,$self->{offset} + $self->{quant} * (1 + $index) ); @time = gmtime($epoch2); $epoch2 += ( $week_start[$time[6] + 7 - $self->{wkst}] ) * $day_size; ( $epoch, $epoch2 ); }, years => sub { my $index = $_[0]->{offset} + $_[0]->{quant} * $_[1]; ( timegm( 0,0,0, 1, 0, $index), timegm( 0,0,0, 1, 0, $index + $_[0]->{quant}) ) }, months => sub { my $mon = $_[0]->{offset} + $_[0]->{quant} * $_[1]; my $year = int($mon / 12); $mon -= $year * 12; my $tmp = timegm( 0,0,0, 1, $mon, $year); $mon += $year * 12 + $_[0]->{quant}; $year = int($mon / 12); $mon -= $year * 12; ( $tmp, timegm( 0,0,0, 1, $mon, $year) ); }, weeks => sub { my $tmp = 3 * $day_size + $_[0]->{quant} * ($_[0]->{offset} + $_[1]); ($tmp, $tmp + $_[0]->{quant}) }, days => sub { my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]); ($tmp, $tmp + $_[0]->{quant}) }, hours => sub { my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]); ($tmp, $tmp + $_[0]->{quant}) }, minutes => sub { my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]); ($tmp, $tmp + $_[0]->{quant}) }, seconds => sub { my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]); ($tmp, $tmp + $_[0]->{quant}) }, one => sub { my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]); ($tmp, $tmp + $_[0]->{quant}) }, ); # Maps an 'offset value' to a 'value' %Value_to_offset = ( one => sub { floor( $_[1] / $_[0]{quant} ) }, seconds => sub { floor( $_[1] / $_[0]{quant} ) }, minutes => sub { floor( $_[1] / $_[0]{quant} ) }, hours => sub { floor( $_[1] / $_[0]{quant} ) }, days => sub { floor( $_[1] / $_[0]{quant} ) }, weeks => sub { floor( ($_[1] - 3 * $day_size) / $_[0]{quant} ) }, months => sub { my @date = gmtime( 0 + $_[1] ); my $tmp = $date[4] + 12 * (1900 + $date[5]); floor( $tmp / $_[0]{quant} ); }, years => sub { my @date = gmtime( 0 + $_[1] ); my $tmp = $date[5] + 1900; floor( $tmp / $_[0]{quant} ); }, weekyears => sub { my ($self, $value) = @_; my @date; # find out YEAR number @date = gmtime( 0 + $value ); my $year = floor( $date[5] + 1900 / $self->{quant} ); # what is the EPOCH for this week-year's begin ? my $begin_epoch = timegm( 0,0,0, 1,0,$year); @date = gmtime($begin_epoch); $begin_epoch += ( $week_start[$date[6] + 7 - $self->{wkst}] ) * $day_size; # what is the EPOCH for this week-year's end ? my $end_epoch = timegm( 0,0,0, 1,0,$year+1); @date = gmtime($end_epoch); $end_epoch += ( $week_start[$date[6] + 7 - $self->{wkst}] ) * $day_size; $year-- if $value < $begin_epoch; $year++ if $value >= $end_epoch; # carp " value=$value offset=$year this_epoch=".$begin_epoch; # carp " next_epoch=".$end_epoch; $year; }, ); # Initialize quantizer %Init_quantizer = ( one => sub {}, seconds => sub { $_[0]->{quant} *= $second_size }, minutes => sub { $_[0]->{quant} *= $minute_size }, hours => sub { $_[0]->{quant} *= $hour_size }, days => sub { $_[0]->{quant} *= $day_size }, weeks => sub { $_[0]->{quant} *= 7 * $day_size }, months => sub {}, years => sub {}, weekyears => sub { $_[0]->{wkst} = 1 unless defined $_[0]->{wkst}; # select which 'cache' to use # $_[0]->{memo} .= $_[0]->{wkst}; }, ); 1; Set-Infinite-0.65/lib/Set/Infinite/Basic.pm0000644000076500000240000006667611365355736020615 0ustar flavioglockstaffpackage Set::Infinite::Basic; # Copyright (c) 2001, 2002, 2003 Flavio Soibelmann Glock. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. require 5.005_03; use strict; require Exporter; use Carp; use Data::Dumper; use vars qw( @ISA @EXPORT_OK @EXPORT ); use vars qw( $Type $tolerance $fixtype $inf $minus_inf @Separators $neg_inf ); @ISA = qw(Exporter); @EXPORT_OK = qw( INFINITY NEG_INFINITY ); @EXPORT = qw(); use constant INFINITY => 100**100**100; use constant NEG_INFINITY => - INFINITY; $inf = INFINITY; $minus_inf = $neg_inf = NEG_INFINITY; use overload '<=>' => \&spaceship, qw("" as_string), ; # TODO: make this an object _and_ class method # TODO: POD sub separators { shift; return $Separators[ $_[0] ] if $#_ == 0; @Separators = @_ if @_; return @Separators; } BEGIN { __PACKAGE__->separators ( '[', ']', # a closed interval '(', ')', # an open interval '..', # number separator ',', # list separator '', '', # set delimiter '{' '}' ); # global defaults for object private vars $Type = undef; $tolerance = 0; $fixtype = 1; } # _simple_* set of internal methods: basic processing of "spans" sub _simple_intersects { my $tmp1 = $_[0]; my $tmp2 = $_[1]; my ($i_beg, $i_end, $open_beg, $open_end); my $cmp = $tmp1->{a} <=> $tmp2->{a}; if ($cmp < 0) { $i_beg = $tmp2->{a}; $open_beg = $tmp2->{open_begin}; } elsif ($cmp > 0) { $i_beg = $tmp1->{a}; $open_beg = $tmp1->{open_begin}; } else { $i_beg = $tmp1->{a}; $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin}; } $cmp = $tmp1->{b} <=> $tmp2->{b}; if ($cmp > 0) { $i_end = $tmp2->{b}; $open_end = $tmp2->{open_end}; } elsif ($cmp < 0) { $i_end = $tmp1->{b}; $open_end = $tmp1->{open_end}; } else { $i_end = $tmp1->{b}; $open_end = ($tmp1->{open_end} || $tmp2->{open_end}); } $cmp = $i_beg <=> $i_end; return 0 if ( $cmp > 0 ) || ( ($cmp == 0) && ($open_beg || $open_end) ) ; return 1; } sub _simple_complement { my $self = $_[0]; if ($self->{b} == $inf) { return if $self->{a} == $neg_inf; return { a => $neg_inf, b => $self->{a}, open_begin => 1, open_end => ! $self->{open_begin} }; } if ($self->{a} == $neg_inf) { return { a => $self->{b}, b => $inf, open_begin => ! $self->{open_end}, open_end => 1 }; } ( { a => $neg_inf, b => $self->{a}, open_begin => 1, open_end => ! $self->{open_begin} }, { a => $self->{b}, b => $inf, open_begin => ! $self->{open_end}, open_end => 1 } ); } sub _simple_union { my ($tmp2, $tmp1, $tolerance) = @_; my $cmp; if ($tolerance) { # "integer" my $a1_open = $tmp1->{open_begin} ? -$tolerance : $tolerance ; my $b1_open = $tmp1->{open_end} ? -$tolerance : $tolerance ; my $a2_open = $tmp2->{open_begin} ? -$tolerance : $tolerance ; my $b2_open = $tmp2->{open_end} ? -$tolerance : $tolerance ; # open_end touching? if ((($tmp1->{b}+$tmp1->{b}) + $b1_open ) < (($tmp2->{a}+$tmp2->{a}) - $a2_open)) { # self disjuncts b return ( $tmp1, $tmp2 ); } if ((($tmp1->{a}+$tmp1->{a}) - $a1_open ) > (($tmp2->{b}+$tmp2->{b}) + $b2_open)) { # self disjuncts b return ( $tmp2, $tmp1 ); } } else { # "real" $cmp = $tmp1->{b} <=> $tmp2->{a}; if ( $cmp < 0 || ( $cmp == 0 && $tmp1->{open_end} && $tmp2->{open_begin} ) ) { return ( $tmp1, $tmp2 ); } $cmp = $tmp1->{a} <=> $tmp2->{b}; if ( $cmp > 0 || ( $cmp == 0 && $tmp2->{open_end} && $tmp1->{open_begin} ) ) { return ( $tmp2, $tmp1 ); } } my $tmp; $cmp = $tmp1->{a} <=> $tmp2->{a}; if ($cmp > 0) { $tmp->{a} = $tmp2->{a}; $tmp->{open_begin} = $tmp2->{open_begin}; } elsif ($cmp == 0) { $tmp->{a} = $tmp1->{a}; $tmp->{open_begin} = $tmp1->{open_begin} ? $tmp2->{open_begin} : 0; } else { $tmp->{a} = $tmp1->{a}; $tmp->{open_begin} = $tmp1->{open_begin}; } $cmp = $tmp1->{b} <=> $tmp2->{b}; if ($cmp < 0) { $tmp->{b} = $tmp2->{b}; $tmp->{open_end} = $tmp2->{open_end}; } elsif ($cmp == 0) { $tmp->{b} = $tmp1->{b}; $tmp->{open_end} = $tmp1->{open_end} ? $tmp2->{open_end} : 0; } else { $tmp->{b} = $tmp1->{b}; $tmp->{open_end} = $tmp1->{open_end}; } return $tmp; } sub _simple_spaceship { my ($tmp1, $tmp2, $inverted) = @_; my $cmp; if ($inverted) { $cmp = $tmp2->{a} <=> $tmp1->{a}; return $cmp if $cmp; $cmp = $tmp1->{open_begin} <=> $tmp2->{open_begin}; return $cmp if $cmp; $cmp = $tmp2->{b} <=> $tmp1->{b}; return $cmp if $cmp; return $tmp1->{open_end} <=> $tmp2->{open_end}; } $cmp = $tmp1->{a} <=> $tmp2->{a}; return $cmp if $cmp; $cmp = $tmp2->{open_begin} <=> $tmp1->{open_begin}; return $cmp if $cmp; $cmp = $tmp1->{b} <=> $tmp2->{b}; return $cmp if $cmp; return $tmp2->{open_end} <=> $tmp1->{open_end}; } sub _simple_new { my ($tmp, $tmp2, $type) = @_; if ($type) { if ( ref($tmp) ne $type ) { $tmp = new $type $tmp; } if ( ref($tmp2) ne $type ) { $tmp2 = new $type $tmp2; } } if ($tmp > $tmp2) { carp "Invalid interval specification: start value is after end"; # ($tmp, $tmp2) = ($tmp2, $tmp); } return { a => $tmp , b => $tmp2 , open_begin => 0 , open_end => 0 }; } sub _simple_as_string { my $set = shift; my $self = $_[0]; my $s; return "" unless defined $self; $self->{open_begin} = 1 if ($self->{a} == -$inf ); $self->{open_end} = 1 if ($self->{b} == $inf ); my $tmp1 = $self->{a}; $tmp1 = $tmp1->datetime if UNIVERSAL::can( $tmp1, 'datetime' ); $tmp1 = "$tmp1"; my $tmp2 = $self->{b}; $tmp2 = $tmp2->datetime if UNIVERSAL::can( $tmp2, 'datetime' ); $tmp2 = "$tmp2"; return $tmp1 if $tmp1 eq $tmp2; $s = $self->{open_begin} ? $set->separators(2) : $set->separators(0); $s .= $tmp1 . $set->separators(4) . $tmp2; $s .= $self->{open_end} ? $set->separators(3) : $set->separators(1); return $s; } # end of "_simple_" methods sub type { my $self = shift; unless (@_) { return ref($self) ? $self->{type} : $Type; } my $tmp_type = shift; eval "use " . $tmp_type; carp "Warning: can't start $tmp_type : $@" if $@; if (ref($self)) { $self->{type} = $tmp_type; return $self; } else { $Type = $tmp_type; return $Type; } } sub list { my $self = shift; my @b = (); foreach (@{$self->{list}}) { push @b, $self->new($_); } return @b; } sub fixtype { my $self = shift; $self = $self->copy; $self->{fixtype} = 1; my $type = $self->type; return $self unless $type; foreach (@{$self->{list}}) { $_->{a} = $type->new($_->{a}) unless ref($_->{a}) eq $type; $_->{b} = $type->new($_->{b}) unless ref($_->{b}) eq $type; } return $self; } sub numeric { my $self = shift; return $self unless $self->{fixtype}; $self = $self->copy; $self->{fixtype} = 0; foreach (@{$self->{list}}) { $_->{a} = 0 + $_->{a}; $_->{b} = 0 + $_->{b}; } return $self; } sub _no_cleanup { $_[0] } # obsolete sub first { my $self = $_[0]; if (exists $self->{first} ) { return wantarray ? @{$self->{first}} : $self->{first}[0]; } unless ( @{$self->{list}} ) { return wantarray ? (undef, 0) : undef; } my $first = $self->new( $self->{list}[0] ); return $first unless wantarray; my $res = $self->new; push @{$res->{list}}, @{$self->{list}}[1 .. $#{$self->{list}}]; return @{$self->{first}} = ($first) if $res->is_null; return @{$self->{first}} = ($first, $res); } sub last { my $self = $_[0]; if (exists $self->{last} ) { return wantarray ? @{$self->{last}} : $self->{last}[0]; } unless ( @{$self->{list}} ) { return wantarray ? (undef, 0) : undef; } my $last = $self->new( $self->{list}[-1] ); return $last unless wantarray; my $res = $self->new; push @{$res->{list}}, @{$self->{list}}[0 .. $#{$self->{list}}-1]; return @{$self->{last}} = ($last) if $res->is_null; return @{$self->{last}} = ($last, $res); } sub is_null { @{$_[0]->{list}} ? 0 : 1; } sub is_empty { $_[0]->is_null; } sub is_nonempty { ! $_[0]->is_null; } sub is_span { ( $#{$_[0]->{list}} == 0 ) ? 1 : 0; } sub is_singleton { ( $#{$_[0]->{list}} == 0 && $_[0]->{list}[0]{a} == $_[0]->{list}[0]{b} ) ? 1 : 0; } sub is_subset { my $a1 = shift; my $b1; if (ref ($_[0]) eq ref($a1) ) { $b1 = shift; } else { $b1 = $a1->new(@_); } return $b1->contains( $a1 ); } sub is_proper_subset { my $a1 = shift; my $b1; if (ref ($_[0]) eq ref($a1) ) { $b1 = shift; } else { $b1 = $a1->new(@_); } my $contains = $b1->contains( $a1 ); return $contains unless $contains; my $equal = ( $a1 == $b1 ); return $equal if !defined $equal || $equal; return 1; } sub is_disjoint { my $intersects = shift->intersects( @_ ); return ! $intersects if defined $intersects; return $intersects; } sub iterate { # TODO: options 'no-sort', 'no-merge', 'keep-null' ... my $a1 = shift; my $iterate = $a1->empty_set(); my (@tmp, $ia); my $subroutine = shift; foreach $ia (0 .. $#{$a1->{list}}) { @tmp = $subroutine->( $a1->new($a1->{list}[$ia]), @_ ); $iterate = $iterate->union(@tmp) if @tmp; } return $iterate; } sub intersection { my $a1 = shift; my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_); return _intersection ( 'intersection', $a1, $b1 ); } sub intersects { my $a1 = shift; my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_); return _intersection ( 'intersects', $a1, $b1 ); } sub intersected_spans { my $a1 = shift; my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_); return _intersection ( 'intersected_spans', $a1, $b1 ); } sub _intersection { my ( $op, $a1, $b1 ) = @_; my $ia; my ( $a0, $na ) = ( 0, $#{$a1->{list}} ); my ( $tmp1, $tmp1a, $tmp2a, $tmp1b, $tmp2b, $i_beg, $i_end, $open_beg, $open_end ); my ( $cmp1, $cmp2 ); my @a; # for-loop optimization (makes little difference) # This was kept for backward compatibility with Date::Set tests my $self = $a1; if ($na < $#{ $b1->{list} }) { $na = $#{ $b1->{list} }; ($a1, $b1) = ($b1, $a1); } # --- B: foreach my $tmp2 ( @{ $b1->{list} } ) { $tmp2a = $tmp2->{a}; $tmp2b = $tmp2->{b}; A: foreach $ia ($a0 .. $na) { $tmp1 = $a1->{list}[$ia]; $tmp1b = $tmp1->{b}; if ($tmp1b < $tmp2a) { $a0++; next A; } $tmp1a = $tmp1->{a}; if ($tmp1a > $tmp2b) { next B; } $cmp1 = $tmp1a <=> $tmp2a; if ( $cmp1 < 0 ) { $tmp1a = $tmp2a; $open_beg = $tmp2->{open_begin}; } elsif ( $cmp1 ) { $open_beg = $tmp1->{open_begin}; } else { $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin}; } $cmp2 = $tmp1b <=> $tmp2b; if ( $cmp2 > 0 ) { $tmp1b = $tmp2b; $open_end = $tmp2->{open_end}; } elsif ( $cmp2 ) { $open_end = $tmp1->{open_end}; } else { $open_end = $tmp1->{open_end} || $tmp2->{open_end}; } if ( ( $tmp1a <= $tmp1b ) && ( ($tmp1a != $tmp1b) || (!$open_beg and !$open_end) || ($tmp1a == $inf) || # XXX ($tmp1a == $neg_inf) ) ) { if ( $op eq 'intersection' ) { push @a, { a => $tmp1a, b => $tmp1b, open_begin => $open_beg, open_end => $open_end } ; } if ( $op eq 'intersects' ) { return 1; } if ( $op eq 'intersected_spans' ) { push @a, $tmp1; $a0++; next A; } } } } return 0 if $op eq 'intersects'; my $intersection = $self->new(); $intersection->{list} = \@a; return $intersection; } sub complement { my $self = shift; if (@_) { my $a1; if (ref ($_[0]) eq ref($self) ) { $a1 = shift; } else { $a1 = $self->new(@_); } return $self->intersection( $a1->complement ); } unless ( @{$self->{list}} ) { return $self->universal_set; } my $complement = $self->empty_set(); @{$complement->{list}} = _simple_complement($self->{list}[0]); my $tmp = $self->empty_set(); foreach my $ia (1 .. $#{$self->{list}}) { @{$tmp->{list}} = _simple_complement($self->{list}[$ia]); $complement = $complement->intersection($tmp); } return $complement; } sub until { my $a1 = shift; my $b1; if (ref ($_[0]) eq ref($a1) ) { $b1 = shift; } else { $b1 = $a1->new(@_); } my @b1_min = $b1->min_a; my @a1_max = $a1->max_a; unless (defined $b1_min[0]) { return $a1->until($inf); } unless (defined $a1_max[0]) { return $a1->new(-$inf)->until($b1); } my ($ia, $ib, $begin, $end); $ia = 0; $ib = 0; my $u = $a1->new; my $last = -$inf; while ( ($ia <= $#{$a1->{list}}) && ($ib <= $#{$b1->{list}})) { $begin = $a1->{list}[$ia]{a}; $end = $b1->{list}[$ib]{b}; if ( $end <= $begin ) { push @{$u->{list}}, { a => $last , b => $end , open_begin => 0 , open_end => 1 }; $ib++; $last = $end; next; } push @{$u->{list}}, { a => $begin , b => $end , open_begin => 0 , open_end => 1 }; $ib++; $ia++; $last = $end; } if ($ia <= $#{$a1->{list}} && $a1->{list}[$ia]{a} >= $last ) { push @{$u->{list}}, { a => $a1->{list}[$ia]{a} , b => $inf , open_begin => 0 , open_end => 1 }; } return $u; } sub start_set { return $_[0]->iterate( sub { $_[0]->min } ); } sub end_set { return $_[0]->iterate( sub { $_[0]->max } ); } sub union { my $a1 = shift; my $b1; if (ref ($_[0]) eq ref($a1) ) { $b1 = shift; } else { $b1 = $a1->new(@_); } # test for union with empty set if ( $#{ $a1->{list} } < 0 ) { return $b1; } if ( $#{ $b1->{list} } < 0 ) { return $a1; } my @b1_min = $b1->min_a; my @a1_max = $a1->max_a; unless (defined $b1_min[0]) { return $a1; } unless (defined $a1_max[0]) { return $b1; } my ($ia, $ib); $ia = 0; $ib = 0; # size+order matters on speed $a1 = $a1->new($a1); # don't modify ourselves my $b_list = $b1->{list}; # -- frequent case - $b1 is after $a1 if ($b1_min[0] > $a1_max[0]) { push @{$a1->{list}}, @$b_list; return $a1; } my @tmp; my $is_real = !$a1->tolerance && !$b1->tolerance; B: foreach $ib ($ib .. $#{$b_list}) { foreach $ia ($ia .. $#{$a1->{list}}) { @tmp = _simple_union($a1->{list}[$ia], $b_list->[$ib], $a1->{tolerance}); if ($#tmp == 0) { $a1->{list}[$ia] = $tmp[0]; while (1) { last if $ia >= $#{$a1->{list}}; last unless _simple_intersects ( $a1->{list}[$ia], $a1->{list}[$ia + 1] ) || $is_real && $a1->{list}[$ia]{b} == $a1->{list}[$ia + 1]{a}; @tmp = _simple_union($a1->{list}[$ia], $a1->{list}[$ia + 1], $a1->{tolerance}); last unless @tmp == 1; $a1->{list}[$ia] = $tmp[0]; splice( @{$a1->{list}}, $ia + 1, 1 ); } next B; } if ($a1->{list}[$ia]{a} >= $b_list->[$ib]{a}) { splice (@{$a1->{list}}, $ia, 0, $b_list->[$ib]); next B; } } push @{$a1->{list}}, $b_list->[$ib]; } return $a1; } # there are some ways to process 'contains': # A CONTAINS B IF A == ( A UNION B ) # - faster # A CONTAINS B IF B == ( A INTERSECTION B ) # - can backtrack = works for unbounded sets sub contains { my $a1 = shift; my $b1 = $a1->union(@_); return ($b1 == $a1) ? 1 : 0; } sub copy { my $self = shift; my $copy = $self->empty_set(); ## return $copy unless ref($self); # constructor! foreach my $key (keys %{$self}) { if ( ref( $self->{$key} ) eq 'ARRAY' ) { @{ $copy->{$key} } = @{ $self->{$key} }; } else { $copy->{$key} = $self->{$key}; } } return $copy; } *clone = \© sub new { my $class = shift; my $self; if ( ref $class ) { $self = bless { list => [], tolerance => $class->{tolerance}, type => $class->{type}, fixtype => $class->{fixtype}, }, ref($class); } else { $self = bless { list => [], tolerance => $tolerance ? $tolerance : 0, type => $class->type, fixtype => $fixtype ? $fixtype : 0, }, $class; } my ($tmp, $tmp2, $ref); while (@_) { $tmp = shift; $ref = ref($tmp); if ($ref) { if ($ref eq 'ARRAY') { # allows arrays of arrays $tmp = $class->new(@$tmp); # call new() recursively push @{ $self->{list} }, @{$tmp->{list}}; next; } if ($ref eq 'HASH') { push @{ $self->{list} }, $tmp; next; } if ($tmp->isa(__PACKAGE__)) { push @{ $self->{list} }, @{$tmp->{list}}; next; } } if ( @_ ) { $tmp2 = shift } else { $tmp2 = $tmp } push @{ $self->{list} }, _simple_new($tmp,$tmp2, $self->{type} ) } $self; } sub empty_set { $_[0]->new; } sub universal_set { $_[0]->new( NEG_INFINITY, INFINITY ); } *minus = \∁ *difference = \∁ sub symmetric_difference { my $a1 = shift; my $b1; if (ref ($_[0]) eq ref($a1) ) { $b1 = shift; } else { $b1 = $a1->new(@_); } return $a1->complement( $b1 )->union( $b1->complement( $a1 ) ); } *simmetric_difference = \&symmetric_difference; # bugfix sub min { ($_[0]->min_a)[0]; } sub min_a { my $self = $_[0]; return @{$self->{min}} if exists $self->{min}; return @{$self->{min}} = (undef, 0) unless @{$self->{list}}; my $tmp = $self->{list}[0]{a}; my $tmp2 = $self->{list}[0]{open_begin} || 0; if ($tmp2 && $self->{tolerance}) { $tmp2 = 0; $tmp += $self->{tolerance}; } return @{$self->{min}} = ($tmp, $tmp2); }; sub max { ($_[0]->max_a)[0]; } sub max_a { my $self = $_[0]; return @{$self->{max}} if exists $self->{max}; return @{$self->{max}} = (undef, 0) unless @{$self->{list}}; my $tmp = $self->{list}[-1]{b}; my $tmp2 = $self->{list}[-1]{open_end} || 0; if ($tmp2 && $self->{tolerance}) { $tmp2 = 0; $tmp -= $self->{tolerance}; } return @{$self->{max}} = ($tmp, $tmp2); }; sub count { 1 + $#{$_[0]->{list}}; } sub size { my $self = $_[0]; my $size; foreach( @{$self->{list}} ) { if ( $size ) { $size += $_->{b} - $_->{a}; } else { $size = $_->{b} - $_->{a}; } if ( $self->{tolerance} ) { $size += $self->{tolerance} unless $_->{open_end}; $size -= $self->{tolerance} if $_->{open_begin}; $size -= $self->{tolerance} if $_->{open_end}; } } return $size; }; sub span { my $self = $_[0]; my @max = $self->max_a; my @min = $self->min_a; return undef unless defined $min[0] && defined $max[0]; my $a1 = $self->new($min[0], $max[0]); $a1->{list}[0]{open_end} = $max[1]; $a1->{list}[0]{open_begin} = $min[1]; return $a1; }; sub spaceship { my ($tmp1, $tmp2, $inverted) = @_; if ($inverted) { ($tmp2, $tmp1) = ($tmp1, $tmp2); } foreach(0 .. $#{$tmp1->{list}}) { my $this = $tmp1->{list}[$_]; if ($_ > $#{ $tmp2->{list} } ) { return 1; } my $other = $tmp2->{list}[$_]; my $cmp = _simple_spaceship($this, $other); return $cmp if $cmp; # this != $other; } return $#{ $tmp1->{list} } == $#{ $tmp2->{list} } ? 0 : -1; } sub tolerance { my $self = shift; my $tmp = pop; if (ref($self)) { # local return $self->{tolerance} unless defined $tmp; $self = $self->copy; $self->{tolerance} = $tmp; delete $self->{max}; # tolerance may change "max" $_ = 1; my @tmp; while ( $_ <= $#{$self->{list}} ) { @tmp = Set::Infinite::Basic::_simple_union($self->{list}->[$_], $self->{list}->[$_ - 1], $self->{tolerance}); if ($#tmp == 0) { $self->{list}->[$_ - 1] = $tmp[0]; splice (@{$self->{list}}, $_, 1); } else { $_ ++; } } return $self; } # global $tolerance = $tmp if defined($tmp); return $tolerance; } sub integer { $_[0]->tolerance (1); } sub real { $_[0]->tolerance (0); } sub as_string { my $self = shift; return $self->separators(6) . join( $self->separators(5), map { $self->_simple_as_string($_) } @{$self->{list}} ) . $self->separators(7),; } sub DESTROY {} 1; __END__ =head1 NAME Set::Infinite::Basic - Sets of intervals 6 =head1 SYNOPSIS use Set::Infinite::Basic; $set = Set::Infinite::Basic->new(1,2); # [1..2] print $set->union(5,6); # [1..2],[5..6] =head1 DESCRIPTION Set::Infinite::Basic is a Set Theory module for infinite sets. It works on reals, integers, and objects. This module does not support recurrences. Recurrences are implemented in Set::Infinite. =head1 METHODS =head2 empty_set Creates an empty_set. If called from an existing set, the empty set inherits the "type" and "density" characteristics. =head2 universal_set Creates a set containing "all" possible elements. If called from an existing set, the universal set inherits the "type" and "density" characteristics. =head2 until Extends a set until another: 0,5,7 -> until 2,6,10 gives [0..2), [5..6), [7..10) Note: this function is still experimental. =head2 copy =head2 clone Makes a new object from the object's data. =head2 Mode functions: $set = $set->real; $set = $set->integer; =head2 Logic functions: $logic = $set->intersects($b); $logic = $set->contains($b); $logic = $set->is_null; # also called "is_empty" =head2 Set functions: $set = $set->union($b); $set = $set->intersection($b); $set = $set->complement; $set = $set->complement($b); # can also be called "minus" or "difference" $set = $set->symmetric_difference( $b ); $set = $set->span; result is (min .. max) =head2 Scalar functions: $i = $set->min; $i = $set->max; $i = $set->size; $i = $set->count; # number of spans =head2 Overloaded Perl functions: print sort, <=> =head2 Global functions: separators(@i) chooses the interval separators. default are [ ] ( ) '..' ','. INFINITY returns an 'Infinity' number. NEG_INFINITY returns a '-Infinity' number. iterate ( sub { } ) Iterates over a subroutine. Returns the union of partial results. first In scalar context returns the first interval of a set. In list context returns the first interval of a set, and the 'tail'. Works in unbounded sets type($i) chooses an object data type. default is none (a normal perl SCALAR). examples: type('Math::BigFloat'); type('Math::BigInt'); type('Set::Infinite::Date'); See notes on Set::Infinite::Date below. tolerance(0) defaults to real sets (default) tolerance(1) defaults to integer sets real defaults to real sets (default) integer defaults to integer sets =head2 Internal functions: $set->fixtype; $set->numeric; =head1 CAVEATS $set = Set::Infinite->new(10,1); Will be interpreted as [1..10] $set = Set::Infinite->new(1,2,3,4); Will be interpreted as [1..2],[3..4] instead of [1,2,3,4]. You probably want ->new([1],[2],[3],[4]) instead, or maybe ->new(1,4) $set = Set::Infinite->new(1..3); Will be interpreted as [1..2],3 instead of [1,2,3]. You probably want ->new(1,3) instead. =head1 INTERNALS The internal representation of a I is a hash: { a => start of span, b => end of span, open_begin => '0' the span starts in 'a' '1' the span starts after 'a' open_end => '0' the span ends in 'b' '1' the span ends before 'b' } For example, this set: [100..200),300,(400..infinity) is represented by the array of hashes: list => [ { a => 100, b => 200, open_begin => 0, open_end => 1 }, { a => 300, b => 300, open_begin => 0, open_end => 0 }, { a => 400, b => infinity, open_begin => 0, open_end => 1 }, ] The I of a set is stored in the C variable: tolerance => 0; # the set is made of real numbers. tolerance => 1; # the set is made of integers. The C variable stores the I of objects that will be stored in the set. type => 'DateTime'; # this is a set of DateTime objects The I value is generated by Perl, when it finds a numerical overflow: $inf = 100**100**100; =head1 SEE ALSO Set::Infinite =head1 AUTHOR Flavio S. Glock =cut Set-Infinite-0.65/lib/Set/Infinite.pm0000644000076500000240000015503611365355672017560 0ustar flavioglockstaffpackage Set::Infinite; # Copyright (c) 2001, 2002, 2003, 2004 Flavio Soibelmann Glock. # All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. use 5.005_03; # These methods are inherited from Set::Infinite::Basic "as-is": # type list fixtype numeric min max integer real new span copy # start_set end_set universal_set empty_set minus difference # symmetric_difference is_empty use strict; use base qw(Set::Infinite::Basic Exporter); use Carp; use Set::Infinite::Arithmetic; use overload '<=>' => \&spaceship, '""' => \&as_string; use vars qw(@EXPORT_OK $VERSION $TRACE $DEBUG_BT $PRETTY_PRINT $inf $minus_inf $neg_inf %_first %_last %_backtrack $too_complex $backtrack_depth $max_backtrack_depth $max_intersection_depth $trace_level %level_title ); @EXPORT_OK = qw(inf $inf trace_open trace_close); $inf = 100**100**100; $neg_inf = $minus_inf = -$inf; # obsolete methods - included for backward compatibility sub inf () { $inf } sub minus_inf () { $minus_inf } sub no_cleanup { $_[0] } *type = \&Set::Infinite::Basic::type; sub compact { @_ } BEGIN { $VERSION = "0.65"; $TRACE = 0; # enable basic trace method execution $DEBUG_BT = 0; # enable backtrack tracer $PRETTY_PRINT = 0; # 0 = print 'Too Complex'; 1 = describe functions $trace_level = 0; # indentation level when debugging $too_complex = "Too complex"; $backtrack_depth = 0; $max_backtrack_depth = 10; # _backtrack() $max_intersection_depth = 5; # first() } sub trace { # title=>'aaa' return $_[0] unless $TRACE; my ($self, %parm) = @_; my @caller = caller(1); # print "self $self ". ref($self). "\n"; print "" . ( ' | ' x $trace_level ) . "$parm{title} ". $self->copy . ( exists $parm{arg} ? " -- " . $parm{arg}->copy : "" ). " $caller[1]:$caller[2] ]\n" if $TRACE == 1; return $self; } sub trace_open { return $_[0] unless $TRACE; my ($self, %parm) = @_; my @caller = caller(1); print "" . ( ' | ' x $trace_level ) . "\\ $parm{title} ". $self->copy . ( exists $parm{arg} ? " -- ". $parm{arg}->copy : "" ). " $caller[1]:$caller[2] ]\n"; $trace_level++; $level_title{$trace_level} = $parm{title}; return $self; } sub trace_close { return $_[0] unless $TRACE; my ($self, %parm) = @_; my @caller = caller(0); print "" . ( ' | ' x ($trace_level-1) ) . "\/ $level_title{$trace_level} ". ( exists $parm{arg} ? ( defined $parm{arg} ? "ret ". ( UNIVERSAL::isa($parm{arg}, __PACKAGE__ ) ? $parm{arg}->copy : "<$parm{arg}>" ) : "undef" ) : "" # no arg ). " $caller[1]:$caller[2] ]\n"; $trace_level--; return $self; } # creates a 'function' object that can be solved by _backtrack() sub _function { my ($self, $method) = (shift, shift); my $b = $self->empty_set(); $b->{too_complex} = 1; $b->{parent} = $self; $b->{method} = $method; $b->{param} = [ @_ ]; return $b; } # same as _function, but with 2 arguments sub _function2 { my ($self, $method, $arg) = (shift, shift, shift); unless ( $self->{too_complex} || $arg->{too_complex} ) { return $self->$method($arg, @_); } my $b = $self->empty_set(); $b->{too_complex} = 1; $b->{parent} = [ $self, $arg ]; $b->{method} = $method; $b->{param} = [ @_ ]; return $b; } sub quantize { my $self = shift; $self->trace_open(title=>"quantize") if $TRACE; my @min = $self->min_a; my @max = $self->max_a; if (($self->{too_complex}) or (defined $min[0] && $min[0] == $neg_inf) or (defined $max[0] && $max[0] == $inf)) { return $self->_function( 'quantize', @_ ); } my @a; my %rule = @_; my $b = $self->empty_set(); my $parent = $self; $rule{unit} = 'one' unless $rule{unit}; $rule{quant} = 1 unless $rule{quant}; $rule{parent} = $parent; $rule{strict} = $parent unless exists $rule{strict}; $rule{type} = $parent->{type}; my ($min, $open_begin) = $parent->min_a; unless (defined $min) { $self->trace_close( arg => $b ) if $TRACE; return $b; } $rule{fixtype} = 1 unless exists $rule{fixtype}; $Set::Infinite::Arithmetic::Init_quantizer{$rule{unit}}->(\%rule); $rule{sub_unit} = $Set::Infinite::Arithmetic::Offset_to_value{$rule{unit}}; carp "Quantize unit '".$rule{unit}."' not implemented" unless ref( $rule{sub_unit} ) eq 'CODE'; my ($max, $open_end) = $parent->max_a; $rule{offset} = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $min); my $last_offset = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $max); $rule{size} = $last_offset - $rule{offset} + 1; my ($index, $tmp, $this, $next); for $index (0 .. $rule{size} ) { # ($this, $next) = $rule{sub_unit} (\%rule, $index); ($this, $next) = $rule{sub_unit}->(\%rule, $index); unless ( $rule{fixtype} ) { $tmp = { a => $this , b => $next , open_begin => 0, open_end => 1 }; } else { $tmp = Set::Infinite::Basic::_simple_new($this,$next, $rule{type} ); $tmp->{open_end} = 1; } next if ( $rule{strict} and not $rule{strict}->intersects($tmp)); push @a, $tmp; } $b->{list} = \@a; # change data $self->trace_close( arg => $b ) if $TRACE; return $b; } sub _first_n { my $self = shift; my $n = shift; my $tail = $self->copy; my @result; my $first; for ( 1 .. $n ) { ( $first, $tail ) = $tail->first if $tail; push @result, $first; } return $tail, @result; } sub _last_n { my $self = shift; my $n = shift; my $tail = $self->copy; my @result; my $last; for ( 1 .. $n ) { ( $last, $tail ) = $tail->last if $tail; unshift @result, $last; } return $tail, @result; } sub select { my $self = shift; $self->trace_open(title=>"select") if $TRACE; my %param = @_; die "select() - parameter 'freq' is deprecated" if exists $param{freq}; my $res; my $count; my @by; @by = @{ $param{by} } if exists $param{by}; $count = delete $param{count} || $inf; # warn "select: count=$count by=[@by]"; if ($count <= 0) { $self->trace_close( arg => $res ) if $TRACE; return $self->empty_set(); } my @set; my $tail; my $first; my $last; if ( @by ) { my @res; if ( ! $self->is_too_complex ) { $res = $self->new; @res = @{ $self->{list} }[ @by ] ; } else { my ( @pos_by, @neg_by ); for ( @by ) { ( $_ < 0 ) ? push @neg_by, $_ : push @pos_by, $_; } my @first; if ( @pos_by ) { @pos_by = sort { $a <=> $b } @pos_by; ( $tail, @set ) = $self->_first_n( 1 + $pos_by[-1] ); @first = @set[ @pos_by ]; } my @last; if ( @neg_by ) { @neg_by = sort { $a <=> $b } @neg_by; ( $tail, @set ) = $self->_last_n( - $neg_by[0] ); @last = @set[ @neg_by ]; } @res = map { $_->{list}[0] } ( @first , @last ); } $res = $self->new; @res = sort { $a->{a} <=> $b->{a} } grep { defined } @res; my $last; my @a; for ( @res ) { push @a, $_ if ! $last || $last->{a} != $_->{a}; $last = $_; } $res->{list} = \@a; } else { $res = $self; } return $res if $count == $inf; my $count_set = $self->empty_set(); if ( ! $self->is_too_complex ) { my @a; @a = grep { defined } @{ $res->{list} }[ 0 .. $count - 1 ] ; $count_set->{list} = \@a; } else { my $last; while ( $res ) { ( $first, $res ) = $res->first; last unless $first; last if $last && $last->{a} == $first->{list}[0]{a}; $last = $first->{list}[0]; push @{$count_set->{list}}, $first->{list}[0]; $count--; last if $count <= 0; } } return $count_set; } BEGIN { # %_first and %_last hashes are used to backtrack the value # of first() and last() of an infinite set %_first = ( 'complement' => sub { my $self = $_[0]; my @parent_min = $self->{parent}->first; unless ( defined $parent_min[0] ) { return (undef, 0); } my $parent_complement; my $first; my @next; my $parent; if ( $parent_min[0]->min == $neg_inf ) { my @parent_second = $parent_min[1]->first; # (-inf..min) (second..?) # (min..second) = complement $first = $self->new( $parent_min[0]->complement ); $first->{list}[0]{b} = $parent_second[0]->{list}[0]{a}; $first->{list}[0]{open_end} = ! $parent_second[0]->{list}[0]{open_begin}; @{ $first->{list} } = () if ( $first->{list}[0]{a} == $first->{list}[0]{b}) && ( $first->{list}[0]{open_begin} || $first->{list}[0]{open_end} ); @next = $parent_second[0]->max_a; $parent = $parent_second[1]; } else { # (min..?) # (-inf..min) = complement $parent_complement = $parent_min[0]->complement; $first = $self->new( $parent_complement->{list}[0] ); @next = $parent_min[0]->max_a; $parent = $parent_min[1]; } my @no_tail = $self->new($neg_inf,$next[0]); $no_tail[0]->{list}[0]{open_end} = $next[1]; my $tail = $parent->union($no_tail[0])->complement; return ($first, $tail); }, # end: first-complement 'intersection' => sub { my $self = $_[0]; my @parent = @{ $self->{parent} }; # warn "$method parents @parent"; my $retry_count = 0; my (@first, @min, $which, $first1, $intersection); SEARCH: while ($retry_count++ < $max_intersection_depth) { return undef unless defined $parent[0]; return undef unless defined $parent[1]; @{$first[0]} = $parent[0]->first; @{$first[1]} = $parent[1]->first; unless ( defined $first[0][0] ) { # warn "don't know first of $method"; $self->trace_close( arg => 'undef' ) if $TRACE; return undef; } unless ( defined $first[1][0] ) { # warn "don't know first of $method"; $self->trace_close( arg => 'undef' ) if $TRACE; return undef; } @{$min[0]} = $first[0][0]->min_a; @{$min[1]} = $first[1][0]->min_a; unless ( defined $min[0][0] && defined $min[1][0] ) { return undef; } # $which is the index to the bigger "first". $which = ($min[0][0] < $min[1][0]) ? 1 : 0; for my $which1 ( $which, 1 - $which ) { my $tmp_parent = $parent[$which1]; ($first1, $parent[$which1]) = @{ $first[$which1] }; if ( $first1->is_empty ) { # warn "first1 empty! count $retry_count"; # trace_close; # return $first1, undef; $intersection = $first1; $which = $which1; last SEARCH; } $intersection = $first1->intersection( $parent[1-$which1] ); # warn "intersection with $first1 is $intersection"; unless ( $intersection->is_null ) { # $self->trace( title=>"got an intersection" ); if ( $intersection->is_too_complex ) { $parent[$which1] = $tmp_parent; } else { $which = $which1; last SEARCH; } }; } } if ( $#{ $intersection->{list} } > 0 ) { my $tail; ($intersection, $tail) = $intersection->first; $parent[$which] = $parent[$which]->union( $tail ); } my $tmp; if ( defined $parent[$which] and defined $parent[1-$which] ) { $tmp = $parent[$which]->intersection ( $parent[1-$which] ); } return ($intersection, $tmp); }, # end: first-intersection 'union' => sub { my $self = $_[0]; my (@first, @min); my @parent = @{ $self->{parent} }; @{$first[0]} = $parent[0]->first; @{$first[1]} = $parent[1]->first; unless ( defined $first[0][0] ) { # looks like one set was empty return @{$first[1]}; } @{$min[0]} = $first[0][0]->min_a; @{$min[1]} = $first[1][0]->min_a; # check min1/min2 for undef unless ( defined $min[0][0] ) { $self->trace_close( arg => "@{$first[1]}" ) if $TRACE; return @{$first[1]} } unless ( defined $min[1][0] ) { $self->trace_close( arg => "@{$first[0]}" ) if $TRACE; return @{$first[0]} } my $which = ($min[0][0] < $min[1][0]) ? 0 : 1; my $first = $first[$which][0]; # find out the tail my $parent1 = $first[$which][1]; # warn $self->{parent}[$which]." - $first = $parent1"; my $parent2 = ($min[0][0] == $min[1][0]) ? $self->{parent}[1-$which]->complement($first) : $self->{parent}[1-$which]; my $tail; if (( ! defined $parent1 ) || $parent1->is_null) { # warn "union parent1 tail is null"; $tail = $parent2; } else { my $method = $self->{method}; $tail = $parent1->$method( $parent2 ); } if ( $first->intersects( $tail ) ) { my $first2; ( $first2, $tail ) = $tail->first; $first = $first->union( $first2 ); } $self->trace_close( arg => "$first $tail" ) if $TRACE; return ($first, $tail); }, # end: first-union 'iterate' => sub { my $self = $_[0]; my $parent = $self->{parent}; my ($first, $tail) = $parent->first; $first = $first->iterate( @{$self->{param}} ) if ref($first); $tail = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail); my $more; ($first, $more) = $first->first if ref($first); $tail = $tail->_function2( 'union', $more ) if defined $more; return ($first, $tail); }, 'until' => sub { my $self = $_[0]; my ($a1, $b1) = @{ $self->{parent} }; $a1->trace( title=>"computing first()" ); my @first1 = $a1->first; my @first2 = $b1->first; my ($first, $tail); if ( $first2[0] <= $first1[0] ) { # added ->first because it returns 2 spans if $a1 == $a2 $first = $a1->empty_set()->until( $first2[0] )->first; $tail = $a1->_function2( "until", $first2[1] ); } else { $first = $a1->new( $first1[0] )->until( $first2[0] ); if ( defined $first1[1] ) { $tail = $first1[1]->_function2( "until", $first2[1] ); } else { $tail = undef; } } return ($first, $tail); }, 'offset' => sub { my $self = $_[0]; my ($first, $tail) = $self->{parent}->first; $first = $first->offset( @{$self->{param}} ); $tail = $tail->_function( 'offset', @{$self->{param}} ); my $more; ($first, $more) = $first->first; $tail = $tail->_function2( 'union', $more ) if defined $more; return ($first, $tail); }, 'quantize' => sub { my $self = $_[0]; my @min = $self->{parent}->min_a; if ( $min[0] == $neg_inf || $min[0] == $inf ) { return ( $self->new( $min[0] ) , $self->copy ); } my $first = $self->new( $min[0] )->quantize( @{$self->{param}} ); return ( $first, $self->{parent}-> _function2( 'intersection', $first->complement )-> _function( 'quantize', @{$self->{param}} ) ); }, 'tolerance' => sub { my $self = $_[0]; my ($first, $tail) = $self->{parent}->first; $first = $first->tolerance( @{$self->{param}} ); $tail = $tail->tolerance( @{$self->{param}} ); return ($first, $tail); }, ); # %_first %_last = ( 'complement' => sub { my $self = $_[0]; my @parent_max = $self->{parent}->last; unless ( defined $parent_max[0] ) { return (undef, 0); } my $parent_complement; my $last; my @next; my $parent; if ( $parent_max[0]->max == $inf ) { # (inf..min) (second..?) = parent # (min..second) = complement my @parent_second = $parent_max[1]->last; $last = $self->new( $parent_max[0]->complement ); $last->{list}[0]{a} = $parent_second[0]->{list}[0]{b}; $last->{list}[0]{open_begin} = ! $parent_second[0]->{list}[0]{open_end}; @{ $last->{list} } = () if ( $last->{list}[0]{a} == $last->{list}[0]{b}) && ( $last->{list}[0]{open_end} || $last->{list}[0]{open_begin} ); @next = $parent_second[0]->min_a; $parent = $parent_second[1]; } else { # (min..?) # (-inf..min) = complement $parent_complement = $parent_max[0]->complement; $last = $self->new( $parent_complement->{list}[-1] ); @next = $parent_max[0]->min_a; $parent = $parent_max[1]; } my @no_tail = $self->new($next[0], $inf); $no_tail[0]->{list}[-1]{open_begin} = $next[1]; my $tail = $parent->union($no_tail[-1])->complement; return ($last, $tail); }, 'intersection' => sub { my $self = $_[0]; my @parent = @{ $self->{parent} }; # TODO: check max1/max2 for undef my $retry_count = 0; my (@last, @max, $which, $last1, $intersection); SEARCH: while ($retry_count++ < $max_intersection_depth) { return undef unless defined $parent[0]; return undef unless defined $parent[1]; @{$last[0]} = $parent[0]->last; @{$last[1]} = $parent[1]->last; unless ( defined $last[0][0] ) { $self->trace_close( arg => 'undef' ) if $TRACE; return undef; } unless ( defined $last[1][0] ) { $self->trace_close( arg => 'undef' ) if $TRACE; return undef; } @{$max[0]} = $last[0][0]->max_a; @{$max[1]} = $last[1][0]->max_a; unless ( defined $max[0][0] && defined $max[1][0] ) { $self->trace( title=>"can't find max()" ) if $TRACE; $self->trace_close( arg => 'undef' ) if $TRACE; return undef; } # $which is the index to the smaller "last". $which = ($max[0][0] > $max[1][0]) ? 1 : 0; for my $which1 ( $which, 1 - $which ) { my $tmp_parent = $parent[$which1]; ($last1, $parent[$which1]) = @{ $last[$which1] }; if ( $last1->is_null ) { $which = $which1; $intersection = $last1; last SEARCH; } $intersection = $last1->intersection( $parent[1-$which1] ); unless ( $intersection->is_null ) { # $self->trace( title=>"got an intersection" ); if ( $intersection->is_too_complex ) { $self->trace( title=>"got a too_complex intersection" ) if $TRACE; # warn "too complex intersection"; $parent[$which1] = $tmp_parent; } else { $self->trace( title=>"got an intersection" ) if $TRACE; $which = $which1; last SEARCH; } }; } } $self->trace( title=>"exit loop" ) if $TRACE; if ( $#{ $intersection->{list} } > 0 ) { my $tail; ($intersection, $tail) = $intersection->last; $parent[$which] = $parent[$which]->union( $tail ); } my $tmp; if ( defined $parent[$which] and defined $parent[1-$which] ) { $tmp = $parent[$which]->intersection ( $parent[1-$which] ); } return ($intersection, $tmp); }, 'union' => sub { my $self = $_[0]; my (@last, @max); my @parent = @{ $self->{parent} }; @{$last[0]} = $parent[0]->last; @{$last[1]} = $parent[1]->last; @{$max[0]} = $last[0][0]->max_a; @{$max[1]} = $last[1][0]->max_a; unless ( defined $max[0][0] ) { return @{$last[1]} } unless ( defined $max[1][0] ) { return @{$last[0]} } my $which = ($max[0][0] > $max[1][0]) ? 0 : 1; my $last = $last[$which][0]; # find out the tail my $parent1 = $last[$which][1]; # warn $self->{parent}[$which]." - $last = $parent1"; my $parent2 = ($max[0][0] == $max[1][0]) ? $self->{parent}[1-$which]->complement($last) : $self->{parent}[1-$which]; my $tail; if (( ! defined $parent1 ) || $parent1->is_null) { $tail = $parent2; } else { my $method = $self->{method}; $tail = $parent1->$method( $parent2 ); } if ( $last->intersects( $tail ) ) { my $last2; ( $last2, $tail ) = $tail->last; $last = $last->union( $last2 ); } return ($last, $tail); }, 'until' => sub { my $self = $_[0]; my ($a1, $b1) = @{ $self->{parent} }; $a1->trace( title=>"computing last()" ); my @last1 = $a1->last; my @last2 = $b1->last; my ($last, $tail); if ( $last2[0] <= $last1[0] ) { # added ->last because it returns 2 spans if $a1 == $a2 $last = $last2[0]->until( $a1 )->last; $tail = $a1->_function2( "until", $last2[1] ); } else { $last = $a1->new( $last1[0] )->until( $last2[0] ); if ( defined $last1[1] ) { $tail = $last1[1]->_function2( "until", $last2[1] ); } else { $tail = undef; } } return ($last, $tail); }, 'iterate' => sub { my $self = $_[0]; my $parent = $self->{parent}; my ($last, $tail) = $parent->last; $last = $last->iterate( @{$self->{param}} ) if ref($last); $tail = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail); my $more; ($last, $more) = $last->last if ref($last); $tail = $tail->_function2( 'union', $more ) if defined $more; return ($last, $tail); }, 'offset' => sub { my $self = $_[0]; my ($last, $tail) = $self->{parent}->last; $last = $last->offset( @{$self->{param}} ); $tail = $tail->_function( 'offset', @{$self->{param}} ); my $more; ($last, $more) = $last->last; $tail = $tail->_function2( 'union', $more ) if defined $more; return ($last, $tail); }, 'quantize' => sub { my $self = $_[0]; my @max = $self->{parent}->max_a; if (( $max[0] == $neg_inf ) || ( $max[0] == $inf )) { return ( $self->new( $max[0] ) , $self->copy ); } my $last = $self->new( $max[0] )->quantize( @{$self->{param}} ); if ($max[1]) { # open_end if ( $last->min <= $max[0] ) { $last = $self->new( $last->min - 1e-9 )->quantize( @{$self->{param}} ); } } return ( $last, $self->{parent}-> _function2( 'intersection', $last->complement )-> _function( 'quantize', @{$self->{param}} ) ); }, 'tolerance' => sub { my $self = $_[0]; my ($last, $tail) = $self->{parent}->last; $last = $last->tolerance( @{$self->{param}} ); $tail = $tail->tolerance( @{$self->{param}} ); return ($last, $tail); }, ); # %_last } # BEGIN sub first { my $self = $_[0]; unless ( exists $self->{first} ) { $self->trace_open(title=>"first") if $TRACE; if ( $self->{too_complex} ) { my $method = $self->{method}; # warn "method $method ". ( exists $_first{$method} ? "exists" : "does not exist" ); if ( exists $_first{$method} ) { @{$self->{first}} = $_first{$method}->($self); } else { my $redo = $self->{parent}->$method ( @{ $self->{param} } ); @{$self->{first}} = $redo->first; } } else { return $self->SUPER::first; } } return wantarray ? @{$self->{first}} : $self->{first}[0]; } sub last { my $self = $_[0]; unless ( exists $self->{last} ) { $self->trace(title=>"last") if $TRACE; if ( $self->{too_complex} ) { my $method = $self->{method}; if ( exists $_last{$method} ) { @{$self->{last}} = $_last{$method}->($self); } else { my $redo = $self->{parent}->$method ( @{ $self->{param} } ); @{$self->{last}} = $redo->last; } } else { return $self->SUPER::last; } } return wantarray ? @{$self->{last}} : $self->{last}[0]; } # offset: offsets subsets sub offset { my $self = shift; if ($self->{too_complex}) { return $self->_function( 'offset', @_ ); } $self->trace_open(title=>"offset") if $TRACE; my @a; my %param = @_; my $b1 = $self->empty_set(); my ($interval, $ia, $i); $param{mode} = 'offset' unless $param{mode}; unless (ref($param{value}) eq 'ARRAY') { $param{value} = [0 + $param{value}, 0 + $param{value}]; } $param{unit} = 'one' unless $param{unit}; my $parts = ($#{$param{value}}) / 2; my $sub_unit = $Set::Infinite::Arithmetic::subs_offset2{$param{unit}}; my $sub_mode = $Set::Infinite::Arithmetic::_MODE{$param{mode}}; carp "unknown unit $param{unit} for offset()" unless defined $sub_unit; carp "unknown mode $param{mode} for offset()" unless defined $sub_mode; my ($j); my ($cmp, $this, $next, $ib, $part, $open_begin, $open_end, $tmp); my @value; foreach $j (0 .. $parts) { push @value, [ $param{value}[$j+$j], $param{value}[$j+$j + 1] ]; } foreach $interval ( @{ $self->{list} } ) { $ia = $interval->{a}; $ib = $interval->{b}; $open_begin = $interval->{open_begin}; $open_end = $interval->{open_end}; foreach $j (0 .. $parts) { # print " [ofs($ia,$ib)] "; ($this, $next) = $sub_mode->( $sub_unit, $ia, $ib, @{$value[$j]} ); next if ($this > $next); # skip if a > b if ($this == $next) { # TODO: fix this $open_end = $open_begin; } push @a, { a => $this , b => $next , open_begin => $open_begin , open_end => $open_end }; } # parts } # self @a = sort { $a->{a} <=> $b->{a} } @a; $b1->{list} = \@a; # change data $self->trace_close( arg => $b1 ) if $TRACE; $b1 = $b1->fixtype if $self->{fixtype}; return $b1; } sub is_null { $_[0]->{too_complex} ? 0 : $_[0]->SUPER::is_null; } sub is_too_complex { $_[0]->{too_complex} ? 1 : 0; } # shows how a 'compacted' set looks like after quantize sub _quantize_span { my $self = shift; my %param = @_; $self->trace_open(title=>"_quantize_span") if $TRACE; my $res; if ($self->{too_complex}) { $res = $self->{parent}; if ($self->{method} ne 'quantize') { $self->trace( title => "parent is a ". $self->{method} ); if ( $self->{method} eq 'union' ) { my $arg0 = $self->{parent}[0]->_quantize_span(%param); my $arg1 = $self->{parent}[1]->_quantize_span(%param); $res = $arg0->union( $arg1 ); } elsif ( $self->{method} eq 'intersection' ) { my $arg0 = $self->{parent}[0]->_quantize_span(%param); my $arg1 = $self->{parent}[1]->_quantize_span(%param); $res = $arg0->intersection( $arg1 ); } # TODO: other methods else { $res = $self; # ->_function( "_quantize_span", %param ); } $self->trace_close( arg => $res ) if $TRACE; return $res; } # $res = $self->{parent}; if ($res->{too_complex}) { $res->trace( title => "parent is complex" ); $res = $res->_quantize_span( %param ); $res = $res->quantize( @{$self->{param}} )->_quantize_span( %param ); } else { $res = $res->iterate ( sub { $_[0]->quantize( @{$self->{param}} )->span; } ); } } else { $res = $self->iterate ( sub { $_[0] } ); } $self->trace_close( arg => $res ) if $TRACE; return $res; } BEGIN { %_backtrack = ( until => sub { my ($self, $arg) = @_; my $before = $self->{parent}[0]->intersection( $neg_inf, $arg->min )->max; $before = $arg->min unless $before; my $after = $self->{parent}[1]->intersection( $arg->max, $inf )->min; $after = $arg->max unless $after; return $arg->new( $before, $after ); }, iterate => sub { my ($self, $arg) = @_; if ( defined $self->{backtrack_callback} ) { return $arg = $self->new( $self->{backtrack_callback}->( $arg ) ); } my $before = $self->{parent}->intersection( $neg_inf, $arg->min )->max; $before = $arg->min unless $before; my $after = $self->{parent}->intersection( $arg->max, $inf )->min; $after = $arg->max unless $after; return $arg->new( $before, $after ); }, quantize => sub { my ($self, $arg) = @_; if ($arg->{too_complex}) { return $arg; } else { return $arg->quantize( @{$self->{param}} )->_quantize_span; } }, offset => sub { my ($self, $arg) = @_; # offset - apply offset with negative values my %tmp = @{$self->{param}}; my @values = sort @{$tmp{value}}; my $backtrack_arg2 = $arg->offset( unit => $tmp{unit}, mode => $tmp{mode}, value => [ - $values[-1], - $values[0] ] ); return $arg->union( $backtrack_arg2 ); # fixes some problems with 'begin' mode }, ); } sub _backtrack { my ($self, $method, $arg) = @_; return $self->$method ($arg) unless $self->{too_complex}; $self->trace_open( title => 'backtrack '.$self->{method} ) if $TRACE; $backtrack_depth++; if ( $backtrack_depth > $max_backtrack_depth ) { carp ( __PACKAGE__ . ": Backtrack too deep " . "(more than $max_backtrack_depth levels)" ); } if (exists $_backtrack{ $self->{method} } ) { $arg = $_backtrack{ $self->{method} }->( $self, $arg ); } my $result; if ( ref($self->{parent}) eq 'ARRAY' ) { # has 2 parents (intersection, union, until) my ( $result1, $result2 ) = @{$self->{parent}}; $result1 = $result1->_backtrack( $method, $arg ) if $result1->{too_complex}; $result2 = $result2->_backtrack( $method, $arg ) if $result2->{too_complex}; $method = $self->{method}; if ( $result1->{too_complex} || $result2->{too_complex} ) { $result = $result1->_function2( $method, $result2 ); } else { $result = $result1->$method ($result2); } } else { # has 1 parent and parameters (offset, select, quantize, iterate) $result = $self->{parent}->_backtrack( $method, $arg ); $method = $self->{method}; $result = $result->$method ( @{$self->{param}} ); } $backtrack_depth--; $self->trace_close( arg => $result ) if $TRACE; return $result; } sub intersects { my $a1 = shift; my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_); $a1->trace(title=>"intersects"); if ($a1->{too_complex}) { $a1 = $a1->_backtrack('intersection', $b1 ); } # don't put 'else' here if ($b1->{too_complex}) { $b1 = $b1->_backtrack('intersection', $a1); } if (($a1->{too_complex}) or ($b1->{too_complex})) { return undef; # we don't know the answer! } return $a1->SUPER::intersects( $b1 ); } sub iterate { my $self = shift; my $callback = shift; die "First argument to iterate() must be a subroutine reference" unless ref( $callback ) eq 'CODE'; my $backtrack_callback; if ( @_ && $_[0] eq 'backtrack_callback' ) { ( undef, $backtrack_callback ) = ( shift, shift ); } my $set; if ($self->{too_complex}) { $self->trace(title=>"iterate:backtrack") if $TRACE; $set = $self->_function( 'iterate', $callback, @_ ); } else { $self->trace(title=>"iterate") if $TRACE; $set = $self->SUPER::iterate( $callback, @_ ); } $set->{backtrack_callback} = $backtrack_callback; # warn "set backtrack_callback" if defined $backtrack_callback; return $set; } sub intersection { my $a1 = shift; my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_); $a1->trace_open(title=>"intersection", arg => $b1) if $TRACE; if (($a1->{too_complex}) or ($b1->{too_complex})) { my $arg0 = $a1->_quantize_span; my $arg1 = $b1->_quantize_span; unless (($arg0->{too_complex}) or ($arg1->{too_complex})) { my $res = $arg0->intersection( $arg1 ); $a1->trace_close( arg => $res ) if $TRACE; return $res; } } if ($a1->{too_complex}) { $a1 = $a1->_backtrack('intersection', $b1) unless $b1->{too_complex}; } # don't put 'else' here if ($b1->{too_complex}) { $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex}; } if ( $a1->{too_complex} || $b1->{too_complex} ) { $a1->trace_close( ) if $TRACE; return $a1->_function2( 'intersection', $b1 ); } return $a1->SUPER::intersection( $b1 ); } sub intersected_spans { my $a1 = shift; my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_); if ($a1->{too_complex}) { $a1 = $a1->_backtrack('intersection', $b1 ) unless $b1->{too_complex}; } # don't put 'else' here if ($b1->{too_complex}) { $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex}; } if ( ! $b1->{too_complex} && ! $a1->{too_complex} ) { return $a1->SUPER::intersected_spans ( $b1 ); } return $b1->iterate( sub { my $tmp = $a1->intersection( $_[0] ); return $tmp unless defined $tmp->max; my $before = $a1->intersection( $neg_inf, $tmp->min )->last; my $after = $a1->intersection( $tmp->max, $inf )->first; $before = $tmp->union( $before )->first; $after = $tmp->union( $after )->last; $tmp = $tmp->union( $before ) if defined $before && $tmp->intersects( $before ); $tmp = $tmp->union( $after ) if defined $after && $tmp->intersects( $after ); return $tmp; } ); } sub complement { my $a1 = shift; # do we have a parameter? if (@_) { my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_); $a1->trace_open(title=>"complement", arg => $b1) if $TRACE; $b1 = $b1->complement; my $tmp =$a1->intersection($b1); $a1->trace_close( arg => $tmp ) if $TRACE; return $tmp; } $a1->trace_open(title=>"complement") if $TRACE; if ($a1->{too_complex}) { $a1->trace_close( ) if $TRACE; return $a1->_function( 'complement', @_ ); } return $a1->SUPER::complement; } sub until { my $a1 = shift; my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_); if (($a1->{too_complex}) or ($b1->{too_complex})) { return $a1->_function2( 'until', $b1 ); } return $a1->SUPER::until( $b1 ); } sub union { my $a1 = shift; my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_); $a1->trace_open(title=>"union", arg => $b1) if $TRACE; if (($a1->{too_complex}) or ($b1->{too_complex})) { $a1->trace_close( ) if $TRACE; return $a1 if $b1->is_null; return $b1 if $a1->is_null; return $a1->_function2( 'union', $b1); } return $a1->SUPER::union( $b1 ); } # there are some ways to process 'contains': # A CONTAINS B IF A == ( A UNION B ) # - faster # A CONTAINS B IF B == ( A INTERSECTION B ) # - can backtrack = works for unbounded sets sub contains { my $a1 = shift; $a1->trace_open(title=>"contains") if $TRACE; if ( $a1->{too_complex} ) { # we use intersection because it is better for backtracking my $b0 = (ref $_[0] eq ref $a1) ? shift : $a1->new(@_); my $b1 = $a1->intersection($b0); if ( $b1->{too_complex} ) { $b1->trace_close( arg => 'undef' ) if $TRACE; return undef; } $a1->trace_close( arg => ($b1 == $b0 ? 1 : 0) ) if $TRACE; return ($b1 == $b0) ? 1 : 0; } my $b1 = $a1->union(@_); if ( $b1->{too_complex} ) { $b1->trace_close( arg => 'undef' ) if $TRACE; return undef; } $a1->trace_close( arg => ($b1 == $a1 ? 1 : 0) ) if $TRACE; return ($b1 == $a1) ? 1 : 0; } sub min_a { my $self = $_[0]; return @{$self->{min}} if exists $self->{min}; if ($self->{too_complex}) { my @first = $self->first; return @{$self->{min}} = $first[0]->min_a if defined $first[0]; return @{$self->{min}} = (undef, 0); } return $self->SUPER::min_a; }; sub max_a { my $self = $_[0]; return @{$self->{max}} if exists $self->{max}; if ($self->{too_complex}) { my @last = $self->last; return @{$self->{max}} = $last[0]->max_a if defined $last[0]; return @{$self->{max}} = (undef, 0); } return $self->SUPER::max_a; }; sub count { my $self = $_[0]; # NOTE: subclasses may return "undef" if necessary return $inf if $self->{too_complex}; return $self->SUPER::count; } sub size { my $self = $_[0]; if ($self->{too_complex}) { my @min = $self->min_a; my @max = $self->max_a; return undef unless defined $max[0] && defined $min[0]; return $max[0] - $min[0]; } return $self->SUPER::size; }; sub spaceship { my ($tmp1, $tmp2, $inverted) = @_; carp "Can't compare unbounded sets" if $tmp1->{too_complex} or $tmp2->{too_complex}; return $tmp1->SUPER::spaceship( $tmp2, $inverted ); } sub _cleanup { @_ } # this subroutine is obsolete sub tolerance { my $self = shift; my $tmp = pop; if (ref($self)) { # local return $self->{tolerance} unless defined $tmp; if ($self->{too_complex}) { my $b1 = $self->_function( 'tolerance', $tmp ); $b1->{tolerance} = $tmp; # for max/min processing return $b1; } return $self->SUPER::tolerance( $tmp ); } # class method __PACKAGE__->SUPER::tolerance( $tmp ) if defined($tmp); return __PACKAGE__->SUPER::tolerance; } sub _pretty_print { my $self = shift; return "$self" unless $self->{too_complex}; return $self->{method} . "( " . ( ref($self->{parent}) eq 'ARRAY' ? $self->{parent}[0] . ' ; ' . $self->{parent}[1] : $self->{parent} ) . " )"; } sub as_string { my $self = shift; return ( $PRETTY_PRINT ? $self->_pretty_print : $too_complex ) if $self->{too_complex}; return $self->SUPER::as_string; } sub DESTROY {} 1; __END__ =head1 NAME Set::Infinite - Sets of intervals =head1 SYNOPSIS use Set::Infinite; $set = Set::Infinite->new(1,2); # [1..2] print $set->union(5,6); # [1..2],[5..6] =head1 DESCRIPTION Set::Infinite is a Set Theory module for infinite sets. A set is a collection of objects. The objects that belong to a set are called its members, or "elements". As objects we allow (almost) anything: reals, integers, and objects (such as dates). We allow sets to be infinite. There is no account for the order of elements. For example, {1,2} = {2,1}. There is no account for repetition of elements. For example, {1,2,2} = {1,1,1,2} = {1,2}. =head1 CONSTRUCTOR =head2 new Creates a new set object: $set = Set::Infinite->new; # empty set $set = Set::Infinite->new( 10 ); # single element $set = Set::Infinite->new( 10, 20 ); # single range $set = Set::Infinite->new( [ 10, 20 ], [ 50, 70 ] ); # two ranges =over 4 =item empty set $set = Set::Infinite->new; =item set with a single element $set = Set::Infinite->new( 10 ); $set = Set::Infinite->new( [ 10 ] ); =item set with a single span $set = Set::Infinite->new( 10, 20 ); $set = Set::Infinite->new( [ 10, 20 ] ); # 10 <= x <= 20 =item set with a single, open span $set = Set::Infinite->new( { a => 10, open_begin => 0, b => 20, open_end => 1, } ); # 10 <= x < 20 =item set with multiple spans $set = Set::Infinite->new( 10, 20, 100, 200 ); $set = Set::Infinite->new( [ 10, 20 ], [ 100, 200 ] ); $set = Set::Infinite->new( { a => 10, open_begin => 0, b => 20, open_end => 0, }, { a => 100, open_begin => 0, b => 200, open_end => 0, } ); =back The C method expects I parameters. If you have unordered ranges, you can build the set using C: @ranges = ( [ 10, 20 ], [ -10, 1 ] ); $set = Set::Infinite->new; $set = $set->union( @$_ ) for @ranges; The data structures passed to C must be I. So this is not good practice: $set = Set::Infinite->new( $object_a, $object_b ); $object_a->set_value( 10 ); This is the recommended way to do it: $set = Set::Infinite->new( $object_a->clone, $object_b->clone ); $object_a->set_value( 10 ); =head2 clone / copy Creates a new object, and copy the object data. =head2 empty_set Creates an empty set. If called from an existing set, the empty set inherits the "type" and "density" characteristics. =head2 universal_set Creates a set containing "all" possible elements. If called from an existing set, the universal set inherits the "type" and "density" characteristics. =head1 SET FUNCTIONS =head2 union $set = $set->union($b); Returns the set of all elements from both sets. This function behaves like an "OR" operation. $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] ); $set2 = new Set::Infinite( [ 7, 20 ] ); print $set1->union( $set2 ); # output: [1..4],[7..20] =head2 intersection $set = $set->intersection($b); Returns the set of elements common to both sets. This function behaves like an "AND" operation. $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] ); $set2 = new Set::Infinite( [ 7, 20 ] ); print $set1->intersection( $set2 ); # output: [8..12] =head2 complement =head2 minus =head2 difference $set = $set->complement; Returns the set of all elements that don't belong to the set. $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] ); print $set1->complement; # output: (-inf..1),(4..8),(12..inf) The complement function might take a parameter: $set = $set->minus($b); Returns the set-difference, that is, the elements that don't belong to the given set. $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] ); $set2 = new Set::Infinite( [ 7, 20 ] ); print $set1->minus( $set2 ); # output: [1..4] =head2 symmetric_difference Returns a set containing elements that are in either set, but not in both. This is the "set" version of "XOR". =head1 DENSITY METHODS =head2 real $set1 = $set->real; Returns a set with density "0". =head2 integer $set1 = $set->integer; Returns a set with density "1". =head1 LOGIC FUNCTIONS =head2 intersects $logic = $set->intersects($b); =head2 contains $logic = $set->contains($b); =head2 is_empty =head2 is_null $logic = $set->is_null; =head2 is_nonempty This set that has at least 1 element. =head2 is_span This set that has a single span or interval. =head2 is_singleton This set that has a single element. =head2 is_subset( $set ) Every element of this set is a member of the given set. =head2 is_proper_subset( $set ) Every element of this set is a member of the given set. Some members of the given set are not elements of this set. =head2 is_disjoint( $set ) The given set has no elements in common with this set. =head2 is_too_complex Sometimes a set might be too complex to enumerate or print. This happens with sets that represent infinite recurrences, such as when you ask for a quantization on a set bounded by -inf or inf. See also: C method. =head1 SCALAR FUNCTIONS =head2 min $i = $set->min; =head2 max $i = $set->max; =head2 size $i = $set->size; =head2 count $i = $set->count; =head1 OVERLOADED OPERATORS =head2 stringification print $set; $str = "$set"; See also: C. =head2 comparison sort > < == >= <= <=> See also: C method. =head1 CLASS METHODS Set::Infinite->separators(@i) chooses the interval separators for stringification. default are [ ] ( ) '..' ','. inf returns an 'Infinity' number. minus_inf returns '-Infinity' number. =head2 type type( "My::Class::Name" ) Chooses a default object data type. Default is none (a normal Perl SCALAR). =head1 SPECIAL SET FUNCTIONS =head2 span $set1 = $set->span; Returns the set span. =head2 until Extends a set until another: 0,5,7 -> until 2,6,10 gives [0..2), [5..6), [7..10) =head2 start_set =head2 end_set These methods do the inverse of the "until" method. Given: [0..2), [5..6), [7..10) start_set is: 0,5,7 end_set is: 2,6,10 =head2 intersected_spans $set = $set1->intersected_spans( $set2 ); The method returns a new set, containing all spans that are intersected by the given set. Unlike the C method, the spans are not modified. See diagram below: set1 [....] [....] [....] [....] set2 [................] intersection [.] [....] [.] intersected_spans [....] [....] [....] =head2 quantize quantize( parameters ) Makes equal-sized subsets. Returns an ordered set of equal-sized subsets. Example: $set = Set::Infinite->new([1,3]); print join (" ", $set->quantize( quant => 1 ) ); Gives: [1..2) [2..3) [3..4) =head2 select select( parameters ) Selects set spans based on their ordered positions C