algorithms/danish.sbl

routines (
           mark_regions
           main_suffix
           consonant_pair
           other_suffix
           undouble
)

externals ( stem )

strings ( ch )

integers ( p1 x )

groupings ( v s_ending )

stringescapes {}

/* special characters (in ISO Latin I) */

stringdef ae   hex 'E6'
stringdef ao   hex 'E5'
stringdef o/   hex 'F8'

define v 'aeiouy{ae}{ao}{o/}'

define s_ending  'abcdfghjklmnoprtvyz{ao}'

define mark_regions as (

    $p1 = limit

    test ( hop 3 setmark x )
    goto v gopast non-v  setmark p1
    try ( $p1 < x  $p1 = x )
)

backwardmode (

    define main_suffix as (
        setlimit tomark p1 for ([substring])
        among(

            'hed' 'ethed' 'ered' 'e' 'erede' 'ende' 'erende' 'ene' 'erne' 'ere'
            'en' 'heden' 'eren' 'er' 'heder' 'erer' 'heds' 'es' 'endes'
            'erendes' 'enes' 'ernes' 'eres' 'ens' 'hedens' 'erens' 'ers' 'ets'
            'erets' 'et' 'eret'
                (delete)
            's'
                (s_ending delete)
        )
    )

    define consonant_pair as (
        test (
            setlimit tomark p1 for ([substring])
            among(
                'gd' // significant in the call from other_suffix
                'dt' 'gt' 'kt'
            )
        )
        next] delete
    )

    define other_suffix as (
        do ( ['st'] 'ig' delete )
        setlimit tomark p1 for ([substring])
        among(
            'ig' 'lig' 'elig' 'els'
                (delete do consonant_pair)
            'l{o/}st'
                (<-'l{o/}s')
        )
    )
    define undouble as (
        setlimit tomark p1 for ([non-v] ->ch)
        ch
        delete
    )
)

define stem as (

    do mark_regions
    backwards (
        do main_suffix
        do consonant_pair
        do other_suffix
        do undouble
    )
)