blob: eb3a542f005455fad477ffb413fc993462d4d0d3 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
;"soundex.scm" Original SOUNDEX algorithm.
;From jjb@isye.gatech.edu Mon May 2 22:29:43 1994
;
; This code is in the public domain.
;Date: Mon, 2 May 94 13:45:39 -0500
; Taken from Knuth, Vol. 3 "Sorting and searching", pp 391--2
(require 'common-list-functions)
(define SOUNDEX
(let* ((letters-to-omit
(list #\A #\E #\H #\I #\O #\U #\W #\Y))
(codes
(list (list #\B #\1)
(list #\F #\1)
(list #\P #\1)
(list #\V #\1)
;
(list #\C #\2)
(list #\G #\2)
(list #\J #\2)
(list #\K #\2)
(list #\Q #\2)
(list #\S #\2)
(list #\X #\2)
(list #\Z #\2)
;
(list #\D #\3)
(list #\T #\3)
;
(list #\L #\4)
;
(list #\M #\5)
(list #\N #\5)
;
(list #\R #\6)))
(xform
(lambda (c)
(let ((code (assq c codes)))
(if code
(cadr code)
c)))))
(lambda (name)
(let ((char-list
(map char-upcase
(remove-if (lambda (c)
(not (char-alphabetic? c)))
(string->list name)))))
(if (null? char-list)
name
(let* (; Replace letters except first with codes:
(n1 (cons (car char-list) (map xform char-list)))
; If 2 or more letter with same code are adjacent
; in the original name, omit all but the first:
(n2 (let loop ((chars n1))
(cond ((null? (cdr chars))
chars)
(else
(if (char=? (xform (car chars))
(cadr chars))
(loop (cdr chars))
(cons (car chars) (loop (cdr chars))))))))
; Omit vowels and similar letters, except first:
(n3 (cons (car char-list)
(remove-if
(lambda (c)
(memq c letters-to-omit))
(cdr n2)))))
;
; pad with 0's or drop rightmost digits until of form "annn":
(let loop ((rev-chars (reverse n3)))
(let ((len (length rev-chars)))
(cond ((= 4 len)
(list->string (reverse rev-chars)))
((> 4 len)
(loop (cons #\0 rev-chars)))
((< 4 len)
(loop (cdr rev-chars))))))))))))
|
