• Status: Solved
• Priority: Medium
• Security: Public
• Views: 290
• Last Modified:

Need to optimize letter permutation code

Good day.

I have some code that gets all the possible combinations of a given set of characters.  So far it works good, but I need it to be optimized to work as fast as possible.

I was thinking of making it multi-threaded or whatever needs to be done to optimize it.

Here's the code:

private
{ Private declarations }
// from AB get A,B,AA,AB,BA,BB
procedure FindPermutationsWithDupes(fullstring: string; SL: TStrings);
procedure FindPermutationsOfLengthWithDupes(level, desiredlen_: integer; fullstring, stringsofar: string; SL: TStrings);

----------------------------------

procedure TForm1.FindPermutationsOfLengthWithDupes(level, desiredlen_: integer; fullstring, stringsofar: string; SL: TStrings);
var
j: integer;
begin
for j := 1 to length(fullstring) do
begin
if level < desiredlen_ then
FindPermutationsOfLengthWithDupes(level + 1, desiredlen_, fullstring, stringsofar + fullstring[j], SL)
else
begin
Sl.Add(stringsofar + fullstring[j]);
Gauge1.Progress := Gauge1.Progress + 1;
if level <= (desiredlen_ div 2) then // to repaint less (and improve performance) change "2" to 3 or 4
Gauge1.Repaint;
end;
end;
end;

procedure TForm1.FindPermutationsWithDupes(fullstring: string; SL: TStrings);
var
desiredlen: integer;
var
maxs: double;
i: integer;
begin
maxs := 0;
for i := length(edit1.text) downto 1 do
maxs := maxs + power(length(fullstring), i);
{eg. for a 4 letter string, you calculate as
power(4, 4) + power(4, 3) + power(4, 2) + power(4, 1)}

Gauge1.MaxValue := Trunc(maxs);
lProgress.Caption := IntToStr(Gauge1.MaxValue);
SL.BeginUpdate;
try
SL.Clear;
for desiredlen := 1 to length(fullstring) do
FindPermutationsOfLengthWithDupes(1, desiredlen, fullstring, '', SL);
finally
SL.EndUpdate;
end;
lListcount.Caption := IntToStr(Sl.Count);
end;
0
Grant Fullen
Asked:
• 8
• 7
• 3
• +1
3 Solutions

Commented:
This is just a few pointers to start with as it will affect much larger looping.
Remove the references to components and assign to local variables instead so the code doesnt have to compute every time. Do the same to the other procedure too.

procedure TForm1.FindPermutationsWithDupes(fullstring: string; SL: TStrings);
var
maxs: double;
i, desiredlen, iFullString, iEditLength: Integer;
begin

maxs := 0;

iFullString := length(fullstring);
iEditLength := length(edit1.Text);

for i := iEditLength downto 1 do
maxs := maxs + power(iFullString, i);

Gauge1.MaxValue := Trunc(maxs);
lProgress.Caption := IntToStr(Gauge1.MaxValue);

SL.BeginUpdate;
try
SL.Clear;
for desiredlen := 1 to iFullString do
FindPermutationsOfLengthWithDupes(1, desiredlen, fullstring, '', SL);
finally
SL.EndUpdate;
end;
lListcount.Caption := IntToStr(Sl.Count);

end;
0

Author Commented:
Alright.

Seems to work pretty good.  But does anyone have any faster methods to add?  Just so you all know I'll be using about 65-70 characters to generate the permutations.  That's why I need it optimized.

I also want to be able to Save/Resume this list it generates.  For example, if it's 1/3 into generating the list of permutations, and I want to stop it, then I want to save what it has so far, then be able to come back and resume from where it last stopped.

You can make it write to the disk as it goes if you want if that makes it easier.
0

Commented:
Hi again,

Ive had another look at what you are doing and I cant really suggest too much more.
It looks like you are using recursion correctly.
0

Author Commented:
Oh ya, there's one major problem I forgot to add.

I mentioned in the above post that I want to do at most 70 characters.

Right now it only lets me do up to 9.  This has to be fixed so I can use 70 characters max.
0

