Go Premium for a chance to win a PS4. Enter to Win

x
Solved

# Need to optimize letter permutation code

Posted on 2006-11-14
Medium Priority
288 Views
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
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
Question by:Grant Fullen
• 8
• 7
• 3
• +1

LVL 15

Assisted Solution

mikelittlewood earned 400 total points
ID: 17945527
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 Comment

ID: 17950931
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

LVL 15

Expert Comment

ID: 17951006
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 Comment

ID: 17951050
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 Comment

ID: 17951091
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

LVL 15

Expert Comment

ID: 17954361
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

LVL 9

Expert Comment

ID: 17958056
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 Comment

ID: 17960838
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

LVL 9

Expert Comment

ID: 17962783
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 Comment

ID: 17969515
Well then do you know an algorithm that does that fast?

I still want to save it.
0

LVL 9

Expert Comment

ID: 17970572
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

nth-permutation
but it is NOT faster for the task you want it for...
0

Author Comment

ID: 17972699
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

LVL 9

Expert Comment

ID: 17973739
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

LVL 9

Assisted Solution

alkisg earned 800 total points
ID: 17973832
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.

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

LVL 9

Expert Comment

ID: 17973859
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

LVL 17

Expert Comment

ID: 17976880
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 Comment

ID: 17977191
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

LVL 9

Expert Comment

ID: 17977234
> 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

LVL 17

Expert Comment

ID: 17982312
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

LVL 17

Accepted Solution

TheRealLoki earned 800 total points
ID: 17982421
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
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;
procedure SendSuccess;
function Getfilename: string;
function GetPermutation(desirednumber: int64): string;
public
procedure Execute; override;
end;

type TPermutationObject = class(TObject)
private
fOnProgress: TOnPermutationProgress;
fCurrentCount: int64;
fPercentage: integer;
fCreationIndex: int64;
fTotalCount: int64;
fOnComplete: TNotifyEvent;
fOnLogMessage: TOnPermutationLogMessage;
fStopping: boolean;
fFullString: string;
procedure SetCurrentCount(const Value: int64);
procedure SetPercentage(const Value: integer);
public
Constructor Create;
Destructor Destroy; override;
procedure Start;
procedure Stop;
procedure Resume;
procedure DeleteResults;
property FullString: string read fFullString write fFullString;
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;
FullString := '';;
end;

destructor TPermutationObject.Destroy;
begin
Stop;
inherited;
end;

var
i: integer;
begin
for i := pred(Threads.Count) downto 0 do
begin
begin
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
else
begin
fStopping := False;
if assigned(fOnComplete) then
fOnComplete(self);
end;
end;

var
uniquename: string;
nextend: int64;
begin
if fStopping then exit;
while (
(fCreationIndex < fTotalCount)
) do
begin
nextend := min(fCreationIndex + NumberOfLinesPerFile, fTotalCount);
uniquename := IntToStr(fCreationIndex) + '_' + InttoStr(nextend);
newthread.Priority := tpNormal; // set to the priority you wish....
fCreationIndex := NextEnd;
end;
end;

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
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
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));
end;

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
begin
if pos('.', SearchRec.Name) <> 1 then
begin
end;
end;
SearchResult := FindNext(SearchRec);
end;
FindClose(SearchRec);
finally
SL.EndUpdate;
tempSL.Clear;
tempSL.Free;
end;
end;

begin
inherited Create(true);
FreeOnTerminate := True;
FullString := FullString_;
fStartPos := StartPos;
fEndPos := EndPos;
fOnSuccess := OnSuccess;
fTotalCount := fEndPos - fStartPos + 1;
fCurrentPos := fStartPos;
end;

var
i: integer;
begin
if FileExists(GetFilename) then
begin
if assigned(fOnSuccess) then
Synchronize(SendSuccess);
end
else
begin
PermutationPoints := TList.Create;
for i := 1 to length(FullString) do
FullStringLength := length(FullString);

results := TStringList.Create;
try
while ( (not terminated) and (fCurrentPos <= fEndPos) ) do
begin
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;

begin
end;

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;

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;
procedure bStartClick(Sender: TObject);
procedure bStopClick(Sender: TObject);
procedure bResumeClick(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
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;

begin
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
PermObject := TPermutationObject.Create;
with PermObject do
begin
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
Left = 320
Top = 44
Width = 121
Height = 25
TabOrder = 7
end
end
0

Author Comment

ID: 18058017

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

## Featured Post

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article explains how to create forms/units independent of other forms/units object names in a delphi project. Have you ever created a form for user input in a Delphi project and then had the need to have that same form in a other Delphi projâ€¦
Introduction The parallel port is a very commonly known port, it was widely used to connect a printer to the PC, if you look at the back of your computer, for those who don't have newer computers, there will be a port with 25 pins and a small printâ€¦
In response to a need for security and privacy, and to continue fostering an environment members can turn to for support, solutions, and education, Experts Exchange has created anonymous question capabilities. This new feature is available to our Prâ€¦
When cloud platforms entered the scene, users and companies jumped on board to take advantage of the many benefits, like the ability to work and connect with company information from various locations. What many didn't foresee was the increased riskâ€¦
###### Suggested Courses
Course of the Month6 days, 15 hours left to enroll