extra/soundex/soundex.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: ascii kernel sequences tr ;
   4 IN: soundex
   5
   6 <PRIVATE
   7
   8 TR: soundex-digits
   9     "AEHIOUWYBFPVCGJKQSXZDTLMNR"
  10     "AEHIOUWY111122222222334556" ;
  11
  12 : remove-duplicates ( seq -- seq' )
  13     ! Remove _consecutive_ duplicates (unlike prune which removes
  14     ! all duplicates).
  15     f swap [ [ = ] keep swap ] reject nip ;
  16
  17 : pad-4 ( seq -- seq' ) "000" append 4 head ;
  18
  19 : remove-hw ( seq -- seq' )
  20     unclip [ [ "HW" member? ] reject ] [ prefix ] bi* ;
  21
  22 : remove-aeiouy ( seq -- seq' )
  23     unclip [ [ "AEIOUY" member? ] reject ] [ prefix ] bi* ;
  24
  25 : ?replace-first ( seq first -- seq )
  26     over first digit? [ over set-first ] [ drop ] if ;
  27
  28 PRIVATE>
  29
  30 : soundex ( string -- soundex )
  31     >upper [ LETTER? ] filter [
  32         remove-hw
  33         soundex-digits
  34         remove-duplicates
  35         remove-aeiouy
  36     ] keep first ?replace-first pad-4 ;