packages feed

phonetic-code 0.1 → 0.1.1.1

raw patch · 3 files changed

+98/−78 lines, 3 filesdep +regex-compatdep ~arraydep ~basedep ~containers

Dependencies added: regex-compat

Dependency ranges changed: array, base, containers

Files

Text/PhoneticCode/Phonix.hs view
@@ -6,29 +6,31 @@ --- 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.+-- | Phonix codes (Gadd 1990) augment slightly improved+-- Soundex codes with a preprocessing step for cleaning up+-- certain n-grams.  Since the preprocessing step contains+-- around 90 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,+-- 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 around 90 substitution rules, -- I transformed the Perl ones, which was easier than -- generating them from scratch. -module Text.PhoneticCode.Phonix (phonix, phonixCodes, phonixRules)+module Text.PhoneticCode.Phonix (+  phonix, phonixCodes, +  phonixRules, phonixRulesPatSubsts, +  applyPhonixRules ) where  import Data.List import Data.Char import Data.Array.IArray-import Data.Maybe import qualified Data.Set as Set-+import Text.Regex  -- | Compute a "full" phonix code; i.e., do not drop any -- encodable characters from the result.  The leading@@ -40,31 +42,28 @@ -- 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.+-- 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+-- 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.+-- 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)+       . applyPhonixRules     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 :)@@ -79,49 +78,6 @@ 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 '?'.@@ -236,3 +192,52 @@  ("MPTS","MPS"),  ("MPS","MS"),  ("MPT","MT") ]++-- | Apply each of the Phonix preprocessing rules in turn to+-- the target word returning the resulting accumulated+-- substitution.+applyPhonixRules :: String -> String+applyPhonixRules = +  flip (foldl' res) phonixRulesREs .+    map toUpper . +    filter isAlpha+  where+    res target (pat, subst) = subRegex pat target subst++-- Compile a regex in single-line mode.+mre :: String -> Regex+mre s = mkRegexWithOpts s False True++-- Compile the patterns in the patSubsts.+phonixRulesREs :: [(Regex, String)]+phonixRulesREs =+  map (\(pat, subst) -> (mre pat, subst)) phonixRulesPatSubsts++-- | List of pattern/substitution pairs built from the+-- 'phonixRules'.+phonixRulesPatSubsts :: [(String, String)]+phonixRulesPatSubsts =+  map reFormat phonixRules+  where+    reFormat (src, dst) =+      let vowelSubst = mre "v"+          consSubst = mre "c"+          dotSubst = mre "\\." in+      let src' = flip (subRegex dotSubst) "([A-Z])" $+                 flip (subRegex consSubst) "([BCDFGHJKLMNPQRSTVWXYZ])" $+                 flip (subRegex vowelSubst) "([AEIOU])" $+                 src in+      let front = +            case matchRegex (mre "^\\^?[^^A-Z]") src' of+              Just _ -> "\\1"+              Nothing -> ""+              in+      let back = +            case matchRegex (mre "[^A-Z$]\\$?$") src' of+              Just _ -> +                case front of+                  "" -> "\\1"+                  _ -> "\\2"+              Nothing -> ""+              in+      (src', front ++ dst ++ back)
Text/PhoneticCode/Soundex.hs view
@@ -13,12 +13,12 @@ -- --  This implementation is based on a number of sources, --  including a description of soundex at---    http://wikipedia.org/wiki/Soundex+--  <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+--  <http://west-penwith.org.uk/misc/soundex.htm> --  accessed 11 September 2008. -- --  This code was originally written for the "thimk" spelling suggestion@@ -37,7 +37,6 @@ 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@@ -98,6 +97,7 @@       unsound c | c >= 'A' && c <= 'Z' = soundexCodes ! c       unsound _ = '?' +soundex_truncated :: Bool -> String -> String soundex_truncated nara = take 4 . (++ repeat '0') . soundex nara  --- | This is the simple variant of `soundex`.  It gives the
phonetic-code.cabal view
@@ -1,6 +1,6 @@ name: phonetic-code-version: 0.1-cabal-version: >= 1.2+version: 0.1.1.1+cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: COPYING@@ -20,7 +20,22 @@    words tend to have the same hash.  category: Text, Natural Language Processing-tested-with: GHC == 6.8.3+tested-with: GHC == 6.8.3, GHC == 6.12.1 -exposed-modules: Text.PhoneticCode.Soundex, Text.PhoneticCode.Phonix-build-depends: base, containers, array+library+  exposed-modules: Text.PhoneticCode.Soundex, Text.PhoneticCode.Phonix+  build-depends: base >= 3 && < 5,+                 containers >= 0.3 && < 1,+                 array >= 0.3 && < 1,+                 regex-compat >= 0.93 && < 2+  ghc-options: -Wall+  default-language: Haskell2010++source-repository head+  type: git+  location: https://github.com/BartMassey/phonetic-code.git++source-repository this+  type: git+  location: https://github.com/BartMassey/phonetic-code.git+  tag: v0.1.1.1