Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Основная";
Текущий архив: 2002.12.30;
Скачать: [xml.tar.bz2];

Вниз

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

 
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]

Up


 
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



Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2002.12.30;
Скачать: [xml.tar.bz2];

Наверх





Память: 0.63 MB
Время: 0.047 c
7-99387
Начинающий програмер
2002-08-26 19:58
2002.12.30
температура процессора


14-99331
test
2002-12-10 16:40
2002.12.30
Эх.....жаль...... не получилось.......


14-99326
Sergo
2002-12-09 12:27
2002.12.30
FM-карта


8-99205
ang
2002-09-12 13:57
2002.12.30
Где найдти библтотеку для отображения tiff файлов?


1-99105
Soul2
2002-12-18 05:30
2002.12.30
TStringList invert.





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский