packages feed

hist-pl-transliter (empty) → 0.1.0

raw patch · 5 files changed

+330/−0 lines, 5 filesdep +basedep +parsecsetup-changed

Dependencies added: base, parsec

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2012, IPI PAN+All rights reserved.++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.++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.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ hist-pl-transliter.cabal view
@@ -0,0 +1,30 @@+name:               hist-pl-transliter+version:            0.1.0+synopsis:           A simple EDSL for transliteration rules+description:+    The library provides a simple embedded domain specific language for+    transliteration rules and a set of rules prepared for documents+    from the IMPACT project.+license:            BSD3+license-file:       LICENSE+cabal-version:      >= 1.6+copyright:          Copyright (c) 2012 IPI PAN+author:             Jakub Waszczuk+maintainer:         waszczuk.kuba@gmail.com+stability:          experimental+category:           Natural Language Processing+homepage:           https://github.com/kawu/hist-pl/tree/master/transliter+build-type:         Simple++library+  hs-source-dirs:   src+  exposed-modules:    NLP.HistPL.Transliter+                    , NLP.HistPL.Transliter.Impact+  build-depends:      base >= 4 && < 5 +                    , parsec++  ghc-options: -Wall++source-repository head+    type: git+    location: https://github.com/kawu/hist-pl.git
+ src/NLP/HistPL/Transliter.hs view
@@ -0,0 +1,156 @@+-- | The module provides a simple embedded domain specific language for+-- defining transliteration rules.  All parsers are case-insensitive+-- by default.+++module NLP.HistPL.Transliter+( +-- * Transliteration+  TrRules (..)+, transliter++-- * Parsers+, Parser+, ciString+, ciChar++-- * Operators+, (#>)+, (>#>)+, (>+>)+, (.|)+, (.|.)+) where++import Control.Applicative ((<$>), (<*>), (<*))+import Control.Monad (msum)+import Data.Char (isUpper, toUpper, toLower)+import Text.Parsec hiding (Line)++-- | A parser data type.+type Parser = Parsec String ()++-- | Case insensitive character parser.+ciChar :: Char -> Parser Char+ciChar c = char (toLower c) <|> char (toUpper c)++-- | Case insensitive string parser.+ciString :: String -> Parser String+ciString = sequence . map ciChar++data Shape = Lower+           | Capitalized +           | Upper++getShape :: String -> Shape+getShape [] = Lower+getShape xs@(x:_)+    | all isUpper xs = Upper+    | isUpper x      = Capitalized+    | otherwise      = Lower ++applyShape :: Shape -> String -> String+applyShape _ [] = []+applyShape Lower xs = map toLower xs+applyShape Upper xs = map toUpper xs+applyShape Capitalized (x:xs) = toUpper x : map toLower xs++-- | A transliteration rule, e.g. (\"abc\" #> \"bcd\") will+-- substitute all \"abc\" (sub)string instances with \"bcd\".+(#>) :: String -> String -> Parser String+(#>) p x = ciString p >#> x++-- | Similar to `#>`, but this function allows to define a custom+-- parser for the string which should be substituted with another+-- string.+(>#>) :: Parser String -> String -> Parser String+(>#>) p x = p >>= \y -> return (applyShape (getShape y) x)++-- | Concatentation of parsers.+(>+>) :: Parser String -> Parser String -> Parser String+(>+>) p p' = (++) <$> p <*> p'++-- | OR parser, i.e. a parser which tries to match the first string argument,+-- and only tries the second one if the first match failed.+(.|) :: String -> String -> Parser String+(.|) x y = try (ciString x) <|> try (ciString y)+-- FIXME: Gdy długość napisu jest <= 1, nie jest potrzebna funkcja try.++-- | Similar to `.|`, but accepts a parser as the first argument.+(.|.) :: Parser String -> String -> Parser String+(.|.) p y = p <|> try (ciString y)+-- FIXME: Gdy długość napisu jest <= 1, nie jest potrzebna funkcja try.++-- | A set of transliteration rules.+data TrRules = TrRules {+    -- | Word-level rule is applied only when it matches the entire word.+      wordRules :: [Parser String]+    -- | Character-level rule is always applied when a match is found.+    , charRules :: [Parser String]+    }++wordParser :: TrRules -> Parser String+wordParser rules = +    perWord <|> perChar+  where+    perWord = msum $ map (\p -> try $ p <* eof) (wordRules rules)+    perChar = (concat <$> many1 (msum $ map try (charRules rules))) <* eof++parseWord :: TrRules -> String -> String+parseWord rules x =+  case parse (wordParser rules) x x of+    Left err -> error $ "parseWord: " ++ show err+    Right y  -> y++-- | Transliterate the word with the given set of transliteration rules.+transliter :: TrRules -> String -> String+transliter rules x =+  case takeWhile (not . eq) ps of+    [] -> x+    xs -> snd $ last $ xs+  where+    ys = iterate (parseWord rules) x+    ps = zip ys $ tail ys+    eq = uncurry (==)++-- -- Text parsing+-- +-- removeHyp :: String -> String+-- removeHyp ('‑':'\n':xs) = removeHyp xs+-- removeHyp (x:xs) = x : removeHyp xs+-- removeHyp [] = []+-- +-- type Text = [Line]+-- type Line = [Seg]+-- data Seg = Orth String+--          | Interp String+--          | Space String+--          deriving (Show)+-- +-- parseText :: String -> Text+-- parseText text =+--     map parseLine $ lines $ removeHyp $ map toLower text+--   where+--     parseLine x = case parse lineParser x x of+--         Left err -> error $ "parseText: " ++ show err+--         Right y  -> y+--     lineParser = many segParser+--     segParser = (Space <$> spaceParser)+--             <|> (Interp <$> interpParser)+--             <|> (Orth <$> orthParser)+--     spaceParser  = many1 $ satisfy isSpace+--     interpParser = many1 $ satisfy isPunctuation+--     orthParser   = many1 $ satisfy $ \c ->+--         not (isPunctuation c) && not (isSpace c)+-- +-- unParseText :: Text -> String+-- unParseText =+--     unlines . map unLine+--   where+--     unLine = concatMap unSeg+--     unSeg (Orth x) = transcript x+--     unSeg (Interp x) = x+--     unSeg (Space x) = x+-- +-- transcriptText :: String -> String+-- transcriptText = unParseText . parseText
+ src/NLP/HistPL/Transliter/Impact.hs view
@@ -0,0 +1,114 @@+-- | A set of transliteration rules prepared for documents from the+-- IMPACT project.+--+-- >>> import NLP.HistPL.Transliter.Impact+-- >>> putStrLn $ transliter impactRules "angol"+-- "anjoł"+++module NLP.HistPL.Transliter.Impact+( impactRules+, module NLP.HistPL.Transliter +) where++import Control.Applicative ((<$>), (<*))+import Text.Parsec hiding (Line)++import NLP.HistPL.Transliter++-- | A set of transliteration rules prepared for documents+-- from the IMPACT project. +impactRules :: TrRules+impactRules = TrRules impactWordRules impactCharRules++-- Word-level transliteration rules +impactWordRules :: [Parser String]+impactWordRules = +    [ "y" #> "i"+    , "ztąd" #> "stąd"+    , "i" #> "j" >+> vowel >+> many1 anyChar+    , "ktor" #> "któr" >+> many1 anyChar+    , "gor" #> "gór" >+> many1 anyChar+    , "wtor" #> "wtór" >+> many1 anyChar+    , "rożn" #> "różn" >+> many1 anyChar+    , ("anyol" .| "angol" .|. "angyol" .|. "angiol" >#> "anjoł")+        >+> many anyChar ]++-- Character-level transliteration rules +impactCharRules :: [Parser String]+impactCharRules =+    [ "à" .|  "á" .|. "á" .|. "â" .|. "ã" .|. "ä" .|. "ȧ" >#> "a"+    , "è" .|  "é" .|. "ê" .|. "ë" .|. "ē" .|. "ĕ"+          .|. "ė" .|. "ẽ" .|. "ə" >#> "e"+    , "ì" .|  "í" .|. "î" .|. "ï" >#> "i"+    , "ñ" #> "ń"+    , "z̄" #> "ż"+    , "ċ" #> "ć"+    , "ṡ" #> "ś"+    , "ow" #> "ów" <* eof+    , "æ" .| "œ" >#> "e"+    , "ⱥ" #> "ą"+    , "ɇ" .| "ẹ" >#> "ę"+    , "ø" #> "ą" -- lub ę+    , sChar >#> "s"   >+> (vowel <|> hardConsonant)+    , sChar >#> "ś"   >+> softConsonant+    , sChar >#> "s"   >+> str "k"+    -- , sChar >#> "s"   >+> str "ki"+    , "ʃʃ" .| "ſſ" .|. "ſs" .|. "ſz" .|. "β" .|. "ß" >#> "sz"+    , "\60122" #> "st"+    , "\60322" #> "si"+    , "st" #> "st"   -- czy to dobra reguła? +    , "źi" .| "żi" >#> "zi"+    , "ći" .| "ċi" >#> "ci"+    , "ńi" .| "ṅi" >#> "ni"+    , "śi" #> "si"+    , "dźi" #> "dzi"+    , "cż" #> "cz"+    , "rż" #> "rz"+    , "sż" #> "sz"+    , str "e" >+> ("x" #> "gz")+    , "x" #> "ksz" >+> str "t"+    , "x" #> "ks"+    , (str "t" <|> str "p" <|> str "r") >+> ("h" #> "")+    , "&" #> "et"+    -- , vowel >+> ("y" #> "j") >+> consonant+    , vowel >+> ("y" #> "j")+    , vowel >+> ("i" #> "j") >+> vowel+    , hardConsonant >+> ("y" #> "yj") >+> vowel+    , softConsonant >+> ("y" #> "ij") >+> vowel+    , "ss" #> "s"+    , "szsz" #> "sz"+    , "mm" #> "m"+    , "ff" #> "f"+    , "pp" #> "p"+    , "ll" #> "l"+    , "tt" #> "t"+    , "v" #> "w" >+> vowel+    , "v" #> "u"+    , "ts" #> "c"+    , "ds" #> "dz"+    , "łi" #> "li"+    , "srz" #> "śrz"+    , "zrz" #> "źrz"+    , singleton <$> anyChar ] -- default+  where+    str = ciString+    sChar = "ʃ" .| "ſ" .|. "\60326" ++-- | FIXME: Samogłoski powinny obejmować także znaki historyczne?+vowel :: Parser String+vowel = singleton <$> oneOf "aąeęioóuy"++softConsonant :: Parser String+softConsonant = ciString "dź"+            <|> (singleton <$> oneOf "bmflśźńć") ++hardConsonant :: Parser String+hardConsonant = (singleton <$> oneOf "pwżcsztnrł")+            <|> (ciString "d" <* notFollowedBy (ciChar 'ź'))++-- consonant :: Parser String+-- consonant = singleton <$> oneOf "bcćdfghjklłmnńprsśtwzźż"++singleton :: a -> [a]+singleton = (:[])