Author Commented:
Okay.  Thanks for pointing that out.  Someone told me I should use variables first then load the input to the memo but I wasn't too sure.

Maybe you can read my above post, about the main 2 issues.
0

Commented:
Ill have a think later today as Im a little busy. Maybe someone else will come up with some other pointers for you in the mean time  :o)
0

Commented:
Are you sure you want to find/save all permutations? They'll be a lot of them for 70 letters! :-)

I'd suggest the following:
1) A function that returns the number of permutations from a given string, e.g.
NumberOfPermutations('AB') = 6
2) A function that calculates IN CONSTANT TIME the Nth permutation, e.g.
NthPermutation('AB', 3) = 'AA'

This way you save a lot of RAM, disk and CPU time. And I suppose NthPermutation will be faster than disk loading...
0

Author Commented:
Yes, I know it's a lot of combinations, and I'm sure I want to save/resume it.

Do you have any example code alkisg?
0

Commented:
I don't have any example code,  but I think there are algorithms that let you map from counter #xxxx to permutation #xxxx.

What I meant was:
Suppose your problem is to find all decimal numbers from 1 to 10.000. Of course, your don't have to save them into an array or file. One just makes a function that converts from the internal binary representation to decimal, and if he/she needs the #1024 number, he/she just converts 1000000000b to decimal in O[1]...

So, whenever you would need permutation #xxxx in your program, you'd just use the function, and avoid storing data.
0

Author Commented:
Well then do you know an algorithm that does that fast?

I still want to save it.
0

