modules/fallback/Set/Infinite/_recurrence.pm

   1 # Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
   2 # This program is free software; you can redistribute it and/or
   3 # modify it under the same terms as Perl itself.
   4
   5 package Set::Infinite::_recurrence;
   6
   7 use strict;
   8
   9 use constant INFINITY     =>       100 ** 100 ** 100 ;
  10 use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
  11
  12 use vars qw( @ISA $PRETTY_PRINT $max_iterate );
  13
  14 @ISA = qw( Set::Infinite );
  15 use Set::Infinite 0.5502;
  16
  17 BEGIN {
  18     $PRETTY_PRINT = 1;   # enable Set::Infinite debug
  19     $max_iterate = 20;
  20
  21     # TODO: inherit %Set::Infinite::_first / _last
  22     #       in a more "object oriented" way
  23
  24     $Set::Infinite::_first{_recurrence} =
  25         sub {
  26             my $self = $_[0];
  27             my ($callback_next, $callback_previous) = @{ $self->{param} };
  28             my ($min, $min_open) = $self->{parent}->min_a;
  29
  30             my ( $min1, $min2 );
  31             $min1 = $callback_next->( $min );
  32             if ( ! $min_open )
  33             {
  34                 $min2 = $callback_previous->( $min1 );
  35                 $min1 = $min2 if defined $min2 && $min == $min2;
  36             }
  37
  38             my $start = $callback_next->( $min1 );
  39             my $end   = $self->{parent}->max;
  40
  41             #print STDERR "set ";
  42             #print STDERR $start->datetime
  43             #   unless $start == INFINITY;
  44             #print STDERR " - " ;
  45             #print STDERR $end->datetime
  46             #    unless $end == INFINITY;
  47             #print STDERR "\n";
  48
  49             return ( $self->new( $min1 ), undef )
  50                 if $start > $end;
  51
  52             return ( $self->new( $min1 ),
  53                      $self->new( $start, $end )->
  54                           _function( '_recurrence', @{ $self->{param} } ) );
  55         };
  56     $Set::Infinite::_last{_recurrence} =
  57         sub {
  58             my $self = $_[0];
  59             my ($callback_next, $callback_previous) = @{ $self->{param} };
  60             my ($max, $max_open) = $self->{parent}->max_a;
  61
  62             my ( $max1, $max2 );
  63             $max1 = $callback_previous->( $max );
  64             if ( ! $max_open )
  65             {
  66                 $max2 = $callback_next->( $max1 );
  67                 $max1 = $max2 if $max == $max2;
  68             }
  69
  70             return ( $self->new( $max1 ),
  71                      $self->new( $self->{parent}->min,
  72                                  $callback_previous->( $max1 ) )->
  73                           _function( '_recurrence', @{ $self->{param} } ) );
  74         };
  75 }
  76
  77 # $si->_recurrence(
  78 #     \&callback_next, \&callback_previous )
  79 #
  80 # Generates "recurrences" from a callback.
  81 # These recurrences are simple lists of dates.
  82 #
  83 # The recurrence generation is based on an idea from Dave Rolsky.
  84 #
  85
  86 # use Data::Dumper;
  87 # use Carp qw(cluck);
  88
  89 sub _recurrence {
  90     my $set = shift;
  91     my ( $callback_next, $callback_previous, $delta ) = @_;
  92
  93     $delta->{count} = 0 unless defined $delta->{delta};
  94
  95     # warn "reusing delta: ". $delta->{count} if defined $delta->{delta};
  96     # warn Dumper( $delta );
  97
  98     if ( $#{ $set->{list} } != 0 || $set->is_too_complex )
  99     {
 100         return $set->iterate(
 101             sub {
 102                 $_[0]->_recurrence(
 103                     $callback_next, $callback_previous, $delta )
 104             } );
 105     }
 106     # $set is a span
 107     my $result;
 108     if ($set->min != NEG_INFINITY && $set->max != INFINITY)
 109     {
 110         # print STDERR " finite set\n";
 111         my ($min, $min_open) = $set->min_a;
 112         my ($max, $max_open) = $set->max_a;
 113
 114         my ( $min1, $min2 );
 115         $min1 = $callback_next->( $min );
 116         if ( ! $min_open )
 117         {
 118                 $min2 = $callback_previous->( $min1 );
 119                 $min1 = $min2 if defined $min2 && $min == $min2;
 120         }
 121
 122         $result = $set->new();
 123
 124         # get "delta" - abort if this will take too much time.
 125
 126         unless ( defined $delta->{max_delta} )
 127         {
 128           for ( $delta->{count} .. 10 )
 129           {
 130             if ( $max_open )
 131             {
 132                 return $result if $min1 >= $max;
 133             }
 134             else
 135             {
 136                 return $result if $min1 > $max;
 137             }
 138             push @{ $result->{list} },
 139                  { a => $min1, b => $min1, open_begin => 0, open_end => 0 };
 140             $min2 = $callback_next->( $min1 );
 141
 142             if ( $delta->{delta} )
 143             {
 144                 $delta->{delta} += $min2 - $min1;
 145             }
 146             else
 147             {
 148                 $delta->{delta} = $min2 - $min1;
 149             }
 150             $delta->{count}++;
 151             $min1 = $min2;
 152           }
 153
 154           $delta->{max_delta} = $delta->{delta} * 40;
 155         }
 156
 157         if ( $max < $min + $delta->{max_delta} )
 158         {
 159           for ( 1 .. 200 )
 160           {
 161             if ( $max_open )
 162             {
 163                 return $result if $min1 >= $max;
 164             }
 165             else
 166             {
 167                 return $result if $min1 > $max;
 168             }
 169             push @{ $result->{list} },
 170                  { a => $min1, b => $min1, open_begin => 0, open_end => 0 };
 171             $min1 = $callback_next->( $min1 );
 172           }
 173         }
 174
 175         # cluck "give up";
 176     }
 177
 178     # return a "_function", such that we can backtrack later.
 179     my $func = $set->_function( '_recurrence', $callback_next, $callback_previous, $delta );
 180
 181     # removed - returning $result doesn't help on speed
 182     ## return $func->_function2( 'union', $result ) if $result;
 183
 184     return $func;
 185 }
 186
 187 sub is_forever
 188 {
 189     $#{ $_[0]->{list} } == 0 &&
 190     $_[0]->max == INFINITY &&
 191     $_[0]->min == NEG_INFINITY
 192 }
 193
 194 sub _is_recurrence
 195 {
 196     exists $_[0]->{method}           &&
 197     $_[0]->{method} eq '_recurrence' &&
 198     $_[0]->{parent}->is_forever
 199 }
 200
 201 sub intersection
 202 {
 203     my ($s1, $s2) = (shift,shift);
 204
 205     if ( exists $s1->{method} && $s1->{method} eq '_recurrence' )
 206     {
 207         # optimize: recurrence && span
 208         return $s1->{parent}->
 209             intersection( $s2, @_ )->
 210             _recurrence( @{ $s1->{param} } )
 211                 unless ref($s2) && exists $s2->{method};
 212
 213         # optimize: recurrence && recurrence
 214         if ( $s1->{parent}->is_forever &&
 215             ref($s2) && _is_recurrence( $s2 ) )
 216         {
 217             my ( $next1, $previous1 ) = @{ $s1->{param} };
 218             my ( $next2, $previous2 ) = @{ $s2->{param} };
 219             return $s1->{parent}->_function( '_recurrence',
 220                   sub {
 221                                # intersection of parent 'next' callbacks
 222                                my ($n1, $n2);
 223                                my $iterate = 0;
 224                                $n2 = $next2->( $_[0] );
 225                                while(1) {
 226                                    $n1 = $next1->( $previous1->( $n2 ) );
 227                                    return $n1 if $n1 == $n2;
 228                                    $n2 = $next2->( $previous2->( $n1 ) );
 229                                    return if $iterate++ == $max_iterate;
 230                                }
 231                   },
 232                   sub {
 233                                # intersection of parent 'previous' callbacks
 234                                my ($p1, $p2);
 235                                my $iterate = 0;
 236                                $p2 = $previous2->( $_[0] );
 237                                while(1) {
 238                                    $p1 = $previous1->( $next1->( $p2 ) );
 239                                    return $p1 if $p1 == $p2;
 240                                    $p2 = $previous2->( $next2->( $p1 ) );
 241                                    return if $iterate++ == $max_iterate;
 242                                }
 243                   },
 244                );
 245         }
 246     }
 247     return $s1->SUPER::intersection( $s2, @_ );
 248 }
 249
 250 sub union
 251 {
 252     my ($s1, $s2) = (shift,shift);
 253     if ( $s1->_is_recurrence &&
 254          ref($s2) && _is_recurrence( $s2 ) )
 255     {
 256         # optimize: recurrence || recurrence
 257         my ( $next1, $previous1 ) = @{ $s1->{param} };
 258         my ( $next2, $previous2 ) = @{ $s2->{param} };
 259         return $s1->{parent}->_function( '_recurrence',
 260                   sub {  # next
 261                                my $n1 = $next1->( $_[0] );
 262                                my $n2 = $next2->( $_[0] );
 263                                return $n1 < $n2 ? $n1 : $n2;
 264                   },
 265                   sub {  # previous
 266                                my $p1 = $previous1->( $_[0] );
 267                                my $p2 = $previous2->( $_[0] );
 268                                return $p1 > $p2 ? $p1 : $p2;
 269                   },
 270                );
 271     }
 272     return $s1->SUPER::union( $s2, @_ );
 273 }
 274
 275 =head1 NAME
 276
 277 Set::Infinite::_recurrence - Extends Set::Infinite with recurrence functions
 278
 279 =head1 SYNOPSIS
 280
 281     $recurrence = $base_set->_recurrence ( \&next, \&previous );
 282
 283 =head1 DESCRIPTION
 284
 285 This is an internal class used by the DateTime::Set module.
 286 The API is subject to change.
 287
 288 It provides all functionality provided by Set::Infinite, plus the ability
 289 to define recurrences with arbitrary objects, such as dates.
 290
 291 =head1 METHODS
 292
 293 =over 4
 294
 295 =item * _recurrence ( \&next, \&previous )
 296
 297 Creates a recurrence set. The set is defined inside a 'base set'.
 298
 299    $recurrence = $base_set->_recurrence ( \&next, \&previous );
 300
 301 The recurrence functions take one argument, and return the 'next' or
 302 the 'previous' occurence.
 303
 304 Example: defines the set of all 'integer numbers':
 305
 306     use strict;
 307
 308     use Set::Infinite::_recurrence;
 309     use POSIX qw(floor);
 310
 311     # define the recurrence span
 312     my $forever = Set::Infinite::_recurrence->new(
 313         Set::Infinite::_recurrence::NEG_INFINITY,
 314         Set::Infinite::_recurrence::INFINITY
 315     );
 316
 317     my $recurrence = $forever->_recurrence(
 318         sub {   # next
 319                 floor( $_[0] + 1 )
 320             },
 321         sub {   # previous
 322                 my $tmp = floor( $_[0] );
 323                 $tmp < $_[0] ? $tmp : $_[0] - 1
 324             },
 325     );
 326
 327     print "sample recurrence ",
 328           $recurrence->intersection( -5, 5 ), "\n";
 329     # sample recurrence -5,-4,-3,-2,-1,0,1,2,3,4,5
 330
 331     {
 332         my $x = 234.567;
 333         print "next occurence after $x = ",
 334               $recurrence->{param}[0]->( $x ), "\n";  # 235
 335         print "previous occurence before $x = ",
 336               $recurrence->{param}[2]->( $x ), "\n";  # 234
 337     }
 338
 339     {
 340         my $x = 234;
 341         print "next occurence after $x = ",
 342               $recurrence->{param}[0]->( $x ), "\n";  # 235
 343         print "previous occurence before $x = ",
 344               $recurrence->{param}[2]->( $x ), "\n";  # 233
 345     }
 346
 347 =item * is_forever
 348
 349 Returns true if the set is a single span,
 350 ranging from -Infinity to Infinity.
 351
 352 =item * _is_recurrence
 353
 354 Returns true if the set is an unbounded recurrence,
 355 ranging from -Infinity to Infinity.
 356
 357 =back
 358
 359 =head1 CONSTANTS
 360
 361 =over 4
 362
 363 =item * INFINITY
 364
 365 The C<Infinity> value.
 366
 367 =item * NEG_INFINITY
 368
 369 The C<-Infinity> value.
 370
 371 =back
 372
 373 =head1 SUPPORT
 374
 375 Support is offered through the C<datetime@perl.org> mailing list.
 376
 377 Please report bugs using rt.cpan.org
 378
 379 =head1 AUTHOR
 380
 381 Flavio Soibelmann Glock <fglock@pucrs.br>
 382
 383 The recurrence generation algorithm is based on an idea from Dave Rolsky.
 384
 385 =head1 COPYRIGHT
 386
 387 Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
 388 This program is free software; you can distribute it and/or
 389 modify it under the same terms as Perl itself.
 390
 391 The full text of the license can be found in the LICENSE file
 392 included with this module.
 393
 394 =head1 SEE ALSO
 395
 396 Set::Infinite
 397
 398 DateTime::Set
 399
 400 For details on the Perl DateTime Suite project please see
 401 L<http://datetime.perl.org>.
 402
 403 =cut
 404