Data commit

Task/Permutations-Derangements/Pascal/permutations-derangements.pas

@@ -0,0 +1,124 @@
+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.