--- /dev/null
+# 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<Infinity> value.
+
+=item * NEG_INFINITY
+
+The C<-Infinity> value.
+
+=back
+
+=head1 SUPPORT
+
+Support is offered through the C<datetime@perl.org> mailing list.
+
+Please report bugs using rt.cpan.org
+
+=head1 AUTHOR
+
+Flavio Soibelmann Glock <fglock@pucrs.br>
+
+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<http://datetime.perl.org>.
+
+=cut
+
projects / kivitendo-erp.git / blobdiff