File Coverage

lib/Math/String/Charset/Grouped.pm

Criterion	Covered	Total	%
statement	232	258	89.9
branch	90	140	64.2
condition	26	40	65.0
subroutine	14	19	73.6
pod	10	13	76.9
total	372	470	79.1

#############################################################################
# Math/String/Charset/Grouped.pm -- a charset of charsets for Math/String
#
# Copyright (C) 1999-2003 by Tels. All rights reserved.
#############################################################################

package Math::String::Charset::Grouped;

require 5.005;		# requires this Perl version or later
use strict;

use base 'Math::String::Charset';

our $VERSION;
$VERSION = '1.30';	# Current version of this package

use Math::BigInt;

our $die_on_error;
$die_on_error = 1;              # set to 0 to not die

# following hash values are used:
# _clen  : length of one character (all chars must have same len unless sep)
# _ones  : list of one-character strings (cross of _end and _start)
# _start : contains array of all valid start characters
# _end   : contains hash (for easier lookup) of all valid end characters
# _order : = 1
# _type  : = 1
# _error : error message or ""
# _count : array of count of different strings with length x
# _sum   : array of starting number for strings with length x
#          _sum[x] = _sum[x-1]+_count[x-1]
# _cnt   : number of elements in _count and _sum (as well as in _scnt & _ssum)
# _cnum  : number of characters in _ones as BigInt (for speed)
# _minlen: minimum string length (anything shorter is invalid), default -inf
# _maxlen: maximum string length (anything longer is invalid), default +inf
# _scale : optional input/output scale

# simple ones:
# _sep  : separator string (undef for none)
# _map  : mapping character to number

# higher orders:
# _bi   : hash with refs to array of bi-grams
# _bmap : hash with refs to hash of bi-grams
# _scnt : array of hashes, count of strings starting with this character

# grouped:
# _spat	: array with pattern of charsets 8for each stirnglen one ARRAY ref)

#############################################################################
# private, initialize self

sub _strict_check
  {
  # a per class check, to be overwritten by subclasses
  my $self = shift;
  my $value = shift;

  my $class = ref($self);
  return $self->{_error} = "Wrong type '$self->{_type}' for $class"
    if $self->{_type} != 1;
  return $self->{_error} = "Wrong order'$self->{_order}' for $class"
    if $self->{_order} != 1;
  foreach my $key (keys %$value)
    {
    return $self->{_error} = "Illegal parameter '$key' for $class"
      if $key !~ /^(start|minlen|maxlen|sep|sets|end|charlen|scale)$/;
    }
  }

