File Coverage

blib/lib/Unicode/SetAutomaton.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Unicode::SetAutomaton;

use strict;
use warnings;
use Set::IntSpan;
use Set::IntSpan::Partition;
use Storable qw(freeze);

our $VERSION = '0.01';

our @utf8hs  = (0x00000000, 0x00000000, 0x0000c080, 0x00e08080, 0xf0808080);
our @utf8min = (0x00000000, 0x00000000, 0x0000C280, 0x00E0A080, 0xF0908080);
our @utf8max = (0x00000000, 0x0000007F, 0x0000DFBF, 0x00EFBFBF, 0xF48FBFBF);

sub _u8enc {

  my $cp = shift;
  my $ln = 4;

  # Encodes code points as utf-8 integers;
  # for example, U+00F6 becomes 0x0000C3B6

  return $cp if $cp <= 0x7F;

  # Spread the bits to their target locations
  my $ret = (($cp << 0) & 0x0000003f) |
            (($cp << 2) & 0x00003f00) |
            (($cp << 4) & 0x003f0000) |
            (($cp << 6) & 0x3f000000) ;

  # Count the length
  $ln -= $cp <= 0xFFFF;
  $ln -= $cp <= 0x07FF;

  # Merge the spread bits with the mode bits
  return $ret | $utf8hs[$ln];
}

sub _get_info {

  my $u8 = shift;

  my $width = 4;
  $width -= $u8 <= 0xFFFFFF;
  $width -= $u8 <= 0xFFFF;
  $width -= $u8 <= 0xFF;

  my $s1 = ($width - 1) * 8;
  my $s2 = (4 - $width) * 8;
  my $ml = 0x00808080 >> $s2;
  my $mh = 0x00BFBFBF >> $s2;
  my $xl = 0x00800000 >> $s2;
  my $xh = 0x00BF0000 >> $s2;

  # The first byte in the partial utf-8 sequence in u8.
  my $head  = $u8 >> $s1;

  # All bytes after the first, or zero if there are none.
  my $tail  = ($u8 & $mh);

  # Indicates whether the first byte after head is 0x80.
  my $islow = ($u8 & $xh) == $xl;

  # Indicates whether the first byte after head is 0xBF.
  my $isupp = ($u8 & $xh) == $xh;

  # Last partial sequence before sequences with head
  my $pmax  = ($head - 1) << $s1 | $mh;

  # First partial sequence for sequences with head
  my $pmin  = ($head + 0) << $s1 | $ml;

  # Last partial sequence for sequences with head
  my $hmax  = ($head + 0) << $s1 | $mh;

  # First partial sequence after sequences with head
  my $hmin  = ($head + 1) << $s1 | $ml;

  # There are a few special cases for the min,max items
  # if the respective head is not a continuation octet.
  # E.g., for 0xE0 pmin should be E0A080 but is E08080.
  # The caller handles them indirectly by splitting.

  my $i = {
    width => $width, head  => $head,  tail  => $tail,
    isLow => $islow, isUpp => $isupp, hmin  => $hmin,
    hmax  => $hmax,  pmin  => $pmin,  pmax  => $pmax,
  };

  return $i;
}

