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