modules/fallback/Set/Infinite/Arithmetic.pm

   1 package Set::Infinite::Arithmetic;
   2 # Copyright (c) 2001 Flavio Soibelmann Glock. All rights reserved.
   3 # This program is free software; you can redistribute it and/or
   4 # modify it under the same terms as Perl itself.
   5
   6 use strict;
   7 # use warnings;
   8 require Exporter;
   9 use Carp;
  10 use Time::Local;
  11 use POSIX qw(floor);
  12
  13 use vars qw( @EXPORT @EXPORT_OK $inf );
  14
  15 @EXPORT = qw();
  16 @EXPORT_OK = qw();
  17 # @EXPORT_OK = qw( %subs_offset2 %Offset_to_value %Value_to_offset %Init_quantizer );
  18
  19 $inf = 100**100**100;    # $Set::Infinite::inf;  doesn't work! (why?)
  20
  21 =head2 NAME
  22
  23 Set::Infinite::Arithmetic - Scalar operations used by quantize() and offset()
  24
  25 =head2 AUTHOR
  26
  27 Flavio Soibelmann Glock - fglock@pucrs.br
  28
  29 =cut
  30
  31 use vars qw( $day_size $hour_size $minute_size $second_size );
  32 $day_size =    timegm(0,0,0,2,3,2001) - timegm(0,0,0,1,3,2001);
  33 $hour_size =   $day_size / 24;
  34 $minute_size = $hour_size / 60;
  35 $second_size = $minute_size / 60;
  36
  37 use vars qw( %_MODE %subs_offset2 %Offset_to_value @week_start %Init_quantizer %Value_to_offset %Offset_to_value );
  38
  39 =head2 %_MODE hash of subs
  40
  41     $a->offset ( value => [1,2], mode => 'offset', unit => 'days' );
  42
  43     $a->offset ( value => [1,2, -5,-4], mode => 'offset', unit => 'days' );
  44
  45 note: if mode = circle, then "-5" counts from end (like a Perl negative array index).
  46
  47     $a->offset ( value => [1,2], mode => 'offset', unit => 'days', strict => $a );
  48
  49 option 'strict' will return intersection($a,offset). Default: none.
  50
  51 =cut
  52
  53 # return value = ($this, $next, $cmp)
  54 %_MODE = (
  55     circle => sub {
  56             if ($_[3] >= 0) {
  57                 &{ $_[0] } ($_[1], $_[3], $_[4] )
  58             }
  59             else {
  60                 &{ $_[0] } ($_[2], $_[3], $_[4] )
  61             }
  62     },
  63     begin =>  sub { &{ $_[0] } ($_[1], $_[3], $_[4] ) },
  64     end =>    sub { &{ $_[0] } ($_[2], $_[3], $_[4] ) },
  65     offset => sub {
  66             my ($this, undef) = &{ $_[0] } ($_[1], $_[3], $_[4] );
  67             my (undef, $next) = &{ $_[0] } ($_[2], $_[3], $_[4] );
  68             ($this, $next);
  69     }
  70 );
  71
  72
  73 =head2 %subs_offset2($object, $offset1, $offset2)
  74
  75     &{ $subs_offset2{$unit} } ($object, $offset1, $offset2);
  76
  77 A hash of functions that return:
  78
  79     ($object+$offset1, $object+$offset2)
  80
  81 in $unit context.
  82
  83 Returned $object+$offset1, $object+$offset2 may be scalars or objects.
  84
  85 =cut
  86
  87 %subs_offset2 = (
  88     weekdays =>    sub {
  89         # offsets to week-day specified
  90         # 0 = first sunday from today (or today if today is sunday)
  91         # 1 = first monday from today (or today if today is monday)
  92         # 6 = first friday from today (or today if today is friday)
  93         # 13 = second friday from today
  94         # -1 = last saturday from today (not today, even if today were saturday)
  95         # -2 = last friday
  96         my ($self, $index1, $index2) = @_;
  97         return ($self, $self) if $self == $inf;
  98         # my $class = ref($self);
  99         my @date = gmtime( $self );
 100         my $wday = $date[6];
 101         my ($tmp1, $tmp2);
 102
 103         $tmp1 = $index1 - $wday;
 104         if ($index1 >= 0) {
 105             $tmp1 += 7 if $tmp1 < 0; # it will only happen next week
 106         }
 107         else {
 108             $tmp1 += 7 if $tmp1 < -7; # if will happen this week
 109         }
 110
 111         $tmp2 = $index2 - $wday;
 112         if ($index2 >= 0) {
 113             $tmp2 += 7 if $tmp2 < 0; # it will only happen next week
 114         }
 115         else {
 116             $tmp2 += 7 if $tmp2 < -7; # if will happen this week
 117         }
 118
 119         # print " [ OFS:weekday $self $tmp1 $tmp2 ] \n";
 120         # $date[3] += $tmp1;
 121         $tmp1 = $self + $tmp1 * $day_size;
 122         # $date[3] += $tmp2 - $tmp1;
 123         $tmp2 = $self + $tmp2 * $day_size;
 124
 125         ($tmp1, $tmp2);
 126     },
 127     years =>     sub {
 128         my ($self, $index, $index2) = @_;
 129         return ($self, $self) if $self == $inf;
 130         # my $class = ref($self);
 131         # print " [ofs:year:$self -- $index]\n";
 132         my @date = gmtime( $self );
 133         $date[5] +=    1900 + $index;
 134         my $tmp = timegm(@date);
 135
 136         $date[5] +=    $index2 - $index;
 137         my $tmp2 = timegm(@date);
 138
 139         ($tmp, $tmp2);
 140     },
 141     months =>     sub {
 142         my ($self, $index, $index2) = @_;
 143         # carp " [ofs:month:$self -- $index -- $inf]";
 144         return ($self, $self) if $self == $inf;
 145         # my $class = ref($self);
 146         my @date = gmtime( $self );
 147
 148         my $mon =     $date[4] + $index;
 149         my $year =    $date[5] + 1900;
 150         # print " [OFS: month: from $year$mon ]\n";
 151         if (($mon > 11) or ($mon < 0)) {
 152             my $addyear = floor($mon / 12);
 153             $mon = $mon - 12 * $addyear;
 154             $year += $addyear;
 155         }
 156
 157         my $mon2 =     $date[4] + $index2;
 158         my $year2 =    $date[5] + 1900;
 159         if (($mon2 > 11) or ($mon2 < 0)) {
 160             my $addyear2 = floor($mon2 / 12);
 161             $mon2 = $mon2 - 12 * $addyear2;
 162             $year2 += $addyear2;
 163         }
 164
 165         # print " [OFS: month: to $year $mon ]\n";
 166
 167         $date[4] = $mon;
 168         $date[5] = $year;
 169         my $tmp = timegm(@date);
 170
 171         $date[4] = $mon2;
 172         $date[5] = $year2;
 173         my $tmp2 = timegm(@date);
 174
 175         ($tmp, $tmp2);
 176     },
 177     days =>     sub {
 178         ( $_[0] + $_[1] * $day_size,
 179           $_[0] + $_[2] * $day_size,
 180         )
 181     },
 182     weeks =>    sub {
 183         ( $_[0] + $_[1] * (7 * $day_size),
 184           $_[0] + $_[2] * (7 * $day_size),
 185         )
 186     },
 187     hours =>    sub {
 188         # carp " [ $_[0]+$_[1] hour = ".( $_[0] + $_[1] * $hour_size )." mode=".($_[0]->{mode})." ]";
 189         ( $_[0] + $_[1] * $hour_size,
 190           $_[0] + $_[2] * $hour_size,
 191         )
 192     },
 193     minutes =>    sub {
 194         ( $_[0] + $_[1] * $minute_size,
 195           $_[0] + $_[2] * $minute_size,
 196         )
 197     },
 198     seconds =>    sub {
 199         ( $_[0] + $_[1] * $second_size,
 200           $_[0] + $_[2] * $second_size,
 201         )
 202     },
 203     one =>      sub {
 204         ( $_[0] + $_[1],
 205           $_[0] + $_[2],
 206         )
 207     },
 208 );
 209
 210
 211 @week_start = ( 0, -1, -2, -3, 3, 2, 1, 0, -1, -2, -3, 3, 2, 1, 0 );
 212
 213 =head2 %Offset_to_value($object, $offset)
 214
 215 =head2 %Init_quantizer($object)
 216
 217     $Offset_to_value{$unit} ($object, $offset);
 218
 219     $Init_quantizer{$unit} ($object);
 220
 221 Maps an 'offset value' to a 'value'
 222
 223 A hash of functions that return ( int($object) + $offset ) in $unit context.
 224
 225 Init_quantizer subroutines must be called before using subs_offset1 functions.
 226
 227 int(object)+offset is a scalar.
 228
 229 Offset_to_value is optimized for calling it multiple times on the same object,
 230 with different offsets. That's why there is a separate initialization
 231 subroutine.
 232
 233 $self->{offset} is created on initialization. It is an index used
 234 by the memoization cache.
 235
 236 =cut
 237
 238 %Offset_to_value = (
 239     weekyears =>    sub {
 240         my ($self, $index) = @_;
 241         my $epoch = timegm( 0,0,0,
 242             1,0,$self->{offset} + $self->{quant} * $index);
 243         my @time = gmtime($epoch);
 244         # print " [QT_D:weekyears:$self->{offset} + $self->{quant} * $index]\n";
 245         # year modulo week
 246         # print " [QT:weekyears: time = ",join(";", @time )," ]\n";
 247         $epoch += ( $week_start[$time[6] + 7 - $self->{wkst}] ) * $day_size;
 248         # print " [QT:weekyears: week=",join(";", gmtime($epoch) )," wkst=$self->{wkst} tbl[",$time[6] + 7 - $self->{wkst},"]=",$week_start[$time[6] + 7 - $self->{wkst}]," ]\n\n";
 249
 250         my $epoch2 = timegm( 0,0,0,
 251             1,0,$self->{offset} + $self->{quant} * (1 + $index) );
 252         @time = gmtime($epoch2);
 253         $epoch2 += ( $week_start[$time[6] + 7 - $self->{wkst}] ) * $day_size;
 254         ( $epoch, $epoch2 );
 255     },
 256     years =>     sub {
 257         my $index = $_[0]->{offset} + $_[0]->{quant} * $_[1];
 258         ( timegm( 0,0,0, 1, 0, $index),
 259           timegm( 0,0,0, 1, 0, $index + $_[0]->{quant}) )
 260       },
 261     months =>     sub {
 262         my $mon = $_[0]->{offset} + $_[0]->{quant} * $_[1];
 263         my $year = int($mon / 12);
 264         $mon -= $year * 12;
 265         my $tmp = timegm( 0,0,0, 1, $mon, $year);
 266
 267         $mon += $year * 12 + $_[0]->{quant};
 268         $year = int($mon / 12);
 269         $mon -= $year * 12;
 270         ( $tmp, timegm( 0,0,0, 1, $mon, $year) );
 271       },
 272     weeks =>    sub {
 273         my $tmp = 3 * $day_size + $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
 274         ($tmp, $tmp + $_[0]->{quant})
 275       },
 276     days =>     sub {
 277         my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
 278         ($tmp, $tmp + $_[0]->{quant})
 279       },
 280     hours =>    sub {
 281         my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
 282         ($tmp, $tmp + $_[0]->{quant})
 283       },
 284     minutes =>    sub {
 285         my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
 286         ($tmp, $tmp + $_[0]->{quant})
 287       },
 288     seconds =>    sub {
 289         my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
 290         ($tmp, $tmp + $_[0]->{quant})
 291       },
 292     one =>       sub {
 293         my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
 294         ($tmp, $tmp + $_[0]->{quant})
 295       },
 296 );
 297
 298
 299 # Maps an 'offset value' to a 'value'
 300
 301 %Value_to_offset = (
 302     one =>      sub { floor( $_[1] / $_[0]{quant} ) },
 303     seconds =>  sub { floor( $_[1] / $_[0]{quant} ) },
 304     minutes =>  sub { floor( $_[1] / $_[0]{quant} ) },
 305     hours =>    sub { floor( $_[1] / $_[0]{quant} ) },
 306     days =>     sub { floor( $_[1] / $_[0]{quant} ) },
 307     weeks =>    sub { floor( ($_[1] - 3 * $day_size) / $_[0]{quant} ) },
 308     months =>   sub {
 309         my @date = gmtime( 0 + $_[1] );
 310         my $tmp = $date[4] + 12 * (1900 + $date[5]);
 311         floor( $tmp / $_[0]{quant} );
 312       },
 313     years =>    sub {
 314         my @date = gmtime( 0 + $_[1] );
 315         my $tmp = $date[5] + 1900;
 316         floor( $tmp / $_[0]{quant} );
 317       },
 318     weekyears =>    sub {
 319
 320         my ($self, $value) = @_;
 321         my @date;
 322
 323         # find out YEAR number
 324         @date = gmtime( 0 + $value );
 325         my $year = floor( $date[5] + 1900 / $self->{quant} );
 326
 327         # what is the EPOCH for this week-year's begin ?
 328         my $begin_epoch = timegm( 0,0,0,  1,0,$year);
 329         @date = gmtime($begin_epoch);
 330         $begin_epoch += ( $week_start[$date[6] + 7 - $self->{wkst}] ) * $day_size;
 331
 332         # what is the EPOCH for this week-year's end ?
 333         my $end_epoch = timegm( 0,0,0,  1,0,$year+1);
 334         @date = gmtime($end_epoch);
 335         $end_epoch += ( $week_start[$date[6] + 7 - $self->{wkst}] ) * $day_size;
 336
 337         $year-- if $value <  $begin_epoch;
 338         $year++ if $value >= $end_epoch;
 339
 340         # carp " value=$value offset=$year this_epoch=".$begin_epoch;
 341         # carp " next_epoch=".$end_epoch;
 342
 343         $year;
 344       },
 345 );
 346
 347 # Initialize quantizer
 348
 349 %Init_quantizer = (
 350     one =>       sub {},
 351     seconds =>   sub { $_[0]->{quant} *= $second_size },
 352     minutes =>   sub { $_[0]->{quant} *= $minute_size },
 353     hours =>     sub { $_[0]->{quant} *= $hour_size },
 354     days =>      sub { $_[0]->{quant} *= $day_size },
 355     weeks =>     sub { $_[0]->{quant} *= 7 * $day_size },
 356     months =>    sub {},
 357     years =>     sub {},
 358     weekyears => sub {
 359         $_[0]->{wkst} = 1 unless defined $_[0]->{wkst};
 360         # select which 'cache' to use
 361         # $_[0]->{memo} .= $_[0]->{wkst};
 362     },
 363 );
 364
 365
 366 1;
 367