Commented:
If you want to save all permutations, repetitive algorithms (like the one you're using) are faster that the nth-permutation ones, that's why I was asking (to avoid the trouble of searching the net).
Repetitive algorithms:
http://www.cut-the-knot.org/do_you_know/AllPerm.shtml
You may also read the papers that this pages refers to.

For nth-permutation algorithms, google for
nth-permutation
but it is NOT faster for the task you want it for...
0

Author Commented:
I've already read that site, and I STILL need to know if anyone has any example code to save and resume this.

Here's a link to my other question.  Go over it.  You'll fully understand what I'm wanting.

http://www.experts-exchange.com/Programming/Programming_Languages/Delphi/Q_22054086.html
0

Commented:
You want to save 66^66 numbers???!!!????
Have you calculated this? It is 1,229984803535237425357460579825e+120
This is ~1,0e+108 Terrabytes!!! You'd need more hard disk space than the whole world has to offer! :-)
...and, even if you had some million years to spend calculating all these combinations, just the act of saving them would take some more million years!!!
0

Commented:
Sorry, wrong result (but close!), I misread your question. You're asking for combinations, not permutations.
So, if you're using 26 capital letters + 26 small letters + 8 special letters (space etc), you'll have
70^60 combinations
which, again, is more than you can calculate or save in a million lifetimes.

To answer your question:

function NumberOfCombinations(const alphabet: String; desiredLength: int64): int64;
begin
Result := Round(IntPower(Length(alphabet), desiredLength));
end;

function NthCombination(const alphabet: String; desiredLength: int64; whichCombination: int64): String;
var
i, digit, al: integer;
begin
al := Length(alphabet);
Result := StringOfChar(alphabet[1], desiredLength);
for i := desiredLength downto 1 do
begin
digit := whichCombination mod al;
whichCombination := whichCombination div al;
Result[i] := alphabet[digit + 1];
end;
end;

Usage: since now it is not recursive, you just do a for loop to find all combinations.
To stop/resume it, you only have to save the current i (just a number).

const
Alphabet = '0123456789';
var
s: String;
i, numComb: int64;
begin
numComb := NumberOfCombinations(Alphabet, 4);
for i := 0 to numComb do
begin
s := NthCombination(Alphabet, 4, i);
//writeln(s)...
end;
end;
0

Commented:
P.S. This code does not calculate smaller strings, e.g.
'A' and 'AB'
but only full-length strings, like 'ABCD'.

If you also want the smaller strings, you'll have to make another for loop to call it again with desiredLength := 1 to 4:

for desiredLength := 1 to 4 do
begin
numComb := NumberOfCombinations(Alphabet, desiredLength);
for i := 0 to numComb do
begin
s := NthCombination(Alphabet, desiredLength, i);
//writeln(s)...
end;
end;

and, to stop/resume you'll need to save both desiredLength and i.
0

Senior DeveloperCommented:
hmmm.... I was working away on another method (which urns out to be similar to the nth discussion above) I was so proud of myself for working it otu too :-(
anyway... I can get up to 13 length strings working before the Int64 limit is blown
Can anyone think of a way around this limit ?
0

Author Commented:
Glad to see you still here TheRealLoki.

Thanks for the code alkisg, I'll try it tomorrow.  Please do keep working with your's TheRealLoki.  I want to try them both.
0

Commented:
> anyway... I can get up to 13 length strings working before the Int64 limit is blown
> Can anyone think of a way around this limit ?

A big number library can be used, such as the gnu multipresision library:
http://www.swox.com/gmp/
0

Senior DeveloperCommented:
If you just want to pick one random permutation of the letters, then you don't really need to save the entire list to disk. you could just use random( maxperutations) and use the algorithm above.
no need to store teh entire list etc...
0

Senior DeveloperCommented:
I'll post what I have so far (with the Int64 limit) while I work on a big number alternative. This might give others a chance to expand or come up with a better alternative

unit PermutationObject;

interface

uses Windows, Classes, math, sysutils, filectrl;

const
NumberOfLinesPerFile = 10000; // less means more files, but more "stages" complete for "resuming"...
// a good value for large text is 100000+
type TOnPermutationProgress = procedure (Sender: TObject; Percentage: integer) of object;
type TOnPermutationLogMessage = procedure (Sender: TObject; s: string) of object;
type TOnPermutationThreadJobSuccess = procedure (Sender: TObject; ThreadName: string; CountDone: int64) of object;
type
TPermutationThread = class(TThread)
private
fTotalCount: int64;
fStartPos, fEndPos, fCurrentPos: int64;
FullString: string;
fThreadName: string; // used for filename in conjunction with Start & End pos

FullStringLength: integer;
PermutationPoints: TList;
results: TStringList;
fOnSuccess: TOnPermutationThreadJobSuccess;
procedure SendSuccess;
function Getfilename: string;
function GetPermutation(desirednumber: int64): string;
public
Constructor Create(FullString_, ThreadName_: string; StartPos, EndPos: int64; OnSuccess: TOnPermutationThreadJobSuccess);
procedure Execute; override;
end;

type TPermutationObject = class(TObject)
private
fMaxNumberOfThreads: integer;
fOnProgress: TOnPermutationProgress;
fCurrentCount: int64;
fPercentage: integer;
fCreationIndex: int64;
fTotalCount: int64;
fOnComplete: TNotifyEvent;
fOnLogMessage: TOnPermutationLogMessage;
fStopping: boolean;
fFullString: string;
procedure OnPermuationThreadTerminate(Sender: TObject);
procedure SetCurrentCount(const Value: int64);
procedure SetPercentage(const Value: integer);
procedure PermutationThreadJobSuccess(Sender: TObject; ThreadName: string; CountDone: int64);
procedure CheckAndMakeNewThreads;
public
Threads: TList;
Constructor Create;
Destructor Destroy; override;
procedure Start;
procedure Stop;
procedure Resume;
procedure DeleteResults;
procedure Loadresults(SL: TStrings);
property FullString: string read fFullString write fFullString;
property MaxNumberOfThreads: integer read fMaxNumberOfThreads write fMaxNumberOfThreads;
property CurrentCount: int64 read fCurrentCount write SetCurrentCount;
property Percentage: integer read fPercentage write SetPercentage;
property OnProgress: TOnPermutationProgress read fOnProgress write fOnProgress;
property OnComplete: TNotifyEvent read fOnComplete write fOnComplete;
property OnLogMessage: TOnPermutationLogMessage read fOnLogMessage write fOnLogMessage;
end;

implementation

{ TPermutationObject }

constructor TPermutationObject.Create;
begin
inherited Create;
fStopping := False;
Threads := TList.Create;
FullString := '';;
MaxNumberOfThreads := 10;
end;

destructor TPermutationObject.Destroy;
begin
Stop;
Threads.Clear;
Threads.Free;
inherited;
end;

procedure TPermutationObject.OnPermuationThreadTerminate(Sender: TObject);
var
i: integer;
begin
for i := pred(Threads.Count) downto 0 do
begin
if sender = Threads[i] then
begin
Threads[i] := nil;
Threads.Delete(i);
end;
end;
{  if assigned(fOnLogMessage) then
fOnLogMessage(self, 'thread complete'); // uncomment if you want more logging}

// now check if we can start another thread
if ( (fCreationIndex < fTotalCount) and (not fStopping) ) then
CheckAndMakeNewThreads
else
if (Threads.Count = 0) then
begin
fStopping := False;
if assigned(fOnComplete) then
fOnComplete(self);
end;
end;

procedure TPermutationObject.CheckAndMakeNewThreads;
var
uniquename: string;
nextend: int64;
newthread: TPermutationThread;
begin
if fStopping then exit;
while (
(Threads.Count < MaxNumberOfThreads) and
(fCreationIndex < fTotalCount)
) do
begin
nextend := min(fCreationIndex + NumberOfLinesPerFile, fTotalCount);
uniquename := IntToStr(fCreationIndex) + '_' + InttoStr(nextend);
newthread := TPermutationThread.Create(FullString, uniquename, fCreationIndex, nextend - 1, PermutationThreadJobSuccess);
newthread.Priority := tpNormal; // set to the priority you wish....
newthread.OnTerminate := OnPermuationThreadTerminate;
fCreationIndex := NextEnd;
Threads.Add(newthread);
newthread.Resume;
end;
end;

procedure TPermutationObject.PermutationThreadJobSuccess(Sender: TObject;
ThreadName: string; CountDone: int64);
begin
CurrentCount := self.CurrentCount + CountDone;
if assigned(fOnLogMessage) then fOnLogMessage(self, Threadname  + ' complete');
end;

procedure TPermutationObject.SetCurrentCount(const Value: int64);
begin
fCurrentCount := Value;
if fTotalCount = 0 then
begin
fPercentage := -1; // ensure the "OnProgress" event fires in this situation
Percentage := 0;
end
else
Percentage := Trunc((fCurrentCount / fTotalCount) * 100);
end;

procedure TPermutationObject.SetPercentage(const Value: integer);
var
fLastPercent: integer;
begin
fLastPercent := fPercentage;
if (fLastPercent <> Value) then
begin
fPercentage := Value;
if assigned(fOnProgress) then fOnProgress(self, fPercentage);
end;
end;

procedure TPermutationObject.Start;
begin
DeleteResults;
Resume;
end;

procedure TPermutationObject.Stop;
var
i: integer;
begin
fStopping := True;
for i := pred(Threads.Count) downto 0 do
begin
TPermutationThread(Threads[i]).Terminate;
end;
end;

procedure TPermutationObject.DeleteResults;
var
SearchRec: TSearchRec;
SearchResult: integer;
begin
ForceDirectories(ExtractFilePath(paramstr(0)) + 'results\');
SearchResult := FindFirst(ExtractFilePath(paramstr(0)) + 'results\*.*', faAnyFile, SearchRec);
while SearchResult = 0 do
begin
if (searchrec.Attr and faDirectory) <> faDirectory then
begin
if pos('.', SearchRec.Name) <> 1 then
DeleteFile(ExtractFilePath(paramstr(0)) + 'results\' + SearchRec.Name);
end;
SearchResult := FindNext(SearchRec);
end;
FindClose(SearchRec);
end;

procedure TPermutationObject.Resume;
var
i: integer;
begin
fCreationIndex := 0;
fTotalCount := 0;
CurrentCount := 0;
for i := 1 to length(FullString) do
fTotalCount := fTotalCount + Trunc(power(length(fullstring), i));
CheckAndMakeNewThreads;
end;

procedure TPermutationObject.Loadresults(SL: TStrings);
var
SearchRec: TSearchRec;
SearchResult: integer;
tempSL: TStringList;
begin
tempSL := TStringList.Create;
SL.BeginUpdate;
try
SL.Clear;
ForceDirectories(ExtractFilePath(paramstr(0)) + 'results\');
SearchResult := FindFirst(ExtractFilePath(paramstr(0)) + 'results\*.dat', faAnyFile, SearchRec);
while SearchResult = 0 do
begin
if (searchrec.Attr and faDirectory) <> faDirectory then
begin
if pos('.', SearchRec.Name) <> 1 then
begin
tempSL.LoadFromFile(ExtractFilePath(paramstr(0)) + 'results\' + SearchRec.Name);
SL.AddStrings(tempSL);
end;
end;
SearchResult := FindNext(SearchRec);
end;
FindClose(SearchRec);
finally
SL.EndUpdate;
tempSL.Clear;
tempSL.Free;
end;
end;

{ TPermutationThread }

constructor TPermutationThread.Create(FullString_, ThreadName_: string; StartPos, EndPos: int64;
OnSuccess: TOnPermutationThreadJobSuccess);
begin
inherited Create(true);
FreeOnTerminate := True;
FullString := FullString_;
fThreadName := ThreadName_;
fStartPos := StartPos;
fEndPos := EndPos;
fOnSuccess := OnSuccess;
fTotalCount := fEndPos - fStartPos + 1;
fCurrentPos := fStartPos;
end;

procedure TPermutationThread.Execute;
var
i: integer;
begin
if FileExists(GetFilename) then
begin
if assigned(fOnSuccess) then
Synchronize(SendSuccess);
end
else
begin
PermutationPoints := TList.Create;
PermutationPoints.Add(pointer(0));
for i := 1 to length(FullString) do
PermutationPoints.Add(pointer(Trunc(IntPower(length(FullString), i))));
FullStringLength := length(FullString);

results := TStringList.Create;
try
while ( (not terminated) and (fCurrentPos <= fEndPos) ) do
begin
results.Add(GetPermutation(fCurrentPos));
inc(fCurrentPos);
end;
if not Terminated then
begin
if results.count > 0 then
begin
results.SaveToFile(GetFilename);
end;
if assigned(fOnSuccess) then
Synchronize(SendSuccess);
end;
finally
PermutationPoints.Clear;
PermutationPoints.Free;
results.Clear;
results.Free;
end;
end;
end;

procedure TPermutationThread.SendSuccess;
begin
fOnSuccess(self, fThreadName, fTotalCount);
end;

function TPermutationThread.GetPermutation(desirednumber: int64): string;
var
i: integer;
tempnum, currentpos: int64;
currsl, lastmax, maxfroml: integer;
whichcharindex: integer;
begin
result := '';
i := 1;
lastmax := 0;
maxfroml := 0;
while desirednumber >= maxfroml + Int64(PermutationPoints[i]) do
begin
maxfroml := maxfroml + Int64(PermutationPoints[i]);
inc(i);
end;
tempnum := (desirednumber - maxfroml);
result := '';
for currsl := i downto 1 do
begin
currentpos := tempnum mod Int64(PermutationPoints[currsl]);
whichcharindex := Trunc(currentpos / Int64(PermutationPoints[currsl]) * FullStringLength) + 1;
result := result + FullString[whichcharindex];
end;
end;

function TPermutationThread.GetFilename: string;
begin
result := ExtractFilePath(paramstr(0)) + 'results\' + fThreadName + '.dat'
end;

end.

//**********************************
// And here is my test form for calling it - requires 4 buttons, 2 memos, and a progress bar
//**********************************

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
PermutationObject, StdCtrls, ComCtrls;

type
TForm1 = class(TForm)
bStart: TButton;
Edit1: TEdit;
ProgressBar1: TProgressBar;
Memo1: TMemo;
Memo2: TMemo;
bStop: TButton;
bResume: TButton;
bLoadResultsToMemo: TButton;
procedure bStartClick(Sender: TObject);
procedure bStopClick(Sender: TObject);
procedure bResumeClick(Sender: TObject);
procedure bLoadResultsToMemoClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
procedure PermutationProgress(Sender: TObject; Percentage: integer);
procedure PermutationLogging(Sender: TObject; S: string);
procedure PermutationComplete(Sender: TObject);
public
{ Public declarations }
PermObject: TPermutationObject;
end;

var
Form1: TForm1;

implementation

{\$R *.DFM}

procedure TForm1.PermutationComplete(Sender: TObject);
begin
memo2.lines.add(DateTimeToStr(Now) + ' - COMPLETE');
while memo2.lines.count > 100 do memo2.lines.Delete(0);
end;

procedure TForm1.PermutationLogging(Sender: TObject; S: string);
begin
memo2.lines.add(DateTimeToStr(Now) + ' - ' + S);
while memo2.lines.count > 100 do memo2.lines.Delete(0);
end;

procedure TForm1.PermutationProgress(Sender: TObject; Percentage: integer);
begin
progressbar1.Position := Percentage;
end;

procedure TForm1.bStartClick(Sender: TObject);
begin
PermObject.FullString := Edit1.Text;
PermObject.Start;
end;

procedure TForm1.bStopClick(Sender: TObject);
begin
PermObject.Stop;
end;

procedure TForm1.bResumeClick(Sender: TObject);
begin
PermObject.FullString := Edit1.Text;
PermObject.Resume;
end;

procedure TForm1.bLoadResultsToMemoClick(Sender: TObject);
begin
memo2.Lines.Add(DateTimeToStr(Now) + ' - Started loading results to memo');
if assigned(PermObject) then PermObject.Loadresults(memo1.lines);
memo2.Lines.Add(DateTimeToStr(Now) + ' - Finished loading results to memo');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
PermObject := TPermutationObject.Create;
with PermObject do
begin
MaxNumberOfThreads := 10;
OnProgress := PermutationProgress;
OnLogMessage := PermutationLogging; // comment this for less info
OnComplete := PermutationComplete;
end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
if assigned(PermObject) then FreeAndNil(PermObject);
end;

end.

//******************
// Form Follows
//******************

object Form1: TForm1
Left = 249
Top = 107
Width = 696
Height = 480
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object bStart: TButton
Left = 52
Top = 44
Width = 75
Height = 25
Caption = 'bStart'
TabOrder = 0
OnClick = bStartClick
end
object Edit1: TEdit
Left = 52
Top = 12
Width = 121
Height = 21
TabOrder = 1
Text = 'Edit1'
end
object ProgressBar1: TProgressBar
Left = 272
Top = 16
Width = 150
Height = 16
Min = 0
Max = 100
Smooth = True
TabOrder = 2
end
object Memo1: TMemo
Left = 56
Top = 84
Width = 185
Height = 89
Lines.Strings = (
'Memo1')
TabOrder = 3
end
object Memo2: TMemo
Left = 56
Top = 184
Width = 561
Height = 253
Lines.Strings = (
'Memo2')
TabOrder = 4
end
object bStop: TButton
Left = 144
Top = 44
Width = 75
Height = 25
Caption = 'bStop'
TabOrder = 5
OnClick = bStopClick
end
object bResume: TButton
Left = 232
Top = 44
Width = 75
Height = 25
Caption = 'bResume'
TabOrder = 6
OnClick = bResumeClick
end
object bLoadResultsToMemo: TButton
Left = 320
Top = 44
Width = 121
Height = 25
Caption = 'bLoadResultsToMemo'
TabOrder = 7
OnClick = bLoadResultsToMemoClick
end
end
0

Author Commented:
Sorry about the absence.

I haven't been able to test this project since now.  I pretty much have what I need now.  Points will be split.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Featured Post

• 8
• 7
• 3
• +1
Tackle projects and never again get stuck behind a technical roadblock.