sub _get_next {

  my $iter = shift;
  my ($clas, $cmin, $cmax, $nmin, $min, $max);

  if ($iter->{splitix}) {

    # When splitting ranges a separate array is used to keep
    # track of artificial ranges. If there any, use them first.
    $cmax = $iter->{split}->[ -- $iter->{splitix} ];
    $cmin = $iter->{split}->[ -- $iter->{splitix} ];
    $clas = $iter->{split}->[ -- $iter->{splitix} ];

  } elsif ( $iter->{derivix} <= $iter->{end} ) {

    # If there are none, we pick a new range from the input.
    $clas = $iter->{deriv}->[ $iter->{derivix} ++ ];
    $cmin = $iter->{deriv}->[ $iter->{derivix} ++ ];
    $cmax = $iter->{deriv}->[ $iter->{derivix} ++ ];

  } else {
    return
  }

  # Compute various properties of the partial sequences.
  $min = _get_info($cmin);
  $max = _get_info($cmax);

  if ($min->{width} != $max->{width}) {

    # The range crosses width boundaries, so split it.
    $nmin = $utf8min[ $min->{width} + 1 ];
    $iter->{split}->[ $iter->{splitix} ++ ] = $clas;
    $iter->{split}->[ $iter->{splitix} ++ ] = $nmin;
    $iter->{split}->[ $iter->{splitix} ++ ] = $cmax;
    $cmax = $utf8max[ $min->{width} ];
  }

  if ($cmin >= 0x00eda080 and $cmax <= 0x00edbfbf) {

    # The current range contains only surrogate code points
    # which are not allowed. So get the next range, if any.
    return _get_next( $iter );

  } elsif ($cmin >= 0x00eda080 and $cmin <= 0x00edbfbf) {

    # cmin is somewhere inside the surrogate range and cmax
    # is not. So we set cmin to the first non-surrogate.
    $cmin = 0x00ee8080;

  } elsif ($cmax >= 0x00eda080 and $cmax <= 0x00edbfbf) {

    # cmax is somewhere inside the surrogate range and cmin
    # is not. So we set cmax to the last non-surrogate.
    $cmax = 0x00ed9fbf;

  } elsif ($cmin < 0x00eda080 and $cmax > 0x00edbfbf) {

    # The range includes code points before and after the
    # surrogate range. So we have to split it into two.
    $nmin = 0x00ee8080;
    $iter->{split}->[ $iter->{splitix} ++ ] = $clas;
    $iter->{split}->[ $iter->{splitix} ++ ] = $nmin;
    $iter->{split}->[ $iter->{splitix} ++ ] = $cmax;
    $cmax = 0x00ed9fbf;
  }

  # cmin and cmax may have changed so recompute the info
  $min = _get_info($cmin);
  $max = _get_info($cmax);

  if (!($min->{head} == $max->{head}) && !($min->{isLow} && $max->{isUpp})) {

    if ($min->{isLow}) {

      # min is a lower and but max is not an upper end, so we split
      # the range into two, one going from min to "one" before max,
      # and the other going from the beginning of max's range to max.
      $nmin = $max->{pmin};
      $iter->{split}->[ $iter->{splitix} ++ ] = $clas;
      $iter->{split}->[ $iter->{splitix} ++ ] = $nmin;
      $iter->{split}->[ $iter->{splitix} ++ ] = $cmax;
      $cmax = $max->{pmax};

    } else {

      # if the heads are different and min is not a lower end then
      # we have to complete min's range first, so split the range.
      $nmin = $min->{hmin};
      $iter->{split}->[ $iter->{splitix} ++ ] = $clas;
      $iter->{split}->[ $iter->{splitix} ++ ] = $nmin;
      $iter->{split}->[ $iter->{splitix} ++ ] = $cmax;
      $cmax = $min->{hmax};

    }
  }

  # cmax may have changed so recompute the info
  $max = _get_info($cmax);

  return $clas, $min, $max;
}