sub _initialize
  {
  # set yourself to the value represented by the given string
  my $self = shift;
  my $value = shift;

  $self->{_clen} = $value->{charlen};
  $self->{_sep}  = $value->{sep};	# separator char

  return $self->{_error} = "Need HASH ref as 'sets'"
    if (ref($value->{sets}) ne 'HASH');

  # make copy at same time
  foreach my $key (keys %{$value->{sets}})
    {
    $self->{_sets}->{$key} = $value->{sets}->{$key};
    }

  # start/end are sets 1 and -1, respectively, and overwrite 'sets'
  $self->{_sets}->{1} = $value->{start} if exists $value->{start};
  $self->{_sets}->{-1} = $value->{end} if exists $value->{end};
  $self->{_sets}->{0} = $value->{chars} if exists $value->{chars};
  # default set
  $self->{_sets}->{0} = ['a'..'z'] if !defined $self->{_sets}->{0};

  my $sets = $self->{_sets};	# shortcut
  foreach my $set (keys %$sets)
    {
    return $self->{_error} =
      "Entries in 'sets' must be ref to Math::String::Charset or ARRAY"
     if ((ref($sets->{$set}) ne 'ARRAY') &&
      (ref($sets->{$set}) ne 'Math::String::Charset'));

    # so for each set, make a Math::String::Charset
    $sets->{$set} = Math::String::Charset->new($sets->{$set})
      if ref($sets->{$set}) eq 'ARRAY';
    }
  $self->{_start} = $sets->{1} || $sets->{0};
  $self->{_end} = $sets->{-1} || $sets->{0};

  $self->{_clen} = $self->{_start}->charlen() if
   ((!defined $self->{_clen}) && (!defined $self->{_sep}));

  # build _ones list (cross from start/end)
  $self->{_ones} = [];

  # _end is a simple charset, so use it's map directly
  my $end = $self->{_end}->{_map};
  my $o = $self->{_ones};
  foreach ($self->{_start}->start())
    {
    push @$o, $_ if exists $end->{$_};
    }
  #print "\n";

  # some tests for validity
  if (!defined $self->{_sep})
    {
    foreach (keys %{$self->{_sets}})
      {
      my $l = $self->{_sets}->{$_}->charlen();
      return $self->{_error} =
        "Illegal character length '$l' for charset '$_', expected '$self->{_clen}'"
          if $self->{_sets}->{$_}->charlen() != $self->{_clen};

      }
    }
  $self->{_cnum} = Math::BigInt->new( scalar @{$self->{_ones}} );
  # initialize array of counts for len of 0..1
  $self->{_cnt} = 2;				# cached amount of class-sizes
  if ($self->{_minlen} <= 0)
    {
    $self->{_count}->[0] = 1;			# '' is one string
    my $sl = $self->{_start}->length();
    my $el = $self->{_end}->length();
    $self->{_count}->[1] = $self->{_cnum};
    $self->{_count}->[2] = $sl * $el;
    # init _sum array
    $self->{_sum}->[0] = Math::BigInt->bzero();
    $self->{_sum}->[1] = Math::BigInt->bone();		# '' is 1 string
    $self->{_sum}->[2] = $self->{_count}->[1] + $self->{_sum}->[1];
    $self->{_sum}->[3] = $self->{_count}->[2] + $self->{_sum}->[2];
    # init set patterns
    $self->{_spat}->[1] = [ undef, $self->{_sets}->{0} ];
    $self->{_spat}->[2] = [ undef, $self->{_start}, $self->{_end} ];
    }
  else
    {
    $self->{_cnt} = 0;				# cached amount of class-sizes
    }

  # from _ones, make mapping name => number
  my $i = Math::BigInt->bone();
  foreach (@{$self->{_ones}})
    {
    $self->{_map}->{$_} = $i++;
    }

  if ($self->{_cnum}->is_zero())
    {
    $self->{_minlen} = 2 if $self->{_minlen} == 1;	# no one's
    # check whether charset can have 2-character long strings
    if ($self->{_count}->[2] == 0)
      {
      $self->{_minlen} = 3 if $self->{_minlen} == 2;	# no two's
      # check whether some path from start to end set exists, if not: empty
      }
    }
  return $self->{_error} =
   "Minlen ($self->{_minlen} must be smaller than maxlen ($self->{_maxlen})"
    if ($self->{_minlen} > $self->{_maxlen});
  return $self;
  }

sub dump
  {
  my $self = shift;

  my $txt = "type: GROUPED\n";

  foreach my $set (sort { $b<=>$a } keys %{$self->{_sets}})
    {
    $txt .= " $set => ". $self->{_sets}->{$set}->dump('   ');
    }
  $txt .= "ones : " . join(' ',@{$self->{_ones}}) . "\n";
  $txt;
  }

sub _calc
  {
  # given count of len 1..x, calculate count for y (y > x) and all between
  # x and y
  # currently re-calcs from 2 on, we could save the state and only calculate
  # the missing counts.

#  print "calc ",caller(),"\n";
  my $self = shift;
  my $max = shift || 1; $max = 1 if $max < 1;
  return if $max <= $self->{_cnt};

#  print "in _calc $self $max\n";
  my $i = $self->{_cnt};                # last defined element
  my $last = $self->{_count}->[$i];
  while ($i++ <= $max)
    {
    # build list of charsets for this length
    my $spat = [];			# set patterns
    my $sets = $self->{_sets};		# shortcut
    for (my $j = 1; $j <= $i; $j++)
      {
      my $r = $j-$i-1;			# reverse
#      print "$j reversed $r (for $i)\n";
      $spat->[$j] = $sets->{$j} || $sets->{$r};			# one of both?
      $spat->[$j] = $sets->{$j}->merge($sets->{$r}) if
	exists $sets->{$j} && exists $sets->{$r};		# both?
      $spat->[$j] = $sets->{0} unless defined $spat->[$j];	# none?
#      print $spat->[$j]->dump(),"\n";
      }
    $self->{_spat}->[$i] = $spat;				# store
    # for each charset, take size and mul together
    $last = Math::BigInt->bone();
    for (my $j = 1; $j <= $i; $j++)
      {
#      print "$i $spat->[$j]\n";
      $last *= $spat->[$j]->length();
#      print "last $last ",$spat->[$j]->length()," ($spat->[$j])\n";
      }
    $self->{_count}->[$i] = $last;
#    print "$i: count $last ";
    $self->{_sum}->[$i] = $self->{_sum}->[$i-1] + $self->{_count}->[$i-1];
#    print "sum $self->{_sum}->[$i]\n";
    }
  $self->{_cnt} = $i-1;         # store new cache size
  return;
  }

