basis/soundex/soundex.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences grouping assocs kernel ascii ascii tr ;
   4 IN: soundex
   5
   6 TR: soundex-tr
   7     ch>upper
   8     "AEHIOUWYBFPVCGJKQSXZDTLMNR"
   9     "00000000111122222222334556" ;
  10
  11 : remove-duplicates ( seq -- seq' )
  12     #! Remove _consecutive_ duplicates (unlike prune which removes
  13     #! all duplicates).
  14     [ 2 <clumps> [ = not ] assoc-filter values ] [ first ] bi prefix ;
  15
  16 : first>upper ( seq -- seq' ) 1 head >upper ;
  17 : trim-first ( seq -- seq' ) dup first [ = ] curry trim-left ;
  18 : remove-zeroes ( seq -- seq' ) CHAR: 0 swap remove ;
  19 : remove-non-alpha ( seq -- seq' ) [ alpha? ] filter ;
  20 : pad-4 ( first seq -- seq' ) "000" 3append 4 head ;
  21
  22 : soundex ( string -- soundex )
  23     remove-non-alpha [ f ] [
  24         [ first>upper ]
  25         [
  26             soundex-tr
  27             [ "" ] [ trim-first ] if-empty
  28             [ "" ] [ remove-duplicates ] if-empty
  29             remove-zeroes
  30         ] bi
  31         pad-4
  32     ] if-empty ;