1routines (
2           prelude postlude mark_regions
3           RV R1 R2
4           standard_suffix
5           verb_suffix
6           residual_suffix
7           residual_form
8)
9
10externals ( stem )
11
12integers ( pV p1 p2 )
13
14groupings ( v )
15
16stringescapes {}
17
18/* special characters */
19
20stringdef a'   '{U+00E1}'  // a-acute
21stringdef a^   '{U+00E2}'  // a-circumflex e.g. 'bota^nico
22stringdef e'   '{U+00E9}'  // e-acute
23stringdef e^   '{U+00EA}'  // e-circumflex
24stringdef i'   '{U+00ED}'  // i-acute
25stringdef o^   '{U+00F4}'  // o-circumflex
26stringdef o'   '{U+00F3}'  // o-acute
27stringdef u'   '{U+00FA}'  // u-acute
28stringdef c,   '{U+00E7}'  // c-cedilla
29
30stringdef a~   '{U+00E3}'  // a-tilde
31stringdef o~   '{U+00F5}'  // o-tilde
32
33
34define v 'aeiou{a'}{e'}{i'}{o'}{u'}{a^}{e^}{o^}'
35
36define prelude as repeat (
37    [substring] among(
38        '{a~}' (<- 'a~')
39        '{o~}' (<- 'o~')
40        ''     (next)
41    ) //or next
42)
43
44define mark_regions as (
45
46    $pV = limit
47    $p1 = limit
48    $p2 = limit  // defaults
49
50    do (
51        ( v (non-v gopast v) or (v gopast non-v) )
52        or
53        ( non-v (non-v gopast v) or (v next) )
54        setmark pV
55    )
56    do (
57        gopast v gopast non-v setmark p1
58        gopast v gopast non-v setmark p2
59    )
60)
61
62define postlude as repeat (
63    [substring] among(
64        'a~' (<- '{a~}')
65        'o~' (<- '{o~}')
66        ''   (next)
67    ) //or next
68)
69
70backwardmode (
71
72    define RV as $pV <= cursor
73    define R1 as $p1 <= cursor
74    define R2 as $p2 <= cursor
75
76    define standard_suffix as (
77        [substring] among(
78
79            'eza' 'ezas'
80            'ico' 'ica' 'icos' 'icas'
81            'ismo' 'ismos'
82            '{a'}vel'
83            '{i'}vel'
84            'ista' 'istas'
85            'oso' 'osa' 'osos' 'osas'
86            'amento' 'amentos'
87            'imento' 'imentos'
88
89           'adora' 'ador' 'a{c,}a~o'
90           'adoras' 'adores' 'a{c,}o~es'  // no -ic test
91           'ante' 'antes' '{a^}ncia' // Note 1
92            (
93                R2 delete
94            )
95            'logia'
96            'logias'
97            (
98                R2 <- 'log'
99            )
100            'u{c,}a~o' 'u{c,}o~es'
101            (
102                R2 <- 'u'
103            )
104            '{e^}ncia' '{e^}ncias'
105            (
106                R2 <- 'ente'
107            )
108            'amente'
109            (
110                R1 delete
111                try (
112                    [substring] R2 delete among(
113                        'iv' (['at'] R2 delete)
114                        'os'
115                        'ic'
116                        'ad'
117                    )
118                )
119            )
120            'mente'
121            (
122                R2 delete
123                try (
124                    [substring] among(
125                        'ante' // Note 1
126                        'avel'
127                        '{i'}vel' (R2 delete)
128                    )
129                )
130            )
131            'idade'
132            'idades'
133            (
134                R2 delete
135                try (
136                    [substring] among(
137                        'abil'
138                        'ic'
139                        'iv'   (R2 delete)
140                    )
141                )
142            )
143            'iva' 'ivo'
144            'ivas' 'ivos'
145            (
146                R2 delete
147                try (
148                    ['at'] R2 delete // but not a further   ['ic'] R2 delete
149                )
150            )
151            'ira' 'iras'
152            (
153                RV 'e'  // -eira -eiras usually non-verbal
154                <- 'ir'
155            )
156        )
157    )
158
159    define verb_suffix as setlimit tomark pV for (
160        [substring] among(
161            'ada' 'ida' 'ia' 'aria' 'eria' 'iria' 'ar{a'}' 'ara' 'er{a'}'
162            'era' 'ir{a'}' 'ava' 'asse' 'esse' 'isse' 'aste' 'este' 'iste'
163            'ei' 'arei' 'erei' 'irei' 'am' 'iam' 'ariam' 'eriam' 'iriam'
164            'aram' 'eram' 'iram' 'avam' 'em' 'arem' 'erem' 'irem' 'assem'
165            'essem' 'issem' 'ado' 'ido' 'ando' 'endo' 'indo' 'ara~o'
166            'era~o' 'ira~o' 'ar' 'er' 'ir' 'as' 'adas' 'idas' 'ias'
167            'arias' 'erias' 'irias' 'ar{a'}s' 'aras' 'er{a'}s' 'eras'
168            'ir{a'}s' 'avas' 'es' 'ardes' 'erdes' 'irdes' 'ares' 'eres'
169            'ires' 'asses' 'esses' 'isses' 'astes' 'estes' 'istes' 'is'
170            'ais' 'eis' '{i'}eis' 'ar{i'}eis' 'er{i'}eis' 'ir{i'}eis'
171            '{a'}reis' 'areis' '{e'}reis' 'ereis' '{i'}reis' 'ireis'
172            '{a'}sseis' '{e'}sseis' '{i'}sseis' '{a'}veis' 'ados' 'idos'
173            '{a'}mos' 'amos' '{i'}amos' 'ar{i'}amos' 'er{i'}amos'
174            'ir{i'}amos' '{a'}ramos' '{e'}ramos' '{i'}ramos' '{a'}vamos'
175            'emos' 'aremos' 'eremos' 'iremos' '{a'}ssemos' '{e^}ssemos'
176            '{i'}ssemos' 'imos' 'armos' 'ermos' 'irmos' 'eu' 'iu' 'ou'
177
178            'ira' 'iras'
179                (delete)
180        )
181    )
182
183    define residual_suffix as (
184        [substring] among(
185            'os'
186            'a' 'i' 'o' '{a'}' '{i'}' '{o'}'
187                ( RV delete )
188        )
189    )
190
191    define residual_form as (
192        [substring] among(
193            'e' '{e'}' '{e^}'
194                ( RV delete [('u'] test 'g') or
195                             ('i'] test 'c') RV delete )
196            '{c,}' (<-'c')
197        )
198    )
199)
200
201define stem as (
202    do prelude
203    do mark_regions
204    backwards (
205        do (
206            ( ( standard_suffix or verb_suffix )
207              and do ( ['i'] test 'c' RV delete )
208            )
209            or residual_suffix
210        )
211        do residual_form
212    )
213    do postlude
214)
215
216/*
217    Note 1: additions of 15 Jun 2005
218*/
219