sub _triples_to_dfa {

  my @triples = @_;
  my (@d, @todo, $d2s, $s2d);

  # The deriv array stores all character class, or rather, utf-8 range
  # information. Each class stores the length of the subsequent data as
  # first item. For classes representing end states the next value is
  # the number of the class. For other classes a list of
  # triples follows. Array references and other structures could be
  # used instead, however this structure mirrors the C implementation.

  my @deriv = ( scalar(@triples), @triples );
  my $lengthix = scalar @deriv;
  my $nextix = scalar @deriv + 1;
  my $nextnum = 0;
  my $start = $nextnum++;
  my $obj2num = { freeze(\@triples), $start };

  $deriv[$lengthix] = 0;

  push @todo, [ $start, $start ];

  while (@todo) {

    my ($index, $currentS) = @{ pop @todo };

    # A special iterator is used to go over the utf-8 ranges in a class.
    # The basic idea of this algorithm is to compute all derivatives of
    # a given class of utf-8 ranges; the iterator automatically splits
    # these ranges such that we can take the "heads" of a range as label
    # for a transition, and the "tails" as range for the next class.

    # As an example, consider a simple class from U+00E4 to U+00F6. The
    # range is utf-8 encoded to 0x0000C3A4 .. 0x0000C3B6. Here the head
    # range would be 0xC3 .. 0xC3 and the tail range 0xA4 .. 0xB6. Then
    #  -- 0xC3 .. 0xC3 --> <1>, <1> -- 0xA4 .. 0xB6 -->  would be
    # the automaton. See the _get_next routine for details on splitting.

    my $iter = {
      split   => [],
      splitix => 0,
      deriv   => \@deriv,
      derivix => $index + 1,
      end     => $index + $deriv[$index],
    };

    my $prev;

    while (1) {

      my $success = my ($cls, $min, $max) = _get_next($iter);

      # If there are no more ranges in the current class, or if the latest
      # head range is not equal to the previous one, we found the end of
      # a new class. Note that head ranges can only be the same if min,max
      # are equal for both the previous and the current range, so we only
      # have to check the two min values.
      if ((not $success) or (defined $prev && $prev->[1] ne $min->{head})) {

        # The hash table obj2num is used to ensure that the same classes
        # are assigned the same state number; not doing so would result
        # an automaton that is not minimal in the number of states, and
        # minimizing it later would be considerably more costly.

        my @new = @deriv[($lengthix + 1) .. ($lengthix + $deriv[$lengthix])];
        my $ice = freeze(\@new);
        my $num = $obj2num->{$ice};

        if (not defined $num) {
          $num = $obj2num->{$ice} = $nextnum++;

          # End states store only the number of the associated class;
          # end states do not have outgoing transitions so we do not
          # add them to the todo list. Other classes are added to it.

          if ($deriv[$lengthix] > 1) {
            push @todo, [$lengthix, $num]
          } else {
            $s2d->{ $num } = $deriv[$lengthix + 1];
            $d2s->[ $deriv[$lengthix + 1] ] = $num;
          }
        }

        # Record the newly found transition in the transition table
        # as four-tuple .
        push @d, [ $currentS, $prev->[1], $prev->[2], $num ];

        $lengthix = $nextix++;
        $deriv[$lengthix] = 0;
        last unless $success;
      }

      # min and max always have the same width. If the width of the
      # current range is one then we are moving to an end state. If
      # it is greater than one, we are creating a new partial class.

      if ($min->{width} != 1) {
        $deriv[ $nextix++ ]  = $cls;
        $deriv[ $nextix++ ]  = $min->{tail};
        $deriv[ $nextix++ ]  = $max->{tail};
        $deriv[ $lengthix ] += 3;
      } else {
        $deriv[ $nextix++ ]  = $cls;
        $deriv[ $lengthix ] += 1;
      }

      $prev = [ $cls, $min->{head}, $max->{head} ]
    }
  }

  return $start, \@d, $d2s, $s2d;
}

sub new {
  my $class = shift;
  my %param = @_;
  my $self = bless { }, $class;
  my @input = @{$param{classes}};
  my @spans;

  # A deterministic finite automaton can only be in a single state
  # at a time, so split the input classes minimally such that each
  # code point belongs to at most a single class, not multiple ones.
  my @disjoint = intspan_partition(@input);

  # intspan_partition unfortunately does not keep track of how it
  # splits classes; we'd like to know, so restore the information.
  for (my $i = 0; $i <= $#disjoint; $i++) {
    for (my $j = 0; $j <= $#input; $j++) {
      next unless $disjoint[$i]->subset($input[$j]);
      push @{$self->{disjoint_to_input}->[$i]}, $j;
    }
  }

  # The construction algorithm considers all spans at once, so we
  # collect all into a single array, noting where each belongs.
  for (my $i = 0; $i <= $#disjoint; $i++) {
    foreach my $span ($disjoint[$i]->spans) {
      push @spans, [ $i, @$span ];
    }
  }

  # While not strictly necessary, it is better to sort the spans,
  # so we do that here. Note that spans are disjoint, so we only
  # have to compare the relevant minimum value for each span pair.
  my @sorted = sort { $a->[1] <=> $b->[1] } @spans;

  # Now we can generate a single list for all
  # triples where min and max are utf-8 integers. It is easier to
  # do this here then telling a complete class apart from partial
  # classes generated later; the spans are not array references
  # mainly because that mirrors the C implementation more closely.
  my @u8triples = map {
    $_->[0], _u8enc($_->[1]), _u8enc($_->[2])
  } @sorted;

  my ($start, $d, $d2s, $s2d) = _triples_to_dfa(@u8triples);

  $self->{state_to_disjoint} = $s2d;
  $self->{disjoint_to_state} = $d2s;
  $self->{disjoint_classes} = \@disjoint;
  $self->{input_classes} = \@input;
  $self->{start_state} = $start;
  $self->{transitions} = $d;

  return $self;
}

