File Coverage

blib/lib/Data/RunningTotal.pm

Criterion	Covered	Total	%
statement	276	290	95.1
branch	91	114	79.8
condition	24	35	68.5
subroutine	20	21	95.2
pod	7	7	100.0
total	418	467	89.5

package Data::RunningTotal;


use 5.005;
use strict;
use warnings;
use Carp;
use Data::RunningTotal::Item;

require Exporter;

our @ISA = qw(Exporter);
our $VERSION = '0.03';

# Create a new Running Total object
sub new {
    my $that = shift;
    my $class = ref($that) || $that;
    my %opts = @_;

    croak("Missing required parameter 'dimensions'") if !exists($opts{dimensions});
    croak("'dimensions' paramter must be an array ref") if (ref($opts{dimensions}) ne "ARRAY");

    my @dimensions = @{$opts{dimensions}};

    # Remember the dimensions
    my %state = (dims    => \@dimensions,
                 numDims => scalar(@dimensions),
                 counts  => [],
                 pendingUpdates => {},
                 updatesPending => 0,
                );

    return bless(\%state);

}

# Increment the count for a specific point
sub inc {
  my ($self, $time, %opts) = @_;

  croak("Missing required parameter 'coords'") if !exists($opts{coords});
  croak("'coords' paramter must be an array ref") if (ref($opts{coords}) ne "ARRAY");

  my $weight = $opts{weight} || 1;

  if (scalar(@{$opts{coords}}) != $self->{numDims}) {
    croak("Expected $self->{numDims} coordinates, but ".scalar(@{$opts{coords}})." given");
  }

  $self->{updatesPending}++;
  push(@{$self->{pendingUpdates}{$time}}, [$weight, @{$opts{coords}}]);

}

# Decrement the count for a specific point
sub dec {
  my ($self, $time, %opts) = @_;

  croak("Missing required parameter 'coords'") if !exists($opts{coords});
  croak("'coords' paramter must be an array ref") if (ref($opts{coords}) ne "ARRAY");

  my $weight = ($opts{weight} || 1) * -1;

  if (scalar(@{$opts{coords}}) != $self->{numDims}) {
    croak("Expected $self->{numDims} coordinates, but ".scalar(@{$opts{coords}})." given");
  }

  $self->{updatesPending}++;
  push(@{$self->{pendingUpdates}{$time}}, [$weight, @{$opts{coords}}]);

}

# Create a new item that can be moved in the space
sub newItem {
  my ($self, %opts) = @_;
  my $weight = $opts{weight} || 1;
  return Data::RunningTotal::Item->new($self, $self->{numDims}, $weight);
}

# Get the count for a specific point or volume in time
# Note that the coords can be code refs
sub getValue {
  my ($self, $time, %opts) = @_;

  croak("Missing required parameter 'coords'") if !exists($opts{coords});
  croak("'coords' paramter must be an array ref") if (ref($opts{coords}) ne "ARRAY");

  $self->_applyPending();

  my $lastIdx           = $self->_findIndexForTime($time);
  my ($eligCoords,
      $numPermutations) = $self->_getEligibleCoords(@{$opts{coords}});

  # It is possible that the user asked for a value that has never been seen
  return 0 if !defined $eligCoords;

  my $dimArrays    = $self->_getDimArrays($eligCoords, $lastIdx);

  # Do the real work
  return $self->_getValueWalkingBackwards($dimArrays, $numPermutations);

}

# Get a list of changes to the weight of each of the specified points/volumes
sub getChangeList {
  my ($self, %opts) = @_;

  croak("Missing required parameter 'coords'") if !exists($opts{coords});
  croak("'coords' paramter must be an array ref") if (ref($opts{coords}) ne "ARRAY");

  $self->_applyPending();

  my ($eligCoords,
      $numPermutations) = $self->_getEligibleCoords(@{$opts{coords}});

  # It is possible that the user asked for a value that has never been seen
  return [] if !defined $eligCoords;

  my $dimArrays    = $self->_getDimArrays($eligCoords);

  # Do the real work
  return $self->_getListWalkingForwards($dimArrays, $opts{period}, $opts{start}, $opts{end});

}

