X-Git-Url: http://wagnertech.de/gitweb/gitweb.cgi/mfinanz.git/blobdiff_plain/782fd7884fb686cd2e336756dadeb4ab5d05a415..03fc848dccbb1c0100b1f72a899b7087234b7029:/modules/fallback/Set/Infinite/_recurrence.pm diff --git a/modules/fallback/Set/Infinite/_recurrence.pm b/modules/fallback/Set/Infinite/_recurrence.pm new file mode 100644 index 000000000..376e168be --- /dev/null +++ b/modules/fallback/Set/Infinite/_recurrence.pm @@ -0,0 +1,404 @@ +# Copyright (c) 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. + +package Set::Infinite::_recurrence; + +use strict; + +use constant INFINITY => 100 ** 100 ** 100 ; +use constant NEG_INFINITY => -1 * (100 ** 100 ** 100); + +use vars qw( @ISA $PRETTY_PRINT $max_iterate ); + +@ISA = qw( Set::Infinite ); +use Set::Infinite 0.5502; + +BEGIN { + $PRETTY_PRINT = 1; # enable Set::Infinite debug + $max_iterate = 20; + + # TODO: inherit %Set::Infinite::_first / _last + # in a more "object oriented" way + + $Set::Infinite::_first{_recurrence} = + sub { + my $self = $_[0]; + my ($callback_next, $callback_previous) = @{ $self->{param} }; + my ($min, $min_open) = $self->{parent}->min_a; + + my ( $min1, $min2 ); + $min1 = $callback_next->( $min ); + if ( ! $min_open ) + { + $min2 = $callback_previous->( $min1 ); + $min1 = $min2 if defined $min2 && $min == $min2; + } + + my $start = $callback_next->( $min1 ); + my $end = $self->{parent}->max; + + #print STDERR "set "; + #print STDERR $start->datetime + # unless $start == INFINITY; + #print STDERR " - " ; + #print STDERR $end->datetime + # unless $end == INFINITY; + #print STDERR "\n"; + + return ( $self->new( $min1 ), undef ) + if $start > $end; + + return ( $self->new( $min1 ), + $self->new( $start, $end )-> + _function( '_recurrence', @{ $self->{param} } ) ); + }; + $Set::Infinite::_last{_recurrence} = + sub { + my $self = $_[0]; + my ($callback_next, $callback_previous) = @{ $self->{param} }; + my ($max, $max_open) = $self->{parent}->max_a; + + my ( $max1, $max2 ); + $max1 = $callback_previous->( $max ); + if ( ! $max_open ) + { + $max2 = $callback_next->( $max1 ); + $max1 = $max2 if $max == $max2; + } + + return ( $self->new( $max1 ), + $self->new( $self->{parent}->min, + $callback_previous->( $max1 ) )-> + _function( '_recurrence', @{ $self->{param} } ) ); + }; +} + +# $si->_recurrence( +# \&callback_next, \&callback_previous ) +# +# Generates "recurrences" from a callback. +# These recurrences are simple lists of dates. +# +# The recurrence generation is based on an idea from Dave Rolsky. +# + +# use Data::Dumper; +# use Carp qw(cluck); + +sub _recurrence { + my $set = shift; + my ( $callback_next, $callback_previous, $delta ) = @_; + + $delta->{count} = 0 unless defined $delta->{delta}; + + # warn "reusing delta: ". $delta->{count} if defined $delta->{delta}; + # warn Dumper( $delta ); + + if ( $#{ $set->{list} } != 0 || $set->is_too_complex ) + { + return $set->iterate( + sub { + $_[0]->_recurrence( + $callback_next, $callback_previous, $delta ) + } ); + } + # $set is a span + my $result; + if ($set->min != NEG_INFINITY && $set->max != INFINITY) + { + # print STDERR " finite set\n"; + my ($min, $min_open) = $set->min_a; + my ($max, $max_open) = $set->max_a; + + my ( $min1, $min2 ); + $min1 = $callback_next->( $min ); + if ( ! $min_open ) + { + $min2 = $callback_previous->( $min1 ); + $min1 = $min2 if defined $min2 && $min == $min2; + } + + $result = $set->new(); + + # get "delta" - abort if this will take too much time. + + unless ( defined $delta->{max_delta} ) + { + for ( $delta->{count} .. 10 ) + { + if ( $max_open ) + { + return $result if $min1 >= $max; + } + else + { + return $result if $min1 > $max; + } + push @{ $result->{list} }, + { a => $min1, b => $min1, open_begin => 0, open_end => 0 }; + $min2 = $callback_next->( $min1 ); + + if ( $delta->{delta} ) + { + $delta->{delta} += $min2 - $min1; + } + else + { + $delta->{delta} = $min2 - $min1; + } + $delta->{count}++; + $min1 = $min2; + } + + $delta->{max_delta} = $delta->{delta} * 40; + } + + if ( $max < $min + $delta->{max_delta} ) + { + for ( 1 .. 200 ) + { + if ( $max_open ) + { + return $result if $min1 >= $max; + } + else + { + return $result if $min1 > $max; + } + push @{ $result->{list} }, + { a => $min1, b => $min1, open_begin => 0, open_end => 0 }; + $min1 = $callback_next->( $min1 ); + } + } + + # cluck "give up"; + } + + # return a "_function", such that we can backtrack later. + my $func = $set->_function( '_recurrence', $callback_next, $callback_previous, $delta ); + + # removed - returning $result doesn't help on speed + ## return $func->_function2( 'union', $result ) if $result; + + return $func; +} + +sub is_forever +{ + $#{ $_[0]->{list} } == 0 && + $_[0]->max == INFINITY && + $_[0]->min == NEG_INFINITY +} + +sub _is_recurrence +{ + exists $_[0]->{method} && + $_[0]->{method} eq '_recurrence' && + $_[0]->{parent}->is_forever +} + +sub intersection +{ + my ($s1, $s2) = (shift,shift); + + if ( exists $s1->{method} && $s1->{method} eq '_recurrence' ) + { + # optimize: recurrence && span + return $s1->{parent}-> + intersection( $s2, @_ )-> + _recurrence( @{ $s1->{param} } ) + unless ref($s2) && exists $s2->{method}; + + # optimize: recurrence && recurrence + if ( $s1->{parent}->is_forever && + ref($s2) && _is_recurrence( $s2 ) ) + { + my ( $next1, $previous1 ) = @{ $s1->{param} }; + my ( $next2, $previous2 ) = @{ $s2->{param} }; + return $s1->{parent}->_function( '_recurrence', + sub { + # intersection of parent 'next' callbacks + my ($n1, $n2); + my $iterate = 0; + $n2 = $next2->( $_[0] ); + while(1) { + $n1 = $next1->( $previous1->( $n2 ) ); + return $n1 if $n1 == $n2; + $n2 = $next2->( $previous2->( $n1 ) ); + return if $iterate++ == $max_iterate; + } + }, + sub { + # intersection of parent 'previous' callbacks + my ($p1, $p2); + my $iterate = 0; + $p2 = $previous2->( $_[0] ); + while(1) { + $p1 = $previous1->( $next1->( $p2 ) ); + return $p1 if $p1 == $p2; + $p2 = $previous2->( $next2->( $p1 ) ); + return if $iterate++ == $max_iterate; + } + }, + ); + } + } + return $s1->SUPER::intersection( $s2, @_ ); +} + +sub union +{ + my ($s1, $s2) = (shift,shift); + if ( $s1->_is_recurrence && + ref($s2) && _is_recurrence( $s2 ) ) + { + # optimize: recurrence || recurrence + my ( $next1, $previous1 ) = @{ $s1->{param} }; + my ( $next2, $previous2 ) = @{ $s2->{param} }; + return $s1->{parent}->_function( '_recurrence', + sub { # next + my $n1 = $next1->( $_[0] ); + my $n2 = $next2->( $_[0] ); + return $n1 < $n2 ? $n1 : $n2; + }, + sub { # previous + my $p1 = $previous1->( $_[0] ); + my $p2 = $previous2->( $_[0] ); + return $p1 > $p2 ? $p1 : $p2; + }, + ); + } + return $s1->SUPER::union( $s2, @_ ); +} + +=head1 NAME + +Set::Infinite::_recurrence - Extends Set::Infinite with recurrence functions + +=head1 SYNOPSIS + + $recurrence = $base_set->_recurrence ( \&next, \&previous ); + +=head1 DESCRIPTION + +This is an internal class used by the DateTime::Set module. +The API is subject to change. + +It provides all functionality provided by Set::Infinite, plus the ability +to define recurrences with arbitrary objects, such as dates. + +=head1 METHODS + +=over 4 + +=item * _recurrence ( \&next, \&previous ) + +Creates a recurrence set. The set is defined inside a 'base set'. + + $recurrence = $base_set->_recurrence ( \&next, \&previous ); + +The recurrence functions take one argument, and return the 'next' or +the 'previous' occurence. + +Example: defines the set of all 'integer numbers': + + use strict; + + use Set::Infinite::_recurrence; + use POSIX qw(floor); + + # define the recurrence span + my $forever = Set::Infinite::_recurrence->new( + Set::Infinite::_recurrence::NEG_INFINITY, + Set::Infinite::_recurrence::INFINITY + ); + + my $recurrence = $forever->_recurrence( + sub { # next + floor( $_[0] + 1 ) + }, + sub { # previous + my $tmp = floor( $_[0] ); + $tmp < $_[0] ? $tmp : $_[0] - 1 + }, + ); + + print "sample recurrence ", + $recurrence->intersection( -5, 5 ), "\n"; + # sample recurrence -5,-4,-3,-2,-1,0,1,2,3,4,5 + + { + my $x = 234.567; + print "next occurence after $x = ", + $recurrence->{param}[0]->( $x ), "\n"; # 235 + print "previous occurence before $x = ", + $recurrence->{param}[2]->( $x ), "\n"; # 234 + } + + { + my $x = 234; + print "next occurence after $x = ", + $recurrence->{param}[0]->( $x ), "\n"; # 235 + print "previous occurence before $x = ", + $recurrence->{param}[2]->( $x ), "\n"; # 233 + } + +=item * is_forever + +Returns true if the set is a single span, +ranging from -Infinity to Infinity. + +=item * _is_recurrence + +Returns true if the set is an unbounded recurrence, +ranging from -Infinity to Infinity. + +=back + +=head1 CONSTANTS + +=over 4 + +=item * INFINITY + +The C value. + +=item * NEG_INFINITY + +The C<-Infinity> value. + +=back + +=head1 SUPPORT + +Support is offered through the C mailing list. + +Please report bugs using rt.cpan.org + +=head1 AUTHOR + +Flavio Soibelmann Glock + +The recurrence generation algorithm is based on an idea from Dave Rolsky. + +=head1 COPYRIGHT + +Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved. +This program is free software; you can distribute it and/or +modify it under the same terms as Perl itself. + +The full text of the license can be found in the LICENSE file +included with this module. + +=head1 SEE ALSO + +Set::Infinite + +DateTime::Set + +For details on the Perl DateTime Suite project please see +L. + +=cut +