packages feed

phonetic-code (empty) → 0.1

raw patch · 5 files changed

+442/−0 lines, 5 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers

Files

+ COPYING view
@@ -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.
+ Setup.hs view
@@ -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
+ Text/PhoneticCode/Phonix.hs view
@@ -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") ]
+ Text/PhoneticCode/Soundex.hs view
@@ -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"]
+ phonetic-code.cabal view
@@ -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