1// Alias: da
2
3routines (
4           mark_regions
5           main_suffix
6           consonant_pair
7           other_suffix
8           undouble
9)
10
11externals ( stem )
12
13strings ( ch )
14
15integers ( p1 x )
16
17groupings ( v s_ending )
18
19stringescapes {}
20
21/* special characters */
22
23stringdef ae   '{U+00E6}'
24stringdef ao   '{U+00E5}'
25stringdef o/   '{U+00F8}'
26
27define v 'aeiouy{ae}{ao}{o/}'
28
29define s_ending  'abcdfghjklmnoprtvyz{ao}'
30
31define mark_regions as (
32
33    $p1 = limit
34
35    test ( hop 3 setmark x )
36    goto v gopast non-v  setmark p1
37    try ( $p1 < x  $p1 = x )
38)
39
40backwardmode (
41
42    define main_suffix as (
43        setlimit tomark p1 for ([substring])
44        among(
45
46            'hed' 'ethed' 'ered' 'e' 'erede' 'ende' 'erende' 'ene' 'erne' 'ere'
47            'en' 'heden' 'eren' 'er' 'heder' 'erer' 'heds' 'es' 'endes'
48            'erendes' 'enes' 'ernes' 'eres' 'ens' 'hedens' 'erens' 'ers' 'ets'
49            'erets' 'et' 'eret'
50                (delete)
51            's'
52                (s_ending delete)
53        )
54    )
55
56    define consonant_pair as (
57        test (
58            setlimit tomark p1 for ([substring])
59            among(
60                'gd' // significant in the call from other_suffix
61                'dt' 'gt' 'kt'
62            )
63        )
64        next] delete
65    )
66
67    define other_suffix as (
68        do ( ['st'] 'ig' delete )
69        setlimit tomark p1 for ([substring])
70        among(
71            'ig' 'lig' 'elig' 'els'
72                (delete do consonant_pair)
73            'l{o/}st'
74                (<-'l{o/}s')
75        )
76    )
77    define undouble as (
78        setlimit tomark p1 for ([non-v] ->ch)
79        ch
80        delete
81    )
82)
83
84define stem as (
85
86    do mark_regions
87    backwards (
88        do main_suffix
89        do consonant_pair
90        do other_suffix
91        do undouble
92    )
93)
94