1// Alias: de 2 3/* 4 Extra rule for -nisse ending added 11 Dec 2009 5*/ 6 7routines ( 8 prelude postlude 9 mark_regions 10 R1 R2 11 standard_suffix 12) 13 14externals ( stem ) 15 16integers ( p1 p2 x ) 17 18groupings ( v s_ending st_ending ) 19 20stringescapes {} 21 22/* special characters */ 23 24stringdef a" '{U+00E4}' 25stringdef o" '{U+00F6}' 26stringdef u" '{U+00FC}' 27stringdef ss '{U+00DF}' 28 29define v 'aeiouy{a"}{o"}{u"}' 30 31define s_ending 'bdfghklmnrt' 32define st_ending s_ending - 'r' 33 34define prelude as ( 35 36 test repeat ( 37 ( 38 ['{ss}'] <- 'ss' 39 ) or next 40 ) 41 42 repeat goto ( 43 v [('u'] v <- 'U') or 44 ('y'] v <- 'Y') 45 ) 46) 47 48define mark_regions as ( 49 50 $p1 = limit 51 $p2 = limit 52 53 test(hop 3 setmark x) 54 55 gopast v gopast non-v setmark p1 56 try($p1 < x $p1 = x) // at least 3 57 gopast v gopast non-v setmark p2 58 59) 60 61define postlude as repeat ( 62 63 [substring] among( 64 'Y' (<- 'y') 65 'U' (<- 'u') 66 '{a"}' (<- 'a') 67 '{o"}' (<- 'o') 68 '{u"}' (<- 'u') 69 '' (next) 70 ) 71 72) 73 74backwardmode ( 75 76 define R1 as $p1 <= cursor 77 define R2 as $p2 <= cursor 78 79 define standard_suffix as ( 80 do ( 81 [substring] R1 among( 82 'em' 'ern' 'er' 83 ( delete 84 ) 85 'e' 'en' 'es' 86 ( delete 87 try (['s'] 'nis' delete) 88 ) 89 's' 90 ( s_ending delete 91 ) 92 ) 93 ) 94 do ( 95 [substring] R1 among( 96 'en' 'er' 'est' 97 ( delete 98 ) 99 'st' 100 ( st_ending hop 3 delete 101 ) 102 ) 103 ) 104 do ( 105 [substring] R2 among( 106 'end' 'ung' 107 ( delete 108 try (['ig'] not 'e' R2 delete) 109 ) 110 'ig' 'ik' 'isch' 111 ( not 'e' delete 112 ) 113 'lich' 'heit' 114 ( delete 115 try ( 116 ['er' or 'en'] R1 delete 117 ) 118 ) 119 'keit' 120 ( delete 121 try ( 122 [substring] R2 among( 123 'lich' 'ig' 124 ( delete 125 ) 126 ) 127 ) 128 ) 129 ) 130 ) 131 ) 132) 133 134define stem as ( 135 do prelude 136 do mark_regions 137 backwards 138 do standard_suffix 139 do postlude 140) 141