File Coverage

lib/Math/String/Charset/Nested.pm

Criterion	Covered	Total	%
statement	211	288	73.2
branch	85	142	59.8
condition	17	37	45.9
subroutine	13	18	72.2
pod	6	9	66.6
total	332	494	67.2

#############################################################################
# Math/String/Charset/Nested -- charsets for Math/String
#
# Copyright (C) 1999-2003 by Tels. All rights reserved.
#############################################################################

# todo: tri-grams etc
#       store counts for different end-chars at the max elemt of _count?
#       if we later need to calculate further, we could pick up there and need
#       not to re-calculate the lower numbers

package Math::String::Charset::Nested;

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)
# _start : contains array of all valid start characters
# _ones  : list of one-character strings (cross of _end and _start)
# _end   : contains hash (for easier lookup) of all valid end characters
# _order : 1,2,3.. etc, 1 => simple, 2 => bigram etc
# _type  : 0 => simple or bi-gram, 1 => grouping
# _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 0
# _maxlen: maximum string length (anything longer is invalid), default undef
# _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
# _sm	: hash w/ mapping of start characters for faster lookup

#############################################################################
# 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} != 0;
  return $self->{_error} = "Wrong order'$self->{_order}' for $class"
    if $self->{_order} != 2;
  foreach my $key (keys %$value)
    {
    return $self->{_error} = "Illegal parameter '$key' for $class"
      if $key !~ /^(start|minlen|maxlen|sep|bi|end|charlen|scale)$/;
    }
  }

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

  my $end = {}; 			# we make array later on
  # add the user-specified end set
  my $bi = $value->{bi} || {};
  return $self->{_error} = "Field 'bi' must be hash ref"
   if ref($bi) ne 'HASH';
  $self->{_order} = 2;
  # if no end set is defined, add all followers as default
  if (exists $value->{end})
    {
    $end = { map { $_ => 1 } @{$value->{end}} };
    }
  else
    {
    foreach my $c (keys %$bi)
      {
      foreach my $f (@{$bi->{$c}})
        {
        $end->{$f} = 1;
        }
      }
    }
  if (exists $value->{start})
    {
    $self->{_start} = [ @{$value->{start}} ];
    }
  else
    {
    # else all chars w/ followers can start a string (longer than 2)
    my $s = { };
    foreach my $c (keys %$bi)
      {
      $s->{$c} = 1 if @{$bi->{$c}} > 0;
      }
    $self->{_start} = [ sort keys %$s ];
    }

  # make copy
  foreach my $c (keys %$bi)
    {
    $self->{_bi}->{$c} = [ @{$bi->{$c}} ]; 	# make copy
    }
  if (!defined $self->{_sep})
    {
    foreach my $c (keys %$bi)
      {
      $self->{_clen} = CORE::length($c);
      last;
      }
    }
  # add empty array for chars with no followers
  $bi = $self->{_bi};
  my @keys = keys %$bi;		# make copy since keys may be modified (necc?)
  foreach my $c (@keys)
    {
    $end->{$c} = 1 if @{$bi->{$c}} == 0;	# no follower

    foreach my $f (@{$bi->{$c}})
      {
      $self->{_bi}->{$f} = [] if !defined $self->{_bi}->{$f};
      $end->{$f} = 1 if @{$bi->{$f}} == 0;
      if (!defined $self->{_sep})
        {
        return $self->{_error} = "Illegal char '$f', length not $self->{_clen}"
          if length($f) != $self->{_clen};
        }
      }
    }

  $self->{_end} = $end;
  # build _ones and _sm list (cross from start/end)
  $self->{_ones} = [];
  $self->{_sm} = {};
  foreach (@{$self->{_start}})
    {
    push @{$self->{_ones}}, $_ if exists $end->{$_};
    $self->{_sm}->{$_} = 1;
    }