sub is_valid
  {
  # check wether a string conforms to the given charset sets
  my $self = shift;
  my $str = shift;

  # print "$str\n";
  return 0 if !defined $str;
  return 1 if $str eq '' && $self->{_minlen} <= 0;

  my @chars;
  if (defined $self->{_sep})
    {
    @chars = split /$self->{_sep}/,$str;
    shift @chars if $chars[0] eq '';
    pop @chars if $chars[-1] eq $self->{_sep};
    }
  else
    {
    my $i = 0; my $len = CORE::length($str); my $clen = $self->{_clen};
    while ($i < $len)
      {
      push @chars, substr($str,$i,$clen); $i += $clen;
      }
    }
  # length okay?
  return 0 if scalar @chars < $self->{_minlen};
  return 0 if scalar @chars > $self->{_maxlen};

  # valid start char?
  return 0 unless defined $self->{_start}->map($chars[0]);
  return 1 if @chars == 1;
  # further checks for strings longer than 1
  my $k = 1;
  my $d = scalar @chars;
  $self->_calc($d) if ($self->{_cnt} < $d);
  my $spat = $self->{_spat}->[$d];
  foreach my $c (@chars)
    {
    return 0 if !defined $spat->[$k++]->map($c);
    }
  # all tests passed
  1;
  }

sub minlen
  {
  my $self = shift;

  $self->{_minlen};
  }

sub maxlen
  {
  my $self = shift;

  $self->{_maxlen};
  }

sub start
  {
  # this returns all the starting characters in a list, or in case of a simple
  # charset, simple the charset
  # in scalar context, returns length of starting set, for simple charsets this
  # equals the length
  my $self = shift;

  wantarray ? @{$self->{_start}} : scalar @{$self->{_start}};
  }

sub end
  {
  # this returns all the end characters in a list, or in case of a simple
  # charset, simple the charset
  # in scalar context, returns length of end set, for simple charsets this
  # equals the length
  my $self = shift;

  wantarray ? sort keys %{$self->{_end}} : scalar keys %{$self->{_end}};
  }

sub ones
  {
  # this returns all the one-char strings (in scalar context the count of them)
  my $self = shift;

  wantarray ? @{$self->{_ones}} : scalar @{$self->{_ones}};
  }

sub num2str
  {
  # convert Math::BigInt/Math::String to string
  # in list context, return (string,stringlen)
  my $self = shift;
  my $x = shift;

  $x = new Math::BigInt($x) unless ref $x;
  return undef if ($x->sign() !~ /^[+-]$/);
  if ($x->is_zero())
    {
    return wantarray ? ('',0) : '';
    }
  my $j = $self->{_cnum};			# nr of chars

  if ($x <= $j)
    {
    my $c =  $self->{_ones}->[$x-1];
    return wantarray ? ($c,1) : $c;             # string len == 1
    }

  my $digits = $self->chars($x); my $d = $digits;
  # now treat the string as it were a zero-padded string of length $digits

  my $es="";                                    # result
  # copy input, make positive number, correct to $digits and cater for 0
  my $y = Math::BigInt->new($x); $y->babs();
  #print "fac $j y: $y new: ";
  $y -= $self->{_sum}->[$digits];

  $self->_calc($d) if ($self->{_cnt} < $d);
  #print "y: $y\n";
  my $mod = 0; my $s = $self->{_sep}; $s = '' if !defined $s;
  my $spat = $self->{_spat}->[$d];		# set pattern
  my $k = $d;
  while (!$y->is_zero())
    {
    #print "bfore:  y/fac: $y / $j \n";
    ($y,$mod) = $y->bdiv($spat->[$k]->length());
    #$es = $self->{_ones}->[$mod] . $s.$es;
    $es = $spat->[$k--]->char($mod) . $s.$es;	# find mod'th char
    #print "after:  div: $y rem: $mod \n";
    $digits --;                         # one digit done
    }
  # padd the remaining digits with the zero-symbol
  while ($digits-- > 0)
    {
    $es = $spat->[$k--]->char(0) . $s . $es;
    }
  $es =~ s/$s$//;                               # strip last sep 'char'
  wantarray ? ($es,$d) : $es;
  }

