123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245 |
- strings ( ch )
- integers ( x p1 p2 )
- booleans ( Y_found stemmed GE_removed )
-
- routines (
-
- R1 R2
- C V VX
- lengthen_V
- Step_1 Step_2 Step_3 Step_4 Step_7
- Step_6 Step_1c
- Lose_prefix
- Lose_infix
- measure
- )
-
- externals ( stem )
-
- groupings ( v v_WX AOU AIOU )
-
- stringescapes {}
-
- stringdef ' hex '27' // yuk
-
- define v 'aeiouy'
- define v_WX v + 'wx'
- define AOU 'aou'
- define AIOU 'aiou'
-
- backwardmode (
-
- define R1 as (setmark x $x >= p1)
- define R2 as (setmark x $x >= p2)
-
- define V as test (v or 'ij')
- define VX as test (next v or 'ij')
- define C as test (not 'ij' non-v)
-
- define lengthen_V as do (
- non-v_WX [ (AOU] test (non-v or atlimit)) or
- ('e'] test (non-v or atlimit
- not AIOU
- not (next AIOU non-v)))
- ->ch insert ch
- )
-
- define Step_1 as
- (
- [among ( (])
-
- '{'}s' (delete)
- 's' (R1 not ('t' R1) C delete)
- 'ies' (R1 <-'ie')
- 'es'
- (('ar' R1 C ] delete lengthen_V) or
- ('er' R1 C ] delete) or
- (R1 C <-'e'))
-
- 'aus' (R1 V <-'au')
- 'en' (('hed' R1 ] <-'heid') or
- ('nd' delete) or
- ('d' R1 C ] delete) or
- ('i' or 'j' V delete) or
- (R1 C delete lengthen_V))
- 'nde' (<-'nd')
- )
- )
-
- define Step_2 as
- (
- [among ( (])
- 'je' (('{'}t' ] delete) or
- ('et' ] R1 C delete) or
- ('rnt' ] <-'rn') or
- ('t' ] R1 VX delete) or
- ('ink' ] <-'ing') or
- ('mp' ] <-'m') or
- ('{'}' ] R1 delete) or
- (] R1 C delete))
- 'ge' (R1 <-'g')
- 'lijke'(R1 <-'lijk')
- 'ische'(R1 <-'isch')
- 'de' (R1 C delete)
- 'te' (R1 <-'t')
- 'se' (R1 <-'s')
- 're' (R1 <-'r')
- 'le' (R1 delete attach 'l' lengthen_V)
- 'ene' (R1 C delete attach 'en' lengthen_V)
- 'ieve' (R1 C <-'ief')
- )
- )
-
- define Step_3 as
- (
- [among ( (])
- 'atie' (R1 <-'eer')
- 'iteit' (R1 delete lengthen_V)
- 'heid'
- 'sel'
- 'ster' (R1 delete)
- 'rder' (<-'r')
- 'ing'
- 'isme'
- 'erij' (R1 delete lengthen_V)
- 'arij' (R1 C <-'aar')
- 'fie' (R2 delete attach 'f' lengthen_V)
- 'gie' (R2 delete attach 'g' lengthen_V)
- 'tst' (R1 C <-'t')
- 'dst' (R1 C <-'d')
- )
- )
-
- define Step_4 as
- (
- ( [among ( (])
- 'ioneel' (R1 <-'ie')
- 'atief' (R1 <-'eer')
- 'baar' (R1 delete)
- 'naar' (R1 V <-'n')
- 'laar' (R1 V <-'l')
- 'raar' (R1 V <-'r')
- 'tant' (R1 <-'teer')
- 'lijker'
- 'lijkst' (R1 <-'lijk')
- 'achtig'
- 'achtiger'
- 'achtigst'(R1 delete)
- 'eriger'
- 'erigst'
- 'erig'
- 'end' (R1 C delete lengthen_V)
- )
- )
- or
- ( [among ( (])
- 'iger'
- 'igst'
- 'ig' (R1 C delete lengthen_V)
- )
- )
- )
-
- define Step_7 as
- (
- [among ( (])
- 'kt' (<-'k')
- 'ft' (<-'f')
- 'pt' (<-'p')
- )
- )
-
- define Step_6 as
- (
- [among ( (])
- 'bb' (<-'b')
- 'cc' (<-'c')
- 'dd' (<-'d')
- 'ff' (<-'f')
- 'gg' (<-'g')
- 'hh' (<-'h')
- 'jj' (<-'j')
- 'kk' (<-'k')
- 'll' (<-'l')
- 'mm' (<-'m')
- 'nn' (<-'n')
- 'pp' (<-'p')
- 'qq' (<-'q')
- 'rr' (<-'r')
- 'ss' (<-'s')
- 'tt' (<-'t')
- 'vv' (<-'v')
- 'ww' (<-'w')
- 'xx' (<-'x')
- 'zz' (<-'z')
- 'v' (<-'f')
- 'z' (<-'s')
- )
- )
-
- define Step_1c as
- (
- [among ( (] R1 C)
- 'd' (not ('n' R1) delete)
- 't' (not ('h' R1) delete)
- )
- )
- )
-
- define Lose_prefix as (
- ['ge'] test hop 3 (goto v goto non-v)
- set GE_removed
- delete
- )
-
- define Lose_infix as (
- next
- gopast (['ge']) test hop 3 (goto v goto non-v)
- set GE_removed
- delete
- )
-
- define measure as (
- do (
- tolimit
- setmark p1
- setmark p2
- )
- do(
- repeat non-v atleast 1 ('ij' or v) non-v setmark p1
- repeat non-v atleast 1 ('ij' or v) non-v setmark p2
- )
-
- )
- define stem as (
-
- unset Y_found
- unset stemmed
- do ( ['y'] <-'Y' set Y_found )
- do repeat(goto (v ['y'])<-'Y' set Y_found )
-
- measure
-
- backwards (
- do (Step_1 set stemmed )
- do (Step_2 set stemmed )
- do (Step_3 set stemmed )
- do (Step_4 set stemmed )
- )
- unset GE_removed
- do (Lose_prefix and measure)
- backwards (
- do (GE_removed Step_1c)
- )
- unset GE_removed
- do (Lose_infix and measure)
- backwards (
- do (GE_removed Step_1c)
- )
- backwards (
- do (Step_7 set stemmed )
- do (stemmed or GE_removed Step_6)
- )
- do(Y_found repeat(goto (['Y']) <-'y'))
- )
|