REBOL [ file: %porterstemming.r date: 18-Nov-2007 title: "Porter Stemming Algorithm" version: 1.0.1 organization: "Digital Bear Consulting" url: http://www.digital-bear.com author: "Dale K. Brearcliffe" email: %daleb--digital-bear--com copyright: "Copyright (c) 2007, 2009 Dale K. Brearcliffe" license: {Copyright (c) 2007, 2009 Dale K. Brearcliffe. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of Digital Bear Consulting nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.} purpose: {Applies the Porter Stemming algorithm as presented in: Porter, 1980, An algorithm for suffix stripping, Program, Vol. 14, no. 3, pp 130-137.} remarks: {This program is based on the modified version of Porter's stemming algorithm posted at: http://tartarus.org/~martin/PorterStemmer/ The program was tested with the sample test vocabulary found at the above web site. In testing it created the same output results as the sample output. Note that this program will force all text to lower case and return results as lower case.} usage: {do %porterstemming.r stemmedWord: porterStem word } library: [ level: 'intermediate platform: 'all type: [function tool] domain: [text text-processing] tested-under: [view 2.7.6.3.1 "Windows XP"] support: none license: BSD see-also: http://tartarus.org/~martin/PorterStemmer/ ] ] porterStem: function [ "Stems Words" word ][ ][ word: lowercase word ;Check for minimum length if (length? word) < 3 [return word] ;Set variables vowels: "aeiou" vowel: charset join vowels {y} consonant: charset ["bcdfghjklmnpqrstvwxYz"] consonant1: charset ["bcdfghjklmnpqrstvz"] cvc: [1 consonant 1 vowel 1 consonant] V: [some vowel] C: [some consonant] C1: [some consonant1] VC: [V C] ruleM: [(m: 0) any C VC (m: m + 1) VC (m: m + 1) VC (m: m + 1) VC (m: m + 1) any V] listStep1a: [{sses} {ss} {ies} {i} {ss} {ss} {s} {}] listStep1b: [{at} {ate} {bl} {ble} {iz} {ize} {bb} {b} {cc} {c} {dd} {d} {ff} {f} {gg} {g} {hh} {h} {jj} {j} {kk} {k} {ll} {ll} {mm} {m} {nn} {n} {pp} {p} {qq} {q} {rr} {r} {ss} {ss} {tt} {t} {vv} {v} {ww} {w} {xx} {x} {zz} {zz}] listStep2: [{ational} {ate} {tional} {tion} {enci} {ence} {anci} {ance} {izer} {ize} {logi} {log} {bli} {ble} {alli} {al} {entli} {ent} {eli} {e} {ousli} {ous} {ization} {ize} {ation} {ate} {ator} {ate} {alism} {al} {iveness} {ive} {fulness} {ful} {ousness} {ous} {aliti} {al} {iviti} {ive} {biliti} {ble}] listStep3: [{icate} {ic} {ative} {} {alize} {al} {iciti} {ic} {ical} {ic} {ful} {} {ness} {}] listStep4: [{al} {} {ance} {} {ence} {} {er} {} {ic} {} {able} {} {ible} {} {ant} {} {ement} {} {ment} {} {ent} {} {ion} {} {ou} {} {ism} {} {ate} {} {iti} {} {ous} {} {ive} {} {ize} {}] ;partOfWord - Given a word and a suffix of interest, the function splits the word, ;returning a block containing the stem, the suffix and a boolean that is set to ;true if the suffix was found in the word. partOfWord: function [ "Creates parts of word breakdown. Returns a block with stem, suffix & pointer." arg1 [string!] arg2 [string!] ][ l1 l2 matched returnvalue stem suffix ][ matched: false l1: length? arg1 l2: length? arg2 stem: copy {} suffix: copy {} if l2 < l1 [ suffix: rightString arg1 l2 stem: leftString arg1 (l1 - l2) if suffix == arg2 [matched: true] ] returnValue: copy [] append returnValue stem append returnValue suffix append returnValue matched return returnValue ] hasVowel?: function [ "Returns true if the passed string contains a vowel." arg1 [string!] ][ returnValue t ][ t: intersect arg1 (join vowels {y}) returnValue: false if t <> "" [returnValue: true] return returnValue ] leftString: function [ "Returns the left most arg2 characters of string arg1." arg1 [string!] arg2 [number!] ][ l ][ l: length? arg1 if (l <= arg2) [return arg1] if (arg2 = 0) [return {}] if (arg2 < 0) [arg2: 0 - arg2] return copy/part arg1 arg2 ] rightString: function [ "Returns the right most arg2 characters of string arg1." arg1 [string!] arg2 [number!] ][ l lt ][ l: length? arg1 if (l <= arg2) [return arg1] if arg2 = 0 [return {}] either arg2 > 0 [ lt: 0 - arg2 ][ lt: arg2 ] return skip tail arg1 lt ] ;Fix the problem with the status of 'y' by changing the lower case 'y' to ;uppercase in those cases where 'y' should be treated as a consonant foreach letter vowels [ replace word join letter {y} join letter {Y} ] if (leftString word 1) == {y} [replace word {y} {Y}] ;Step 1a removes plurality ;Rule: SSES -> SS caresses -> caress ;Rule: IES -> I ponies -> poni ; ties -> ti ;Rule: SS -> SS caress -> caress ;Rule: S -> cats -> cat forskip listStep1a 2 [ partOfWordResults: partOfWord word first listStep1a stem: first partOfWordResults ptr: third partOfWordResults if ptr [ word: join stem second listStep1a break ] ] listStep1a: head listStep1a ;Step 1b removes past participles ;Rule: (m>0) EED -> EE feed -> feed ; agreed -> agree step1bDone: false step1b1: false partOfWordResults: partOfWord word {eed} stem: first partOfWordResults ptr: third partOfWordResults if ptr [ step1bDone: true parse stem ruleM if m > 0 [ word: join stem {ee} ] ] ;Rule: (*v*) ED -> plastered -> plaster ; bled -> bled if not step1bDone [ partOfWordResults: partOfWord word {ed} stem: first partOfWordResults ptr: third partOfWordResults if ptr [ step1bDone: true if hasVowel? stem [ word: stem step1b1: true ] ] ] ;Rule: (*v*) ING -> motoring -> motor ; sing -> sing if not step1bDone [ partOfWordResults: partOfWord word {ing} stem: first partOfWordResults ptr: third partOfWordResults if ptr [ if hasVowel? stem [ word: stem step1b1: true ] ] ] ;If the second or third of the rules in Step 1b is successful, the following ;is done: ; ; AT -> ATE conflat(ed) -> conflate ; BL -> BLE troubl(ed) -> trouble ; IZ -> IZE siz(ed) -> size ; (*d and not (*L or *S or *Z)) ; -> single letter ; hopp(ing) -> hop ; tann(ed) -> tan ; fall(ing) -> fall ; hiss(ing) -> hiss ; fizz(ed) -> fizz if step1b1 [ forskip listStep1b 2 [ partOfWordResults: partOfWord word first listStep1b stem: first partOfWordResults ptr: third partOfWordResults if ptr [ word: join stem second listStep1b step1b1: false break ] ] listStep1b: head listStep1b ] ;Rule: (m=1 and *o) -> E fail(ing) -> fail ; fil(ing) -> file if step1b1 [ parse word ruleM if m == 1 [ letter: rightString word 1 if parse letter C1 [ if parse (rightString word 3) cvc [ word: join word {e}] ] ] ] ;Step 1c ;Rule: (*v*) Y -> I happy -> happi ; sky -> sky partOfWordResults: partOfWord word {y} stem: first partOfWordResults ptr: third partOfWordResults if ptr [ if hasVowel? stem [word: join stem {i}] ] partOfWordResults: partOfWord word {Y} stem: first partOfWordResults ptr: third partOfWordResults if ptr [ if hasVowel? stem [word: join stem {i}] ] ;Step 2 ;Rule: (m>0) ATIONAL -> ATE relational -> relate ;Rule: (m>0) TIONAL -> TION conditional -> condition ; rational -> rational ;Rule: (m>0) ENCI -> ENCE valenci -> valence ;Rule: (m>0) ANCI -> ANCE hesitanci -> hesitance ;Rule: (m>0) IZER -> IZE digitizer -> digitize ;Rule: (m>0) LOGI -> LOG - New Rule added ;Rule: (m>0) ABLI -> ABLE conformabli -> conformable ;Rule: (m>0) BLI -> BLE - Replaces rule: (m>0) ABLI -> ABLE ;Rule: (m>0) ALLI -> AL radicalli -> radical ;Rule: (m>0) ENTLI -> ENT differentli -> different ;Rule: (m>0) ELI -> E vileli - > vile ;Rule: (m>0) OUSLI -> OUS analogousli -> analogous ;Rule: (m>0) IZATION -> IZE vietnamization -> vietnamize ;Rule: (m>0) ATION -> ATE predication -> predicate ;Rule: (m>0) ATOR -> ATE operator -> operate ;Rule: (m>0) ALISM -> AL feudalism -> feudal ;Rule: (m>0) IVENESS -> IVE decisiveness -> decisive ;Rule: (m>0) FULNESS -> FUL hopefulness -> hopeful ;Rule: (m>0) OUSNESS -> OUS callousness -> callous ;Rule: (m>0) ALITI -> AL formaliti -> formal ;Rule: (m>0) IVITI -> IVE sensitiviti -> sensitive ;Rule: (m>0) BILITI -> BLE sensibiliti -> sensible forskip listStep2 2 [ partOfWordResults: partOfWord word first listStep2 stem: first partOfWordResults ptr: third partOfWordResults if ptr [ parse stem ruleM if m > 0 [ word: join stem second listStep2 ] break ] ] listStep2: head listStep2 ;Step 3 ;Rule: (m>0) ICATE -> IC triplicate -> triplic ;Rule: (m>0) ATIVE -> formative -> form ;Rule: (m>0) ALIZE -> AL formalize -> formal ;Rule: (m>0) ICITI -> IC electriciti -> electric ;Rule: (m>0) ICAL -> IC electrical -> electric ;Rule: (m>0) FUL -> hopeful -> hope ;Rule: (m>0) NESS -> goodness -> good forskip listStep3 2 [ partOfWordResults: partOfWord word first listStep3 stem: first partOfWordResults ptr: third partOfWordResults if ptr [ parse stem ruleM if m > 0 [ word: join stem second listStep3 ] break ] ] listStep3: head listStep3 ;Step 4 ;Rule: (m>1) AL -> revival -> reviv ;Rule: (m>1) ANCE -> allowance -> allow ;Rule: (m>1) ENCE -> inference -> infer ;Rule: (m>1) ER -> airliner -> airlin ;Rule: (m>1) IC -> gyroscopic -> gyroscop ;Rule: (m>1) ABLE -> adjustable -> adjust ;Rule: (m>1) IBLE -> defensible -> defens ;Rule: (m>1) ANT -> irritant -> irrit ;Rule: (m>1) EMENT -> replacement -> replac ;Rule: (m>1) MENT -> adjustment -> adjust ;Rule: (m>1) ENT -> dependent -> depend ;Rule: (m>1 and (*S or *T)) ION -> adoption -> adopt ;Rule: (m>1) OU -> homologou -> homolog ;Rule: (m>1) ISM -> communism -> commun ;Rule: (m>1) ATE -> activate -> activ ;Rule: (m>1) ITI -> angulariti -> angular ;Rule: (m>1) OUS -> homologous -> homolog ;Rule: (m>1) IVE -> effective -> effect ;Rule: (m>1) IZE -> bowdlerize -> bowdler forskip listStep4 2 [ partOfWordResults: partOfWord word first listStep4 stem: first partOfWordResults ptr: third partOfWordResults if ptr [ parse stem ruleM if m > 1 [ either (first listStep4) == {ion} [ if ((rightString stem 1) == {s}) or ((rightString stem 1) == {t}) [ word: join stem second listStep4 ] ][ word: join stem second listStep4 ] ] break ] ] listStep4: head listStep4 ;Step 5a ;Rule: (m>1) E -> probate -> probat ; rate -> rate ;Rule: (m=1 and not *o) E -> cease -> ceas partOfWordResults: partOfWord word {e} stem: first partOfWordResults ptr: third partOfWordResults if ptr [ parse stem ruleM either m > 1 [ word: stem ][ if m == 1 [ letter: rightString stem 1 if ((not parse letter C1) or (not parse (rightString stem 3) cvc)) [ word: stem ] ] ] ] ;Step 5b ;Rule: (m > 1 and *d and *L) -> single letter ; controll -> control ; roll -> roll partOfWordResults: partOfWord word {l} stem: first partOfWordResults ptr: third partOfWordResults if ptr [ parse stem ruleM if m > 1 [ if (rightString stem 1) == {l} [word: stem] ] ] return lowercase word ]