sub str2num
  {
  # convert Math::String to Math::BigInt
  my $self = shift;
  my $str = shift;			# simple string

  my $int = Math::BigInt->bzero();
  my $i = CORE::length($str);

  return $int if $i == 0;
  # print "str2num $i $clen '$str'\n";
  my $map = $self->{_map};
  my $clen = $self->{_clen};		# len of one char

  if ((!defined $self->{_sep}) && ($i == $clen))
    {
    return $int->bnan() if !exists $map->{$str};
    return $map->{$str}->copy();
    }

  my $mul = Math::BigInt->bone();
  my $cs;					# charset at pos i
  my $k = 1;					# position
  my $c = 0;					# chars in string
  if (!defined $self->{_sep})
    {
    return $int->bnan() if $i % $clen != 0;	# not multiple times clen
    $c = int($i/$clen);
    $self->_calc($c) if ($self->{_cnt} < $c);
    my $spat = $self->{_spat}->[$c];
#    print "$c ($self->{_cnt}) spat: ",scalar @$spat,"\n";
    $i -= $clen;
    $k = $c;
    while ($i >= 0)
      {
      $cs = $spat->[$k--];			# charset at pos k
#      print "$i $k $cs nr $int ";
#      print "mapped ",substr($str,$i,$clen)," => ",
#       $cs->map(substr($str,$i,$clen)) || 0;
#      print " mul $mul => ";
      $int += $mul * $cs->map(substr($str,$i,$clen));
      $mul *= $cs->length();
#     print "mul $mul\n";
      $i -= $clen;
      }
    }
  else
    {
    # with sep char
    my @chars = split /$self->{_sep}/, $str;
    shift @chars if $chars[0] eq '';                    # strip leading sep
    pop @chars if $chars[-1] eq $self->{_sep}; 		# strip trailing sep
    $c = scalar @chars;
    $self->_calc($c) if ($self->{_cnt} < $c);
    my $spat = $self->{_spat}->[$c];
    $k = $c;
    foreach (reverse @chars)
      {
      $cs = $spat->[$k--];				# charset at pos k
      $int += $mul * $cs->map($_);
      $mul *= $cs->length();
      }
    }
  $int + $self->{_sum}->[$c];				# add base sum
  }

#sub char
#  {
#  # return nth char from charset
#  my $self = shift;
#  my $char = shift || 0;
#
#  return undef if $char > scalar @{$self->{_ones}}; # dont create spurios elems
#  return $self->{_ones}->[$char];
#  }

sub first
  {
  my $self = shift;
  my $count = abs(shift || 0);

  return if $count < $self->{_minlen};
  return if defined $self->{_maxlen} && $count > $self->{_maxlen};
  return '' if $count == 0;

  return $self->{_ones}->[0] if $count == 1;

  $self->_calc($count);
  my $spat = $self->{_spat}->[$count];
  my $es = '';
  my $s = $self->{_sep} || '';
  for (my $i = 1; $i <= $count; $i++)
    {
    $es .= $s . $spat->[$i]->char(0);
    }
  $s = quotemeta($s);
  $es =~ s/^$s// if $s ne '';		# remove first sep
  $es;
  }

sub last
  {
  my $self = shift;
  my $count = abs(shift || 0);

  return if $count < $self->{_minlen};
  return if defined $self->{_maxlen} && $count > $self->{_maxlen};
  return '' if $count == 0;

  return $self->{_ones}->[-1] if $count == 1;

  $self->_calc($count);
  my $spat = $self->{_spat}->[$count];
  my $es = '';
  my $s = $self->{_sep} || '';
  for (my $i = 1; $i <= $count; $i++)
    {
    $es .= $s . $spat->[$i]->char(-1);
    }
  $s = quotemeta($s);
  $es =~ s/^$s// if $s ne '';		# remove first sep
  $es;
  }

sub next
  {
  my $self = shift;
  my $str = shift;

  if ($str->{_cache} eq '')				# 0 => 1
    {
    my $min = $self->{_minlen}; $min = 1 if $min <= 0;
    $str->{_cache} = $self->first($min);
    return;
    }

  # only the rightmost digit is adjusted. If this overflows, we simple
  # invalidate the cache. The time saved by updating the cache would be to
  # small to be of use, especially since updating the cache takes more time
  # then. Also, if the cached isn't used later, we would have spent the
  # update-time in vain.

  # for higher orders not ready yet
  $str->{_cache} = undef;
  }

sub prev
  {
  my $self = shift;
  my $str = shift;

  if ($str->{_cache} eq '')				# 0 => -1
    {
    my $min = $self->{_minlen}; $min = -1 if $min >= 0;
    $str->{_cache} = $self->first($min);
    return;
    }

  # for higher orders not ready yet
  $str->{_cache} = undef;
  }

__END__