#  print "ones => ",join(' ',@{$self->{_ones}}),"\n";
  # remove anything from start with no followers, but keep original order
  my @s;
  foreach my $c (@{$self->{_start}})
    {
    push @s, $c
     if ((!defined $self->{_bi}->{$c}) || (@{$self->{_bi}->{$c}} > 0));
    }
  $self->{_start} = \@s;

  # initialize array of counts for len of 0..1
  $self->{_cnt} = 1;				# cached amount of class-sizes
  $self->{_count}->[0] = 1;			# '' is one string
  $self->{_count}->[1] = Math::BigInt->new (scalar @{$self->{_ones}});	# 1

  # initialize array of counts for len of 2
  $end = $self->{_end};
  my $count = Math::BigInt::bzero();
  foreach my $c (keys %$bi)
    {
    $count += scalar @{$bi->{$c}} if exists $end->{$c};
    }
  $self->{_count}->[2] = $count;					# 2
  $self->{_cnt}++;	# adjust cache size

  # init _sum array
  $self->{_sum}->[0] = 0;
  $self->{_sum}->[1] = 1;
  $self->{_sum}->[2] = $self->{_count}->[1] + 1;

  # from _ones, make mapping name => number
  my $i = 1;
  foreach (@{$self->{_ones}})
    {
    $self->{_map}->{$_} = $i++;
    }
  # create mapping for is_valid (contains number of follower)
  foreach my $c (keys %{$self->{_bi}})	# for all chars
    {
    my $i = 0;
    foreach my $cf (@{$self->{_bi}->{$c}})	# for all followers
      {
      $self->{_bmap}->{$c}->{$cf} = $i++;	# make hash for easier lookup
      }
    }

  # init _scnt array ([0] not used in both)
  $self->{_scnt}->[1] = {};
  #foreach my $c (keys %{$self->{_map}})	# it's nearly the same
  #  {
  #  $self->{_ssum}->[1]->{$c} = $self->{_map}->{$c} - 1;
  #  }

  # class 1
  foreach my $c (@{$self->{_start}})
    {
    $self->{_scnt}->[1]->{$c} = 1		# exactly one for each char
     if exists $self->{_end}->{$c};		# but not for invalid's
    }
  # class 2
  my $last = Math::BigInt::bzero();
  foreach my $c (keys %{$self->{_bi}})		# for each possible character
    {
    my $cnt = 0;
    foreach my $cf (@{$bi->{$c}})		# for each follower
      {
      $cnt ++ if exists $self->{_end}->{$cf};	# that can end the string
      }
    $self->{_scnt}->[2]->{$c} = $cnt;		# store
    $last += $cnt				# next one is summed up
     if exists $self->{_sm}->{$c};		# if starting with valid char
    }
  # print $self->{_count}->[2]||0," should already be $last\n";
  $self->{_count}->[2] = $last;			# all in class #2
  $self->{_cnt} = 2;				# cache size for bi is one more
  $self->{_cnum} = Math::BigInt->new( scalar @{$self->{_ones}} );
  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
      $self->_min_path_len();
      }
    }
  return $self;
  }

sub _min_path_len
  {
  # for n-grams calculate the minimum path len
  # Starting with each character in the start set, traverse the n-gram tree
  # until it arrives at one of the end characters. The count between is the
  # length of the shortes valid string.
  # This might be greater than the length the user specified, because it is
  # possible to have no shorter strings due to restrictions.
  my $self = shift;

  # these are already know, and if non-zero, we already have minlen
  return if $self->class(1) != 0 || $self->class(2) != 0;

  my $minlen = $self->{_minlen} || 3;	# either the defined min len, or 3
  }

sub dump
  {
  my $self = shift;

  print "type: BIGRAM:\n";
  my $bi = $self->{_bi};
  foreach my $c (keys %$bi)
    {
    print " $c => [";
    foreach my $f (@{$bi->{$c}})
      {
      print "'$f', ";
      }
    print "]\n";
    }
  print "start: ", join(' ',@{$self->{_start}}),"\n";
  print "end  : ", join(' ',keys %{$self->{_end}}),"\n";
  print "ones : ", join(' ',@{$self->{_ones}}),"\n";
  }

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.

  my $self = shift;
  my $max = shift || 1; $max = 1 if $max < 1;
  return if $max <= $self->{_cnt};

