File Coverage

lib/Math/String/Charset.pm

Criterion	Covered	Total	%
statement	419	469	89.3
branch	187	240	77.9
condition	75	111	67.5
subroutine	42	46	91.3
pod	27	33	81.8
total	750	899	83.4

#############################################################################
# Math/String/Charset.pm -- package which defines a charset for Math/String
#
# Copyright (C) 1999-2008 by Tels. All rights reserved.
#############################################################################

package Math::String::Charset;
use base Exporter;
@EXPORT_OK = qw/analyze/;

BEGIN
  {
  *analyze = \&study;
  }

use vars qw($VERSION);
$VERSION = '1.17';	# Current version of this package
require  5.008003;	# requires this Perl version or later

use strict;
use Math::BigInt;

use vars qw/$die_on_error $CALC/;
$die_on_error = 1;		# set to 0 to not die

use Math::String::Charset::Nested;
use Math::String::Charset::Grouped;

# 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 (1 = simple, 2 = nested)
# _type  : = 0 (0 = simple, 1 = grouped, 2 = wordlist)
# _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 undef
# _scale : optional output/input scale

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

# See the other Charset package files for the keys the higher-order charsets use.

my $ONE = Math::BigInt->bone();

BEGIN
  {
  # this will fail if Math::BigInt is loaded with a different lib afterwards!
  $CALC = Math::BigInt->config()->{lib} || 'Math::BigInt::Calc';
  }

#############################################################################

sub new
  {
  my $class = shift;
  $class = ref($class) || $class || __PACKAGE__;

  my $self = bless {}, $class;

  my $value;
  if (!ref($_[0]))
    {
    $value = [ @_ ];
    }
  else
    {
    $value = shift;
    }
  if (ref($value) !~ /^(ARRAY|HASH)$/)
    {
    # got an object, so make copy
    foreach my $k (keys %$value)
      {
      if (ref($value->{$k}) eq 'ARRAY')
        {
        $self->{$k} = [ @{$value->{$k}} ];
        }
      elsif (ref($value->{$k}) eq 'HASH')
        {
        foreach my $j (keys %{$value->{k}})
          {
          $self->{$k}->{$j} = $value->{$k}->{$j};
          }
        }
      else
        {
        $self->{$k} = $value->{$k};
        }
      }
    return $self;
    }

  # convert ARRAY ref into HASH ref in the same go
  $value = $self->_check_params($value);

#  print "new $class type $self->{_type} order $self->{_order} $self->{_error}\n";

  if ($self->{_error} eq '')
    {
    # now route request for initialization to subclasses if we are in baseclass
    if ($class eq 'Math::String::Charset')
      {
      return Math::String::Charset::Grouped->new($value)
        if ($self->{_type} == 1);
      if (($self->{_type} == 2) && ($self->{_order} == 1))
	{
	require Math::String::Charset::Wordlist;
        return Math::String::Charset::Wordlist->new($value);
	}
      return Math::String::Charset::Nested->new($value)
        if ($self->{_order} == 2);
      }
    $self->_strict_check($value);
    $self->_initialize($value);
    }
  die ($self->{_error}) if $die_on_error && $self->{_error} ne '';
  $self;
  }

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

