File Coverage

blib/lib/Set/Infinite/_recurrence.pm
Criterion Covered Total %
statement 111 144 77.0
branch 47 76 61.8
condition 36 72 50.0
subroutine 13 17 76.4
pod 4 4 100.0
total 211 313 67.4


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