Mega Code Archive
Permutations of a string
<![CDATA[
Title: Permutations of a string
Question: The number of possible rearrangements of the letters of a word is huge. This article provides an algorithm for generating all of them.
Answer:
var
// doAbort: boolean; // Time consuming, so may want abort option
resultList: TStringlist;
// Simple integer factorial handles 12! = 479,001,600 max
// Doesn't complain if n negative, just returns 1
function factorial(n: integer): integer;
var
i, x: integer;
begin
x := 1;
if n 1 then
for i := 2 to n do x := x * i;
result := x;
end;
// Number of permutations
// = length! / product of ( (count of unique characters)! )
function numberOfPermutations(theWord: string): integer;
var
char1, char2: string[1];
len, i, j: integer;
maxPermutations: integer; // If no characters duplicated
prodOfCharCount: integer; // Product of count factorial
posCounted: array of boolean; // Mark counted positions
countOfChar: array of integer; // Count of unique characters
upWord: string; // theWord in all caps
begin
upWord := upperCase(theWord); // Ignore differences in case
len := length(upWord);
setLength(posCounted, len); // Allocate memory for array
setLength(countOfChar, len); // Allocate memory for array
// Initialize the arrays for marking and counting
for i := 0 to len-1 do begin
posCounted[i] := false;
countOfChar[i] := 1; // Product of these must not be zero
end;
// Go thru the word and count appearances of each letter
for i := 0 to len-1 do begin // Get a letter
char1 := copy(upWord, i+1, 1);
for j := i+1 to len-1 do begin // Check remaining letters
char2 := copy(upWord, j+1, 1);
if not posCounted[j] then // Skip if previously matched
if char1 = char2 then begin // Found match to count
inc(countOfChar[i]); // Count the character
posCounted[j] := true; // Mark as counted to avoid recount
end;
end;
end;
// Replace character counts by factorials of character counts
for i := 0 to len-1 do countOfChar[i] := factorial(countOfChar[i]);
prodOfCharCount := 1; // Initialize
for i := 0 to len-1 do prodOfCharCount :=
prodOfCharCount*countOfChar[i];
maxPermutations := factorial(len);
numberOfPermutations := maxPermutations div prodOfCharCount;
end;
// Returns str with the last i characters rotated j times
// Needed by permute procedure below
function subRotate(i, j: integer; str: string): string;
var
len, rotStrPos, rotChrPos, n: integer;
baseStr: string;
begin
len := length(str);
rotStrPos := len - i + 1; // First char to rotate
rotChrPos := rotStrPos + j; // New first char after rotation
baseStr := copy(str, 1, rotStrPos-1); // No change to this part
// Append rotated characters to base string
for n := rotChrPos to len do
insert(copy(str, n, 1), baseStr, length(baseStr)+1);
for n := rotStrPos to rotChrPos-1 do
insert(copy(str, n, 1), baseStr, length(baseStr)+1);
result := baseStr;
end;
// Fills global resultList with all permutations of aWord
procedure permute(aWord: string);
// Algorithm:
// Put wordIn into resultList
// For i = 2 to length(wordIn)
// For each item in the resultList
// For j = 1 to i-1
// Add R(i,j, item) to listToAdd
// Next j
// Next item
// Add listToAdd to resultList
// Next i
// R(i,j,item) returns the item string with the last i characters rotated j times
// R(3,2, abcd) = adbc
var
listToAdd: TStringlist;
i, j, k, len: integer;
begin
resultList.clear; // Clear global var for reuse
len := length(aWord);
listToAdd := TStringlist.create;
listToAdd.duplicates := dupIgnore;
listToAdd.sorted := true;
resultList.append(aWord); // See Algorithm comments above
for i := 2 to len do begin
for j := 0 to resultList.count-1 do begin
for k := 1 to i-1 do begin
listToAdd.append(subRotate(i, k, resultList[j]));
{ if doAbort then begin // Good place to allow abort
resultList.clear;
listToAdd.free;
exit;
end;
application.processMessages; }
end;
end;
resultList.addStrings(listToAdd);
listToAdd.clear;
end;
listToAdd.free;
end;
]]>