use strict;
use warnings;

my $word;

while(<>)
  {
  # Einfacher Ansatz, um Wörter zu unterscheiden
  my @worte = split /\s+/, $_;

  for $word(@worte)
    {
    print "$word --> ";
    $word = lc($word);
    # wandle Großbuchstaben Ä,Ö,Ü in Kleinbuchstaben um
    # -> wird von lc im Hauptprogramm nicht gemacht
    $word =~ s/Ä/ä/g;
    $word =~ s/Ö/ö/g;
    $word =~ s/Ü/ü/g;

    $word = stem($word);
    print "$word\n";
    }
  }

sub stem
  {
  # Porter Stemmer in Perl fuer das Deutsche.
  #
  # Grundgeruest des Programms uebernommen von der englischen Version aus:
  #   Porter, 1980, An algorithm for suffix stripping, Program, Vol. 14,
  #   no. 3, pp 130-137,
  # in der Perl-Implementierung von:
  #     http://www.tartarus.org/~martin/PorterStemmer
  #
  # Modifiziert:
  #    01/2002 Johannes Lang
  #    08/2009 Juergen Plate

  # Initialisierung - koennte auch als eigene Funktion herausgezogen
  # werden, damit's etwas schneller wird
  my $c = "[^aeiouyäöü]";        # Konsonant
  my $v = "[aeiouyäöü]";         # Vokal
  my $C = "${c}[^aeiouyäöü]*";   # Konsonantenfolge
  my $V = "${v}[aeiouyäöü]*";    # Vokalfolge
  my $s_end = "[bdfghklmnrt]";   # s-ending
  my $st_end = "[bdfghklmnt]";   # st-ending (s-endings ohne r)

  my ($stem, $suffix, $R1, $_R1, $R2);
  my $word = shift;

  $word =~ s/ß/ss/g;             # ersetze ß durch ss

  # u und y zwischen Vokalen --> uppercase, z.B. kauend -> kaUend
  $word =~ s/($V)([uy])($V)/$1.(ucfirst $2).$3/eg;

  $word =~ /($v$c)/;             # Vokal + Kons.
  $R1 = $';                      # alles nach dem Match -> R1
  $_R1 = $`;                     # alles vor dem Match zwischenspeichern

  if ( !($R1 =~ /$c/) ) 
    { $R2 = ''; }                # R1 enthaelt keinen konsonant-> R2 null
  else 
    {
    $R1 =~ /($v$c)/;
    $R2 = $';                    # alles nach dem Match in R1 -> R2
    }

  if (length($_R1) < 1)          # vor R1 mindestens 3 Zeichen
    { $R1 =~ s/^.//; }           # 1.Zeichen weg

  # Step 1: suche nach dem laengsten der folgenden Suffixe
  #  (a) e,  em,  en,  ern,  er,  es
  #  (b) s (mit einem s-ending davor)
  # und loeschen falls in R1.
  # (z.B. äckern -> äck, ackers -> acker, armes -> arm)

  $stem = $suffix = $word;

  if ( $word =~ /(ern)$/ ) 
    {
    $stem = $`;
    $suffix = $1;
    }
  elsif ( $word =~ /(em|en|er|es)$/ ) 
    {
    $stem = $`;
    $suffix = $1;
    }
  elsif ( $word =~ /(e)$/ ) 
    {
    $stem = $`;
    $suffix = $1;
    }
  elsif ( $word =~ /(${s_end})(s)$/ ) 
    {
    $stem = $`.$1;
    $suffix = $2;
    }

  $word = $stem if ($R1 =~ /$suffix$/);


  # Step 2: suche nach dem laengsten der folgenden Suffixe
  #  (a) en,  er,  st
  #  (b) st (nach einem st-ending, min. 3 Buchstaben davor)
  #  und loeschen falls in R1.
  # (z.B. derbsten -> derbst by step 1, and derbst -> derb by step 2,
  #  weil b ein st-ending ist und 3 Buchstaben davo stehen)

  $stem = $suffix = $word;

  if ( $word =~ /(en|er)$/ ) 
    {
    $stem = $`;
    $suffix = $1;
    }
  elsif ( $word =~ /(${st_end})(st)$/ ) 
    {
    if (length($`) >= 3) 
      {
      $stem = $` . $1;
      $suffix = $2;
      }
    }

  $word = $stem if ($R1 =~ /$suffix/);

  # Step 3: d-suffixes; suche nach dem laengsten der folgenden Suffixe
  # und fuehre die entsprechende Anweisung aus
  #   end,  ung
  #     loeschen falls in R2
  #     falls ig davor, loeschen falls in R2 und kein e davor
  #   ig,  ik,  isch
  #     loeschen falls in R2 und kein e davor
  #   lich,  heit
  #     loeschen falls in R2
  #     falls er oder en davor, loeschen falls in R1
  #   keit
  #     loeschen falls in R2  und lich oderr ig davor


  if ( $word =~ /(end|ung)$/ ) 
    {
    $stem = $`;
    $suffix = $1;
    $word = $stem if($R2 =~ /$suffix/ or 
                    ($stem =~ /[^e]ig$/ and $R2 =~ /$suffix/));
    }
  elsif ( $word =~ /(ig|ik|isch)$/ ) 
    {
    $stem = $`;
    $suffix = $1;
    $word = $stem if($stem =~ /[^e]$/ and $R2 =~ /$suffix/);
    }
  elsif ( $word =~ /(lich|heit)$/ ) 
    {
    $stem = $`;
    $suffix = $1;
    $word = $stem if($R2 =~ /$suffix/ or 
                    ($stem =~ /(er|en)$/ and $R1 =~ /$suffix/));
    }
  elsif ( $word =~ /keit$/ ) 
    {
    $stem = $`;
    $suffix = $&;
    $word = $stem if($R2 =~ /$suffix/ or 
                     ($stem =~ /(lich|ig)$/ and $R2 =~ /$suffix/));
    }

  # nun U und Y wieder klein schreiben und die Umlaupünktchen entfernen
  $word =~ s/(.+)([UY])/$1.(lcfirst $2)/eg;
  $word =~ s/ä/a/g;
  $word =~ s/ö/o/g;
  $word =~ s/ü/u/g;

  return $word;
  }