125 lines
3.1 KiB
ObjectPascal
125 lines
3.1 KiB
ObjectPascal
program Derangements_RC;
|
|
(*
|
|
Pascal solution for Rosetta Code task "Permutations/Derangements"
|
|
Console program written in Free Pascal (Lazarus)
|
|
*)
|
|
// Returns first derangement in lexicographic order.
|
|
// Function return is false if there are no derangements.
|
|
function FirstDerangement( var val : array of integer) : boolean;
|
|
var
|
|
n, j : integer;
|
|
begin
|
|
n := Length( val);
|
|
result := (n <> 1);
|
|
if n < 2 then exit;
|
|
if Odd(n) then begin
|
|
val[n - 3] := n - 2;
|
|
val[n - 2] := n - 1;
|
|
val[n - 1] := n - 3;
|
|
dec( n, 3);
|
|
end;
|
|
j := 0;
|
|
while (j < n) do begin
|
|
val[j] := j + 1;
|
|
val[j + 1] := j;
|
|
inc( j, 2);
|
|
end;
|
|
end;
|
|
|
|
// Returns next derangement in lexicographic order.
|
|
// Function return is false if there are no more derangements.
|
|
// Finds next derangement directly, i.e. not by generating
|
|
// permutations until a derangement is found.
|
|
function NextDerangement( var val : array of integer) : boolean;
|
|
var
|
|
i, j, n : integer;
|
|
backward, done : boolean;
|
|
free : array of boolean;
|
|
begin
|
|
n := Length( val);
|
|
if (n < 3) then begin
|
|
result := false;
|
|
exit;
|
|
end;
|
|
SetLength( free, n);
|
|
for j := 0 to n - 1 do free[j] := false;
|
|
i := n - 1;
|
|
free[val[i]] := true;
|
|
backward := true;
|
|
done := false;
|
|
repeat
|
|
if backward then begin
|
|
dec(i); j := val[i]; free[j] := true;
|
|
end
|
|
else begin
|
|
inc(i); j := -1;
|
|
end;
|
|
repeat
|
|
inc(j)
|
|
until (j >= n) or (free[j] and (j <> i));
|
|
if (j < n) then begin // found a suitable free value
|
|
val[i] := j; free[j] := false;
|
|
if (i = n - 1) then done := true // found the next derangement
|
|
else backward := false;
|
|
end
|
|
else if (i = 0) then done := true // no more derangements
|
|
else backward := true;
|
|
until done;
|
|
result := (i > 0);
|
|
end;
|
|
|
|
// Finds all derangements of integers 0..(n - 1) and
|
|
// returns the number of derangements.
|
|
// if boolean "show" is true, writes derangments to standard output.
|
|
function FindDerangements( n : integer;
|
|
show : boolean) : integer;
|
|
var
|
|
int_array : array of integer;
|
|
j : integer;
|
|
ok : boolean;
|
|
begin
|
|
result := 0;
|
|
if (n < 0) then exit;
|
|
SetLength( int_array, n);
|
|
ok := FirstDerangement( int_array);
|
|
while ok do begin
|
|
inc( result);
|
|
if show then begin
|
|
for j := 0 to n - 1 do Write( ' ', int_array[j]);
|
|
WriteLn();
|
|
end;
|
|
ok := NextDerangement( int_array);
|
|
end;
|
|
end;
|
|
|
|
// Returns subfactorial of passed-in integer.
|
|
function Subfactorial( n : integer) : uint64;
|
|
var
|
|
j : integer;
|
|
begin
|
|
result := 1;
|
|
for j := 1 to n do begin
|
|
result := result*j;
|
|
if Odd(j) then dec(result) else inc(result);
|
|
end;
|
|
end;
|
|
|
|
// Main routine for Rosetta Code task.
|
|
var
|
|
n, nrFound, nrCalc : integer;
|
|
begin
|
|
WriteLn( 'Derangements of 4 integers');
|
|
nrFound := FindDerangements( 4, true);
|
|
WriteLn( 'Number of derangements found = ', nrFound);
|
|
WriteLn();
|
|
WriteLn( 'Number of derangements');
|
|
WriteLn( ' n Found Subfactorial');
|
|
for n := 0 to 9 do begin
|
|
nrFound := FindDerangements( n, false);
|
|
nrCalc := Subfactorial( n);
|
|
WriteLn( n:3, nrFound:8, nrCalc:8);
|
|
end;
|
|
WriteLn();
|
|
WriteLn( 'Subfactorial(20) = ', Subfactorial(20));
|
|
end.
|