extra/levenshtein/levenshtein.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays help io kernel math namespaces sequences ;
   4 IN: levenshtein
   5
   6 : <matrix> ( m n -- matrix )
   7     [ drop 0 <array> ] curry* map ; inline
   8
   9 : matrix-> nth nth ; inline
  10 : ->matrix nth set-nth ; inline
  11
  12 SYMBOL: d
  13
  14 : ->d ( n i j -- ) d get ->matrix ; inline
  15 : d-> ( i j -- n ) d get matrix-> ; inline
  16
  17 SYMBOL: costs
  18
  19 : init-d ( str1 str2 -- )
  20     [ length 1+ ] 2apply 2dup <matrix> d set
  21     [ 0 over ->d ] each
  22     [ dup 0 ->d ] each ; inline
  23
  24 : compute-costs ( str1 str2 -- )
  25     swap [
  26         [ = 0 1 ? ] curry* { } map-as
  27     ] curry { } map-as costs set ; inline
  28
  29 : levenshtein-step ( i j -- )
  30     [ 1+ d-> 1+ ] 2keep
  31     [ >r 1+ r> d-> 1+ ] 2keep
  32     [ d-> ] 2keep
  33     [ costs get matrix-> + min min ] 2keep
  34     >r 1+ r> 1+ ->d ; inline
  35
  36 : levenshtein-result ( -- n ) d get peek peek ; inline
  37
  38 : levenshtein ( str1 str2 -- n )
  39     [
  40         2dup init-d
  41         2dup compute-costs
  42         [ length ] 2apply [
  43             [ levenshtein-step ] curry each
  44         ] curry* each
  45         levenshtein-result
  46     ] with-scope ;