В поисках панграмм [excel, vba]
Формулировка задачи:
ПРИВЕТСТВИЕ
ЧЕГО МЫ ХОТИМ?
На входе имеем базу слов, на выходе – все возможные по условиям панграммы.
УСЛОВИЯ
1. Панграммы ищем для n букв (первостепенно – 33).
2. Все буквы в конечном наборе слов предложении встречаются ровно по 1 разу.
3. Исходная база содержит слова с повторяющимися буквами и/или всякими ненужными символами (какими конкретно – не известно).
МОЙ ВКЛАД
1. Нашел формулу массива для первоначальной сортировки базы:
{=ИЛИ((ДЛСТР(A2)-ДЛСТР(ПОДСТАВИТЬ(СТРОЧН(A2);СИМВОЛ(СТРОКА($1:$255));"")))>1)}
Для слов с повторяющимися буквами выдает ИСТИНА. Далее сортируем, все строки с ИСТИНА в расход, оставляем одни только ЛОЖИ.
2. Нашел макрос на очищение нашей уже обрезанной базы от всякой нечисти - достаточно указать список лишних символов. Проблема: база большая, какой там конкретно мусор – не известно. Искал макрос который бы выводил список всех символов (по 1 шт), имеющихся на листе, не нашел.
3. Подумал над алгоритмом для работы с результирующей базой.
ВОЗМОЖНЫЙ АЛГОРИТМ
1. Выводим все буквы слова функцией ПСТР.
2. Создаем двоичный код каждого слова функцией СЧЁТЕСЛИ.
3. Переводим в десятичную систему счисления, поочередно умножая на 2^m (m<33) и затем суммируя. Можно, конечно, объединить все 0 и 1 в громоздкое 33-ёхзначное число, которое потом перегнать функцией ДВВДЕС. Имеем столбец #1 с.. назовем это численной записью числа.
4. Сортируем базу слов по столбцу #1. Имеем численную запись чисел по возрастанию/убыванию.
5. Моя остановочка.
Дело за малым – научиться выделять из столбца #1 диапазон слов с разными буквами, сумма численных значений которых равна (2^33)-1 = 8589934591 (для 33-ёх букв, не говоря уже о количестве вариаций для 32, 31 и т.д.)
ЛЁД ТРОНУЛСЯ
Нашел такую весчь, называется подбор слагаемых под нужную сумму. Является частным случаем «задачи о рюкзаке». Наиболее оптимальные на мой беглый взгляд алгоритмы обитают тута (http://www.excelworld.ru/forum/10-5196-1). Вот если бы эту штуку как-то применить в нашей задаче. Описанный мною выше возможный алгоритм можно упростить до записи слов в двоичном коде. Далее:
1. Берем первое слово, сверяем с каждым на наличие одинаковых букв (единичек). Отбираем массив #1(1) слов с буквами, которых нет в нашем первом слове.
2. Берем первое слово из массива #1(1), сверяем с каждым из массива #1(1) на наличие одинаковых букв (единичек). Отбираем массив #2(1) слов с буквами, которых нет в нашем первом слове из массива #1(1).
3. Повторяем операцию до тех пор, пока конечный массив не превратится в слово. Суммируем двоичный код получившейся выборки и проверяем на равенство 11…11 (33 шт).
4. Возвращаемся на массив уровнем выше (предпоследний), берем оттуда второе слово и делаем все то же самое (опускаемся вниз, проверяем на равенство новую выборку). Если слов в нем больше двух, повторяем операцию с третьим и так далее.
5. Продолжаем последовательно подниматься до массива #1(1), где выбираем уже второе слово, вновь опускаемся до конечного «массива» (одно слово), вновь последовательно поднимаемся и опускаемся; возвратившись в массив #1(1), берем третье слово и так далее.
6. Проверив все слова из массива #1(1), возвращаемся в исходную базу, берем 2 слово, получаем массив #1(2) и работаем с ним аналогично.
Перевод в десятичную СС – это просто сокращение записи. Можно назначить буквам «вес», например 1-33 и начать искать слагаемые под сумму 33*(33+1)/2 = 561, но т.к. они разнятся всего на единицу, ложных вариантов будет как минимум 90%. Можно назначить первой букве вес 10^-16, 17-ой – 1, последней – 10^16. В промежутке известно что. Ложные варианты сократятся на порядок. 10 можно заменить и на 100, и на 1000, но я не уверен, будет ли алгоритм подбора слагаемых под сумму корректно обрабатывать такие данные.
По сути, от двоичного кодирования, как и от дальнейших преобразований, можно отказаться и работать напрямую с буквами. Не говоря уже о возможности существования варианта, где для сравнения 2-х слов на наличие одинаковых букв достаточно, 2-х ячеек, в которых, собственно, и записаны эти слова.
Еще нашел макросы на расположение букв в слове в алфавитном порядке. Модернизированную таким образом базу можно отсортировать в алфавитном порядке, имеем, таким образом, 33 группы. Далее можно сгруппировать слова по наличию сочетаний АБ – ЮЯ (528), АБВ – ЭЮЯ (5456), АБВГ – ЫЭЯЮ (40920) и т.д. (исходя из формулы N!/((N – M*K)!*((K!)^M)), и уже это использовать как условие для запрета совмещения тех или иных слов.
Если все гораздо проще, то да простит меня Оккам!
Решение задачи: «В поисках панграмм [excel, vba]»
textual
Листинг программы
Option Base 1 Dim Ch Sub Pangramma_na_baze() Const MaxKolPangramm = 1 ' Чтобы не набирать огромное число комбинаций слов для среднего числа букв Dim i&, ii%, j%, k%, kk&, A, B, PanKol%, strokaVhod$, KolSlov&, S$, Z$, Novoe As Boolean Dim KolSlovStolb&(10), Pangramma$(MaxKolPangramm), Predlojenie$(16), SlovoRow&(0 To 16), SlovoCol%(0 To 16) Dim Obrazec() As Boolean, OstatokObr() As Boolean, OstatokObrOld(), Tek() As Boolean ReDim Obrazec(33), OstatokObr(33), OstatokObrOld(0 To 33), Tek(33) strokaVhod = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" ' "ад и ёж" '"а я ёж" ' "абвгдеёжзя" '"абвгдеёжзийклмнопрстуфхцчшщъыьэюя" strokaVhod = LCase(strokaVhod) ' работаем со строчными буквами ' Цифрограмма слова это массив от 1до 33, 1-32 = а-я, 33=ё . True если есть буква в слове. Cifrogramma strokaVhod, Obrazec 'Номера позиций в цифрограмме в порядке понижения частотности букв ' о е а и н т с р в л к м д п у я ы ь г з б ч й х ж ш ю ц щ э ф ъ ё Ch = Array(15, 6, 1, 9, 14, 19, 18, 17, 3, 12, 11, 13, 5, 16, 20, 32, 28, 29, 4, 8, 2, 24, 10, 22, 7, 25, 31, 23, 26, 30, 21, 27, 33) With Worksheets("Baza") ' Массив с базой слов. Номер столбца от 1 до 10 равен числу букв в словах. Каждый столбец упорядочен по алфавиту. A = .UsedRange.Value For j = 1 To 10 KolSlovStolb(j) = .Cells(.Rows.Count, j).End(xlUp).Row Next End With ReDim B(UBound(A), 10) ' Массив массивов цифрогамм слов из базы For j = 1 To 10 For i = 1 To KolSlovStolb(j) ReDim Tek(33) Cifrogramma A(i, j), Tek B(i, j) = Tek Next i Next j '--- перебор слов в базе------------ For PanKol = 1 To MaxKolPangramm OstatokObr = Obrazec KolSlov = 0 Erase Predlojenie 'For k = 1 To 16: SlovoRow(k) = 0: SlovoCol(k) = 10: Next k '############################################## оптимизация для 33 букв For k = 1 To 16: SlovoRow(k) = 0: SlovoCol(k) = 5: Next k ' оптимизация для 33 букв KolSlovStolb(1) = 0: KolSlovStolb(2) = 0 ' оптимизация для 33 букв '############################################## оптимизация для 33 букв If PanKol = 1 Then SlovoRow(0) = 0: SlovoCol(0) = SlovoCol(1) Do For j = SlovoCol(KolSlov) To 1 Step -1 ii = IIf(j = SlovoCol(KolSlov), SlovoRow(KolSlov) + 1, 1) For i = ii To KolSlovStolb(j) If EstVObrazce(OstatokObr, B(i, j)) Then ObrazecMinusSlovo OstatokObr, B(i, j), Tek ' Stop '+++++++++++ SlovoRow(KolSlov) = i SlovoCol(KolSlov) = j OstatokObrOld(KolSlov) = OstatokObr OstatokObr = Tek KolSlov = KolSlov + 1 Predlojenie(KolSlov) = A(i, j) If NeOstalosBukv(OstatokObr) Then S = "" For k = 1 To KolSlov S = S & Predlojenie(k) & " " Next k S = Trim(S) Novoe = True For ii = 1 To PanKol - 1 If Pangramma(ii) = S Then Novoe = False: Exit For Next ii If Novoe Then For k = 1 To KolSlov Pangramma(PanKol) = Predlojenie(k) Next k Pangramma(PanKol) = S Exit Do End If End If End If '+++++++++++++++++++++ DoEvents '+++++++++ '+++++++++++++++++++++ Next i 'Stop '+++++++++++ Next j kk = kk + 1 '++++++++++++++++ If kk Mod 10 = 0 Then Debug.Print kk, For k = 1 To KolSlov Debug.Print Predlojenie(k) & " "; Next k Debug.Print End If '++++++++++++++++ SlovoRow(KolSlov) = 0 'SlovoCol(KolSlov) = 10 '############################################## ' оптимизация для 33 букв SlovoCol(KolSlov) = 5 ' оптимизация для 33 букв '############################################## ' оптимизация для 33 букв KolSlov = KolSlov - 1 If KolSlov < 0 Then Exit Do OstatokObr = OstatokObrOld(KolSlov) '+++++++++++++++ ' Ограничитель итераций If kk > 100000 Then End '+++++++++++++++ Loop Next PanKol '----------------------------------- S = "" For i = 1 To MaxKolPangramm S = S & Pangramma(i) & vbCrLf Next 'MsgBox S Debug.Print S End Sub Function EstVObrazce(Obrazec, Slovo) As Boolean Dim i% For i = 1 To 33 If Obrazec(Ch(i)) = False And Slovo(Ch(i)) Then Exit Function Next EstVObrazce = True End Function Function ObrazecMinusSlovo(Obrazec, Slovo, Ostatok) As Boolean Dim i% Ostatok = Obrazec For i = 1 To 33 If Obrazec(i) And Slovo(i) Then Ostatok(i) = False Next ObrazecMinusSlovo = True End Function Function NeOstalosBukv(Obrazec) As Boolean Dim i% For i = 33 To 1 Step -1 If Obrazec(i) Then Exit Function Next NeOstalosBukv = True End Function Sub Cifrogramma(S, Obrazec) Dim i%, B$ For i = 1 To Len(S) B = Mid(S, i, 1) Select Case B Case "ё" Obrazec(33) = True Case "а" To "я", "ё" Obrazec(Asc(B) - 223) = True End Select Next i End Sub
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д