Permutações

A função Permute devolve as permutações sem repetição dos caracteres de uma string.

Se se pretender as permutações com repetição, dever-se-á usar a função Perm.

{$mode objfpc}
program permutations;
const
   NEWLINE =
      {$ifdef windows}
         #13+
      {$endif}
         #10;

type
   TStrArray = array of string;


function Fact(n : byte) : Int64;
(* Factorial of n: n! = n * (n-1)! *)
begin
   if n in [0, 1] then
      Fact := 1
   else
      Fact := n * Fact(Pred(n));
end;


function Rm(x : char; xs : string) : string;
(* Remove the first occurrence of x in xs. *)
begin
   Rm := xs;
   Delete(Rm, Pos(x, xs), 1);
end;


procedure Clean(var l : TStrArray);
(* Clears any garbage present in list l. *)
var i : LongInt;
begin
   for i := Low(l) to High(l) do
      l[i] := '';
end;


operator in (x : string; ys : TStrArray) res : boolean;
(* Overloads the operator in: is there any x in list ys? *)
var y : string;
begin
   res := false;
   for y in ys do
      if x = y then begin
         res := true;
         break;
      end;
end;


procedure WriteArray(arr : TStrArray; sep : string = NEWLINE);
(* Writes contents of list arr separated by sep. *)
var s : string;
begin
   for s in arr do
      write(s, sep);
end;


function Perm(const xs : string) : TStrArray;
(* Returns total permutations. *)
var
   i  : LongInt;
   x  : char;
   y  : string;
   ys : TStrArray;
begin
   if Length(xs) = 0 then begin
      Perm := nil
   end else begin
      SetLength(Perm, Fact(Length(xs)));

      if Length(xs) = 1 then
         Perm[0] := xs
      else begin
         i := 0;
         for x in xs do begin
            ys := Perm(Rm(x, xs));
            for y in ys do begin
               Perm[i] := Concat(String(x), y);
               Inc(i);
            end;
         end;
      end;
   end;
end;


function Permute(const xs : string) : TStrArray;
(* Returns permutations without repetition. *)

   function Nub(zs : TStrArray) : TStrArray;
   (* Eliminates duplicated elements from zs. *)
   var
      z     : string;
      i     : LongInt;
      count : LongInt = 0;
   begin
      SetLength(Nub, Length(zs));
      Clean(Nub);
      for z in zs do begin
         if not (z in Nub) then begin
            Nub[count] := z;
            Inc(count);
         end;
      end;
      SetLength(Nub, count);
   end;

begin  (* Permute *)
   Permute := Nub(Perm(xs));
end;


begin  (* MAIN BLOCK *)
   WriteArray(Permute('CAII'));
   readln;
end.

Adaptado de: Pastebin - Permutations with(out) repetition