; soundex calculator ; http://www.searchforancestors.com/soundex.html ;http://www.java2s.com/Code/Java/Collections-Data-Structure/SoundextheSoundexAlgorithmasdescribedbyKnuth.htm ;* Knuth's examples of various names and the soundex codes they map ; * to are: ; * <b>Euler, Ellery -> E460 ; * <b>Gauss, Ghosh -> G200 ; * <b>Hilbert, Heilbronn -> H416 ; * <b>Knuth, Kant -> K530 ; * <b>Lloyd, Ladd -> L300 ; * <b>Lukasiewicz, Lissajous -> L222 (deffacts KnuthTests (person Euler) ; -> E460 (person Ellery) ; -> E460 (person Gauss) ; -> G200 (person Ghosh) ; -> G200 (person Hilbert) ; -> H416 (person Heilbronn) ; -> H416 (person Knuth) ; -> K530 (person Kant) ; -> K530 (person Lloyd) ; -> L300 (person Ladd) ; -> L300 (person Lukasiewicz) ; -> L222 (person Lissajous) ; -> L222 ) ; NB algorithm works on the model of a name WRITTEN down ; 'following' is positional on that, NOT sequential (defrule bustName (declare (salience 500)) (person ?name) => (bind $?list (create$)) (loop-for-count (?i 1 (str-length ?name)) (bind ?ch (upcase (sub-string ?i ?i ?name))) (bind $?list (create$ $?list (sym-cat ?ch))) ) (assert (name $?list))) (deffacts background (letters A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) (letters a b c d e f g h i j k l m n o p q r s t u v w x y z) (deletes A E I O U H W Y ) (soundex 1 B P F V ) (soundex 2 C S G J K Q X Z) (soundex 3 D T) (soundex 4 L) (soundex 5 M N) (soundex 6 R) (step 1) ) ;(deffacts riggs ; (name R I G G S #) ; (name A R R U N A T E G U I) ;) (defrule knockout "Cross out spaces, punctuation, accents and other marks " (step 1) ?n<-(name $?A ?ch $?B) (not (letters $? ?ch $?)) => (retract ?n) (assert (name $?A $?B))) (defrule nextStep (declare (salience -10)) ?s<-(step ?n&:(< ?n 6)) => (retract ?s) (assert (step (+ ?n 1)))) (defrule crossout "Cross out any of the following characters A E I O U H W Y (unless first letter of surname)" (step 2) ?n<-(name ?i $?A ?ch $?B) (test (member$ ?ch (create$ A E I O U H W Y))) => (retract ?n) (assert (OLD ?i $?A ?ch $?B)) (assert (name ?i $?A # $?B))) (defrule seconds "Cross out the second letter of duplicate characters " (step 3) ?n<-(name $?A ?ch&~# ?ch $?B) => (retract ?n) (assert (OLD $?A ?ch ?ch $?B)) (assert (name $?A ?ch # $?B))) (defrule likesoundexdSeconds "Cross out the second letter of adjacent characters with the same soundex number." (step 4) ?n<-(name ?init $?A ?ch1&~# ?ch2 $?B) (soundex ?c $? ?ch1 $?) (soundex ?c $? ?ch2 $?) => (retract ?n) (assert (OLD ?init $?A ?ch1 ?ch2 $?B)) (assert (name ?init $?A ?ch1 # $?B))) (defrule ensoundex "Convert characters (in positions 2 to 4) to a number " (step 5) ?n<-(name ?init $?A # $?B) => (retract ?n) (assert (OLD ?init $?A # $?B)) (assert (name ?init $?A $?B))) (defrule soundexIt (step 6) ?n<-(name ?init $?A ?ch $?B) (soundex ?code $? ?ch $?) => (retract ?n) (assert (name ?init $?A ?code $?B))) (defrule report4 (declare (salience -10)) (step 6) (name $?name) => (printout t (subseq$ (create$ $?name 0 0 0) 1 4) crlf)) |