view release on metacpan or  search on metacpan

lib/Algorithm/LineSegments.pm  view on Meta::CPAN

  my @d = @{ $o{points} };

  my @q;

  for (my $ix = 0; $ix < @d - 1; $ix += 2) {
    push @q, [$d[$ix], $d[$ix+1]];
  }

  my $min = min @d;
  my $max = max @d;

  ###################################################################
  # This function projects values from $min to $max to 0 to 1. This
  # is useful in order to keep the cost values similar.
  ###################################################################
  my $scale_to_unit = sub {
    my $v = shift;
    return ($v - $min) / ($max - $min);
  };

  $o{cost} //= sub {
    my ($left, $right) = @_;
    _normalised_euclidean($q[$left], $q[$right], $scale_to_unit);
  };

  $o{continue} //= sub {
    my ($count, $cost) = @_;
    return 0 if $count <= 3; 
    return 1;
  };
  
  my $heap = Heap::Priority->new;
  $heap->lowest_first;
  $heap->add($_, $o{cost}->($_, $_+1)) for 0 .. $#q - 1;

  ###################################################################
  # I haven't found a good solution to maintain the heap and modify
  # the list, so as a workaround the heap identifies a mergable pair
  # with the key and when merging elements of a pair, the second
  # element is replaced by `undef` to maintain the size of the list,
  # so the heap keys, indices into the list, remain valid. This has
  # the consequence of producing gaps in the list, and the variables
  # below maintain how the gaps can be skipped.
  ###################################################################
  my %next = map { $_ => $_ + 1 } 0 .. $#q - 1;
  my %prev = map { $_ => $_ - 1 } 1 .. $#q - 1;

  for (my $count = @q;;) {
    my $ix = $heap->pop;
    last unless defined $ix;

    #################################################################
    # Ordinarily it should be possible to obtain the priority of the
    # element on top of the heap, but the chosen module can report
    # only the priorities of all elements, which is a bit costly, so
    # instead the cost is re-computed here for now.
    #################################################################
    my $cost = $o{cost}->($ix, $next{$ix});
    
    #################################################################
    # The callback can be by calling code to stop the merging process 
    #################################################################
    last unless $o{continue}->($count, $cost);

    my $k = $ix;
    my $j = $next{$k};
    
    next unless defined $j;
    
    my @merged = map { @{ $q[$_] } } $k, $j;
    $q[$k] = undef;
    $q[$j] = undef;
    splice @q, $k, 2, [@merged], undef;
    $count--;
    
    #################################################################
    # Now that $k has changed, merging $k with the element before or
    # after has a different cost, so those elements are removed from
    # the heap and added again with the newly calculated cost factor.
    #################################################################
    $heap->delete_item($next{$k}) if defined $next{$k};
    $heap->delete_item($prev{$k}) if defined $prev{$k};

    $next{$k} = $next{$j};

    $heap->add($prev{$k}, $o{cost}->($prev{$k}, $k)) if defined $prev{$k};
    $heap->add($k, $o{cost}->($k, $next{$k})) if defined $next{$k};

    $prev{$next{$j}} = $k if defined $next{$j};
    
    delete $next{$j};
    delete $prev{$j};
  }

  my @temp = grep { defined } @q;
  my @result;
  my $pos = 0;
  for (my $ix = 0; $ix < @temp; ++$ix) {
    push @result, [
      [ $pos, $temp[$ix][0] ],
      [ $pos + scalar(@{$temp[$ix]}) - 1, $temp[$ix][-1] ]
    ];
    $pos += scalar(@{$temp[$ix]})
  }
  
  return @result;
}

1;

__END__

=head1 NAME

Algorithm::LineSegments - Piecewise linear function approximation

=head1 SYNOPSIS

  use Algorithm::LineSegments;
  my @points = line_segment_points(
    points => \@numbers,