# Pass in N change lists and it will combine them into a single
# changelist with a time value and N following values
sub combineChangeList {
  my ($self, @lists) = @_;

  my @res;

  my $numLists = scalar(@lists);
  my @listIdxs;
  my @lastVals;
  for my $i (0 .. $numLists-1) {
    $listIdxs[$i] = 0;
    $lastVals[$i] = 0;
  }

  while(1) {
    my $minTime = $lists[0][$listIdxs[0]][0];
    for my $i (1 .. $numLists-1) {
      my $listTime = $lists[$i][$listIdxs[$i]][0];
      $minTime = $listTime if !defined $minTime || defined $listTime && $listTime < $minTime;
    }

    last if !defined $minTime;

    for my $i (0 .. $numLists-1) {
      my $listTime = $lists[$i][$listIdxs[$i]][0];
      if (defined $listTime && $listTime == $minTime) {
        $lastVals[$i] = $lists[$i][$listIdxs[$i]][1];
        $listIdxs[$i]++;
      }
    }
    push(@res, [$minTime, @lastVals]);
  }

  return \@res;

}


######################################################################
## Private Methods
######################################################################

# Just dump out the state - should be removed before prime time
sub _dumpState {
  my ($self) = @_;

  # print Dumper $self;

}

# Apply all the pending updates
sub _applyPending {
  my ($self) = @_;

  if ($self->{updatesPending} == 0) {
    return;
  }

  # Clean out last data
  @{$self->{counts}} = ();
  @{$self->{dimIdxs}} = ();

  my %last;
  my $idx = 0;
  foreach my $time (sort {$a <=> $b} keys(%{$self->{pendingUpdates}})) {
    foreach my $update (@{$self->{pendingUpdates}{$time}}) {
      my $tref = \%last;
      my $coords = $update;
      my $weight = shift(@{$coords});
      # map {$tref->{$_} = {} if !defined($tref->{$_}); $tref = $tref->{$_};} @{$coords};
      map {$tref = ($tref->{$_} ||= {});} @{$coords};
      $tref->{val} += $weight;
      push(@{$self->{counts}}, [$time, $tref->{val}, $tref->{lastIdx}]);
      $tref->{lastIdx} = $idx;
      foreach my $dim (0 .. $self->{numDims}-1) {
        push(@{$self->{dimIdxs}[$dim]{$coords->[$dim]}}, $idx);
      }
      $idx++;
    }
  }
  $self->{updatesPending} = 0;

}

# Look through the list of counts ordered by time and find the
# index for the specified time
sub _findIndexForTime {
  my ($self, $time) = @_;

  # just do a simple binary search to find the first entry that
  # is greater than the time or the last entry that equals the time
  my $start = 0;
  my $end = scalar(@{$self->{counts}})-1;
  my $origEnd = $end;
  my $lastSmaller;
  my $lastEqual;

  my $notDone = 1;
  while ($notDone) {

    if ($start >= $end) {
      $notDone = 0;
    }
    my $idx = int(($end-$start)/2)+$start;

    if ($self->{counts}[$idx][0] < $time) {
      $lastSmaller = $idx;
      $start       = $idx+1;
    }
    elsif ($self->{counts}[$idx][0] == $time) {
      $lastEqual   = $idx;
      $start       = $idx+1;
    }
    else {
      $end         = $idx-1;
    }

  }

  return $lastEqual if defined $lastEqual;
  return $lastSmaller if defined $lastSmaller;
  return $origEnd;

}


