home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / BIPL.ZIP / PROCS.ZIP / SOUNDEX.ICN < prev    next >
Encoding:
Text File  |  1992-09-28  |  1.4 KB  |  51 lines
  1. ############################################################################
  2. #
  3. #    File:     soundex.icn
  4. #
  5. #    Subject:  Procedures to produce Soundex code for name
  6. #
  7. #    Author:   Cheyenne Wills
  8. #
  9. #    Date:     July 14, 1989
  10. #
  11. ###########################################################################
  12. #
  13. #  This procedure produces a code for a name that tends to bring together
  14. #  variant spellings.  See Donald E. Knuth, The Art of Computer Programming,
  15. #  Vol.3; Searching and Sorting, pp. 391-392.
  16. #
  17. ############################################################################
  18.  
  19. procedure soundex(name)
  20.    local first, c, i
  21.    name := map(name,string(&lcase),string(&ucase)) # Convert to uppercase..
  22.    first := name[1]
  23.  
  24. # Retain the first letter of the name, and convert all
  25. # occurrences of A,E,H,I,O,U,W,Y in other positions to "."
  26. #
  27. # Assign the following numbers to the remaining letters
  28. # after the first:
  29. #
  30. # B,F,P,V => 1           L => 4
  31. # C,G,J,K,Q,S,X,Z => 2       M,N => 5
  32. # D,T => 3           R => 6
  33.  
  34.    name := map(name,"ABCDEFGHIJKLMNOPQRSTUVWXYZ",
  35.             ".123.12..22455.12623.1.2.2")
  36.  
  37. # If two or more letters with the same code were adjacent
  38. # in the original name, omit all but the first
  39.  
  40.    every c := !"123456" do
  41.        while i := find(c||c,name) do
  42.        name[i+:2] := c
  43.    name[1] := first
  44.  
  45. # Now delete our place holder ('.')
  46.  
  47.    while i := upto('.',name) do name[i] := ""
  48.  
  49.    return left(name,4,"0")
  50. end
  51.