text_stemmer

// Dutch stemming algorithm developed by Martin Porter

routines (
           prelude postlude
           e_ending
           en_ending
           mark_regions
           R1 R2
           undouble
           standard_suffix
)

externals ( stem )

booleans ( e_found )

integers ( p1 p2 x )

groupings ( v v_I v_j )

stringescapes {}

/* special characters */

stringdef a"   '{U+00E4}'
stringdef e"   '{U+00EB}'
stringdef i"   '{U+00EF}'
stringdef o"   '{U+00F6}'
stringdef u"   '{U+00FC}'

stringdef a'   '{U+00E1}'
stringdef e'   '{U+00E9}'
stringdef i'   '{U+00ED}'
stringdef o'   '{U+00F3}'
stringdef u'   '{U+00FA}'

stringdef e`   '{U+00E8}'

define v       'aeiouy{e`}'
define v_I     v + 'I'
define v_j     v + 'j'

define prelude as (
    test repeat (
        [substring] among(
            '{a"}' '{a'}'
                (<- 'a')
            '{e"}' '{e'}'
                (<- 'e')
            '{i"}' '{i'}'
                (<- 'i')
            '{o"}' '{o'}'
                (<- 'o')
            '{u"}' '{u'}'
                (<- 'u')
            ''  (next)
        )
    )
    try(['y'] <- 'Y')
    repeat (
        gopast v
        try (
            // If we see `i` not followed by a vowel then we know it couldn't
            // match on the next iteration so we can advance past it.
            //
            // However if we replace `i` with `I` we do need to check the vowel
            // after the `i` in the next iteration to match the documented
            // behaviour, e.g. consider input `iiiii`.  This may well not make
            // a difference for any actual Dutch words though.
            [('i'] do(v <- 'I')) or
             ('y']      <- 'Y')
        )
    )
)

define mark_regions as (

    $p1 = limit
    $p2 = limit

    test(hop 3 setmark x)

    gopast v  gopast non-v  setmark p1
    try($p1 < x  $p1 = x)  // at least 3
    gopast v  gopast non-v  setmark p2

)

define postlude as repeat (

    [substring] among(
        'Y'  (<- 'y')
        'I'  (<- 'i')
        ''   (next)
    )

)

backwardmode (

    define R1 as $p1 <= cursor
    define R2 as $p2 <= cursor

    define undouble as (
        test among('kk' 'dd' 'tt') [next] delete
    )

    define e_ending as (
        unset e_found
        ['e'] R1 test non-v delete
        set e_found
        undouble
    )

    define en_ending as (
        R1 non-v and not 'gem' delete
        undouble
    )

    define standard_suffix as (
        do (
            [substring] among(
                'heden'
                (   R1 <- 'heid'
                )
                'en' 'ene'
                (   en_ending
                )
                's' 'se'
                (   R1 non-v_j delete
                )
            )
        )
        do e_ending

        do ( ['heid'] R2 not 'c' delete
             ['en'] en_ending
           )

        do (
            [substring] among(
                'end' 'ing'
                (   R2 delete
                    (['ig'] R2 not 'e' delete) or undouble
                )
                'ig'
                (   R2 not 'e' delete
                )
                'lijk'
                (   R2 delete e_ending
                )
                'baar'
                (   R2 delete
                )
                'bar'
                (   R2 e_found delete
                )
            )
        )
        do (
            non-v_I
            test (
                among ('aa' 'ee' 'oo' 'uu')
                non-v
            )
            [next] delete
        )
    )
)

define stem as (

        do prelude
        do mark_regions
        backwards
            do standard_suffix
        do postlude
)