sub _check_params
  {
  # check params
  my $self = shift;
  my $value = shift;

  $self->{_error} = ""; 			# no error
  $self->{_count} = [ ];

  # convert array ref to hash
  $value = { start => $value } if (ref($value) eq 'ARRAY');

  # from 1st take clen
  $self->{_clen} = $value->{charlen};
  $self->{_sep} = $value->{sep};

  return $self->{_error} = "Can not have both 'sep' and 'charlen' in new()"
    if ((exists $value->{charlen}) && (exists $value->{sep}));

  $self->{_order} = $value->{order};
  $self->{_type} = $value->{type};

  $self->{_scale} = Math::BigInt->new($value->{scale})
    if exists $value->{scale};

  return $self->{_error} = "Can not have both 'bi' and 'sets' in new()"
    if ((exists $value->{sets}) && (exists $value->{bi}));

  if (!defined $self->{_type})
    {
    $self->{_type} = 0;
    $self->{_type} = 1 if exists $value->{sets};
    }

  if (!defined $self->{_order})
    {
    $self->{_order} = 1;
    $self->{_order} = 2 if exists $value->{bi};
    }

  return $self->{_error} = "Illegal type '$self->{_type}' used with 'bi'"
    if ((exists $value->{bi}) && ($self->{_type} != 0));

  return $self->{_error} = "Illegal type '$self->{_type}' used with 'sets'"
    if ((exists $value->{sets}) && ($self->{_type} == 0));

  return $self->{_error} = "Illegal type '$self->{_type}'"
   if (($self->{_type} < 0) || ($self->{_type} > 2));

  return $self->{_error} =
   "Illegal combination of type '$self->{_type}' and order '$self->{_order}'"
    if (($self->{_type} == 1) && ($self->{_order} != 1));

  if ($self->{_order} == 1)
    {
    return $self->{_error} =
     "Illegal combination of order '$self->{_order}' and 'end'"
      if defined $value->{end};

    return $self->{_error} =
     "Illegal combination of order '$self->{_order}' and 'bi'"
      if defined $value->{bi};
    }

  return $self->{_error} = "Illegal order '$self->{_order}'"
   if (($self->{_order} < 1) || ($self->{_order} > 2));

  $self->{_sep} = $value->{sep};			# sep char or undef
  return $self->{_error} = "Field 'sep' must not be empty"
    if (defined $self->{_sep} && $self->{_sep} eq '');

  $self->{_minlen} = $value->{minlen};
  $self->{_maxlen} = $value->{maxlen};
  $self->{_minlen} = Math::BigInt->binf('-') if !defined $self->{_minlen};
  $self->{_maxlen} = Math::BigInt->binf() if !defined $self->{_maxlen};
  return $self->{_error} = 'Maxlen is smaller than minlen!'
   if ($self->{_minlen} > $self->{_maxlen});

  $value;
  }

sub _initialize
  {
  # init only for simple charsets, the rest is done in subclass
  my $self = shift;
  my $value = shift;

  $self->{_start} = [ ];
  $self->{_start} = [ @{$value->{start}} ] if defined $value->{start};

  $self->{_clen} = CORE::length($self->{_start}->[0])
   if !defined $self->{_sep};

  $self->{_ones} = $self->{_start};

# XXX TODO: remove
#  foreach (@{$self->{_start}}) { $self->{_end}->{$_} = 1; }

  # some more tests for validity
  if (!defined $self->{_sep})
    {
    foreach (@{$self->{_start}})
      {
      $self->{_error} = "Illegal char '$_', length not $self->{_clen}"
       if CORE::length($_) != $self->{_clen};
      }
    }
  # 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

  # 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++;
    }
  $self->{_cnum} = Math::BigInt->new( scalar @{$self->{_ones}} );

  # _end contains entries for all valid end characters, and since these are the
  # same than in _map, we can reuse _map to save memory and construction time

  $self->{_end} = $self->{_map};

  return $self->{_error} = "Empty charset!"
   if ($self->{_cnum}->is_zero() && $self->{_minlen} > 0);

  $self;
  }

sub scale
  {
  my $self = shift;

  $self->{_scale} = Math::BigInt->new($_[0]) if @_ > 0;
  $self->{_scale};
  }

sub zero
  {
  # return the string representing zero. If no minlen is defined, this is
  # simple '', otherwise the first string of the first class after minlen which
  # is not empty
  my $self = shift;

  return $self->{_zero} if defined $self->{_zero};	# already known?

  return '' if $self->{_minlen} > 0;
  my $i = $self->{_minlen};
  while ($self->class($i) == 0) { $i++; }
  $self->{_minlen} = $i;				# adjust minlen
  $self->{_zero} = $self->first($i);
  $self->{_zero};
  }

