20090526

Twtrize — сократитель речи

Как известно, письменность избыточна: мы можем угадывать написанные слова, даже если некоторые буквы неразборчивы, перепутаны местами или вообще отсутствуют. К счастью, в компьютерной письменности все буквы разборчивы, почерк у всех одинаково хорош. Именно поэтому появилась возможность очень сильно сокращать слова, убирая из них «лишние» буквы.

Люди иногда сознательно сокращают слова, набирая 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.