Составление слов перебором вариантов букв

← →
Luke B. Dremlin (2002-12-08 04:44) [0]

Собственно вопрос. Требуется генерировать слова последовательным
перебором всех вариантов расположения букв(цифр,знаков). Количество
букв в результируещем слове выбирает пользователь. Буквы вводит он же.
Например: Введены буквы А,В,С,D нужно сгенерировать все требуквенные (цифру 3 тоже вводит пользователь)
слова получаемые из этих букв и вывести их либо в файл либо в мемо.

Примерно таким образом:

AAA
AAB
AAC
AAD
ABA
ABB
ABC
ABD
...
DDA
DDB
DDC
DDD

Окажите пожалуйста посильную помощь начинающему делфинисту.
И если не трудно с комментариями, а то я чуть не закипел :) пытаять
разобраться в отрывке похожего примера
http://delphi.mastak.ru/cgi-bin/forum.pl?look=1&id=1020973030&n=9

С огромным уважением Luke B. Dremlin

← →
Sha (2002-12-08 08:30) [1]

Представь себе все числа четверичной системы счисления, меньшие четырех в кубе. Будет легче :).

← →
Netcoder (2002-12-08 11:36) [2]

Объяви массив с буквами, а потом организуй четыре вложенных цикла. ПРОСТО

← →
Luke B. Dremlin (2002-12-08 14:10) [3]

> Netcoder (08.12.02 11:36)
> Объяви массив с буквами, а потом организуй четыре вложенных
> цикла. ПРОСТО

Приведенный пример - частный случай проблемы.
Дело в том что изначально неизвестно сколько вложенных циклов нужно т.к. количество букв в результате вводит юзер. Тут что-то с рекурсией но мне не совсем понятно что именно.

Ссылки по теме:
http://delphi.vitpc.com/asp/answer.asp?IDAnswer=1545

А нужно универсальное решение.

Спасибо.

← →
Юрий Зотов (2002-12-08 14:17) [4]

Не нужно никаких рекурсий. Используйте в качестве массива строку, добавляйте в ее конец каждую новую введенную букву, пока не будет введен признак окончания ввода. А потом - циклы.

← →
Luke B. Dremlin (2002-12-08 14:23) [5]

> Юрий Зотов © (08.12.02 14:17)
> Не нужно никаких рекурсий. Используйте в качестве массива
> строку, добавляйте в ее конец каждую новую введенную букву,
> пока не будет введен признак окончания ввода. А потом -
> циклы.

А можно подробней?

Спасибо.

← →
Sha (2002-12-08 16:52) [6]

function sNext(const sPrev, sChar: string): string;
var
i, j, k: integer;
begin;
Result:=sPrev;
k:=length(sChar);
if k<=0 then exit;
i:=length(sPrev);
while i>0 do begin;
j:=pos(sPrev[i],sChar);
if j<k then begin;
Result[i]:=sChar[j+1];
break;
end;
Result[i]:=sChar[1];
dec(i);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
c, s: string;
begin;
c:="abcd";
s:="ddd";
repeat;
s:=sNext(s,c);
Memo1.Lines.Add(IntToStr(Memo1.Lines.Count+1)+s);
until s="ddd";
end;

← →
Luke B. Dremlin (2002-12-08 17:05) [7]

Спасибо. Пошел пробовать. Результаты сообщу.

← →
Дмитрий К.К. (2002-12-08 18:20) [8]

Угу, будь добр, сообщи ;)

← →
Юрий Зотов (2002-12-08 18:47) [9]

Еще вариант. Программа работает в консоли, если нужно - переделайте.

program Project1;
{$APPTYPE CONSOLE}

var
S, X, Z: string; // S - множество букв, X - текущее слово, Z - последнее слово
L, N: byte; // L - длина множества букв, N - длина слова

function NextWord: boolean;
// Формирует следующее слово по аналогии с целыми числами: X := X + 1
// Возвращает False, если это невозможно (текущее слово уже равно последнему).
var
i: byte;
begin
Result := X <> Z;
if Result then
for i := N downto 1 do
if X[i] <> S[L] then
begin
X[i] := S[Pos(X[i], S) + 1];
Exit
end
else X[i] := S[1]
end { NextWord };

var
Ch: char;
i, j: byte;
begin { main }
// Вводим непустой набор неповторяющихся букв
S := "";
while S = "" do
begin
WriteLn("Input your letters:");
repeat
ReadLn(Ch);
Ch := UpCase(Ch);
if (Ch in ["A".."Z"]) and (Pos(Ch, S) = 0) then S := S + Ch
until not (Ch in ["A".."Z"]);
if S = "" then WriteLn("Empty set.")
end;

// Сортируем его "пузырьком" по возрастанию
L := Length(S);
for i := 1 to L - 1 do
for j := L downto i + 1 do
if S[i] > S[j] then
begin
Ch := S[i];
S[i] := S[j];
S[j] := Ch
end;
WriteLn("Your letters are: ", S);

// Вводим ненулевую длину слова
repeat
Write("Input word length: ");
ReadLn(N);
if N = 0 then WriteLn("Invalid length.")
until N <> 0;

// Формируем первое и последнее слово
X := "";
for i := 1 to N do X := X + S[1];
Z := "";
WriteLn("Result:");
for i := 1 to N do Z := Z + S[L];

