Люди иногда сознательно сокращают слова, набирая SMS или твиты — чтобы потратить меньше денег или укоротить сообщение.
Идея возникла, когда на одном из многочисленных «сократителей URL» я увидел надпись «Shrink text». И мне пришло в голову, что вот он возьмёт, и сократит сам текст: выдаст что-нибудь вроде «shrnk txt». Конечно, сервис всего лишь заменял в тексте URL, но я подумал, что можно было бы сокращать и сам текст.
Не знаю, как в английском, а в русском, по-моему, можно убрать довольно много гласных букв, а текст будет по-прежнему читаться. Я решил испытать идею, и написал этот сократитель.
Программа преобразует текст на русском языке, выкидывая из него некоторые буквы и символы. Прошу рассматривать это как забавную игрушку и программой не злоупотреблять.
Зависимости
Программа написана на Literate Haskell (это значит, что то, что, вы сейчас читаете, и есть программа!). Используются следующие модули:
> import System.IO.UTF8 as U
> import Data.Char (toLower)
> import Text.Regex.Posix ((=~))
> import Data.Char (isPunctuation)
TODO: Я использую старый способ работать с UTF-8 (utf8-string), надо переделать под новую библиотеку text.
Алгоритм
Данная программа «сжимает» русский текст так:
I. Из слов убираются (почти) все гласные и мягкие знаки,
> filterVowels = filter (`notElem` (aVowels ++ jVowels))
Неприкосновенны гласные, которые:
I.a. являютя частью приставки «не-»
> rmVowels = map wordFilter
> where
> wordFilter ('н':'е':cs) = "не" ++ wordFilter cs
I.b. стоят в трёх- и менее -буквенных словах
> wordFilter w = if length w <= 3
> then w
I.c. стоят в начале или конце слова
> else
> let (prefix,inner,ending) = splitWord w
> in prefix ++ (ajaFilter inner) ++ ending
> splitWord s = let p = takeWhile dontRemove s
> r = drop (length p) s
> e = reverse $ takeWhile dontRemove $ reverse r
> m = take ((length r) - (length e)) r
> dontRemove c = c `elem` vowels || isPunctuation c
> in (p,m,e)
I.d. являются комбинациями со звуком «й»: «-ою-», «-ая—» и проч.
> ajaFilter [] = []
> ajaFilter s = let (b,m,a) = s =~ diftPat :: (String,String,String)
> diftPat = "[" ++ vowels ++ "][" ++ jVowels ++ "]"
> in (sameConsFilter b) ++ m ++ (ajaFilter a)
I.e. стоят меж двух одинаковых согласных
> sameConsFilter [] = []
> sameConsFilter s =
> let (b,m,a) = s =~ sameConsPat :: (String,String,String)
> sameConsPat = "(["++consonants++"])[" ++ vowels ++ "]\\1"
> in (filterVowels b) ++ m ++ (sameConsFilter a)
Программа использует такой список гласных:
> vowels = aVowels ++ jVowels
где есть и простые гласные (к ним же причислен и мягкий знак)
> aVowels = "аиоуыэь"
и дифтонгообразующие (не знаю правильного термина — в общем, дающие звук «й»),
к ним же причислена и буква «й»:
> jVowels = "яйёюе"
Для некоторых правил требуется также список русских согласных:
> consonants = "бвгджзклмнпрстфхцчшщ"
II. из предложений убираются знаки препинания, кроме точек, вопросительных и восклицательных знаков
> rmSomePunctuation = filter (not . null) . map rmTrailing
> where rmTrailing = reverse . rmHead . reverse
> rmHead [] = []
> rmHead s@(c:cs) = case c `elem` rmlist of
> True -> rmHead cs
> False -> s
Список подлежащих удалению знаков препинания:
> rmlist = ",;-—:–"
III. из текста удаляются некоторые предлоги (в телеграфном стиле)
> rmPrepositions = filter (`notElem` preps) . words
> where preps = [ "в", "во", "на", "над", "к", "от", "из"
> , "по", "под", "через" ]
IV. для пущей стилизации текст пишется в нижнем регистре
> tolower = map toLower
Использование программы
Программу можно использовать как простой unix-фильтр: он читает текст из потока stdin и печает «сжатый» текст в стандартный вывод (stdout).
> main = U.interact $ (++ "\n") . twtrize
> twtrize = unwords . filter ( not . null ) .
> rmVowels . rmSomePunctuation . rmPrepositions . tolower
Пример:
$ printf "Гласные, а также некоторые предлоги — как, например, «на», — из \
текста удаляются, но какие-то остаются.\n" | runhaskell twtrize.lhs
глсные а ткже нектрые прдлги как нпрмр «на» ткста удляются но какие-то
остаются.
Последняя версия: исходник здесь. Лицензия: BSD-3.