#  my ($counts,$org_counts);
  # map to hash
#  my $end = $self->{_end};
#  %$counts = map { $_, $end->{$_} } keys %$end; 	# make copy

  my ($last,$count);
  my $i = $self->{_cnt}+1;		# start with next undefined level
  while ($i <= $max)
    {
    # take current level, calculate all possible ending characters
    # and count them (e.g. 2 times 'b', 2 times 'c' and 3 times 'a')
    # each of the ending chars has a number of possible bi-grams. For the next
    # length, we must add the count of the ending char to each of the possible
    # bi-grams. After this, we get the new count for all new ending chars.
  #  %$org_counts = map { $_, $counts->{$_} } keys %$counts; 	# make copy
  #  $counts = {};						# init to 0
  #  $cnt = Math::BigInt::bzero();
  #  # for each of the ending chars
  #  foreach my $char (keys %$org_counts)
  #    {
  #    # and for each of it's bigrams
  #    $c = $org_counts->{$char};			# speed up
  #    foreach my $ec ( @{$self->{_bi}->{$char}})
  #      {
  #      # add to the new ending char the number of possibilities
  #      $counts->{$ec} += $c;
  #      }
  #    # now sum them up by multiplying bi-grams times org_char count
  #    $cnt += @{$self->{_bi}->{$char}} * $org_counts->{$char};
  #    }
  #  $self->{_count}->[$i] = $cnt;	# store this level
    #print "$i => $self->{_count}->[$i]\n";

    #########################################################################
    # for each starting char, add together how many strings each follower
    # starts in level-1
    # print "level $i\n";
    $last = Math::BigInt::bzero();
    $count = Math::BigInt::bzero();		# all counts
    my $bi = $self->{_bi};
    foreach my $c (keys %$bi)			# for each possible char
      {
      my $cnt = 0;
      foreach my $cf (@{$bi->{$c}})		# for each follower
        {
        my $ci = $self->{_scnt}->[$i-1]->{$cf} || 0;
#	print "$c followed by $cf $ci times\n",
        $cnt += $ci;				# add count in level-1
        }
      $self->{_scnt}->[$i]->{$c} = $cnt;	# store
#      $self->{_ssum}->[$i]->{$c} = $last;	# store sum up to here
      $last += $cnt;				# next one is summed up
      $count += $cnt if exists $self->{_sm}->{$c};	# only valid starts
#      print "last $last count $count cnt $cnt\n";
      }
    $self->{_count}->[$i] = $count;		# all in class w/ valid starts
    $self->{_sum}->[$i] = $self->{_count}->[$i-1] + $self->{_sum}->[$i-1];

#    $last = Math::BigInt->bzero();		# set to 0
#    foreach $c (@{$self->{_start}})
#      {
#      $cnt = Math::BigInt->bzero();		# number of followers
#      foreach $cf (@{$self->{_bi}->{$c}})	# for each follower
#        {
#        my $ci = $self->{_scnt}->[$i-1]->{$cf} || 0;
#        print "$c $cnt += ",$ci," ($cf)\n";
#        $cnt += $ci;				# add count in level-1
#        }
#      $self->{_scnt}->[$i]->{$c} = $cnt;	# and store it
#      $self->{_ssum}->[$i]->{$c} = $last;	# store sum up to here
#      $last += $cnt;				# next one is summed up
#      }
#    $self->{_count}->[$i] = $last;		# sum of all strings
#    $self->{_sum}->[$i] = $self->{_count}->[$i-1] + $self->{_sum}->[$i-1];
    $i++;
    }
  $self->{_cnt} = $i-1;				# store new cache size
  }

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

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

  #my $int = Math::BigInt::bzero();
  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?
  my $map = $self->{_map};
  return 0 unless exists $map->{$chars[0]};
  # check if conforms to bi-grams
  return 1 if @chars == 1;
  # further checks for strings longer than 1
  my $i = 1; 				# start at second char
  $map = $self->{_bmap};
  while ($i < @chars)
    {
    #print "is valid $i $chars[$i-1] $chars[$i]\n";
#    print "$chars[$i-1] $chars[$i]: ",
 #     $map->{$chars[$i-1]} || 'undef'," ",
 #     $map->{$chars[$i-1]}->{$chars[$i]} || 'undef',"\n";
    return 0 unless exists $map->{$chars[$i-1]};
    return 0 unless exists $map->{$chars[$i-1]}->{$chars[$i]};
    $i++;
    }
  return 1;
  }

