1#!/usr/bin/perl 2# -*- Mode: Perl -*- 3# Word.pm -- 4# ITIID : $ITI$ $Header $__Header$ 5# Author : Ulrich Pfeifer 6# Created On : Thu Feb 1 13:57:42 1996 7# Last Modified By: Ulrich Pfeifer 8# Last Modified On: Sun Apr 3 12:17:56 2005 9# Language : Perl 10# Update Count : 70 11# Status : Unknown, Use with caution! 12# 13 14package Text::German; 15 16$VERSION = $VERSION = 0.06; 17use Text::German::Util; 18require Text::German::Adjektiv; 19require Text::German::Ausnahme; 20require Text::German::Endung; 21require Text::German::Regel; 22require Text::German::Verb; 23require Text::German::Vorsilbe; 24require Text::German::Cache; 25 26sub partition { 27 my $word = shift; 28 my $vorsilbe = Text::German::Vorsilbe::max_vorsilbe($word); 29 my $vl = length($vorsilbe||''); 30 my $endung = Text::German::Endung::max_endung(substr($word,$vl)); 31 my $el = length($endung||''); 32 my $l = length($word); 33 34 return ($vorsilbe, substr($word, $vl, $l-$vl-$el), $endung); 35} 36 37sub reduce { 38 my $word = shift; 39 my $satz_anfang = shift; 40 my @word = partition($word); 41 my @tmp; 42 43 printf "INIT %s\n", join ':', @word if $debug; 44 $word[0] ||= ''; 45 $word[2] ||= ''; 46 47 my $a = Text::German::Ausnahme::reduce(@word); 48 return($a) if defined $a; 49 50 my $c = wordclass($word, $satz_anfang); 51 52 unless ($c&$FUNNY || $word[2]) { 53 return $word[1]; 54 } 55 if ($c & $VERB) { 56 @tmp = Text::German::Verb::reduce(@word); 57 if ($#tmp) { 58 @word = @tmp; 59 printf "VERB %s\n", join ':', @word if $debug; 60 return($word[1].'en'); 61 } 62 } 63 if ($c & $ADJEKTIV) { 64 @tmp = Text::German::Adjektiv::reduce(@word); 65 if ($#tmp) { 66 @word = @tmp; 67 printf "VERB %s\n", join ':', @word if $debug; 68 return($word[1]); 69 } 70 } 71 @tmp = Text::German::Regel::reduce(@word); 72 if ($#tmp) { 73 @word = @tmp; 74 printf "REGEL %s\n", join ':', @word if $debug; 75 } 76 #return join ':', @word; 77 return $word[0].$word[1]; # vorsilbe wieder anhaengen 78} 79 80# Do not use this! 81my $cache; 82 83sub cache_reduce { 84 unless ($cache) { 85 $cache = Text::German::Cache->new(Verbose => 0, 86 Function => sub {reduce($_[0], 1); }, 87 Gc => 1000, 88 Hold => 600, 89 ); 90 } 91 $cache->get(@_); 92} 93 94# This is a hoax! 95sub stem { 96 my $word = shift; 97 my $gf = reduce($word, @_); 98 my @word = partition($gf); 99 100 return $word[1]; 101} 102 1031; 104