File Coverage

blib/lib/Number/Nary.pm

Criterion	Covered	Total	%
statement	100	101	99.0
branch	31	34	91.1
condition	2	3	66.6
subroutine	21	21	100.0
pod	3	3	100.0
total	157	162	96.9

use 5.006;
use warnings;
use strict;
package Number::Nary;
{
  $Number::Nary::VERSION = '1.100312';
}
# ABSTRACT: encode and decode numbers as n-ary strings

use Carp qw(croak);
use Scalar::Util 0.90 qw(reftype);
use List::MoreUtils 0.09 qw(uniq);
use UDCode ();

use Sub::Exporter -setup => {
  exports => [ qw(n_codec n_encode n_decode) ],
  groups  => {
    default    => [ qw(n_codec) ],
    codec_pair => \&_generate_codec_pair,
  }
};

sub _generate_codec_pair {
  my (undef, undef, $arg, undef) = @_;

  my $local_arg = {%$arg};
  my $digits    = delete $local_arg->{digits};

  my %pair;
  @pair{qw(encode decode)} = n_codec($digits, $local_arg);
  return \%pair;
}


sub _split_len_iterator {
  my ($length) = @_;

  return sub {
    my ($string, $callback) = @_;

    my $places = length($string) / $length;

    croak "string length is not a multiple of digit length"
      unless $places == int $places;

    for my $position (1 .. $places) {
      my $digit = substr $string, (-$length * $position), $length;
      $callback->($digit, $position);
    }
  }
}

sub _split_digit_iterator {
  my ($digits) = @_;

  sub {
    my ($string, $callback) = @_;
    my @digits;
    ITER: while (length $string) {
      for (@$digits) {
        if (index($string, $_) == 0) {
          push @digits, substr($string, 0, length $_, '');
          next ITER;
        }
      }
      croak "could not decompose string '$string'";
    }

    for (1 .. @digits) {
      $callback->($digits[-$_], $_);
    }
  }
}

sub _set_iterator {
  my ($digits, $length_ref) = @_;

  croak "digit set is empty" unless @$digits;
  croak "digit set contains zero-length digit"
    if do { no warnings 'uninitialized'; grep { ! length $_ } @$digits };
  croak "digit set contains repeated digits" if @$digits != uniq @$digits;

  my @lengths = uniq map { length } @$digits;

  return _split_len_iterator($lengths[0]) if @lengths == 1;

  croak "digit set may be ambiguous" if ! UDCode::is_udcode(@$digits);

  return _split_digit_iterator($digits);
}

sub n_codec {
  my ($digit_set, $arg) = @_;

  my @digits;

  if (ref $digit_set) {
    croak "digit set must be a string or arrayref"
      unless reftype $digit_set eq 'ARRAY';
    @digits = @$digit_set;
  } else {
    @digits = split //, $digit_set;
  }

  my $iterator = _set_iterator(\@digits);

  my $encode_sub = sub {
    my ($value) = @_;

    croak "value isn't an non-negative integer"
      if not defined $value
      or $value !~ /\A\d+\z/;

    my $string = '';

    if (@digits == 1) {
      $string = $digits[0] x $value;
    } else {
      while (1) {
        my $digit = $value % @digits;
        $value = int($value / @digits);
        $string = "$digits[$digit]$string";
        last unless $value;
      }
    }

    $string = $arg->{postencode}->($string) if $arg->{postencode};
    return $string;
  };

  my %digit_value = do { my $i = 0; map { $_ => $i++ } @digits; };

  my $decode_sub = sub {
    my ($string) = @_;
    return unless defined $string;

    $string = $arg->{predecode}->($string) if $arg->{predecode};

    my $value = 0;

    $iterator->($string, sub {
      my ($digit, $position) = @_;
      croak "string to decode contains invalid digits"
        unless exists $digit_value{$digit};

      # Stupid hack, but I'm just cramming unary support in here at the moment.
      # It can be polished up later, if needed.  -- rjbs, 2009-11-22
      $value += @digits == 1
              ? 1
              : ($digit_value{$digit}  *  @digits ** ($position++ - 1));
    });

    return $value;
  };

  return ($encode_sub, $decode_sub);
}


# If you really can't stand using n_codec, you could memoize these.
sub n_encode { (n_codec($_[1]))[0]->($_[0]) }
sub n_decode { (n_codec($_[1]))[1]->($_[0]) }


1; # my ($encode_sub, $decode_sub) = n_codec('8675309'); # jennynary

__END__