File Coverage

blib/lib/Text/German/Regel.pm

Criterion	Covered	Total	%
statement	44	54	81.4
branch	23	32	71.8
condition			n/a
subroutine	3	3	100.0
pod	0	2	0.0
total	70	91	76.9

#                              -*- Mode: Perl -*-
# Regel.pm --
# Author          : Ulrich Pfeifer
# Created On      : Thu Feb  1 09:10:48 1996
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Sun Apr  3 12:11:51 2005
# Language        : Perl
# Update Count    : 73
# Status          : Unknown, Use with caution!

package Text::German::Regel;
use Text::German::Util;

$debug = 0;
@REGEL = ();                    # -w

{
  local ($_);

  while () {
    chomp;
    my ($regel, $a,$b,$c,$d,$e,@f) = split(/:/, $_);
    next unless $regel;
    push(@{$REGEL[$regel]}, [$a,
                             $b,
                             $c,
                             bit_to_int($d),
                             bit_to_int($e),
                             @f]);
  }
  close DATA;
}
sub reduce {
  my($v,$s,$e) = @_;
  #my $init = join ':', ($v,$s,$e);
  #local ($debug) = ($s eq 'Mit')?4:0;

  return undef if length($s.$e) < 3;
  while (length($s)<3) {
    $s .= substr($e,0,1);
    $e = substr($e,1);
  }
  while (1) {
    my @tmp = reduce1($v,$s,$e);
    if ($#tmp) {
      my $tmp = join ':', @tmp;
      #print STDERR "$init => $tmp\n";
      return @tmp;              # if $tmp  ne $init;
    }
    return @tmp if !$e;
    $s .= substr($e,0,1);
    $e = substr($e,1);
  }
}

sub reduce1 {
  my($v,$s,$e) = @_;
  my $fc;
  my $fr;
  my $did_match;

  while (1) {
    $fr = Text::German::Endung::regel($e); # || '001'; # ???
    last if defined $fr;
    last unless $e;
    $s .= substr($e,0,1);
    $e = substr($e,1);
  }
  return undef unless $fr;
  $fc = Text::German::Endung::wort_klasse($e);

 ruleset:
  while (defined $REGEL[$fr]) {
    for $r (@{$REGEL[$fr]}) {
      next unless $r->[4] | $fc; # allowed wordclasses
      my $match = $r->[5];
      $match =~ s/\+/[bcdfghjklmnpqrstvwxyz]/;
      $match =~ s/\%/[aeiou\344\366\374]/;
      #my $ns = $s.$e;
      #$ns = substr($ns,0,length($ns)-$r->[1]);
      #$e  = substr($e, length($e)-$r->[1]);
      print "\tREGEL: $fr:", (join ':', @{$r}),"\t($s,$match)\n"
        if $debug > 1;
      if ($s =~ /$match$/) {
        $did_match++;
        print "\tREGEL: $fr:", (join ':', @{$r}),"\t$s => "
          if $debug;
        $s = (substr($s,0,length($s)-$r->[7])) if $r->[7];
        $s .= $r->[8] if $r->[8];
        print "$s\n" if $debug;
        if ($r->[6]) {          # vorsilbe 'ge' kann entfallen?
          $v =~ s/^ge//;
        }
        $fr = $r->[0];
        $fc = $r->[3];          # ???
        if ($fr ne '000') {
          next ruleset;
        } else {
          #$s = substr($s,0,length($s)-$r->[1]);
          last;
        }
      }
    }
    last;
  }
  if ($did_match) {
    return ($v,$s,$e);
  } else {
    return undef;
  }
}

1;

# regel
# 0 Folgeregel
# 1 # zeichen entfernen
# 2
# 3 new wc
# 4 KLASSE fuer match
# 5 MATCH
# 6 vorsilbe ge
# 7 #chars to remove
# 8 string to append
# 017:000:2:te:01001:01001:önn:1:3:ann
__DATA__