# Go through all the possible coords and produce a list of lists of them
sub _getEligibleCoords {
  my ($self, @coordSels) = @_;

  my @res;
  my $permutations = 1;
  for my $i (0 .. $self->{numDims}-1) {
    my @elig;
    if (ref $coordSels[$i] eq "CODE") {
      # Call the code ref on each possible coordinate, collecting ones that return true
      foreach my $coord (keys(%{$self->{dimIdxs}[$i]})) {
        if (&{$coordSels[$i]}($coord)) {
          push(@elig, $coord);
        }
      }
    }
    elsif (!defined $coordSels[$i]) {
      # An undefined coordidate selector behaves like a wildcard
      # foreach my $coord (keys(%{$self->{dimIdxs}[$i]})) {
      #   push(@elig, $coord);
      # }
      push(@res, undef);
      $permutations *= scalar(keys(%{$self->{dimIdxs}[$i]}));
      next;
    }
    elsif (defined $self->{dimIdxs}[$i]{$coordSels[$i]}) {
      push(@elig, $coordSels[$i]);
    }

    if (scalar(@elig) == 0) {
      # No coords found for the selector - no value will be found
      return undef;
    }

    $permutations *= scalar(@elig);
    push(@res, \@elig);

  }

  return (\@res, $permutations);

}

# This will combine and sort all the selected coordinates into single
# arrays per dimension
sub _getDimArrays {
  my ($self, $eligibleCoords, $lastIdx) = @_;

  my @res;
  for my $i (0 .. $self->{numDims}-1) {
    if (!defined $eligibleCoords->[$i]) {
      # Do nothing - this indicates that all coordinates should be
      # included, which is what will happen if we don't include any
    }
    elsif (scalar(@{$eligibleCoords->[$i]}) > 1) {
      my @coordList;
      foreach my $coord (@{$eligibleCoords->[$i]}) {
        my $list = $self->{dimIdxs}[$i]{$coord};
        if (defined $lastIdx) {
          my $end = _binarySearch($list, $lastIdx);
          @coordList = (@coordList, @{$list}[0..$end]);
        }
        else {
          @coordList = (@coordList, @{$list});
        }
      }
      @coordList = sort {$a <=> $b} @coordList;
      push(@res, \@coordList);
    }
    else {
      if (defined $lastIdx) {
        my $end = _binarySearch($self->{dimIdxs}[$i]{$eligibleCoords->[$i][0]}, $lastIdx);
        my @subset = @{$self->{dimIdxs}[$i]{$eligibleCoords->[$i][0]}}[0..$end];
        push(@res, \@subset);
      }
      else {
        push(@res, $self->{dimIdxs}[$i]{$eligibleCoords->[$i][0]});
      }
    }

  }

  # Special case - if all the selectors were undef, then there
  # will be no dimension arrays on the result list.  Create
  # a single list that contains all the indices
  if (scalar(@res) == 0) {
    my @allIndices = (0..$lastIdx);
    push(@res, \@allIndices);
  }

  return \@res;

}

sub _getValueWalkingBackwards {
  my ($self, $dimArrays, $numPermutations) = @_;
  my $sum = 0;
  my $nDims = scalar(@{$dimArrays});
  my $dimBound = $nDims-1;
  my %blackList;
  my $permsFound = 0;

  my @idxs;
  for my $i (0 .. $dimBound) {
    $idxs[$i] = scalar(@{$dimArrays->[$i]})-1;
  }

  my $currMin = scalar(@{$self->{counts}});
 mainLoop:
  while ($permsFound < $numPermutations) {
    my $allTheSame = 1;
    foreach my $i (0 .. $dimBound) {
      while ($idxs[$i] >= 0 && $dimArrays->[$i][$idxs[$i]] > $currMin) {
        $idxs[$i]--;
      }
      if ($idxs[$i] < 0) {
        last mainLoop;
      }
      if ($dimArrays->[$i][$idxs[$i]] < $currMin) {
        $currMin = $dimArrays->[$i][$idxs[$i]];
        $allTheSame = 0 unless $i == 0;
      }
    }

    if ($allTheSame) {
      if ($blackList{$currMin}) {
      }
      else {
        $sum += $self->{counts}[$currMin][1];
        $permsFound++;
      }
      $blackList{$self->{counts}[$currMin][2]} = 1 if defined $self->{counts}[$currMin][2];
      $idxs[0]--;
      if ($idxs[0] < 0) {
        last mainLoop;
      }
    }

  }

  return $sum;

}


