source: project/release/3/soundex/trunk/soundex.scm @ 11871

Last change on this file since 11871 was 11871, checked in by kburton, 12 years ago

first attempt at egg configuration

File size: 3.0 KB
Line 
1(declare (export soundex))
2
3(load-relative "fuzzy-lib.scm")
4
5(define *unused-regex* #/[^AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr]/)
6
7(define (sndx-remove-unused string)
8  (string-substitute *unused-regex* "" (string-upcase string) #t))
9
10(define *subst-map*
11  (list
12   (cons #/[AaEeHhIiOoUuWwYy]/ "0")
13   (cons #/[BbFfPpVv]/         "1")
14   (cons #/[CcGgJjKkQqSsXxZz]/ "2")
15   (cons #/[DdTt]/             "3")
16   (cons #/[Ll]/               "4")
17   (cons #/[MmNn]/             "5")
18   (cons #/[Rr]/               "6")))
19
20(define (sndx-chars->code string)
21  (string-substitute*
22   (sndx-remove-unused string)
23   *subst-map*))
24
25(define (soundex string)
26  (let* ((clean (sndx-remove-unused string))
27         (first-char (substring clean 0 1))
28         (code (remove-duplicate-chars
29                (sndx-chars->code clean))))
30    (set! code (substring code 1))
31    (set! code (string-substitute "0" "" code #t))
32    (substring (string-append first-char code "000")
33               0 4)))
34
35(define (test file #!optional (verbose #f))
36  (let ((pass 0)
37        (fail 0))
38    (for-each
39     (lambda (pair)
40       (if (and verbose (= 0 (modulo pass 1000)))
41           (printf "~a passed, ~a failed\n" pass fail))
42       (let* ((in-code (car pair))
43              (string (cadr pair))
44              (code (soundex string)))
45         (if (not (string=? code in-code))
46             (begin
47               (printf "FAIL: ~a,~a but got ~a\n"
48                       string in-code code)
49               (incf fail))
50             (incf pass))))
51     (map tab-line->fields (file->lines file)))
52    (list pass fail)))
53
54(define (test3 file #!optional (verbose #f))
55  (let ((pass 0)
56        (fail 0))
57    (for-each
58     (lambda (line)
59       (if (and verbose (= 0 (modulo pass 1000)))
60           (printf "~a passed, ~a failed\n" pass fail))
61       (match 
62        (tab-line->fields line)
63        ((in-code string)
64         (let ((code (soundex string)))
65           (if (not (string=? code in-code))
66               (begin
67                 (printf "FAIL: ~a,~a but got ~a\n"
68                         string in-code code)
69                 (set! fail (+ 1 fail)))
70               (set! pass (+ 1 pass)))))))
71     (file->lines file))
72    (list pass fail)))
73
74(define (test2 file #!optional (verbose #f))
75  (let ((pass 0)
76        (fail 0))
77    (for-each-line 
78     file
79     (lambda (line)
80       (if (and verbose (= 0 (modulo pass 1000)))
81           (printf "~a passed, ~a failed\n" pass fail))
82       (match 
83        (tab-line->fields line)
84        ((in-code string)
85         (let ((code (soundex string)))
86           (if (not (string=? code in-code))
87               (begin
88                 (printf "FAIL: ~a,~a but got ~a\n"
89                         string in-code code)
90                 (set! fail (+ 1 fail)))
91               (set! pass (+ 1 pass))))))))
92    (list pass fail)))
93
94'(time (match 
95       (test (expand-tilde-file "~/personal/presentations/fuzzy-string/data/lname-perl-soundex.tab") #t)
96       ((pass fail)
97        (printf "~a tests passed\n" pass)
98        (printf "~a tests failed\n" fail))))
99
Note: See TracBrowser for help on using the repository browser.