+++ /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