64 lines
1.6 KiB
Factor
64 lines
1.6 KiB
Factor
! Copyright (C) 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: arrays compiler help io kernel math namespaces sequences
|
|
test words ;
|
|
IN: levenshtein
|
|
|
|
: <matrix> ( m n -- matrix )
|
|
[ drop 0 <array> ] map-with ; inline
|
|
|
|
: matrix-> nth nth ; inline
|
|
: ->matrix nth set-nth ; inline
|
|
|
|
SYMBOL: d
|
|
|
|
: ->d ( n i j -- ) d get ->matrix ; inline
|
|
: d-> ( i j -- n ) d get matrix-> ; inline
|
|
|
|
SYMBOL: costs
|
|
|
|
: init-d ( str1 str2 -- )
|
|
[ length 1+ ] 2apply 2dup <matrix> d set
|
|
[ 0 over ->d ] each
|
|
[ dup 0 ->d ] each ; inline
|
|
|
|
: compute-costs ( str1 str2 -- )
|
|
>array [
|
|
swap >array [ = 0 1 ? ] map-with
|
|
] map-with costs set ; inline
|
|
|
|
: levenshtein-step ( i j -- )
|
|
[ 1+ d-> 1+ ] 2keep
|
|
[ >r 1+ r> d-> 1+ ] 2keep
|
|
[ d-> ] 2keep
|
|
[ costs get matrix-> + min min ] 2keep
|
|
>r 1+ r> 1+ ->d ; inline
|
|
|
|
: levenshtein-result ( -- n ) d get peek peek ; inline
|
|
|
|
: levenshtein ( str1 str2 -- n )
|
|
[
|
|
2dup init-d
|
|
2dup compute-costs
|
|
[ length ] 2apply [
|
|
swap [ swap levenshtein-step ] each-with
|
|
] each-with
|
|
levenshtein-result
|
|
] with-scope ; compiled
|
|
|
|
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
|
|
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
|
|
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
|
|
[ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
|
|
|
|
: fancy-apropos ( str -- )
|
|
all-words
|
|
[ [ word-name levenshtein ] keep 2array ] map-with
|
|
[ first 3 <= ] subset
|
|
natural-sort [
|
|
second [ word-name ] keep [ help ] write-outliner
|
|
terpri
|
|
] each ;
|
|
|
|
PROVIDE: examples/levenshtein ;
|