diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,34 @@ +Copyright © 2008 Bart Massey +ALL RIGHTS RESERVED + +[This program is licensed under the "3-clause ('new') BSD License"] + +Redistribution and use in source and binary forms, with or +without modification, are permitted provided that the +following conditions are met: + * Redistributions of source code must retain the above + copyright notice, this list of conditions and the following + disclaimer. + * Redistributions in binary form must reproduce the + above copyright notice, this list of conditions and the + following disclaimer in the documentation and/or other + materials provided with the distribution. + * Neither the name of the copyright holder, nor the names + of other affiliated organizations, nor the names + of other contributors may be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND +CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +--- Copyright (C) 2007 Bart Massey +--- ALL RIGHTS RESERVED +--- Please see the file COPYING in this software +--- distribution for license information. + +import Distribution.Simple +main = defaultMain diff --git a/Text/PhoneticCode/Phonix.hs b/Text/PhoneticCode/Phonix.hs new file mode 100644 --- /dev/null +++ b/Text/PhoneticCode/Phonix.hs @@ -0,0 +1,238 @@ +--- Phonix code calculator +--- Copyright © 2008 Bart Massey +--- ALL RIGHTS RESERVED + +--- This software is licensed under the "3-clause ('new') +--- BSD License". Please see the file COPYING provided with +--- this distribution for license terms. + +-- |Phonix codes (Gadd 1990) augment slightly improved Soundex codes +-- with a preprocessing step for cleaning up certain n-grams. Since +-- the preprocessing step contains more than 150 rules processed by +-- a slow custom-written scanner, this implementation is not too fast. +-- +-- This code was based on a number of sources, including +-- the CPAN Phonix code calculator +-- Text::Phonetic::Phonix.pm . Because the paper describing +-- the codes is not freely available and I'm lazy, I did not use +-- it as a reference. +-- Also because Phonix involves over 150 substitution rules, +-- I transformed the Perl ones, which was easier than +-- generating them from scratch. + +module Text.PhoneticCode.Phonix (phonix, phonixCodes, phonixRules) +where + +import Data.List +import Data.Char +import Data.Array.IArray +import Data.Maybe +import qualified Data.Set as Set + + +-- | Compute a "full" phonix code; i.e., do not drop any +-- encodable characters from the result. The leading +-- character of the code will be folded to uppercase. +-- Non-alphabetics are not encoded. If no alphabetics are +-- present, the phonix code will be "0". +-- +-- There appear to be many, many variants of phonix +-- implemented on the web, and I'm too cheap and lazy to go +-- find the original paper by Gadd (1990) that actually +-- describes the original algorithm. Thus, I am taking some +-- big guesses on intent here as I implement. +-- Corrections, especially those involving getting me a copy +-- of the article, are welcome. +-- +-- Dropping the "trailing sound" seems to be +-- an integral part of Gadd's technique, but I'm not sure how +-- it is supposed to be done. I am currently compressing runs +-- of vowels, and then dropping the trailing digit or vowel +-- from the code. +-- +-- Another area of confusion is whether to compress strings of +-- the same code, as in Soundex, or merely strings of the same +-- consonant. I have chosen the former. +phonix :: String -> String +phonix = filter (/= '?') + . drop_trailing_sound + . encode + . apply_rules + . map toUpper + . dropWhile (not . isAlpha) + where + drop_trailing_sound = init . concatMap question_squash . group where + question_squash ('?' : _) = ['?'] + question_squash l = l + apply_rules w = foldl' (flip $ uncurry gSubst) w phonixRules + filter_multiples = map head . group + encode "" = "0" + encode as@(a : _) = (devowel a :) + . drop 1 + . filter_multiples + . map unsound $ as + unsound c | c >= 'A' && c <= 'Z' = phonixCodes ! c + unsound _ = '?' + devowel c | isVowely c = 'v' + devowel c = c + +isVowely :: Char -> Bool +isVowely c = c `Set.member` (Set.fromList "AEIOUY") + +isVowel :: Char -> Bool +isVowel c = c `Set.member` (Set.fromList "AEIOU") + +globMatches :: Char -> Char -> Bool +globMatches 'v' = isVowel +globMatches 'c' = not . isVowel +globMatches '.' = const True +globMatches _ = const False + +isGlob :: Char -> Bool +isGlob c = c `Set.member` (Set.fromList "vc.") + +matches :: Char -> Char -> Bool +s `matches` t = s == t || s `globMatches` t + +subst :: String -> String -> String -> String +subst "" _ _ = error "subst: bad pattern" +subst _ _ "" = "" +subst s d t + | length t < length s = t + | and (zipWith matches s t) = deglob ++ subst s d t' + | otherwise = skip + where + deglob = dn . d1 $ d where + d1 d0 + | isGlob . head $ s = head t : d0 + | otherwise = d0 + dn d0 + | isGlob . last $ s = d0 ++ [t !! (length s - 1)] + | otherwise = d0 + t' = drop (length s) t + skip = head t : subst s d (tail t) + +gSubst :: String -> String -> String -> String +gSubst "" _ _ = error "gSubst: bad pattern" +gSubst s d t + | head s == '^' = let (t0, t1) = splitAt (length s - 1) t in + subst (tail s) d t0 ++ t1 + | last s == '$' = let (t0, t1) = splitAt (length t - length s + 1) t in + t0 ++ subst (init s) d t1 + | otherwise = subst s d t + + +-- | Array of phonix codes for single characters. The +-- array maps uppercase letters (only) to a character +-- representing a code in the range ['1'..'8'] or '?'. +phonixCodes :: Array Char Char +phonixCodes = accumArray updater '?' ('A', 'Z') codes where + updater '?' c = c + updater _ c = error ("updater called twice on " ++ [c]) + groups = [('1', "BP"), + ('2', "CGJKQ"), + ('3', "DT"), + ('4', "L"), + ('5', "MN"), + ('6', "R"), + ('7', "FV"), + ('8', "SXZ")] + codes = concatMap make_codes groups + make_codes (i, s) = zip s (repeat i) + +-- | Substitution rules for Phonix canonicalization. "^" ("$") +-- is used to anchor a pattern to the beginning (end) of the word. +-- "c" ("v", ".") at the beginning or end of a pattern match +-- a consonant (vowel, arbitrary character). A character matched +-- in this fashion is automatically tacked onto the beginning (end) +-- of the pattern. +phonixRules :: [(String, String)] +phonixRules = [ + ("DG","G"), + ("CO","KO"), + ("CA","KA"), + ("CU","KU"), + ("CY","SI"), + ("CI","SI"), + ("CE","SE"), + ("^CLv","KL"), + ("CK","K"), + ("GC$","K"), + ("JC$","K"), + ("^CRv","KR"), + ("^CHRv","KR"), + ("^WR","R"), + ("NC","NK"), + ("CT","KT"), + ("PH","F"), + ("AA","AR"), --- neu + ("SCH","SH"), + ("BTL","TL"), + ("GHT","T"), + ("AUGH","ARF"), + (".LJv","LD"), + ("LOUGH","LOW"), + ("^Q","KW"), + ("^KN","N"), + ("GN$","N"), + ("GHN","N"), + ("GNE$","N"), + ("GHNE","NE"), + ("GNES$","NS"), + ("^GN","N"), + (".GNc","N"), + ("^PS","S"), + ("^PT","T"), + ("^CZ","C"), + ("vWZ.","Z"), + (".CZ.","CH"), + ("LZ","LSH"), + ("RZ","RSH"), + (".Zv","S"), + ("ZZ","TS"), + ("cZ.","TS"), + ("HROUGH","REW"), + ("OUGH","OF"), + ("vQv","KW"), + ("vJv","Y"), + ("^YJv","Y"), + ("^GH","G"), + ("vGH$","E"), + ("^CY","S"), + ("NX","NKS"), + ("^PF","F"), + ("DT$","T"), + ("TL$","TIL"), + ("DL$","DIL"), + ("YTH","ITH"), + ("^TJv","CH"), + ("^TSJv","CH"), + ("^TSv","T"), + ("TCH","CH"), --- old che + ("^vWSK","VSIKE"), + ("^PNv","N"), + ("^MNv","N"), + ("vSTL","SL"), + ("TNT$","ENT"), + ("EAUX$","OH"), + ("EXCI","ECS"), + ("X","ECS"), + ("NED$","ND"), + ("JR","DR"), + ("EE$","EA"), + ("ZS","S"), + ("vRc","AH"), + ("vHRc","AH"), + ("vHR$","AH"), + ("RE$","AR"), + ("vR$","AH"), + ("LLE","LE"), + ("cLE$","ILE"), + ("cLES$","ILES"), + ("E$",""), + ("ES$","S"), + ("vSS","AS"), + ("vMB$","M"), + ("MPTS","MPS"), + ("MPS","MS"), + ("MPT","MT") ] diff --git a/Text/PhoneticCode/Soundex.hs b/Text/PhoneticCode/Soundex.hs new file mode 100644 --- /dev/null +++ b/Text/PhoneticCode/Soundex.hs @@ -0,0 +1,137 @@ +--- Soundex code calculator +--- Copyright © 2008 Bart Massey +--- ALL RIGHTS RESERVED + +--- This software is licensed under the "3-clause ('new') +--- BSD License". Please see the file COPYING provided with +--- this distribution for license terms. + +-- |Soundex is a phonetic coding algorithm. +-- It transforms word into a similarity hash based on an +-- approximation of its sounds. Thus, similar-sounding +-- words tend to have the same hash. +-- +-- This implementation is based on a number of sources, +-- including a description of soundex at +-- http://wikipedia.org/wiki/Soundex +-- and in Knuth's "The Art of Computer Programming" 2nd ed +-- v1 pp394-395. A very helpful reference on the details +-- and differences among soundex algorithms is "Soundex: +-- The True Story", +-- http://west-penwith.org.uk/misc/soundex.htm +-- accessed 11 September 2008. +-- +-- This code was originally written for the "thimk" spelling suggestion +-- application in Nickle (http://nickle.org) in July 2002 +-- based on a description from +-- http://www.geocities.com/Heartland/Hills/3916/soundex.html +-- which is now +-- http://www.searchforancestors.com/soundex.html +-- The code was ported September 2008; the Soundex variants were also +-- added at this time. + +module Text.PhoneticCode.Soundex (soundex, soundexSimple, + soundexNARA, soundexCodes) +where + +import Data.List +import Data.Char +import Data.Array.IArray +import Data.Maybe + +-- |Array of soundex codes for single characters. The +-- array maps uppercase letters (only) to a character +-- representing a code in the range ['1'..'7'] or '?'. Code +-- '7' is returned as a coding convenience for +-- American/Miracode/NARA/Knuth soundex. + +soundexCodes :: Array Char Char +soundexCodes = accumArray updater '?' ('A', 'Z') codes where + updater '?' c = c + updater _ c = error ("updater called twice on " ++ [c]) + groups = [('1', "BFPV"), + ('2', "CGJKQSXZ"), + ('3', "DT"), + ('4', "L"), + ('5', "MN"), + ('6', "R"), + ('7', "HW")] + codes = concatMap make_codes groups + make_codes (i, s) = zip s (repeat i) + + +-- | Utility function: id except for point substitution. +subst :: Eq a => a -> a -> a -> a +subst from to source + | from == source = to + | otherwise = source + + +-- | Compute a "full" soundex code; i.e., do not drop any +-- encodable characters from the result. The leading +-- character of the code will be folded to uppercase. +-- Non-alphabetics are not encoded. If no alphabetics are +-- present, the soundex code will be "0". +-- +-- The two commonly encountered forms of soundex are Simplified +-- and another known as American, Miracode, NARA or Knuth. This +-- code will calculate either---passing True gets NARA, and False +-- gets Simplified. +soundex :: Bool -> String -> String +soundex nara = filter (/= '?') + . encode + . map toUpper + . dropWhile (not . isAlpha) + where + narify + | nara = filter (/= '7') + | otherwise = map (subst '7' '?') + filter_multiples = map head . group + --- The second clause of encode originally had a bug + --- correctly predicted by STTS (ref above)! + encode "" = "0" + encode as@(a : _) = (a :) + . drop 1 + . filter_multiples + . narify + . map unsound $ as + unsound c | c >= 'A' && c <= 'Z' = soundexCodes ! c + unsound _ = '?' + +soundex_truncated nara = take 4 . (++ repeat '0') . soundex nara + +--- | This is the simple variant of `soundex`. It gives the +--- first four characters of the full soundex code, zero-padded +--- as needed. +soundexSimple :: String -> String +soundexSimple = soundex_truncated False + +--- | This is the most common US census variant of `soundex`, +--- compatible with most existing calculators. It gives the +--- first four characters of the full soundex code, zero-padded +--- as needed. +soundexNARA :: String -> String +soundexNARA = soundex_truncated True + +--- Some tests from the web and from Knuth that this +--- software passes. +--- +-- soundexTest = and [ +-- soundexSimple "Lloyd" == "L300", +-- soundexSimple "Woolcock" == "W422", +-- soundexSimple "Donnell" == "D540", +-- soundexSimple "Baragwanath" == "B625", +-- soundexSimple "Williams" == "W452", +-- soundexSimple "Ashcroft" == "A226", +-- soundexNARA "Ashcroft" == "A261", +-- soundexSimple "Euler" == "E460", +-- soundexSimple "Ellery" == "E460", +-- soundexSimple "Gauss" == "G200", +-- soundexSimple "Ghosh" == "G200", +-- soundexSimple "Hilbert" == "H416", +-- soundexSimple "Heilbronn" == "H416", +-- soundexSimple "Knuth" == "K530", +-- soundexSimple "Kant" == "K530", +-- soundexSimple "Ladd" == "L300", +-- soundexSimple "Lukasiewicz" == "L222", +-- soundexSimple "Lissajous" == "L222"] diff --git a/phonetic-code.cabal b/phonetic-code.cabal new file mode 100644 --- /dev/null +++ b/phonetic-code.cabal @@ -0,0 +1,26 @@ +name: phonetic-code +version: 0.1 +cabal-version: >= 1.2 +build-type: Simple +license: BSD3 +license-file: COPYING +copyright: Copyright © 2008 Bart Massey +author: Bart Massey +maintainer: bart@cs.pdx.edu +stability: alpha +homepage: http://wiki.cs.pdx.edu/bartforge/phonetic-code +package-url: http://wiki.cs.pdx.edu/cabal-packages/phonetic-code-0.1.tar.gz +synopsis: Phonetic codes: Soundex and Phonix +description: + + This package implements the "phonetic coding" algorithms + Soundex and Phonix. A phonetic coding algorithm + transforms a word into a similarity hash based on an + approximation of its sounds. Thus, similar-sounding + words tend to have the same hash. + +category: Text, Natural Language Processing +tested-with: GHC == 6.8.3 + +exposed-modules: Text.PhoneticCode.Soundex, Text.PhoneticCode.Phonix +build-depends: base, containers, array