// Выводим текущее и формируем следующее слово
repeat
WriteLn(X)
until not NextWord;

// Притормаживаем консоль до нажатия Enter
ReadLn
end.

← →
Fantasist (2002-12-08 19:01) [10]

Ну так с рекурсией быстрее, и признак окончания выводиться сам.

procedure TForm1.MakeList(Symbs: string; n: integer); var i,k:integer; str:array of integer; s:string; function Next(m:integer):boolean; begin Result:=False; if str[m]+1<k then Inc(str[m]) else if m>0 then begin str[m]:=0; Result:=Next(m-1); end else Result:=True; end; begin SetLength(str,n); k:=Length(Symbs); fillchar(pointer(str)^,SizeOf(Integer)*Length(str),0); SetLength(s,n); repeat for i:=1 to n do s[i]:=Symbs[str[i-1]+1]; Memo1.Lines.Add(s); until Next(n-1); end;

← →
Luke B. Dremlin (2002-12-08 19:16) [11]

Всем огромное СПАСИБО!
Задача решена первым способом (который предложил уважаемый Sha).
После небольшой доработки все поставленные условия задачи выполнены.

СПАСИБО ВАМ МАСТЕРА!

← →
Sego (2002-12-09 21:48) [12]

Если интересно, была написана программка, если интересно-комбинация перебором любой последовательности символов-любой длинны.
http://www.geocities.com/vtk000003/files/Kergr2.zip
понравиться поищу исходник....
сразу не даю, потому как не знаю остался или он после краха сиситемы.

← →
Sha (2002-12-09 21:53) [13]

Теперь попробуй написать ее так, чтобы каждый символ входил в слово не более N раз. Это гораздо интересней.

← →
Sego (2002-12-09 22:07) [14]

2 Sha © (09.12.02 21:53)
писалось для генрации словарей, для подбора к архивам
прошу строго не судить просо хотел помочь да и не прграммер я совсем, хватаюсь по мере необходимости нашего админа хрен заставишь для обычного юзера че-то написать.

← →
Luke B. Dremlin (2002-12-14 17:44) [15]

Для информации.

Решение предложенное уважаемым Fantasist оказалось более быстрым чем первое.

Еще раз спасибо ВСЕМ!

← →
Sha (2002-12-14 18:31) [16]

Специально для любителей оптимизировать учебные примеры:

procedure sUpdate(pw, pc: pchar; i, k: integer);
var
ch: char;
begin;
dec(k);
if k>=0 then while i>0 do begin;
dec(i);
ch:=(pw+i)^;
if ch=(pc+k)^ then (pw+i)^:=pc^
else begin;
repeat; dec(k); until (k<=0) or (ch=(pc+k)^);
(pw+i)^:=(pc+k+1)^;
break;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
c, s, t: string;
pw, pc: pchar;
i, k: integer;
begin;
c:="012";
SetLength(t,4); FillChar(pchar(@t[1])^,length(t),c[length(c)]);

Memo1.Lines.BeginUpdate;
Memo1.Lines.Clear;

s:=t; pw:=@s[1]; pc:=@c[1]; i:=length(s); k:=length(c);
repeat;
sUpdate(pw,pc,i,k);
Memo1.Lines.Add(IntToStr(Memo1.Lines.Count+1)+" "+s);
until s=t;

Memo1.Lines.EndUpdate;
end;

-------------------------------------------
Оптимизация хорошо, а удобочитаемость лучше.
На встроенном asm"е будет еще быстрее, только нужно ли это в учебном примере?

← →
Sha (2002-12-14 18:46) [17]

Хочу заметить также, что процедура Next, предложенная
Fantasist © (08.12.02 19:01), является внутренней и строки в нее не передаются.
При таких условиях можно написать функцию в несколько раз более быструю. Однако, такая функция вряд ли может претендовать на роль стандартной билиотечной функции - для других имен строк,
длин и т.п. ее придется переписывать заново.

← →
Sha (2002-12-16 09:24) [18]

← →
Vlad1 (2002-12-17 20:05) [19]

Работает нормально:

function TForm1.ChangeOrderStr(k:integer; const S: String): String; var a,b:TStringList;T:String;i,j:integer; begin Result:=""; if (K<=0)or(k>length(s)) then exit; if k=1 then begin a:=TStringList.Create; try a.Sorted:=true; a.Duplicates:=dupIgnore; for i:=1 to length(s) do a.Add(s[i]); Result:=a.GetText; finally a.Free;a:=nil; end end else begin a:=TStringList.Create; b:=TStringList.Create; try a.Sorted:=true; a.Duplicates:=dupIgnore; b.Text:=ChangeOrderStr(k-1,s); for i:=1 to length(s) do for j:=0 to b.Count-1 do a.Add(s[i]+b[j]); Result:=a.GetText; finally a.Free; a:=nil; b.Free; b:=nil; end;//try end; end;
Пример:

procedure TForm1.Button2Click(Sender: TObject); var r,r1,r2:string; begin R:=ChangeOrderStr(StrToInt(Edit1.Text),Edit2.Text); R1:=copy(r,1,10); r2:=copy(r,length(r)-10,11); Memo1.Text:=r1+#13#10+r2; Caption:=IntToStr(length(r)) end;
Может кое-когда получиться туева хуча строк - отсюда ограничения на вывод в Мемo

Составление слов перебором вариантов букв Найти похожие ветки