sub one
  {
  # return the string representing one. If no minlen is defined, this is
  # simple the first string with length(1), otherwise the first string of the
  # first class after minlen which is not empty
  my $self = shift;

  return '' if $self->{_minlen} > 0;
  my $i = $self->{_minlen};
  while ($self->class($i) == 0) { $i++; }
  $self->{_minlen} = $i;				# adjust minlen
  $self->first($i)->next();
  }

sub copy
  {
  # for speed reasons, do not make a copy of a charset, but share it instead
  my ($c,$x);
  if (@_ > 1)
    {
    # if two arguments, the first one is the class to "swallow" subclasses
    ($c,$x) = @_;
    }
  else
    {
    $x = shift;
    $c = ref($x);
    }
  return unless ref($x); # only for objects

  my $self = {}; bless $self,$c;
  foreach my $k (keys %$x)
    {
    if (ref($x->{$k}) eq 'SCALAR')
      {
      $self->{$k} = \${$x->{$k}};
      }
    elsif (ref($x->{$k}) eq 'ARRAY')
      {
      $self->{$k} = [ @{$x->{$k}} ];
      }
    elsif (ref($x->{$k}) eq 'HASH')
      {
      # only one level deep!
      foreach my $h (keys %{$x->{$k}})
        {
        $self->{$k}->{$h} = $x->{$k}->{$h};
        }
      }
    elsif (ref($x->{$k}))
      {
      my $c = ref($x->{$k});
      $self->{$k} = $c->new($x->{$k});  # no copy() due to deep rec
      }
    else
      {
      # simple scalar w/o reference
      $self->{$k} = $x->{$k};
      }
    }
  $self;
  }

sub count
  {
  # Return count of all possible strings described by in charset as positive
  # bigint. Returns 'inf' if no maxlen is defined, because there should be no
  # upper bound on how many strings are possible.
  # if maxlen is defined, forces a calculation of all possible class() values
  # and may therefore be slow on the first call, also caches possible lot's of
  # values.
  my $self = shift;
  my $count = Math::BigInt->bzero();

  return $count->binf() if $self->{_maxlen}->is_inf();

  for (my $i = 0; $i < $self->{_maxlen}; $i++)
    {
    $count += $self->class($i);
    }
  $count;
  }

sub dump
  {
  my $self = shift;
  my $indend = shift || '';

  my $txt = "type SIMPLE:\n";
  $txt .= $indend . "start: " . join(' ',@{$self->{_start}}) . "\n";
  my $e = $self->{_end};
  $txt .= $indend . "end  : " . join(' ', sort { $e->{$a} <=> $e->{$b} } keys %$e) . "\n";
  $txt .= $indend . "ones : " . join(' ',@{$self->{_ones}}) . "\n";
  $txt;
  }

sub error
  {
  my $self = shift;

  $self->{_error};
  }

sub order
  {
  # return charset's order/class
  my $self = shift;
  $self->{_order};
  }

sub type
  {
  # return charset's type
  my $self = shift;
  $self->{_type};
  }

sub charlen
  {
  # return charset's length of one character
  my $self = shift;
  $self->{_clen};
  }

sub length
  {
  # return number of characters in charset
  my $self = shift;

  scalar @{$self->{_ones}};
  }

sub _calc
  {
  # given count of len 1..x, calculate count for y (y > x) and all between
  # x and y
  my $self = shift;
  my $max = shift || 1; $max = 1 if $max < 1;
  return if $max <= $self->{_cnt};

  my $i = $self->{_cnt}; 		# last defined element
  my $last = $self->{_count}->[$i];
  my $size = Math::BigInt->new ( scalar @{$self->{_ones}} );
  while ($i <= $max)
    {
    $last = $last * $size;
    $self->{_count}->[$i+1] = $last;
    $self->{_sum}->[$i+1] = $self->{_sum}->[$i] + $self->{_count}->[$i];
    $i++;
    }
  $self->{_cnt} = $i-1;		# store new cache size
  }