sub _getListWalkingForwards {
  my ($self, $dimArrays, $period, $start, $end) = @_;
  my $currSum = 0;
  my $nDims = scalar(@{$dimArrays});
  my $dimBound = $nDims-1;
  my @res;

  my @idxs;
  my @maxIdx;
  for my $i (0 .. $dimBound) {
    $idxs[$i] = 0;
    $maxIdx[$i] = scalar(@{$dimArrays->[$i]});
  }

  my $currMax = -1;

  my $lastSum;
  my $lastTime;
 mainLoop:
  while (1) {
    my $allTheSame = 1;
    foreach my $i (0 .. $dimBound) {
      while ($idxs[$i] < $maxIdx[$i] &&
             $dimArrays->[$i][$idxs[$i]] < $currMax) {
        $idxs[$i]++;
      }
      if ($idxs[$i] >= $maxIdx[$i]) {
        last mainLoop;
      }
      if ($dimArrays->[$i][$idxs[$i]] > $currMax) {
        $currMax = $dimArrays->[$i][$idxs[$i]];
        $allTheSame = 0 unless $i == 0;
      }
    }

    if ($allTheSame) {
      last mainLoop if defined($end) && $self->{counts}[$currMax][0] > $end;
      $currSum -= $self->{counts}[$self->{counts}[$currMax][2]][1] if defined $self->{counts}[$currMax][2];
      $currSum += $self->{counts}[$currMax][1];
      _addToPeriodicList(\@res, $period, $self->{counts}[$currMax][0], $currSum);
    }

    $idxs[0]++;
    if ($idxs[0] >= $maxIdx[0]) {
      last mainLoop;
    }
  }

  return \@res;

}

# Add the results to a list, taking into account
# duplicates for the same time as well as the periodic
# requirements
sub _addToPeriodicList {
  my ($list, $period, $time, $value) = @_;

  my $adjustedTime;
  if ($period) {
    $adjustedTime = (int($time/$period)+1)*$period;
  }
  else {
    $adjustedTime = $time;
  }

  my $lastIdx = scalar(@{$list})-1;

  if ($lastIdx >= 0) {
    if ($list->[$lastIdx][1] == $value) {
      return;
    }
    elsif ($lastIdx >= 0 && $list->[$lastIdx][0] == $adjustedTime) {
      # The penultimate entry on the list may already have this value
      # don't put it on if it is the same
      if ($lastIdx >= 1 && $list->[$lastIdx-1][1] == $value) {
        pop(@{$list});
      }
      else {
        $list->[$lastIdx] = [$adjustedTime, $value];
      }
      return;
    }
  }

  $list->[$lastIdx+1] = [$adjustedTime, $value];

}


# Returns the index of the last value that is equal to the search
# value or the first value that is greater.
sub _binarySearch {
  my ($list, $value) = @_;

  my $start        = 0;
  my $end          = scalar(@{$list}) - 1;
  my $origEnd      = $end;
  my $notDone      = 1;
  my $lastSmaller;
  my $lastEqual;

  while ($notDone) {

    if ($start >= $end) {
      $notDone = 0;
    }
    my $idx = int(($end-$start)/2)+$start;

    if ($list->[$idx] < $value) {
      $lastSmaller  = $idx;
      $start        = $idx+1;
    }
    elsif ($list->[$idx] == $value) {
      $start        = $idx+1;
      $lastEqual    = $idx;
    }
    else {
      $end          = $idx;
    }

  }

  return $lastEqual if defined $lastEqual;
  return $lastSmaller if defined $lastSmaller;
  return $origEnd;
}


1;
__END__