字符串的排列组合

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;