sub class
  {
  # return number of all combinations with a certain length
  my $self = shift;
  my $len = shift; $len = 0 if !defined $len;
  $len = abs(int($len));

  return 0 if $len < $self->{_minlen} || $len > $self->{_maxlen};

  # print "$len $self->{_minlen}\n";
  $len -= $self->{_minlen} if $self->{_minlen} > 0;	# correct
  # not known yet, so calculate and cache
  $self->_calc($len) if $self->{_cnt} < $len;
  $self->{_count}->[$len];
  }

sub lowest
  {
  # return number of first string with $length characters
  # equivalent to $charset->first($length)->num2str();
  my $self = shift;
  my $len = abs(int(shift || 1));

  # not known yet, so calculate and cache
  $self->_calc($len) if $self->{_cnt} < $len;
  $self->{_sum}->[$len];
  }

sub highest
  {
  # return number of first string with $length characters
  # equivalent to $charset->first($length)->num2str();
  my $self = shift;
  my $len = abs(int(shift || 1));

  $len++;
  # not known yet, so calculate and cache
  $self->_calc($len) if $self->{_cnt} < $len;
  $self->{_sum}->[$len]-1;
  }

sub norm
  {
  # normalize a string by removing separator char at front/end
  my $self = shift;
  my $str = shift;

  return $str if !defined $self->{_sep};

  $str =~ s/$self->{_sep}\z//;		# remove at end
  $str =~ s/^$self->{_sep}//;		# remove at front
  $str;
  }

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;
  if ($str eq '')
    {
    return $self->{_minlen} <= 0 ? 1 : 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} || scalar @chars > $self->{_maxlen};

  # valid start char?
  my $map = $self->{_map};
  # XXX TODO: remove
  # return 0 unless exists $map->{$chars[0]};
  foreach (@chars)
    {
    return 0 unless exists $map->{$_};
    }
  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 and stringlen
  my ($self,$x) = @_;

  $x = Math::BigInt->new($x) unless ref $x;

  return undef if $x->{sign} !~ /^[+-]$/;

  my $j = $self->{_cnum};			# nr of chars

  if ($self->{_minlen} <= $ONE)
    {
    if ($x->is_zero())
      {
      return wantarray ? ('',0) : '';
      }

    # single character?
    if ($x <= $j && $self->{_minlen} <= $ONE)
      {
      my $c = $self->{_ones}->[$x->numify() - 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

  # length is not right (too short or too long)
  if ($digits < $self->{_minlen} || $digits > $self->{_maxlen})
    {
    return wantarray ? (undef,0) : undef;
    }

  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];

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

sub str2num
  {
  # convert Math::String to Math::BigInt (does not take scale into account)
  my ($self,$str) = @_;

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

  return $int if $i == 0;
  my $map = $self->{_map};
  my $clen = $self->{_clen} || 0;	# len of one char

  if ($i == $clen)
    {
    $int->{value} = $CALC->_new( $map->{$str} );
    return $int;
    }

  my $cnum = $self->{_cnum}; my $j;
  if (ref($cnum))
    {
    $j = $cnum->{value};
    }
  else
    {
    $j = $CALC->_new($cnum);
    }

  if (!defined $self->{_sep})
    {
    # first step (mul = 1):
    # 0 + 1 * str => str
    $i -= $clen;
    $int->{value} = $CALC->_new( $map->{substr($str,$i,$clen)});
    my $mul = $CALC->_copy($j);

    # other steps:
    $i -= $clen;
    # while ($i >= 0)
    while ($i > 0)
      {
      $CALC->_add( $int->{value}, $CALC->_mul( $CALC->_copy($mul), $CALC->_new( $map->{substr($str,$i,$clen)} )));
      $CALC->_mul( $mul , $j);
      $i -= $clen;
#      print "s2n $int j: $j i: $i m: $mul c: ",
#      substr($str,$i+$clen,$clen),"\n";
      }
    # last step (no need to update $i or preserving/updating $mul)
    $CALC->_add( $int->{value}, $CALC->_mul( $CALC->_copy($mul), $CALC->_new( $map->{substr($str,$i,$clen)} )));
    }
  else
    {
    # with sep char
    my $mul = $CALC->_one();
    my @chars = split /$self->{_sep}/, $str;
    shift @chars if $chars[0] eq '';			# strip leading sep
    foreach (reverse @chars)
      {
      $CALC->_add( $int->{value}, $CALC->_mul( $CALC->_copy($mul), $CALC->_new( $map->{$_} )));
      $CALC->_mul( $mul , $j);
      }
    }

  $int;
  }

sub char
  {
  # return nth char from charset (see also map())
  my $self = shift;
  my $char = shift || 0;

  return undef if $char > scalar @{$self->{_ones}}; 	# dont create spurios elems
  $self->{_ones}->[$char];
  }

sub map
  {
  # map char to number (see also char())
  my ($self,$char) = @_;

  return undef unless defined $char && exists $self->{_map}->{$char};
  $self->{_map}->{$char} - 1;
  }

sub chars
  {
  # return number of characters in output string
  my ($self,$x) = @_;

  return 0 if $x->is_zero() || $x->is_nan() || $x->is_inf();
  my $i = 1;
  my $y = $x->as_number()->babs();

  while ($y >= $self->{_sum}->[$i])
    {
    $self->_calc($i) if $self->{_cnt} < $i;
    $i++;
    }
  --$i;			# correct for last ++
  }

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;

  my $t = ($self->{_sep}||'') . $self->{_ones}->[0];
  my $es = $t x $count;
  $es =~ s/^$self->{_sep}// if defined $self->{_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;

  my $t = ($self->{_sep}||'') . $self->{_ones}->[-1];
  my $es = $t x $count;
  $es =~ s/^$self->{_sep}// if defined $self->{_sep};
  $es;
  }

sub next
  {
  # take one string, and return the next string following it (without
  # converting the string to it's number form first for speed reasons)
  my ($self,$str) = @_;

  if ($str->{_cache} eq '')				# 0 => 1
    {
    my $min = $self->{_minlen};
    #$str->{_cache} = $self->first($min) and return if $min->is_positive();
    $str->{_cache} = $self->{_ones}->[0];
    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.

  # simple charsets
  my $char;
  my $clen = $self->{_clen};
  my $s = \$str->{_cache};		# ref to cache contents
  my $sep = $self->{_sep};
  if (defined $sep)
    {
    # split last part
    $$s =~ /.*$sep(.*?)\z/; $char = $1;
    $char = $$s unless $$s =~ /$sep/;
    }
  else
    {
    # extract last char
    $char = substr($$s,-$clen,$clen);
    }
  my $old = $char;	# for seperator replacement
  $char = $self->{_map}->{$char};	# map is +1 by default
  $char -=2 if $str->{sign} eq '-';
  if ((!defined $char) || ($char >= @{$self->{_start}}) || ($char < 0))
    {
    # overflow
    $str->{_cache} = undef;		# invalidate cache
    return;
    }
  $char = $self->{_start}->[$char];	# num 2 char
  if (defined $sep)
    {
    # split last part and replace
    $$s =~ s/$old\z/$char/;
    }
  else
    {
    # replace the last char
    substr($$s,-$clen,$clen) = $char;
    }
  }

sub prev
  {
  my ($self,$str) = @_;

  if ($str->{_cache} eq '')				# 0 => -1
    {
    my $min = $self->{_minlen};
    $str->{_cache} = undef, and return if $min->is_positive(); # >= 0;
    $str->{_cache} = $self->{_ones}->[0];
    return;
    }

  # simple charsets
  my $char;
  my $clen = $self->{_clen};
  my $s = \$str->{_cache};
  my $sep = $self->{_sep};
  if (defined $sep)
    {
    # split last part and replace
    $$s =~ /.*$sep(.*?)\z/; $char = $1;
    $char = $$s unless $$s =~ /$sep/;
    }
  else
    {
    # extract last char and replace
    $char = substr($$s,-$clen,$clen);
    }

  my $old = $char;	# for seperator replacement
  if ((defined $char) && (exists $self->{_map}->{$char}))
    {
    $char = $self->{_map}->{$char} - 1;
    $char += $str->{sign} eq '-' ? 1 : -1;
    if ($char < 0 || $char >= @{$self->{_start}})
      {
      $str->{_cache} = undef;			# invalidate cache
      return; 					# under or overflow
      }
    }
  else
    {
    $str->{_cache} = undef;			# invalidate cache
    return; 					# underflow if char not defined
    }
  $char = $self->{_start}->[$char];		# map num back to char
  if (defined $self->{_sep})
    {
    $$s =~ s/$old\z/$char/; 			# split last part and replace
    }
  else
    {
    substr($$s,-$clen,$clen) = $char;		# simple replace
    }
  }

sub merge
  {
  # merge yourself with another simple charset
  my $self = shift;
  my $other = shift;

  # TODO
  $self;
  }

###############################################################################

sub study
  {
  # study a list of words and return a hash describing them
  # study ( { order => $depth, words = \@words, sep => ''}, charlen => 1,
  # hist => 1, );

  my $arg;
  if (ref $_[0] eq 'HASH')
    {
    $arg = shift;
    }
  else
    {
    $arg = { @_ };
    }

  my $depth = abs($arg->{order} || $arg->{depth} || 1);
  my $words = $arg->{words} || [];
  my $sep = $arg->{sep};
  my $charlen = $arg->{charlen} || 1;
  my $cut = $arg->{cut} || 0;
  my $hist = $arg->{hist} || 0;

  die "depth of study must be between 1..2" if ($depth < 1 || $depth > 2);
  my $starts = {};              # word starts
  my $ends = {};                # word ends
  my $chars = {};               # for depth 1
  my $bi = { }; my ($l,@chars,$x,$y,$word,$i);
  foreach $word (@$words)
    {
    # count starting chars and ending chars
    $starts->{substr($word,0,$charlen)} ++;
    $ends->{substr($word,-$charlen,$charlen)} ++;
    $l = CORE::length($word) / $charlen;
    next if (int($l) != $l);			# illegal word
    if ($depth == 1)
      {
      for (my $i = 0; $i < $l; $i += $charlen)
        {
        $chars->{substr($word,$i,$charlen)} ++;
        }
      next;					# next word
      }
    $l = $l - $depth + 1;
    for ($i = 0; $i < $l; $i += $charlen)
      {
      $x = substr($word,$i,$charlen); $y = substr($word,$i+$charlen,$charlen);
      $bi->{$x}->{$y} ++;
      }
    }
  my $args = {};
  my (@end,@start);
  foreach (sort { $starts->{$b} <=> $starts->{$a} } keys %$starts)
    {
    push @start, $_;
    }
  $args->{start} = \@start;
  foreach (sort { $ends->{$b} <=> $ends->{$a} } keys %$ends)
    {
    push @end, $_;
    }
  $args->{end} = \@end;
  if ($depth > 1)
    {
    my @sorted;
    foreach my $c (keys %$bi)
      {
      my $bc = $bi->{$c};
      $args->{bi}->{$c} = [
        sort { $bc->{$b} <=> $bc->{$a} or $a cmp $b } keys %$bc
        ];
      }
    }
  else
    {
    my @chars = ();
    foreach (sort { $chars->{$b} <=> $chars->{$a} } keys %$chars)
      {
      push @chars, $_;
      }
    $args->{chars} = \@chars;
    }
  if ($hist != 0)
    {
    # return histogram
    if ($depth > 1)
      {
      $args->{hist} = $bi;
      }
    else
      {
      $args->{hist} = $chars;
      }
    }
  $args;
  }

__END__