sub num2str
  {
  # convert Math::BigInt/Math::String to string
  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 = "num2str() for bi-grams not ready yet";
  return 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;
  my $map = $self->{_map};
  my $clen = $self->{_clen};		# len of one char
  return new Math::BigInt($map->{$str}) if $i == $clen;
  if (!defined $self->{_sep})
    {
    my $class = $i / $clen;
    $self->_calc($class) if $class > $self->{_cnt};	# not yet cached?
    $int = $self->{_sum}->[$class];			# base number
    # print "base $int class $class\n";
    $i = $clen; $class--;
    # print "start with pos $i, class $class\n";
    while ($class > 0)
      {
      $int += $self->{_ssum}->[$class]->{substr($str,$i,$clen)};
      # print "$i $class $int ",substr($str,$i,$clen)," ",
      # $self->{_ssum}->[$class]->{substr($str,$i,$clen)},"\n";
      $class --;
      $i += $clen;
      #print "s2n $int j: $j i: $i m: $mul c: ",
      #substr($str,$i+$clen,$clen),"\n";
      }
    # print "$int\n";
    }
  else
    {
    # sep char
    my @chars = split /$self->{_sep}/, $str;
    shift @chars if $chars[0] eq '';			# strip leading sep
    my $class = scalar @chars;
    foreach (@chars)
      {
      $int += $self->{_ssum}->[$class]->{$_};
      $class --;
      # print "$class $int\n";
      }
    }
  return $int;
  }

sub chars
  {
  # return number of characters in output string
  my $self = shift;
  my $x = shift;

  return 0 if $x->is_zero() || $x->is_nan() || $x->is_inf();

  my $i = 1;
  # not done yet
  return $i;
  }

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;
  my $f;
  foreach my $c (@{$self->{_start}})
    {
    $f = $self->_first('',$c,1,$count);
    return $f if defined $f;
    }
  return;
  }

sub _first
  {
  # recursively check followers whether they are okay, or not
  # $self, $f, $ending, $level, $count,

  my ($self,$f,$ending,$level,$count) = @_;

  if ($level >= $count)				# overshot
    {
    return $f.$ending if exists $self->{_end}->{$ending};
    return;
    }

  return if !exists $self->{_bi}->{$ending};
  foreach my $c (@{$self->{_bi}->{$ending}})
    {
    my $rc = $self->_first($f.$ending,$c,$level+1,$count);
    return $rc if defined $rc;
    }
  return;					# found nothing
  }

sub _last
  {
  # recursively check followers whether they are okay, or not
  # $self, $f, $ending, $level, $count,

  my ($self,$f,$ending,$level,$count) = @_;

  if ($level >= $count)				# overshot
    {
    return $f.$ending if exists $self->{_end}->{$ending};
    return;
    }

  return if !exists $self->{_bi}->{$ending};

  foreach my $c (reverse @{$self->{_bi}->{$ending}})
    {
    my $rc = $self->_last($f.$ending,$c,$level+1,$count);
    return $rc if defined $rc;
    }
  return;					# found nothing
  }

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;
  my $f;
  foreach my $c (reverse @{$self->{_start}})
    {
    $f = $self->_last('',$c,1,$count);
    return $f if defined $f;
    }
  return;
  }

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

  if ($str->{_cache} eq '')				# 0 => 1
    {
    $str->{_cache} = $self->first($self->minlen()||1);
    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;

  $self;
  }

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

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

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

  $self;
  }


__END__