sub _regex_append {
  my $node = shift;
  my $type = shift;

  if (UNIVERSAL::isa($node, 'Set::IntSpan')) {

    if ($node->size == 1) {
      $_[0] .= sprintf "\\x%02x", $node->elements

    } else {
      $_[0] .= "[";

      foreach my $span ($node->spans) {
        if ($span->[0] == $span->[1]) {
          $_[0] .= sprintf "\\x%02x", $span->[0]
        } else {
          $_[0] .= sprintf "\\x%02x-\\x%02x", @$span
        }
      }

      $_[0] .= "]";
    }

  } elsif ($node->[0] eq 'Group') {
    _regex_append($node->[1], 'Group', $_[0]);
    _regex_append($node->[2], 'Group', $_[0]);

  } elsif ($node->[0] eq 'Choice' and $type eq 'Group') {
    $_[0] .= "(";
    _regex_append($node->[1], 'Choice', $_[0]);
    $_[0] .= "|";
    _regex_append($node->[2], 'Choice', $_[0]);
    $_[0] .= ")";

  } elsif ($node->[0] eq 'Choice') {
    _regex_append($node->[1], 'Choice', $_[0]);
    $_[0] .= "|";
    _regex_append($node->[2], 'Choice', $_[0]);

  } else {
    die
  }

}

sub as_expressions {
  my $self = shift;
  my $last = 0;
  my @m;

  require Graph::Directed;
  my $g = Graph::Directed->new;

  # Convert the transitions into a matrix using Set::IntSpan objects
  # to represent byte classes and use a graph to keep track of the
  # predecessors and successors of each state. Would be nice if the
  # Set::IntSpan::union method accepted undef as set to avoid the if.

  foreach my $transition (@{ $self->{transitions} }) {
    my ($src, $min, $max, $dst) = @$transition;

    if (defined $m[$src][$dst]) {
      $m[$src][$dst] = $m[$src][$dst]->union([[$min,$max]]);
    } else {
      $m[$src][$dst] = Set::IntSpan->new([[$min,$max]]);
    }

    $g->add_edge($src, $dst);
    $last = $dst > $last ? $dst : $last;
  }

  # States will be eliminated in the reverse order of their creation.
  # I am unsure if that produces the best result but could so far not
  # find counter-examples. A more elaborate algorithm would make sure
  # a state is removed before any, if that is possible, that must be
  # visited before or after when going from start state to final state.

  my @order = grep {

    # We only remove a state if it is neither the start state nor
    # a final state. $self->{state_to_disjoint} holds final ones.

    $_ != $self->{start_state} and
      not exists $self->{state_to_disjoint}->{$_}

  } (0 .. $last);

  while (@order) {

    my $curr = pop @order;
    my @pred = $g->predecessors($curr);
    my @succ = $g->successors($curr);

    # A state is eliminated by connecting all predecessors with all
    # successors by an increasingly complex regular expression. We
    # store the regular expression as a binary tree to ease adding
    # needed braces later. Note that the transition graph does not
    # have cycles, otherwise we would have to encode the cycle too.

    foreach my $pred (@pred) {
      foreach my $succ (@succ) {

        my $group = [ Group => $m[$pred][$curr], $m[$curr][$succ] ];
        if ($m[$pred][$succ]) {
          $m[$pred][$succ] = [ Choice => $m[$pred][$succ], $group ];
        } else {
          $m[$pred][$succ] = $group;
          $g->add_edge($pred, $succ);
        }
      }
    }

    $g->delete_vertex($curr);
  }

  # Now the matrix has a regular expression for each of the dis-
  # joint classes at m[start_state][final_state]. We iterate over
  # the disjoint classes, pretty print the expression, and return
  # them in the order of the disjoint classes.

  my @expressions;

  for (my $i = 0; $i <= $#{ $self->{disjoint_to_state} }; $i++) {
    my $final = $self->{disjoint_to_state}->[$i];
    my $regex = "";
    _regex_append($m[$self->{start_state}][$final], 'Root', $regex);
    push @expressions, $regex;
  }

  return @expressions;
}

1;

__END__