UInt32 seed = 0
F nonrandom()
   :seed = 1664525 * :seed + 1013904223
   R (:seed >> 16) / Float(FF'FF)

F mrUnrank1(&vec, rank, n)
   I n < 1 {R}
   V (q, r) = divmod(rank, n)
   swap(&vec[r], &vec[n - 1])
   mrUnrank1(&vec, q, n - 1)

F mrRank1(&vec, &inv, n)
   I n < 2 {R 0}
   V s = vec[n - 1]
   swap(&vec[n - 1], &vec[inv[n - 1]])
   swap(&inv[s], &inv[n - 1])
   R s + n * mrRank1(&vec, &inv, n - 1)

F getPermutation(&vec, rank)
   L(i) 0 .< vec.len {vec[i] = i}
   mrUnrank1(&vec, rank, vec.len)

F getRank(vec)
   V v = [0] * vec.len
   V inv = [0] * vec.len
   L(val) vec
      v[L.index] = val
      inv[val] = L.index
   R mrRank1(&v, &inv, vec.len)

V tv3 = [0] * 3
L(r) 6
   getPermutation(&tv3, r)
   print(‘#2 -> #. -> #.’.format(r, tv3, getRank(tv3)))

print()
V tv4 = [0] * 4
L(r) 24
   getPermutation(&tv4, r)
   print(‘#2 -> #. -> #.’.format(r, tv4, getRank(tv4)))

print()
V tv12 = [0] * 12
L 4
   V r = Int(nonrandom() * factorial(12))
   getPermutation(&tv12, r)
   print(‘#9 -> #. -> #.’.format(r, tv12, getRank(tv12)))


#include <stdio.h>
#include <stdlib.h>

#define SWAP(a,b) do{t=(a);(a)=(b);(b)=t;}while(0)

void _mr_unrank1(int rank, int n, int *vec) {
    int t, q, r;
    if (n < 1) return;

    q = rank / n;
    r = rank % n;
    SWAP(vec[r], vec[n-1]);
    _mr_unrank1(q, n-1, vec);
}

int _mr_rank1(int n, int *vec, int *inv) {
    int s, t;
    if (n < 2) return 0;

    s = vec[n-1];
    SWAP(vec[n-1], vec[inv[n-1]]);
    SWAP(inv[s], inv[n-1]);
    return s + n * _mr_rank1(n-1, vec, inv);
}

/* Fill the integer array <vec> (of size <n>) with the
 * permutation at rank <rank>.
 */
void get_permutation(int rank, int n, int *vec) {
    int i;
    for (i = 0; i < n; ++i) vec[i] = i;
    _mr_unrank1(rank, n, vec);
}

/* Return the rank of the current permutation of array <vec>
 * (of size <n>).
 */
int get_rank(int n, int *vec) {
    int i, r, *v, *inv;

    v = malloc(n * sizeof(int));
    inv = malloc(n * sizeof(int));

    for (i = 0; i < n; ++i) {
        v[i] = vec[i];
        inv[vec[i]] = i;
    }
    r = _mr_rank1(n, v, inv);
    free(inv);
    free(v);
    return r;
}

int main(int argc, char *argv[]) {
    int i, r, tv[4];

    for (r = 0; r < 24; ++r) {
        printf("%3d: ", r);
        get_permutation(r, 4, tv);

        for (i = 0; i < 4; ++i) {
            if (0 == i) printf("[ ");
            else printf(", ");
            printf("%d", tv[i]);
        }
        printf(" ] = %d\n", get_rank(4, tv));
    }
}


import std.stdio, std.algorithm, std.range;

alias TRank = ulong;

TRank factorial(in uint n) pure nothrow {
    TRank result = 1;
    foreach (immutable i; 2 .. n + 1)
        result *= i;
    return result;
}

/// Fill the integer array <vec> with the permutation at rank <rank>.
void computePermutation(size_t N)(ref uint[N] vec, TRank rank)
pure nothrow if (N > 0 && N < 22) {
    N.iota.copy(vec[]);

    foreach_reverse (immutable n; 1 .. N + 1) {
        immutable size_t r = rank % n;
        rank /= n;
        swap(vec[r], vec[n - 1]);
    }
}

/// Return the rank of the current permutation.
TRank computeRank(size_t N)(in ref uint[N] vec) pure nothrow
if (N > 0 && N < 22) {
    uint[N] vec2, inv = void;

    TRank mrRank1(in uint n) nothrow {
        if (n < 2)
            return 0;

        immutable s = vec2[n - 1];
        swap(vec2[n - 1], vec2[inv[n - 1]]);
        swap(inv[s], inv[n - 1]);
        return s + n * mrRank1(n - 1);
    }

    vec2[] = vec[];
    foreach (immutable i; 0 .. N)
        inv[vec[i]] = i;
    return mrRank1(N);
}

void main() {
    import std.random;

    uint[4] items1 = void;
    immutable rMax1 = items1.length.factorial;
    for (TRank rank = 0; rank < rMax1; rank++) {
        items1.computePermutation(rank);
        writefln("%3d: %s = %d", rank, items1, items1.computeRank);
    }
    writeln;

    uint[21] items2 = void;
    immutable rMax2 = items2.length.factorial;
    foreach (immutable _; 0 .. 5) {
        immutable rank = uniform(0, rMax2);
        items2.computePermutation(rank);
        writefln("%20d: %s = %d", rank, items2, items2.computeRank);
    }
}


' version 31-03-2017
' compile with: fbc -s console

' Myrvold and Ruskey
' only for up to 20 elements, 21! > 2^64 -1
Function Factorial(n As Integer) As ULongInt

    Dim As ULongInt tmp = 1

    For i As ULong = 2 To n
        tmp *= i
    Next

    Return tmp

End Function

Sub unrank1(n As ULong, r As ULongInt , pi() As UByte)

    If n > 0 Then
        Swap pi(n -1), pi(r Mod n)
        unrank1(n -1, (r \ n), pi())
    End If

End Sub

Function rank1(n As ULongInt, pi() As UByte, pi_inv() As UByte) As ULongInt

    If n = 1 Then Return 0

    Dim As UByte s = pi(n -1)

    Swap pi(n -1), pi(pi_inv(n -1))
    Swap pi_inv(s), pi_inv(n -1)

    Return (s + n * rank1(n -1, pi(), pi_inv()))

End Function

Sub unrank2(n As ULong, r As ULongInt, pi() As ubyte)

    If n > 0 Then
        Dim As ULongInt fac = Factorial(n - 1)
        Dim As ULongint s = r \ fac
        Swap pi(n -1), pi(s)
        unrank2(n -1, r - s * fac, pi())
    End If

End Sub

Function rank2(n As ULong, pi() As UByte, pi_inv() As UByte) As ULongInt

    If n = 1 Then Return 0
    Dim As UByte s = pi(n -1)
    Swap pi(n -1), pi(pi_inv(n -1))
    Swap pi_inv(s), pi_inv(n -1)
    Return (s * Factorial(n -1) + rank2(n -1, pi(), pi_inv()))

End Function

' ------=< MAIN >=------

Dim As ULongInt i, i1, j, n, n1
Dim As UByte pi(), pi_inv()
Dim As String frmt1, frmt2
Randomize timer

n = 3 : n1 = Factorial(n)
ReDim pi(n -1), pi_inv(n - 1)
frmt1 = " ###"
frmt2 = "##"

Print "Rank:     unrank1       rank1"

For i = 0 To n1 -1
    For j = 0 To n -1
        pi(j) = j
    Next
    Print Using frmt1 & ": --> "; i;
    unrank1(n, i, pi())
    For j = 0 To n -1
        Print Using frmt2; pi(j);
        pi_inv(pi(j))= j
    Next

    Print Using "  -->" & frmt1; rank1(n, pi(), pi_inv())

Next

n = 12 : n1 = Factorial(n)
ReDim pi(n -1), pi_inv(n - 1)
frmt1 = "###########"
frmt2 = "###"
Print : Print "4 random samples of permutations from 12 objects"
Print "  Rank:                     unrank1                         rank1"

For i = 1 To 4
    i1 = Int(Rnd * n1)
    For j = 0 To n -1 : pi(j) = j : Next
    Print Using frmt1 & ": --> "; i1; : unrank1(n, i1, pi())
    For j = 0 To n -1 : Print Using frmt2; pi(j);
    pi_inv(pi(j))= j : Next
    Print Using "  -->" & frmt1; rank1(n, pi(), pi_inv())
Next

Print : Print String(69,"-") : Print
Print "Rank:     unrank2       rank2"

n = 3 : n1 = Factorial(n)
ReDim pi(n -1), pi_inv(n - 1)
frmt1 = " ###"
frmt2 = "##"

For i = 0 To n1 -1
    For j = 0 To n -1
        pi(j) = j
    Next
    Print Using  frmt1 & ": --> "; i;
    unrank2(n, i, pi())
    For j = 0 To n -1
        Print Using frmt2; pi(j);
        pi_inv(pi(j))= j
    Next

    Print Using "  -->" & frmt1; rank2(n, pi(), pi_inv())

Next

n = 12 : n1 = Factorial(n)
ReDim pi(n -1), pi_inv(n - 1)
frmt1 = "###########"
frmt2 = "###"
Print : Print "4 random samples of permutations from 12 objects"
Print "  Rank:                     unrank2                         rank2"

For i = 1 To 4
    i1 = Int(Rnd * n1)
    For j = 0 To n -1 : pi(j) = j : Next
    Print Using frmt1 & ": --> "; i1; : unrank2(n, i1, pi())
    For j = 0 To n -1 : Print Using frmt2; pi(j);
    pi_inv(pi(j))= j : Next
    Print Using "  -->" & frmt1; rank2(n, pi(), pi_inv())
Next

' empty keyboard buffer
While InKey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End


package main

import (
    "fmt"
    "math/rand"
)

// returns permutation q of n items, using Myrvold-Ruskey rank.
func MRPerm(q, n int) []int {
    p := ident(n)
    var r int
    for n > 0 {
        q, r = q/n, q%n
        n--
        p[n], p[r] = p[r], p[n]
    }
    return p
}

// returns identity permutation of n items.
func ident(n int) []int {
    p := make([]int, n)
    for i := range p {
        p[i] = i
    }
    return p
}

// returns Myrvold-Ruskey rank of permutation p
func MRRank(p []int) (r int) {
    p = append([]int{}, p...)
    inv := inverse(p)
    for i := len(p) - 1; i > 0; i-- {
        s := p[i]
        p[inv[i]] = s
        inv[s] = inv[i]
    }
    for i := 1; i < len(p); i++ {
        r = r*(i+1) + p[i]
    }
    return
}

// returns inverse of a permutation.
func inverse(p []int) []int {
    r := make([]int, len(p))
    for i, x := range p {
        r[x] = i
    }
    return r
}

// returns n!
func fact(n int) (f int) {
    for f = n; n > 2; {
        n--
        f *= n
    }
    return
}

func main() {
    n := 3
    fmt.Println("permutations of", n, "items")
    f := fact(n)
    for i := 0; i < f; i++ {
        p := MRPerm(i, n)
        fmt.Println(i, p, MRRank(p))
    }
    n = 12
    fmt.Println("permutations of", n, "items")
    f = fact(n)
    m := map[int]bool{}
    for len(m) < 4 {
        r := rand.Intn(f)
        if m[r] {
            continue
        }
        m[r] = true
        fmt.Println(r, MRPerm(r, n))
    }
}


fact :: Int -> Int
fact n = product [1 .. n]

-- Always assume elements are unique.

rankPerm [] _ = []
rankPerm list n = c : rankPerm (a ++ b) r
  where
    (q, r) = n `divMod` fact (length list - 1)
    (a, c:b) = splitAt q list

permRank [] = 0
permRank (x:xs) = length (filter (< x) xs) * fact (length xs) + permRank xs

main :: IO ()
main = mapM_ f [0 .. 23]
  where
    f n = print (n, p, permRank p)
      where
        p = rankPerm [0 .. 3] n


import java.math.BigInteger;
import java.util.*;

class RankPermutation
{
  public static BigInteger getRank(int[] permutation)
  {
    int n = permutation.length;
    BitSet usedDigits = new BitSet();
    BigInteger rank = BigInteger.ZERO;
    for (int i = 0; i < n; i++)
    {
      rank = rank.multiply(BigInteger.valueOf(n - i));
      int digit = 0;
      int v = -1;
      while ((v = usedDigits.nextClearBit(v + 1)) < permutation[i])
        digit++;
      usedDigits.set(v);
      rank = rank.add(BigInteger.valueOf(digit));
    }
    return rank;
  }

  public static int[] getPermutation(int n, BigInteger rank)
  {
    int[] digits = new int[n];
    for (int digit = 2; digit <= n; digit++)
    {
      BigInteger divisor = BigInteger.valueOf(digit);
      digits[n - digit] = rank.mod(divisor).intValue();
      if (digit < n)
        rank = rank.divide(divisor);
    }
    BitSet usedDigits = new BitSet();
    int[] permutation = new int[n];
    for (int i = 0; i < n; i++)
    {
      int v = usedDigits.nextClearBit(0);
      for (int j = 0; j < digits[i]; j++)
        v = usedDigits.nextClearBit(v + 1);
      permutation[i] = v;
      usedDigits.set(v);
    }
    return permutation;
  }

  public static void main(String[] args)
  {
    for (int i = 0; i < 6; i++)
    {
      int[] permutation = getPermutation(3, BigInteger.valueOf(i));
      System.out.println(String.valueOf(i) + " --> " + Arrays.toString(permutation) + " --> " + getRank(permutation));
    }
    Random rnd = new Random();
    for (int n : new int[] { 12, 144 })
    {
      BigInteger factorial = BigInteger.ONE;
      for (int i = 2; i <= n; i++)
        factorial = factorial.multiply(BigInteger.valueOf(i));
      // Create 5 random samples
      System.out.println("n = " + n);
      for (int i = 0; i < 5; i++)
      {
        BigInteger rank = new BigInteger((factorial.bitLength() + 1) << 1, rnd);
        rank = rank.mod(factorial);
        int[] permutation = getPermutation(n, rank);
        System.out.println("  " + rank + " --> " + Arrays.toString(permutation) + " --> " + getRank(permutation));
      }
    }
  }

}


# Assuming sufficiently-precise integer arithmetic,
# if the input and $j are integers, then the result will be a pair of integers,
# except that if $j is 0, then an error condition is raised.
def divmod($j):
  . as $i
  | ($i % $j) as $mod
  | [($i - $mod) / $j, $mod] ;

# Input may be an object or an array
def swap($i; $j):
  .[$i] as $t
  | .[$i] = .[$j]
  | .[$j] = $t;

def factorial:
  . as $n
  | reduce range(2; $n) as $i ($n; . * $i);

def lpad($len): tostring | ($len - length) as $l | (" " * $l)[:$l] + .;


using Printf

nobjs = 4
a = collect(1:nobjs)
println("All permutations of ", nobjs, " objects:")
for i in 1:factorial(nobjs)
    p = nthperm(a, i)
    prank = nthperm(p)
    print(@sprintf("%5d => ", i))
    println(p, " (", prank, ")")
end

nobjs = 12
nsamp = 4
ptaken = Int[]
println()
println(nsamp, " random permutations of ", nobjs, " objects:")
for i in 1:nsamp
    p = randperm(nobjs)
    prank = nthperm(p)
    while prank in ptaken
        p = randperm(nobjs)
        prank = nthperm(p)
    end
    push!(ptaken, prank)
    println("         ", p, " (", prank, ")")
end


// version 1.1.2

import java.util.Random

fun IntArray.swap(i: Int, j: Int) {
    val temp = this[i]
    this[i] = this[j]
    this[j] = temp
}

tailrec fun mrUnrank1(rank: Int, n: Int, vec: IntArray) {
    if (n < 1) return
    val q = rank / n
    val r = rank % n
    vec.swap(r, n - 1)
    mrUnrank1(q, n - 1, vec)
}

fun mrRank1(n: Int, vec: IntArray, inv: IntArray): Int {
    if (n < 2) return 0
    val s = vec[n - 1]
    vec.swap(n - 1, inv[n - 1])
    inv.swap(s, n - 1)
    return s + n * mrRank1(n - 1, vec, inv)
}

fun getPermutation(rank: Int, n: Int, vec: IntArray) {
    for (i in 0 until n) vec[i] = i
    mrUnrank1(rank, n, vec)
}

fun getRank(n: Int, vec: IntArray): Int {
    val v   = IntArray(n)
    val inv = IntArray(n)
    for (i in 0 until n) {
        v[i] = vec[i]
        inv[vec[i]] = i
    }
    return mrRank1(n, v, inv)
}

fun main(args: Array<String>) {
    var tv = IntArray(3)
    for (r in 0..5) {
        getPermutation(r, 3, tv)
        System.out.printf("%2d -> %s -> %d\n", r, tv.contentToString(), getRank(3, tv))
    }
    println()
    tv = IntArray(4)
    for (r in 0..23) {
        getPermutation(r, 4, tv)
        System.out.printf("%2d -> %s -> %d\n", r, tv.contentToString(), getRank(4, tv))
    }

    println()
    tv = IntArray(12)
    val a = IntArray(4)
    val rand = Random()
    val fact12 = (2..12).fold(1) { acc, i -> acc * i }
    for (i in 0..3) a[i] = rand.nextInt(fact12)
    for (r in a) {
        getPermutation(r, 12, tv)
        System.out.printf("%9d -> %s -> %d\n", r, tv.contentToString(), getRank(12, tv))
    }
}


fromrank[list_, 0] := list;
fromrank[list_, n_] :=
  Prepend[fromrank[DeleteCases[list, #],
      Mod[n, ([email protected] - 1)!]], #] &@
   RankedMin[list, Quotient[n, ([email protected] - 1)!] + 1];

rank[{}] = 0;
rank[{x_, y___}] := Count[{y}, _?(# < x &)] [email protected]{y}! + rank[{y}];

Print /@ Table[{n, fromrank[{0, 1, 2, 3}, n],
    [email protected][{0, 1, 2, 3}, n]}, {n, 0, 23}];

Do[[email protected][Range[0, 12 - 1], RandomInteger[12!]], {4}];
Do[[email protected][Range[0, 144 - 1], RandomInteger[144!]], {4}];


func mrUnrank1(vec: var openArray[int]; rank, n: int) =
  if n < 1: return
  let q = rank div n
  let r = rank mod n
  swap vec[r], vec[n - 1]
  vec.mrUnrank1(q, n - 1)

func mrRank1(vec, inv: var openArray[int]; n: int): int =
  if n < 2: return 0
  let s = vec[n - 1]
  swap vec[n - 1], vec[inv[n - 1]]
  swap inv[s], inv[n - 1]
  result = s + n * vec.mrRank1(inv, n - 1)

func getPermutation(vec: var openArray[int]; rank: int) =
  for i in 0..vec.high: vec[i] = i
  vec.mrUnrank1(rank, vec.len)

func getRank(vec: openArray[int]): int =
  var v, inv = newSeq[int](vec.len)
  for i, val in vec:
    v[i] = val
    inv[val] = i
  result = v.mrRank1(inv, vec.len)

when isMainModule:

  import math, random, sequtils, strformat

  randomize()

  var tv3: array[3, int]
  for r in 0..5:
    tv3.getPermutation(r)
    echo &"{r:>2} → {tv3} → {tv3.getRank()}"

  echo ""
  var tv4: array[4, int]
  for r in 0..23:
    tv4.getPermutation(r)
    echo &"{r:>2} → {tv4} → {tv4.getRank()}"

  echo ""
  var tv12: array[12, int]
  for r in newSeqWith(4, rand(fac(12))):
    tv12.getPermutation(r)
    echo &"{r:>9} → {tv12} → {tv12.getRank()}"


use ntheory qw/:all/;

my $n = 3;
print "    Iterate Lexicographic rank/unrank of $n objects\n";
for my $k (0 .. factorial($n)-1) {
  my @perm = numtoperm($n, $k);
  my $rank = permtonum(\@perm);
  die unless $rank == $k;
  printf "%2d --> [@perm] --> %2d\n", $k, $rank;
}
print "\n";

print "    Four 12-object random permutations using ranks\n";
print join(" ", numtoperm(12,urandomm(factorial(12)))), "\n"  for 1..4;
print "\n";
print "    Four 12-object random permutations using randperm\n";
print join(" ", randperm(12)),"\n"  for 1..4;
print "\n";
print "    Four 4-object random permutations of 100k objects using randperm\n";
print join(" ", randperm(100000,4)),"\n"  for 1..4;


with javascript_semantics
function get_rank(sequence l)
    integer r = length(l)
    sequence inv = repeat(0,r)
    for i=1 to r do
        inv[l[i]+1] = i-1
    end for
    integer res = 0, mul = 1
    l = deep_copy(l)
    for n=r to 2 by -1 do
        integer s = l[n]
        l[inv[n]+1] = s
        inv[s+1] = inv[n]
        res += s*mul
        mul *= n
    end for
    return res
end function

puts(1,"rank->permute->rank:\n")
sequence l = tagset(2,0)
for n=1 to factorial(length(l)) do
    sequence p = permute(n,l)
    ?{n-1,p,get_rank(p)}
end for

puts(1,"4 random individual samples of 12 items:\n")
l = tagset(11,0)
for i=1 to 4 do
    ?permute(rand(factorial(12)),l)
end for


from math import factorial as fact
from random import randrange
from textwrap import wrap

def identity_perm(n):
    return list(range(n))

def unranker1(n, r, pi):
    while n > 0:
        n1, (rdivn, rmodn) = n-1, divmod(r, n)
        pi[n1], pi[rmodn] = pi[rmodn], pi[n1]
        n = n1
        r = rdivn
    return pi

def init_pi1(n, pi):
    pi1 = [-1] * n
    for i in range(n):
        pi1[pi[i]] = i
    return pi1

def ranker1(n, pi, pi1):
    if n == 1:
        return 0
    n1 = n-1
    s = pi[n1]
    pi[n1], pi[pi1[n1]] = pi[pi1[n1]], pi[n1]
    pi1[s], pi1[n1] = pi1[n1], pi1[s]
    return s + n * ranker1(n1, pi, pi1)

def unranker2(n, r, pi):
    while n > 0:
        n1 = n-1
        s, rmodf = divmod(r, fact(n1))
        pi[n1], pi[s] = pi[s], pi[n1]
        n = n1
        r = rmodf
    return pi

def ranker2(n, pi, pi1):
    if n == 1:
        return 0
    n1 = n-1
    s = pi[n1]
    pi[n1], pi[pi1[n1]] = pi[pi1[n1]], pi[n1]
    pi1[s], pi1[n1] = pi1[n1], pi1[s]
    return s * fact(n1) + ranker2(n1, pi, pi1)

def get_random_ranks(permsize, samplesize):
    perms = fact(permsize)
    ranks = set()
    while len(ranks) < samplesize:
        ranks |= set( randrange(perms)
                      for r in range(samplesize - len(ranks)) )
    return ranks

def test1(comment, unranker, ranker):
    n, samplesize, n2 = 3, 4, 12
    print(comment)
    perms = []
    for r in range(fact(n)):
        pi = identity_perm(n)
        perm = unranker(n, r, pi)
        perms.append((r, perm))
    for r, pi in perms:
        pi1 = init_pi1(n, pi)
        print('  From rank %2i to %r back to %2i' % (r, pi, ranker(n, pi[:], pi1)))
    print('\n  %i random individual samples of %i items:' % (samplesize, n2))
    for r in get_random_ranks(n2, samplesize):
        pi = identity_perm(n2)
        print('    ' + ' '.join('%2i' % i for i in unranker(n2, r, pi)))
    print('')

def test2(comment, unranker):
    samplesize, n2 = 4, 144
    print(comment)
    print('  %i random individual samples of %i items:' % (samplesize, n2))
    for r in get_random_ranks(n2, samplesize):
        pi = identity_perm(n2)
        print('    ' + '\n      '.join(wrap(repr(unranker(n2, r, pi)))))
    print('')

if __name__ == '__main__':
    test1('First ordering:', unranker1, ranker1)
    test1('Second ordering:', unranker2, ranker2)
    test2('First ordering, large number of perms:', unranker1)


#lang racket (require math)
(define-syntax def (make-rename-transformer #'match-define-values))

(define (perm xs n)
  (cond [(empty? xs) '()]
        [else (def (q r) (quotient/remainder n (factorial (sub1 (length xs)))))
              (def (a (cons c b)) (split-at xs q))
              (cons c (perm (append a b) r))]))

(define (rank ys)
  (cond [(empty? ys) 0]
        [else (def ((cons x0 xs)) ys)
              (+ (rank xs)
                 (* (for/sum ([x xs] #:when (< x x0)) 1)
                    (factorial (length xs))))]))


use v6;

sub rank2inv ( $rank, $n = * ) {
    $rank.polymod( 1 ..^ $n );
}

sub inv2rank ( @inv ) {
    [+] @inv Z* [\*] 1, 1, * + 1 ... *
}

sub inv2perm ( @inv, @items is copy = ^@inv.elems ) {
    my @perm;
    for @inv.reverse -> $i {
        @perm.append: @items.splice: $i, 1;
    }
    @perm;
}

sub perm2inv ( @perm ) {     #not in linear time
    (
        { @perm[++$ .. *].grep( * < $^cur ).elems } for @perm;
    ).reverse;
}

for ^6 {
    my @row.push: $^rank;
    for ( *.&rank2inv(3) , &inv2perm, &perm2inv, &inv2rank )  -> &code {
        @row.push: code( @row[*-1] );
    }
    say @row;
}

my $perms =  4;      #100;
my $n     = 12;      #144;

say 'Via BigInt rank';
for ( ( ^([*] 1 .. $n) ).pick($perms) ) {
    say $^rank.&rank2inv($n).&inv2perm;
};

say 'Via inversion vectors';
for ( { my $i=0;  inv2perm (^++$i).roll xx $n } ... *  ).unique( with => &[eqv] ).[^$perms] {
    .say;
};

say 'Via Raku method pick';
for ( { [(^$n).pick(*)] } ... * ).unique( with => &[eqv] ).head($perms) {
    .say
};


/*REXX program displays permutations of   N   number of  objects  (1, 2, 3,  ···).      */
parse arg N y seed .                             /*obtain optional arguments from the CL*/
if N=='' | N==","  then N=  4                    /*Not specified?  Then use the default.*/
if y=='' | y==","  then y= 17                    /* "      "         "   "   "     "    */
if datatype(seed,'W')  then call random ,,seed   /*can make RANDOM numbers repeatable.  */
permutes= permSets(N)                            /*returns  N! (number of permutations).*/
w= length(permutes)                              /*used for aligning the  SAY  output.  */
@.=
      do p=0  for permutes                       /*traipse through each of the permutes.*/
      z= permSets(N, p)                          /*get which of the  permutation  it is.*/
      say 'for'     N     "items, permute rank"      right(p,w)        'is: '        z
      @.p= z                                     /*define a rank permutation in @ array.*/
      end   /*p*/
say                                              /* [↓]  displays a particular perm rank*/
say '  the permutation rank of'  y  "is: "   @.y /*display a particular permutation rank*/
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
permSets:   procedure expose @. #;     #= 0;   parse arg x,r,c;   c= space(c);    xm= x -1
                    do j=1  for x;     @.j= j-1;   end  /*j*/
            _=0;    do u=2  for xm;    _= _ @.u;   end  /*u*/
            if r==#  then return _;            if c==_  then return #
                    do  while .permSets(x,0);  #= #+1;            _= @.1
                       do v=2  for xm;    _= _  @.v;    end  /*v*/
                    if r==#  then return  _;   if c==_  then return #
                    end   /*while···*/
            return #+1
/*──────────────────────────────────────────────────────────────────────────────────────*/
.permSets:  procedure expose @.;       parse arg p,q;                  pm= p-1
                 do k=pm  by -1  for pm;   kp= k+1;  if @.k<@.kp  then do; q=k; leave; end
                 end   /*k*/

                 do j=q+1  while j<p;  parse  value  @.j  @.p   with   @.p  @.j;    p= p-1
                 end   /*j*/
            if q==0  then return 0
                 do p=q+1  while @.p<@.q
                 end   /*p*/
            parse  value   @.p  @.q   with   @.q  @.p
            return 1


# Project : Permutations/Rank of a permutation

list = [0, 1, 2, 3]
for perm = 0 to 23
    str = ""
    for i = 1 to len(list)
        str = str + list[i] + ", "
    next
    see nl
    str = left(str, len(str)-2)
    see "(" + str + ") -> " + perm
    nextPermutation(list)
next

func nextPermutation(a)
     elementcount = len(a)
     if elementcount < 1 then return ok
     pos = elementcount-1
     while a[pos] >= a[pos+1]
           pos -= 1
           if pos <= 0 permutationReverse(a, 1, elementcount)
              return
           ok
     end
     last = elementcount
     while a[last] <= a[pos]
           last -= 1
     end
     temp = a[pos]
     a[pos] = a[last]
     a[last] = temp
     permutationReverse(a, pos+1, elementcount)

 func permutationReverse(a, first, last)
      while first < last
            temp = a[first]
            a[first] = a[last]
            a[last] = temp
            first = first + 1
            last = last - 1
      end


class Permutation
  include Enumerable
  attr_reader :num_elements, :size

  def initialize(num_elements)
    @num_elements = num_elements
    @size = fact(num_elements)
  end

  def each
    return self.to_enum unless block_given?
    (0[email protected]).each{|i| yield unrank(i)}
  end

  def unrank(r)  # nonrecursive version of Myrvold Ruskey unrank2 algorithm.
    pi = (0...num_elements).to_a
    (@num_elements-1).downto(1) do |n|
      s, r = r.divmod(fact(n))
      pi[n], pi[s] = pi[s], pi[n]
    end
    pi
  end

  def rank(pi)  # nonrecursive version of Myrvold Ruskey rank2 algorithm.
    pi = pi.dup
    pi1 = pi.zip(0...pi.size).sort.map(&:last)
    (pi.size-1).downto(0).inject(0) do |memo,i|
      pi[i], pi[pi1[i]] = pi[pi1[i]], (s = pi[i])
      pi1[s], pi1[i] = pi1[i], pi1[s]
      memo += s * fact(i)
    end
  end

  private
  def fact(n)
    n.zero? ? 1 : n.downto(1).inject(:*)
  end
end


import scala.math._

def factorial(n: Int): BigInt = {
  (1 to n).map(BigInt.apply).fold(BigInt(1))(_ * _)
}

def indexToPermutation(n: Int, x: BigInt): List[Int] = {
  indexToPermutation((0 until n).toList, x)
}

def indexToPermutation(ns: List[Int], x: BigInt): List[Int] = ns match {
  case Nil => Nil
  case _ => {
    val (iBig, xNew) = x /% factorial(ns.size - 1)
    val i = iBig.toInt
    ns(i) :: indexToPermutation(ns.take(i) ++ ns.drop(i + 1), xNew)
  }
}

def permutationToIndex[A](xs: List[A])(implicit ord: Ordering[A]): BigInt = xs match {
  case Nil => BigInt(0)
  case x :: rest => factorial(rest.size) * rest.count(ord.lt(_, x)) + permutationToIndex(rest)
}


# A functional swap routine
proc swap {v idx1 idx2} {
    lset v $idx2 [lindex $v $idx1][lset v $idx1 [lindex $v $idx2];subst ""]
}

# Fill the integer array <vec> with the permutation at rank <rank>
proc computePermutation {vecName rank} {
    upvar 1 $vecName vec
    if {![info exist vec] || ![llength $vec]} return
    set N [llength $vec]
    for {set n 0} {$n < $N} {incr n} {lset vec $n $n}
    for {set n $N} {$n>=1} {incr n -1} {
	set r [expr {$rank % $n}]
	set rank [expr {$rank / $n}]
	set vec [swap $vec $r [expr {$n-1}]]
    }
}

# Return the rank of the current permutation.
proc computeRank {vec} {
    if {![llength $vec]} return
    set inv [lrepeat [llength $vec] 0]
    set i -1
    foreach v $vec {lset inv $v [incr i]}
    # First argument is lambda term
    set mrRank1 {{f n vec inv} {
	if {$n < 2} {return 0}
	set s [lindex $vec [set n1 [expr {$n - 1}]]]
	set vec [swap $vec $n1 [lindex $inv $n1]]
	set inv [swap $inv $s $n1]
	return [expr {$s + $n * [apply $f $f $n1 $vec $inv]}]
    }}
    return [apply $mrRank1 $mrRank1 [llength $vec] $vec $inv]
}


import "random" for Random
import "/fmt" for Fmt

var swap = Fn.new { |a, i, j|
    var t = a[i]
    a[i] = a[j]
    a[j] = t
}

var mrUnrank1 // recursive
mrUnrank1 = Fn.new { |rank, n, vec|
    if (n < 1) return
    var q = (rank/n).floor
    var r = rank % n
    swap.call(vec, r, n - 1)
    mrUnrank1.call(q, n - 1, vec)
}

var mrRank1 // recursive
mrRank1 = Fn.new { |n, vec, inv|
    if (n < 2) return 0
    var s = vec[n-1]
    swap.call(vec, n - 1, inv[n-1])
    swap.call(inv, s, n - 1)
    return s + n * mrRank1.call(n - 1, vec, inv)
}

var getPermutation = Fn.new { |rank, n, vec|
    for (i in 0...n) vec[i] = i
    mrUnrank1.call(rank, n, vec)
}

var getRank = Fn.new { |n, vec|
    var v   = List.filled(n, 0)
    var inv = List.filled(n, 0)
    for (i in 0...n) {
        v[i] = vec[i]
        inv[vec[i]] = i
    }
    return mrRank1.call(n, v, inv)
}

var tv = List.filled(3, 0)
for (r in 0..5) {
    getPermutation.call(r, 3, tv)
    Fmt.print("$2d -> $n -> $d", r, tv, getRank.call(3, tv))
}
System.print()
tv = List.filled(4, 0)
for (r in 0..23) {
    getPermutation.call(r, 4, tv)
    Fmt.print("$2d -> $n -> $d", r, tv, getRank.call(4, tv))
}
System.print()
tv = List.filled(12, 0)
var a = List.filled(4, 0)
var rand = Random.new()
var fact12 = (2..12).reduce(1) { |acc, i| acc * i }
for (i in 0..3) a[i] = rand.int(fact12)
for (r in a) {
    getPermutation.call(r, 12, tv)
    Fmt.print("$9d -> $n -> $d", r, tv, getRank.call(12, tv))
}


fcn computePermutation(items,rank){  // in place permutation of items
   foreach n in ([items.len()..1,-1]){
      r:=rank%n;
      rank/=n;
      items.swap(r,n-1);
   }
   items
}


F derangements(n)
   [[Int]] r
   V perm = Array(0 .< n)
   L
      I all(enumerate(perm).map((indx, p) -> indx != p))
         r [+]= perm
      I !perm.next_permutation()
         L.break
   R r

F subfact(n) -> Int64
   R I n < 2 {1 - n} E (subfact(n - 1) + subfact(n - 2)) * (n - 1)

V n = 4
print(‘Derangements of ’Array(0 .< n))
L(d) derangements(n)
   print(‘  ’d)

print("\nTable of n vs counted vs calculated derangements")
L(n) 10
   print(‘#2 #<6 #.’.format(n, derangements(n).len, subfact(n)))

n = 20
print("\n!#. = #.".format(n, subfact(n)))


*        Permutations/Derangements 01/04/2017
DERANGE  CSECT
         USING  DERANGE,R13        base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         STM    R14,R12,12(R13)    save previous context
         ST     R13,4(R15)         link backward
         ST     R15,8(R13)         link forward
         LR     R13,R15            set addressability
         XPRNT  PG1,L'PG1          print title
         LA     R1,4               4
         LA     R2,1               1 : combinations print
         BAL    R14,DERGEN         call dergen
         STH    R0,COUNT           count=dergen(4,1)
         XPRNT  PG2,L'PG2          print table headings
         XPRNT  PG3,L'PG3          print hyphens
         SR     R4,R4
         STH    R4,II              ii=0
       DO WHILE=(CH,R4,LE,=H'9')   do ii=0 to 9
         MVC    PG,=CL80' '          clear buffer
         XDECO  R4,PG                edit ii
         LR     R1,R4                ii
         LA     R2,0                 0 : no combination print
         BAL    R14,DERGEN           dergen(ii,0)
         XDECO  R0,PG+12             edit
         LH     R1,II                ii
         BAL    R14,SUBFACT          subfact(ii)
         XDECO  R0,PG+24             edit
         XPRNT  PG,L'PG              print
         LH     R4,II                ii
         LA     R4,1(R4)             i+1
         STH    R4,II                i=i+1
       ENDDO    ,                  enddo i
         LA     R0,12              12
         STH    R0,II              ii=12
         MVC    PG,=CL16'!xx='     init buffer
         XDECO  R0,XDEC            edit ii
         MVC    PG+1(2),XDEC+10    output
         LH     R1,II              ii
         BAL    R14,SUBFACT        subfact(ii)
         XDECO  R0,PG+4            edit subfact(ii)
         XPRNT  PG,16              print
         L      R13,4(0,R13)       restore previous savearea pointer
         LM     R14,R12,12(R13)    restore previous context
         XR     R15,R15            rc=0
         BR     R14                exit
*------- ----   -------------------------------------------
DERGEN   EQU    *                  dergen(n,fprt)
         ST     R14,SAVEDG
         ST     R1,N               n
         ST     R2,FPRT            fprt
       IF LTR,R1,Z,R1 THEN         if n=0 then
         LA     R0,1                 1
         B      RETDG                return(1)
       ENDIF    ,                  endif
         MVC    C,=F'0'            c=0
         LA     R6,1               i=1
       DO WHILE=(C,R6,LE,N)        do i=1 to 2
         LR     R1,R6                i
         SLA    R1,1
         STH    R6,A-2(R1)           a(i)=i
         STH    R6,AO-2(R1)          ao(i)=i
         LA     R6,1(R6)             i++
       ENDDO    ,                  enddo i
         L      R1,N               n
         BAL    R14,FACT
         ST     R0,FACTNM1         fact(n)-1
         SR     R6,R6              i=0
       DO WHILE=(C,R6,LE,FACTNM1)  do i=0 to fact(n)-1
         L      R1,N                 n
         BAL    R14,NEXTPER          call nextper(n)
         MVI    D,X'01'              d=true
         LA     R7,1
       DO WHILE=(C,R7,LE,N)          do j=1 to n
         LR     R1,R7                  j
         SLA    R1,1
         LH     R2,A-2(R1)             a(j)
         LH     R3,AO-2(R1)            ao(j)
       IF CR,R2,EQ,R3 THEN             if a(j)=ao(j) then
         MVI    D,X'00'                  d=false
       ENDIF    ,                      endif
         LA     R7,1(R7)               j++
       ENDDO    ,                    enddo j
       IF CLI,D,EQ,X'01' THEN        if d then
         L      R2,C                   c
         LA     R2,1(R2)               c+1
         ST     R2,C                   c=c+1
       IF CLI,FPRT+3,EQ,X'01' THEN     if fprt=1 then
         MVC    PG,=CL80' '              clear buffer
         LA     R10,PG                   pgi=0
         LA     R7,1                     j=1
       DO WHILE=(C,R7,LE,N)              do j=1 to n
         LR     R1,R7                      j
         SLA    R1,1
         LH     R2,A-2(R1)                 a(j)
         XDECO  R2,XDEC                    edit
         MVC    0(1,R10),XDEC+11           output
         LA     R10,2(R10)                 pgi=pgi+2
         LA     R7,1(R7)                   j++
        ENDDO    ,                        enddo j
         XPRNT  PG,L'PG                   print
       ENDIF    ,                      endif
       ENDIF    ,                    endif
         LA     R6,1(R6)             i++
        ENDDO    ,                 enddo i
         L      R0,C               c
         B      RETDG              return(c)
RETDG    L      R14,SAVEDG
         BR     R14
SAVEDG   DS     A
*------- ----   -------------------------------------------
NEXTPER  EQU    *                  nextper(nk)
         ST     R14,SAVENP
         ST     R1,NK              nk
         BCTR   R1,0               nk-1
         ST     R1,NELEM           nelem=nk-1
       IF C,R1,LT,=F'1' THEN       if nelem<1 then
         LA     R0,0                 return(0)
         B      RETNP
       ENDIF    ,                  endif
         L      R8,NELEM           nelem
         BCTR   R8,0               pos=nelem-1
LOOPW1   EQU    *                  while a(pos+1)>=a(pos+2)
         LR     R1,R8                pos
         SLA    R1,1
         LH     R2,A(R1)             a(pos+1)
         CH     R2,A+2(R1)           if a(pos+1)<a(pos+2)
         BL     ELOOPW1              then exit while
         BCTR   R8,0                 pos=pos-1
       IF LTR,R8,M,R8 THEN           if pos<0 then
         LA     R1,0                   0
         L      R2,NELEM               nelem
         BAL    R14,PERMREV            call permrev(0,nelem)
         LA     R0,0                   return(0)
         B      RETNP
       ENDIF    ,                    endif
         B      LOOPW1             endwhile
ELOOPW1  L      R9,NELEM           last=nelem
LOOPW2   EQU    *                  do while a(last+1)<=a(pos+1)
         LR     R1,R9                last
         SLA    R1,1
         LH     R2,A(R1)             a(last+1)
         LR     R1,R8                pos
         SLA    R1,1
         CH     R2,A(R1)             if a(last+1)>a(pos+1)
         BH     ELOOPW2              then exit while
         BCTR   R9,0                 last=last-1
         B      LOOPW2             endwhile
ELOOPW2  LR     R1,R8              pos
         SLA    R1,1               *2
         LA     R2,A(R1)           @a(pos+1)
         LR     R1,R9              last
         SLA    R1,1
         LA     R3,A(R1)           @a(last+1)
         LH     R0,0(R2)           w=a(pos+1)
         MVC    0(2,R2),0(R3)      a(pos+1)=a(last+1)
         STH    R0,0(R3)           a(last+1)=w
         LA     R1,1(R8)           pos+1
         L      R2,NELEM           nelem
         BAL    R14,PERMREV        call permrev(pos+1,nelem)
RETNP    L      R14,SAVENP
         BR     R14
SAVENP   DS     A
*------- ----   -------------------------------------------
PERMREV  EQU    *                  permrev(firstix,lastix)
         LR     R4,R1              xfirst
         LR     R5,R2              xlast
       DO WHILE=(CR,R4,LT,R5)      do while(xfirst<xlast)
         LR     R1,R4                xfirst
         SLA    R1,1                 *2
         LA     R2,A(R1)             @a(xfirst+1)
         LR     R1,R5                xlast
         SLA    R1,1                 *2
         LA     R3,A(R1)             @a(xlast+1)
         LH     R0,0(R2)             w=a(xfirst+1)
         MVC    0(2,R2),0(R3)        a(xfirst+1)=a(xlast+1)
         STH    R0,0(R3)             a(xlast+1)=w
         LA     R4,1(R4)             xfirst=xfirst+1
         BCTR   R5,0                 xlast=xlast-1
       ENDDO    ,                  enddo
         BR     R14
*------- ----   ----------------------------------------
FACT     EQU    *                  fact(n)
       IF C,R1,LE,=F'1' THEN       if n<=1 then
         LA     R0,1                 return(1)
       ELSE     ,                  else
         LA     R5,1                 f=1
         LA     R2,1                 i=1
       DO WHILE=(CR,R2,LE,R1)        do i=1 to n
         MR     R4,R2                  f*i
         LA     R2,1(R2)               i++
       ENDDO    ,                    enddo
         LR     R0,R5                return(f)
       ENDIF    ,                  endif
         BR     R14
*------- ----   -------------------------------------------
SUBFACT  EQU    *                  subfact(n)
         ST     R1,NY              n
       IF LTR,R1,Z,R1 THEN         if n=0 then
         LA     R0,1                 return(1)
       ELSE     ,                  else
         LA     R4,1                 1
         ST     R4,TT                tt(0)=1
         ST     R4,IY                i=1
       DO WHILE=(C,R4,LE,NY)         do i=1 to n
         L      R4,IY                  i
         SRDA   R4,32
         D      R4,=F'2'               i/2
       IF LTR,R4,Z,R4 THEN             if i//2=0 then
         LA     R0,1                     nn=1
       ELSE     ,                      else
         L      R0,=F'-1'                nn=-1
       ENDIF    ,                      endif
         L      R1,IY                  i
         SLA    R1,2
         L      R3,TT-4(R1)            tt(i-1)
         M      R2,IY                  *i
         AR     R3,R0                  +nn
         L      R1,IY                  i
         SLA    R1,2
         ST     R3,TT(R1)              tt(i)=i*tt(i-1)+nn
         L      R4,IY                  i
         LA     R4,1(R4)               i++
         ST     R4,IY                  i
       ENDDO    ,                    enddo
         L      R1,NY                n
         SLA    R1,2
         L      R0,TT(R1)            return(tt(n))
       ENDIF    ,                  endif
         BR     R14
*        ----   -------------------------------------------
A        DS     12H                A work
AO       DS     12H                A origin
II       DS     H
COUNT    DS     H
N        DS     F
FPRT     DS     F                  flag for printing
C        DS     F
D        DS     X                  boolean : a(i) different ao(i)
FACTNM1  DS     F                  fact(n)-1
NK       DS     F                  n           in nextper
NELEM    DS     F                  n elements  in nextper
NY       DS     F                  n           in subfact
IY       DS     F                  i           in subfact
TT       DS     13F                tt(0:12)
PG1      DC     CL44'derangements for the numbers : 1 2 3 4 are :'
PG2      DC     CL38'  table of n     counted  calculated :'
PG3      DC     CL36' ----------- ----------- -----------'
XDEC     DS     CL12               temp for xdeco
PG       DC     CL80' '            buffer
         YREGS
         END    DERANGE


with Ada.Text_IO; use Ada.Text_IO;
procedure DePermute is
   type U64 is mod 2**64;
   type Num is range 0 .. 20;
   type NumList is array (Natural range <>) of Num;
   type PtNumList is access all NumList;
   package IO is new Ada.Text_IO.Integer_IO (Num);
   package UIO is new Ada.Text_IO.Modular_IO (U64);

   function deranged (depth : Natural; list : PtNumList;
      show : Boolean) return U64 is
      tmp : Num;  count : U64 := 0;
   begin
      if depth = list'Length then
         if show then
            for i in list'Range loop IO.Put (list (i), 2); end loop;
            New_Line;
         end if;  return 1;
      end if;
      for i in reverse depth .. list'Last loop
         if Num (i + 1) /= list (depth) then
            tmp := list (i); list (i) := list (depth); list (depth) := tmp;
            count := count + deranged (depth + 1, list, show);
            tmp := list (i); list (i) := list (depth); list (depth) := tmp;
         end if;
      end loop;
      return count;
   end deranged;

   function gen_n (len : Natural; show : Boolean) return U64 is
      list : PtNumList;
   begin
      list := new NumList (0 .. len - 1);
      for i in list'Range loop list (i) := Num (i + 1); end loop;
      return deranged (0, list, show);
   end gen_n;

   function sub_fact (n : Natural) return U64 is begin
      if n < 2 then return U64 (1 - n);
      else return (sub_fact (n - 1) + sub_fact (n - 2)) * U64 (n - 1);
      end if;
   end sub_fact;

   count : U64;
begin
   Put_Line ("Deranged 4:");
   count := gen_n (4, True);
   Put_Line ("List vs. calc:");
   for i in Natural range 0 .. 9 loop
      IO.Put (Num (i), 1);  UIO.Put (gen_n (i, False), 7);
      UIO.Put (sub_fact (i), 7);  New_Line;
   end loop;
   Put_Line ("!20 = " & U64'Image (sub_fact (20)));
end DePermute;


isClean?: function [s,o][
    loop.with:'i s 'a [
        if a = o\[i] -> return false
    ]
    return true
]

derangements: function [n][
    original: 1..n
    select permutate original 'x ->
        isClean? x original
]

subfactorial: function [n].memoize[
    (n =< 1)? -> 1 - n
              -> (n-1) * (add subfactorial n-1 subfactorial n-2)
]

print "Derangements of 1 2 3 4:"
loop derangements 4 'x [
    print x
]

print "\nNumber of derangements:"
print [pad "n" 5 pad "counted" 15 pad "calculated" 15]
print repeat "-" 39
loop 0..9 'z [
    counted: size derangements z
    calculated: subfactorial z
    print [pad to :string z 5 pad to :string counted 15 pad to :string calculated 15]
]

print ~"\n!20 = |subfactorial 20|"


#NoEnv
SetBatchLines -1
Process, Priority,, high

output := "Derangements for 1, 2, 3, 4:`n"

obj := [1, 2, 3, 4], objS := obj.Clone()
Loop ; permute 4
{
	obj := perm_NextObj(Obj)
	If !obj
		break
	For k, v in obj
		if ( objS[k] = v )
			continue 2
	output .= ObjDisp(obj) "`n"
}
output .= "`nTable of n, counted, calculated derangements:`n"

Loop 10 ; Count !n
{
	obj := []
	count := 0
	output .= A_Tab . (i := A_Index-1) . A_Tab
	Loop % i
		obj[A_Index] := A_Index
	objS := obj.Clone()
	Loop
	{
		obj := perm_NextObj(Obj)
		If !obj
			break
		For k, v in obj
			if ( objS[k] = v )
				continue 2
		count++
	}
	output .= count . A_Tab . cd(i) . "`n"
}
output .= "`nApproximation of !20: " . cd(20)
MsgBox % Clipboard := output

perm_NextObj(obj){ ; next lexicographic permutation
	p := 0, objM := ObjMaxIndex(obj)
	Loop % objM
	{
		If A_Index=1
			continue
		t := obj[objM+1-A_Index]
		n := obj[objM+2-A_Index]
		If ( t < n )
		{
			p := objM+1-A_Index, pC := obj[p]
			break
		}
	}
	If !p
		return false
	Loop
	{
		t := obj[objM+1-A_Index]
		If ( t > pC )
		{
			n := objM+1-A_Index, nC := obj[n]
			break
		}
	}

	obj[n] := pC, obj[p] := nC
	return ObjReverse(obj, objM-p)
}

ObjReverse(Obj, tail){
 o := ObjClone(Obj), ObjM := ObjMaxIndex(O)
 Loop % tail
	o[ObjM-A_Index+1] := Obj[ObjM+A_Index-tail]
 return o
}

ObjDisp(obj){
	For k, v in obj
		s .= v ", "
	return SubStr(s, 1, strLen(s)-2)
}

cd(n){  ; Count Derangements
	static e := 2.71828182845904523536028747135
	return n ? floor(ft(n)/e + 1/2) : 1
}
ft(n){  ; FacTorial
	a := 1
	Loop % n
		a *= A_Index
	return a
}


      PRINT"Derangements for the numbers 0,1,2,3 are:"
      Count% = FN_Derangement_Generate(4,TRUE)

      PRINT'"Table of n, counted derangements, calculated derangements :"

      FOR I% = 0 TO 9
        PRINT I%, FN_Derangement_Generate(I%,FALSE), FN_SubFactorial(I%)
      NEXT

      PRINT'"There is no long int in BBC BASIC!"
      PRINT"!20 = ";FN_SubFactorial(20)

      END

      DEF FN_Derangement_Generate(N%, fPrintOut)
      LOCAL A%(), O%(), C%, D%, I%, J%
      IF N% = 0 THEN = 1
      DIM A%(N%-1), O%(N%-1)
      FOR I% = 0 TO N%-1 : A%(I%) = I% : NEXT
      O%() = A%()
      FOR I% = 0 TO FN_Factorial(DIM(A%(),1)+1)-1
        PROC_NextPermutation(A%())
        D% = TRUE
        FOR J%=0 TO N%-1
          IF A%(J%) = O%(J%) THEN D% = FALSE
        NEXT
        IF D% THEN
          C% += 1
          IF fPrintOut THEN
            FOR K% = 0 TO N%-1
              PRINT ;A%(K%);" ";
            NEXT
            PRINT
          ENDIF
        ENDIF
      NEXT
      = C%

      DEF PROC_NextPermutation(A%())
      LOCAL first, last, elementcount, pos
      elementcount = DIM(A%(),1)
      IF elementcount < 1 THEN ENDPROC
      pos = elementcount-1
      WHILE A%(pos) >= A%(pos+1)
        pos -= 1
        IF pos < 0 THEN
          PROC_Permutation_Reverse(A%(), 0, elementcount)
          ENDPROC
        ENDIF
      ENDWHILE
      last = elementcount
      WHILE A%(last) <= A%(pos)
        last -= 1
      ENDWHILE
      SWAP A%(pos), A%(last)
      PROC_Permutation_Reverse(A%(), pos+1, elementcount)
      ENDPROC

      DEF PROC_Permutation_Reverse(A%(), firstindex, lastindex)
      LOCAL first, last
      first = firstindex
      last = lastindex
      WHILE first < last
        SWAP A%(first), A%(last)
        first += 1
        last -= 1
      ENDWHILE
      ENDPROC

      DEF FN_Factorial(N) : IF (N = 1) OR (N = 0) THEN =1 ELSE = N * FN_Factorial(N-1)

      DEF FN_SubFactorial(N) : IF N=0 THEN =1 ELSE =N*FN_SubFactorial(N-1)+-1^N

      REM Or you could use:
      REM DEF FN_SubFactorial(N) : IF N<1 THEN =1 ELSE =(N-1)*(FN_SubFactorial(N-1)+FN_SubFactorial(N-2))


( ( calculated-!n
  =   memo answ
    .   (memo==)
      & ( !arg:0&1
        | !arg:1&0
        | !(memo.):? (!arg.?answ) ?&!answ
        |       (!arg+-1)
              * (calculated-!n$(!arg+-1)+calculated-!n$(!arg+-2))
            : ?answ
          & (!arg.!answ) !(memo.):?(memo.)
          & !answ
        )
  )
& ( counted-!n
  =   p P h H A Z L
    .     !arg:(%?p ?P.?H.?L)
        &   !H
          :   ?A
              (%@?h:~!p)
              (?Z&counted-!n$(!P.!A !Z.!h !L))
      |   !arg:(..?L)
        & 1+!count:?count
        & (!count.!L) !D:?D
        & ~
  )
& out$"Derangements of 1 2 3 4"
& :?D
& 0:?count
& ( counted-!n$(4 3 2 1.4 3 2 1.)
  | out$!D
  )
& ( pad
  =   len w
    .   @(!arg:? [?len)
      & @("       ":? [!len ?w)
      & !w !arg
  )
& :?K
& -1:?N
& out$(str$(N pad$List pad$Calc))
&   whl
  ' ( !N+1:<10:?N
    & (   0:?count
        & :?D
        & counted-!n$(!K.!K.)
      | out$(str$(!N pad$!count pad$(calculated-!n$!N)))
      )
    & !N !K:?K
    )
& out$("!20 =" calculated-!n$20)
& lst$calculated-!n
)


#include <stdio.h>
typedef unsigned long long LONG;

LONG deranged(int depth, int len, int *d, int show)
{
        int i;
        char tmp;
        LONG count = 0;

        if (depth == len) {
                if (show) {
                        for (i = 0; i < len; i++) putchar(d[i] + 'a');
                        putchar('\n');
                }
                return 1;
        }
        for (i = len - 1; i >= depth; i--) {
                if (i == d[depth]) continue;

                tmp = d[i]; d[i] = d[depth]; d[depth] = tmp;
                count += deranged(depth + 1, len, d, show);
                tmp = d[i]; d[i] = d[depth]; d[depth] = tmp;
        }
        return count;
}

LONG gen_n(int n, int show)
{
        LONG i;
        int a[1024]; /* 1024 ought to be big enough for anybody */

        for (i = 0; i < n; i++) a[i] = i;
        return deranged(0, n, a, show);
}

LONG sub_fact(int n)
{
        return n < 2 ? 1 - n : (sub_fact(n - 1) + sub_fact(n - 2)) * (n - 1);
}

int main()
{
        int i;

        printf("Deranged Four:\n");
        gen_n(4, 1);

        printf("\nCompare list vs calc:\n");
        for (i = 0; i < 10; i++)
                printf("%d:\t%llu\t%llu\n", i, gen_n(i, 0), sub_fact(i));

        printf("\nfurther calc:\n");
        for (i = 10; i <= 20; i++)
                printf("%d: %llu\n", i, sub_fact(i));

        return 0;
}


using System;
class Derangements
{
  static int n = 4;
  static int [] buf = new int [n];
  static bool [] used = new bool [n];

  static void Main()
  {
    for (int i = 0; i < n; i++) used [i] = false;
    rec(0);
  }

  static void rec(int ind)
  {
    for (int i = 0; i < n; i++)
    {
      if (!used [i] && i != ind)
      {
        used [i] = true;
        buf [ind] = i;
	if (ind + 1 < n) rec(ind + 1);
        else Console.WriteLine(string.Join(",", buf));
	used [i] = false;
      }
    }
  }
}


(ns derangements.core
  (:require [clojure.set :as s]))

(defn subfactorial [n]
  (case n
    0 1
    1 0
    (* (dec n) (+ (subfactorial (dec n)) (subfactorial (- n 2))))))

(defn no-fixed-point
  "f : A -> B must be a biyective function written as a hash-map, returns
  all g : A -> B such that (f(a) = b) => not(g(a) = b)"
  [f]
  (case (count f)
    0 [{}]
    1 []
    (let [g  (s/map-invert f)
          a  (first (keys f))
          a' (f a)]
      (mapcat
       (fn [b'] (let [b  (g b')
                      f' (dissoc f a b)]
                   (concat (map #(reduce conj % [[a b'] [b a']])
                                (no-fixed-point f'))
                           (map #(conj % [a b'])
                                (no-fixed-point (assoc f' b a'))))))
       (filter #(not= a' %) (keys g))))))

(defn derangements [xs]
  {:pre [(= (count xs) (count (set xs)))]}
  (map (fn [f] (mapv f xs))
       (no-fixed-point (into {} (map vector xs xs)))))

(defn -main []
  (do
    (doall (map println (derangements [0,1,2,3])))
    (doall (map #(println (str (subfactorial %) " " (count (derangements (range %)))))
                (range 10)))
    (println (subfactorial 20))))


import std.stdio, std.algorithm, std.typecons, std.conv,
       std.range, std.traits;

T factorial(T)(in T n) pure nothrow @safe @nogc {
    Unqual!T result = 1;
    foreach (immutable i; 2 .. n + 1)
        result *= i;
    return result;
}

T subfact(T)(in T n) pure nothrow @safe @nogc {
    if (0 <= n && n <= 2)
        return n != 1;
    return (n - 1) * (subfact(n - 1) + subfact(n - 2));
}

auto derangements(in size_t n, in bool countOnly=false)
pure nothrow @safe {
    size_t[] seq = n.iota.array;
    auto ori = seq.idup;
    size_t[][] all;
    size_t cnt = n == 0;

    foreach (immutable tot; 0 .. n.factorial - 1) {
        size_t j = n - 2;
        while (seq[j] > seq[j + 1])
            j--;
        size_t k = n - 1;
        while (seq[j] > seq[k])
            k--;
        seq[k].swap(seq[j]);

        size_t r = n - 1;
        size_t s = j + 1;
        while (r > s) {
            seq[s].swap(seq[r]);
            r--;
            s++;
        }

        j = 0;
        while (j < n && seq[j] != ori[j])
            j++;
        if (j == n) {
            if (countOnly)
                cnt++;
            else
                all ~= seq.dup;
        }
    }

    return tuple(all, cnt);
}

void main() @safe {
    "Derangements for n = 4:".writeln;
    foreach (const d; 4.derangements[0])
        d.writeln;

    "\nTable of n vs counted vs calculated derangements:".writeln;
    foreach (immutable i; 0 .. 10)
        writefln("%s  %-7s%-7s", i, derangements(i, 1)[1], i.subfact);

    writefln("\n!20 = %s", 20L.subfact);
}


(lib 'list) ;; in-permutations
(lib 'bigint)

;; generates derangements by filtering out permutations
(define (derangement? nums) ;; predicate
    (for/and ((n nums) (i (length nums))) (!= n i)))

(define (derangements n)
    (for/list ((p (in-permutations n))) #:when (derangement? p) p))

(define (count-derangements n)
    (for/sum ((p (in-permutations n))) #:when (derangement? p) 1))

;;
;;  !n = (n - 1) (!(n-1) + !(n-2))

(define (!n n)
	(* (1- n) (+ (!n (1- n)) (!n (- n 2)))))
(remember '!n #(1 0))


defmodule Permutation do
  def derangements(n) do
    list = Enum.to_list(1..n)
    Enum.filter(permutation(list), fn perm ->
      Enum.zip(list, perm) |> Enum.all?(fn {a,b} -> a != b end)
    end)
  end

  def subfact(0), do: 1
  def subfact(1), do: 0
  def subfact(n), do: (n-1) * (subfact(n-1) + subfact(n-2))

  def permutation([]), do: [[]]
  def permutation(list) do
    for x <- list, y <- permutation(list -- [x]), do: [x|y]
  end
end

IO.puts "derangements for n = 4"
Enum.each(Permutation.derangements(4), &IO.inspect &1)

IO.puts "\nNumber of derangements"
IO.puts " n    derange   subfact"
Enum.each(0..9, fn n ->
  :io.format "~2w :~9w,~9w~n", [n, length(Permutation.derangements(n)), Permutation.subfact(n)]
end)
Enum.each(10..20, fn n ->
  :io.format "~2w :~19w~n", [n, Permutation.subfact(n)]
end)


// Generate derangements. Nigel Galloway: July 9th., 2019
let derange n=
  let fG n i g=let e=Array.copy n in e.[i]<-n.[g]; e.[g]<-n.[i]; e
  let rec derange n g α=seq{
    match (α>0,n&&&(1<<<α)=0) with
     (true,true)->for i in [0..α-1] do if n&&&(1<<<i)=0 then let g=(fG g α i) in yield! derange (n+(1<<<i)) g (α-1); yield! derange n g (α-1)
    |(true,false)->yield! derange n g (α-1)
    |(false,false)->yield g
    |_->()}
  derange 0 [|1..n|] (n-1)


USING: combinators formatting io kernel math math.combinatorics
prettyprint sequences ;
IN: rosetta-code.derangements

: !n ( n -- m )
    {
        { 0 [ 1 ] }
        { 1 [ 0 ] }
        [ [ 1 - !n ] [ 2 - !n + ] [ 1 - * ] tri ]
    } case ;

: derangements ( n -- seq )
    <iota> dup [ [ = ] 2map [ f = ] all? ] with
    filter-permutations ;

"4 derangements" print 4 derangements . nl
"n   count    calc\n=  ======  ======" print
10 <iota> [
    dup [ derangements length ] [ !n ] bi
    "%d%8d%8d\n" printf
] each nl
"!20 = " write 20 !n .


' version 08-04-2017
' compile with: fbc -s console

Sub Subfactorial(a() As ULongInt)

    Dim As ULong i
    Dim As ULongInt num

    For i = 0 To UBound(a)
        num = num * i
        If (i And 1) = 1 Then
            num -= 1
        Else
            num += 1
        End If
        a(i) = num
    Next

End Sub

' Heap's algorithm non-recursive
Function perms_derange(n As ULong, flag As Long = 0) As ULongInt
    ' fast upto n < 12
    If n = 0 Then Return 1

    Dim As ULong i, j, c1, count
    Dim As ULong a(0 To n -1), c(0 To n -1)

    For j = 0 To n -1
        a(j) = j
    Next

    While i < n
        If c(i) < i Then
            If (i And 1) = 0 Then
                Swap a(0), a(i)
            Else
                Swap a(c(i)), a(i)
            End If
            For j = 0 To n -1
                If a(j) = j Then j = 99
            Next
            If j < 99 Then
                count += 1
                If flag = 0 Then
                    c1 += 1
                    For j = 0 To n -1
                        Print a(j);
                    Next
                    If c1 > 12 Then
                        Print : c1 = 0
                    Else
                        Print " ";
                    End If
                End If
            End If
            c(i) += 1
            i = 0
        Else
            c(i) = 0
            i += 1
        End If
    Wend
    If flag = 0 AndAlso c1 <> 0 Then Print
    Return count

End Function

' ------=< MAIN >=------

Dim As ULong i, n = 4
Dim As ULongInt subfac(20)

Subfactorial(subfac())

Print "permutations derangements for n = "; n
i = perms_derange(n)
Print "count returned = "; i; " , !"; n; " calculated = "; subfac(n)

Print
Print "count  counted subfactorial"
Print "---------------------------"
For i = 0 To 9
    Print Using " ###: ########     ########"; i; perms_derange(i, 1); subfac(i)
Next
For i = 10 To 20
    Print Using " ###:   ###################"; i; subfac(i)
Next

' empty keyboard buffer
While InKey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End


package main

import (
    "fmt"
    "math/big"
)

// task 1: function returns list of derangements of n integers
func dList(n int) (r [][]int) {
    a := make([]int, n)
    for i := range a {
        a[i] = i
    }
    // recursive closure permutes a
    var recurse func(last int)
    recurse = func(last int) {
        if last == 0 {
            // bottom of recursion.  you get here once for each permutation.
            // test if permutation is deranged.
            for j, v := range a {
                if j == v {
                    return // no, ignore it
                }
            }
            // yes, save a copy
            r = append(r, append([]int{}, a...))
            return
        }
        for i := last; i >= 0; i-- {
            a[i], a[last] = a[last], a[i]
            recurse(last - 1)
            a[i], a[last] = a[last], a[i]
        }
    }
    recurse(n - 1)
    return
}

// task 3: function computes subfactorial of n
func subFact(n int) *big.Int {
    if n == 0 {
        return big.NewInt(1)
    } else if n == 1 {
        return big.NewInt(0)
    }
    d0 := big.NewInt(1)
    d1 := big.NewInt(0)
    f := new(big.Int)
    for i, n64 := int64(1), int64(n); i < n64; i++ {
        d0, d1 = d1, d0.Mul(f.SetInt64(i), d0.Add(d0, d1))
    }
    return d1
}

func main() {
    // task 2:
    fmt.Println("Derangements of 4 integers")
    for _, d := range dList(4) {
        fmt.Println(d)
    }

    // task 4:
    fmt.Println("\nNumber of derangements")
    fmt.Println("N  Counted  Calculated")
    for n := 0; n <= 9; n++ {
        fmt.Printf("%d %8d %11s\n", n, len(dList(n)), subFact(n).String())
    }

    // stretch (sic)
    fmt.Println("\n!20 =", subFact(20))
}


def fact = { n -> [1,(1..<(n+1)).inject(1) { prod, i -> prod * i }].max() }
def subfact
subfact = { BigInteger n -> (n == 0) ? 1 : (n == 1) ? 0 : ((n-1) * (subfact(n-1) + subfact(n-2))) }

def derangement = { List l ->
    def d = []
  if (l) l.eachPermutation { p -> if ([p,l].transpose().every{ pp, ll -> pp != ll }) d << p }
    d
}


import Control.Monad (forM_)

import Data.List (permutations)

-- Compute all derangements of a list
derangements
  :: Eq a
  => [a] -> [[a]]
derangements = (\x -> filter (and . zipWith (/=) x)) <*> permutations

-- Compute the number of derangements of n elements
subfactorial
  :: (Eq a, Num a)
  => a -> a
subfactorial 0 = 1
subfactorial 1 = 0
subfactorial n = (n - 1) * (subfactorial (n - 1) + subfactorial (n - 2))

main :: IO ()
main
-- Generate and show all the derangements of four integers
 = do
  print $ derangements [1 .. 4]
  putStrLn ""
  -- Print the count of derangements vs subfactorial
  forM_ [1 .. 9] $
    \i ->
       putStrLn $
       mconcat
         [show (length (derangements [1 .. i])), " ", show (subfactorial i)]
  putStrLn ""
  -- Print the number of derangements in a list of 20 items
  print $ subfactorial 20


derangement=: (A.&i.~ !)~ (*/ .~: # [) i.  NB. task item 1
subfactorial=: ! * +/@(_1&^ % !)@[email protected]>:  NB. task item 3


import java.util.ArrayList;
import java.util.Arrays;
import java.util.List;

public class Derangement {

    public static void main(String[] args) {
        System.out.println("derangements for n = 4\n");
        for (Object d  : (ArrayList)(derangements(4, false)[0])) {
            System.out.println(Arrays.toString((int[])d));
        }

        System.out.println("\ntable of n vs counted vs calculated derangements\n");
        for (int i = 0; i < 10; i++) {
            int d = ((Integer)derangements(i, true)[1]).intValue();
            System.out.printf("%d  %-7d %-7d\n", i, d, subfact(i));
        }

        System.out.printf ("\n!20 = %20d\n", subfact(20L));
    }

    static Object[] derangements(int n, boolean countOnly) {
        int[] seq = iota(n);
        int[] ori = Arrays.copyOf(seq, n);
        long tot = fact(n);

        List<int[]> all = new ArrayList<int[]>();
        int cnt = n == 0 ? 1 : 0;

        while (--tot > 0) {
            int j = n - 2;
            while (seq[j] > seq[j + 1]) {
                j--;
            }
            int k = n - 1;
            while (seq[j] > seq[k]) {
                k--;
            }
            swap(seq, k, j);

            int r = n - 1;
            int s = j + 1;
            while (r > s) {
                swap(seq, s, r);
                r--;
                s++;
            }

            j = 0;
            while (j < n && seq[j] != ori[j]) {
                j++;
            }
            if (j == n) {
                if (countOnly) {
                    cnt++;
                } else {
                    all.add(Arrays.copyOf(seq, n));
                }
            }
        }
        return new Object[]{all, cnt};
    }

    static long fact(long n) {
        long result = 1;
        for (long i = 2; i <= n; i++) {
            result *= i;
        }
        return result;
    }

    static long subfact(long n) {
        if (0 <= n && n <= 2) {
            return n != 1 ? 1 : 0;
        }
        return (n - 1) * (subfact(n - 1) + subfact(n - 2));
    }

    static void swap(int[] arr, int lhs, int rhs) {
        int tmp = arr[lhs];
        arr[lhs] = arr[rhs];
        arr[rhs] = tmp;
    }

    static int[] iota(int n) {
        if (n < 0) {
            throw new IllegalArgumentException("iota cannot accept < 0");
        }
        int[] r = new int[n];
        for (int i = 0; i < n; i++) {
            r[i] = i;
        }
        return r;
    }
}


def derangements:

  # In order to reference the original array conveniently, define _derangements(ary):
  def _derangements(ary):
    # We cannot put the i-th element in the i-th place:
    def deranged:  # state: [i, available]
      .[0] as $i | .[1] as $in
      | if $i == (ary|length) then []
        else
        ($in[] | select (. != ary[$i])) as $j
        |  [$j] + ([$i+1, ($in - [$j])] | deranged)
        end
      ;
    [0,ary]|deranged;
    . as $in | _derangements($in);

def subfact:
  if . == 0 then 1
  elif . == 1 then 0
  else (.-1) * (((.-1)|subfact) + ((.-2)|subfact))
  end;

# Avoid creating an array just to count the items in a stream:
def count(g): reduce g as $i (0; . + 1);


using Printf, Combinatorics

derangements(n::Int) = (perm for perm in permutations(1:n)
                        if all(indx != p for (indx, p) in enumerate(perm)))

function subfact(n::Integer)::Integer
    if n in (0, 2)
        return 1
    elseif n == 1
        return 0
    elseif 1 ≤ n ≤ 18
        return round(Int, factorial(n) / e)
    elseif n > 0
        return (n - 1) * ( subfact(n - 1) + subfact(n - 2) )
    else
        error()
    end
end

println("Derangements of [1, 2, 3, 4]")
for perm in derangements(4)
    println(perm)
end

@printf("\n%5s%13s%13s\n", "n", "derangements", "!n")
for n in 1:10
    ders = derangements(n)
    subf = subfact(n)
    @printf("%5i%13i%13i\n", n, length(collect(ders)), subf)
end

println("\n!20 = ", subfact(20))


// version 1.1.2

fun <T> permute(input: List<T>): List<List<T>> {
    if (input.size == 1) return listOf(input)
    val perms = mutableListOf<List<T>>()
    val toInsert = input[0]
    for (perm in permute(input.drop(1))) {
        for (i in 0..perm.size) {
            val newPerm = perm.toMutableList()
            newPerm.add(i, toInsert)
            perms.add(newPerm)
        }
    }
    return perms
}

fun derange(input: List<Int>): List<List<Int>> {
    if (input.isEmpty()) return listOf(input)
    return permute(input).filter { permutation ->
        permutation.filterIndexed { i, index -> i == index }.none()
    }
}

fun subFactorial(n: Int): Long =
    when (n) {
        0 -> 1
        1 -> 0
        else -> (n - 1) * (subFactorial(n - 1) + subFactorial(n - 2))
    }

fun main(args: Array<String>) {
    val input = listOf(0, 1, 2, 3)

    val derangements = derange(input)
    println("There are ${derangements.size} derangements of $input, namely:\n")
    derangements.forEach(::println)

    println("\nN  Counted   Calculated")
    println("-  -------   ----------")
    for (n in 0..9) {
        val list = List(n) { it }
        val counted = derange(list).size
        println("%d  %-9d %-9d".format(n, counted, subFactorial(n)))
    }
    println("\n!20 = ${subFactorial(20)}")
}


-- Return an iterator to produce every permutation of list
function permute (list)
    local function perm (list, n)
        if n == 0 then coroutine.yield(list) end
        for i = 1, n do
            list[i], list[n] = list[n], list[i]
            perm(list, n - 1)
            list[i], list[n] = list[n], list[i]
        end
    end
    return coroutine.wrap(function() perm(list, #list) end)
end

-- Return a copy of table t (wouldn't work for a table of tables)
function copy (t)
    if not t then return nil end
    local new = {}
    for k, v in pairs(t) do new[k] = v end
    return new
end

-- Return true if no value in t1 can be found at the same index of t2
function noMatches (t1, t2)
    for k, v in pairs(t1) do
        if t2[k] == v then return false end
    end
    return true
end

-- Return a table of all derangements of table t
function derangements (t)
    local orig = copy(t)
    local nextPerm, deranged = permute(t), {}
    local numList, keep = copy(nextPerm())
    while numList do
        if noMatches(numList, orig) then table.insert(deranged, numList) end
        numList = copy(nextPerm())
    end
    return deranged
end

-- Return the subfactorial of n
function subFact (n)
    if n < 2 then
        return 1 - n
    else
        return (subFact(n - 1) + subFact(n - 2)) * (n - 1)
    end
end

-- Return a table of the numbers 1 to n
function listOneTo (n)
    local t = {}
    for i = 1, n do t[i] = i end
    return t
end

-- Main procedure
print("Derangements of [1,2,3,4]")
for k, v in pairs(derangements(listOneTo(4))) do print("", unpack(v)) end
print("\n\nSubfactorial vs counted derangements\n")
print("\tn\t| subFact(n)\t| Derangements")
print("    " .. string.rep("-", 42))
for i = 0, 9 do
    io.write("\t" .. i .. "\t|  " .. subFact(i))
    if string.len(subFact(i)) < 5 then io.write("\t") end
    print("\t|  " .. #derangements(listOneTo(i)))
end
print("\n\nThe subfactorial of 20 is " .. subFact(20))


Needs["Combinatorica`"]
derangements[n_] := Derangements[Range[n]]
derangements[4]
Table[{NumberOfDerangements[i], Subfactorial[i]}, {i, 9}] // TableForm
Subfactorial[20]


import algorithm, sequtils, strformat, strutils, tables

iterator derangements[T](a: openArray[T]): seq[T] =
  var perm = @a
  while true:
    if not perm.nextPermutation():
      break
    block checkDerangement:
      for i, val in a:
        if perm[i] == val: break checkDerangement
      yield perm

proc `!`(n: Natural): Natural =
  if n <= 1: return 1 - n
  result = (n - 1) * (!(n - 1) + !(n - 2))

echo "Derangements of 1 2 3 4:"
for d in [1, 2, 3, 4].derangements():
  echo d.join(" ")

echo "\nNumber of derangements:"
echo "n   counted   calculated"
echo "-   -------   ----------"
for n in 0..9:
  echo &"{n}   {toSeq(derangements(toSeq(1..n))).len:>6}      {!n:>6}"

echo "\n!20 = ", !20


derangements(n)=if(n,round(n!/exp(1)),1);
derange(n)={
	my(v=[[]],tmp);
	for(level=1,n,
		tmp=List();
		for(i=1,#v,
			for(k=1,n,
				if(k==level, next);
				for(j=1,level-1,if(v[i][j]==k, next(2)));
				listput(tmp, concat(v[i],k))
			)
		);
		v=Vec(tmp)
	);
	v
};
derange(4)
for(n=0,9,print("!"n" = "#derange(n)" = "derangements(n)))
derangements(20)


sub d {
        # compare this with the deranged() sub to see how to turn procedural
        # code into functional one ('functional' as not in 'understandable')
        $#_ ? map d([ @{$_[0]}, $_[$_] ], @_[1 .. $_-1, $_+1 .. $#_ ]),
                        grep { $_[$_] != @{$_[0]} } 1 .. $#_
            : $_[0]
}

sub deranged {  # same as sub d above, just a readable version to explain method
        my ($result, @avail) = @_;
        return $result if !@avail;              # no more elements to pick from, done

        my @list;                               # list of permutations to return
        for my $i (0 .. $#avail) {              # try to add each element to result in turn
                next if $avail[$i] == @$result; # element n at n-th position, no-no
                my $e = splice @avail, $i, 1;   # move the n-th element from available to result
                push @list, deranged([ @$result, $e ], @avail);
                                                # and recurse down, keep what's returned
                splice @avail, $i, 0, $e;       # put that element back, try next
        }
        return @list;
}

sub choose {    # choose k among n, i.e. n! / k! (n-k)!
        my ($n, $k) = @_;
        factorial($n) / factorial($k) / factorial($n - $k)
}

my @fact = (1);
sub factorial {
        # //= : standard caching technique.  If cached value available,
        #       return it; else compute, cache and return.
        #       For this specific task not really necessary.
        $fact[ $_[0] ] //= $_[0] * factorial($_[0] - 1)
}

my @subfact;
sub sub_factorial {
        my $n = shift;
        $subfact[$n] //= do     # same caching stuff, try comment out this line
        {
                # computes deranged without formula, using recursion
                my $total = factorial($n);      # total permutations
                for my $k (1 .. $n) {
                        # minus the permutations where k items are fixed
                        # to original location, and the rest deranged
                        $total -= choose($n, $k) * sub_factorial($n - $k)
                }
                $total
        }
}

print "Derangements for 4 elements:\n";
my @deranged = d([], 0 .. 3);
for (1 .. @deranged) {
        print "$_: @{$deranged[$_-1]}\n"
}

print "\nCompare list length and calculated table\n";
for (0 .. 9) {
        my @x = d([], 0 .. $_-1);
        print $_, "\t", scalar(@x), "\t", sub_factorial($_), "\n"
}

print "\nNumber of derangements:\n";
print "$_:\t", sub_factorial($_), "\n" for 1 .. 20;


with javascript_semantics
function deranged(sequence s1, sequence s2)
    for i=1 to length(s1) do
        if s1[i]==s2[i] then return 0 end if
    end for
    return 1
end function

function derangements(integer n)
    sequence ts = tagset(n)
    sequence res = {}
    for i=1 to factorial(n) do
        sequence s = permute(i,ts)
        if deranged(s,ts) then
            res = append(res,s)
        end if
    end for
    return res
end function

function subfactorial(integer n)
    if n<2 then return 1-n end if
    return (n-1)*(subfactorial(n-1)+subfactorial(n-2))
end function

?derangements(4)
for n=0 to 9 do
    printf(1,"%d: counted:%d, calculated:%d\n",{n,length(derangements(n)),subfactorial(n)})
end for
string msg = iff(machine_bits()=32?" (incorrect on 32-bit!)":"") -- (fine on 64-bit)
printf(1,"!20=%d%s\n",{subfactorial(20),msg})

include mpfr.e
function mpz_sub_factorial(integer n)
-- probably not the most efficient way to do this!
    if n<2 then return sprintf("%d",{1-n}) end if
    mpz f = mpz_init(mpz_sub_factorial(n-1)),
        g = mpz_init(mpz_sub_factorial(n-2))
    mpz_add(f,f,g)
    mpz_mul_si(f,f,n-1)
    string res = mpz_get_str(f)
    {f,g} = mpz_free({f,g})
    return res
end function
printf(1,"!20=%s (mpfr)\n",{mpz_sub_factorial(20)})


import util.

go =>
   foreach(N in 0..9)
      println([N,num_derangements=num_derangements(N), subfactorial=subfactorial(N), subfactorial2=subfactorial2(N)])
   end,
   println(["!20", subfactorial(20)]),
   println(["!20 approx", subfactorial2(20)]),
   println("subfactorial0..30"=[subfactorial(N) : N in 0..30 ]),
   println("subfactorial2_0..30"=[subfactorial2(N) : N in 0..30 ]),
   println(["!200", subfactorial(200)]),
   nl,
   println("Syntax sugar:"),
   println("'!'(20)"='!'(20)),
   println("200.'!'()"=200.'!'()),
   println("'!!'(20)"='!!'(20)),
   println("'!-!!'(10)"='!-!!'(10)),
   nl.

num_derangements(N) = derangements(N).length.

derangements(N) = D =>
  D = [P : P in permutations(1..N), nofixpoint(P)].

% subfactorial: tabled recursive function
table
subfactorial(0) = 1.
subfactorial(1) = 0.
subfactorial(N) = (N-1)*(subfactorial(N-1)+subfactorial(N-2)).

% approximate version of subfactorial
subfactorial2(0) = 1.
subfactorial2(N) = floor(1.0*floor(factorial(N)/2.71828 + 1/2.0)).

% Factorial
fact(N) = F =>
   F1 = 1,
   foreach(I in 1..N)
     F1 := F1 * I
   end,
   F = F1.

% No fixpoint in L
nofixpoint(L) =>
   foreach(I in 1..L.length)
     L[I] != I
   end.

% Some syntax sugar. Note: the function must be an atom.
'!'(N) = fact(N).
'!!'(N) = subfactorial(N).

'!-!!'(N) = fact(N) - subfactorial(N).


(load "@lib/simul.l")  # For 'permute'

(de derangements (Lst)
   (filter
      '((L) (not (find = L Lst)))
      (permute Lst) ) )

(de subfact (N)
   (if (>= 2 N)
      (if (= 1 N) 0 1)
      (*
         (dec N)
         (+ (subfact (dec N)) (subfact (- N 2))) ) ) )


Procedure.q Subfactoral(n)
If n=0:ProcedureReturn 1:EndIf
If n=1:ProcedureReturn 0:EndIf
ProcedureReturn (Subfactoral(n-1)+Subfactoral(n-2))*(n-1)
EndProcedure

factFile.s="factorials.txt"
tempFile.s="temp.txt"
drngFile.s="derangements.txt"
DeleteFile(factFile.s)
DeleteFile(tempFile.s)
DeleteFile(drngFile.s)

n=4

; create our storage file
f.s=factFile.s
If CreateFile(0,f.s)
WriteStringN(0,"1.2")
WriteStringN(0,"2.1")
CloseFile(0)
Else
Debug "not createfile :"+f.s
EndIf

showfactorial=#False

If showfactorial
; cw("nfactorial n ="+str(n))
Debug "nfactorial n ="+Str(n)
EndIf

; build up the factorial combinations
For l=1 To n-2
Gosub nfactorial
Next

; extract the derangements
; cw("derangements["+str(perm(n))+"] for n="+str(n))
Debug "derangements["+Str(Subfactoral(n))+"] for n="+Str(n)
Gosub derangements
; cw("")
Debug ""

; show the first 20 derangements
For i=0 To 20
Debug "derangements["+Str(Subfactoral(i))+"] for n="+Str(i)
Next

End

derangements:
x=0
If ReadFile(0,factFile.s) And CreateFile(1,drngFile.s)
Repeat
r.s = ReadString(0)
cs=CountString(r.s,".")
If cs
hit=0
t.s=""
; scan for numbers at their index
For i=1 To cs+1
s.s=StringField(r.s,i,".")
t.s+s.s+"."
If Val(s.s)=i:hit+1:EndIf
Next
t.s=RTrim(t.s,".")
; show only those which are valid
If Not hit
x+1
; cw(t.s+" "+str(x))
Debug t.s+" "+Str(x)
WriteStringN(1,t.s+" "+Str(x))
EndIf
EndIf
Until Eof(0)
CloseFile(0)
CloseFile(1)
Else
Debug "not readfile :"+factFile.s
Debug "not createfile :"+drngFile.s
EndIf
; cw("")
Debug ""
Return

nfactorial:
x=0
If ReadFile(0,factFile.s) And CreateFile(1,tempFile.s)
Repeat
r.s = ReadString(0)
cs=CountString(r.s,".")
If cs
For j=1 To cs+2
t.s=""
For i=1 To cs+1
s.s=StringField(r.s,i,".")
If i=j
t.s+"."+Str(cs+2)+"."+s.s
Else
t.s+"."+s.s
EndIf
Next
If j=cs+2:t.s+"."+Str(cs+2):EndIf
t.s=Trim(t.s,".")
x+1
If cs+2=n And showfactorial
; cw(t.s+" "+str(x))
Debug t.s+" "+Str(x)
EndIf
WriteStringN(1,t.s)
Next
EndIf
Until Eof(0)
CloseFile(0)
CloseFile(1)
Else
Debug "not readfile :"+factFile.s
Debug "not createfile :"+tempFile.s
EndIf
CopyFile(tempFile.s,factFile.s)
DeleteFile(tempFile.s)
Return


from itertools import permutations
import math

def derangements(n):
    'All deranged permutations of the integers 0..n-1 inclusive'
    return ( perm for perm in permutations(range(n))
             if all(indx != p for indx, p in enumerate(perm)) )

def subfact(n):
    if n == 2 or n == 0:
        return 1
    elif n == 1:
        return 0
    elif  1 <= n <=18:
        return round(math.factorial(n) / math.e)
    elif n.imag == 0 and n.real == int(n.real) and n > 0:
        return (n-1) * ( subfact(n - 1) + subfact(n - 2) )
    else:
        raise ValueError()

def _iterlen(iter):
    'length of an iterator without taking much memory'
    l = 0
    for x in iter:
        l += 1
    return l

if __name__ == '__main__':
    n = 4
    print("Derangements of %s" % (tuple(range(n)),))
    for d in derangements(n):
        print("  %s" % (d,))

    print("\nTable of n vs counted vs calculated derangements")
    for n in range(10):
        print("%2i %-5i %-5i" %
              (n, _iterlen(derangements(n)), subfact(n)))

    n = 20
    print("\n!%i = %i" % (n, subfact(n)))


' Heap's algorithm non-recursive
FUNCTION permsderange (n!, flag!)
    IF n = 0 THEN permsderange = 1

    DIM a!(0 TO n), c!(0 TO n)

    FOR j = 0 TO n - 1: a(j) = j: NEXT j

    WHILE i < n
        IF c(i) < i THEN
            IF (i AND 1) = 0 THEN
                SWAP a(0), a(i)
            ELSE
                SWAP a(c(i)), a(i)
            END IF
            FOR j = 0 TO n - 1
                IF a(j) = j THEN j = 99
            NEXT j
            IF j < 99 THEN
                count = count + 1
                IF flag = 0 THEN
                    c1 = c1 + 1
                    FOR j = 0 TO n - 1
                        PRINT a(j);
                    NEXT j
                    IF c1 > 12 THEN
                        PRINT : c1 = 0
                    ELSE
                        PRINT
                    END IF
                END IF
            END IF
            c(i) = c(i) + 1
            i = 0
        ELSE
            c(i) = 0
            i = i + 1
        END IF
    WEND
    IF flag = 0 AND c1 <> 0 THEN PRINT
    permsderange = count
END FUNCTION

SUB Subfactorial (a!())
    FOR i = 0 TO UBOUND(a)
        num = num * i
        IF (i AND 1) = 1 THEN
            num = num - 1
        ELSE
            num = num + 1
        END IF
        a(i) = num
    NEXT i
END SUB

n! = 4
DIM subfac!(7)

CALL Subfactorial(subfac())

PRINT "permutations derangements for n = "; n
i! = permsderange(n, 0)
PRINT "count returned ="; i; " , !"; n; " calculated ="; subfac(n)

PRINT
PRINT "count  counted subfactorial"
PRINT "---------------------------"
FOR i = 0 TO 7
    PRINT USING " ###: ########     ########"; i; permsderange(i, 1); subfac(i)
NEXT i


  [ stack ]                            is deranges.num (     --> [ )

                               forward is (deranges)
  [ over size
    deranges.num share = iff
      [ over temp take
        swap nested join
        temp put ]
    else
      [ dup size times
         [ 2dup i^ pluck
           dip [ over size ]
           tuck != iff
             [ rot swap
               nested join
               swap (deranges) ]
           else
             [ drop 2drop ] ] ]
    2drop ]                      resolves (deranges)   ( [ [ -->   )

  [ dup deranges.num put
    [] swap times [ i^ join ]
    [] temp put
    [] swap (deranges)
    temp take
    deranges.num release ]             is derangements (   n --> [ )

  [ dup 0 = iff [ drop 1 ] done
    1 0 rot
    1 - times
      [ swap over + i^ 1+ * ]
    nip ]                              is sub!         (   n --> n )

  4 derangements witheach [ echo cr ]
  cr
  10 times
    [ i^ echo sp
      i^ derangements size echo sp
      i^ sub! echo cr ]
  cr
  20 sub! echo


#lang racket

(define (all-misplaced? l)
  (for/and ([x (in-list l)] [n (in-naturals 1)]) (not (= x n))))

;; 1. Create a named function to generate derangements of the integers 0..n-1.
(define (derangements n)
  (define (all-misplaced? l1 l2)
    (or (null? l1)
        (and (not (eq? (car l1) (car l2)))
             (all-misplaced? (cdr l1) (cdr l2)))))
  (define l (range n))
  (for/list ([p (permutations l)] #:when (all-misplaced? p l))
    p))

;; 2. Generate and show all the derangements of 4 integers using the above
;;    routine.
(derangements 4)
;; -> '((1 0 3 2) (3 0 1 2) (1 3 0 2) (2 0 3 1) (2 3 0 1)
;;      (3 2 0 1) (1 2 3 0) (2 3 1 0) (3 2 1 0))

;; 3. Create a function that calculates the subfactorial of n, !n.
(define (sub-fact n)
  (if (< n 2) (- 1 n)
      (* (+ (sub-fact (- n 1)) (sub-fact (- n 2))) (sub1 n))))

;; 4. Print and show a table of the counted number of derangements of n vs. the
;;    calculated !n for n from 0..9 inclusive.
(for ([i 10])
  (printf "~a ~a ~a\n" i
          (~a #:width 7 #:align 'right (length (derangements i)))
          (sub-fact i)))
;; Output:
;; 0       1 1
;; 1       0 0
;; 2       1 1
;; 3       2 2
;; 4       9 9
;; 5      44 44
;; 6     265 265
;; 7    1854 1854
;; 8   14833 14833
;; 9  133496 133496

;; Extra: !20
(sub-fact 20)
;; -> 895014631192902121


sub derangements(@l) {
    @l.permutations.grep(-> @p { none(@p Zeqv @l) })
}

sub prefix:<!>(Int $n) {
    (1, 0, 1, -> $a, $b { ($++ + 2) × ($b + $a) } ... *)[$n]
}

say 'derangements([1, 2, 3, 4])';
say derangements([1, 2, 3, 4]), "\n";

say 'n == !n == derangements(^n).elems';
for 0 .. 9 -> $n {
    say "!$n == { !$n } == { derangements(^$n).elems }"
}


/*REXX program generates all  permutations  of   N   derangements  and  subfactorial #  */
numeric digits 1000                              /*be able to handle large subfactorials*/
parse arg N .;     if N=='' | N==","  then N=4   /*Not specified?  Then use the default.*/
d= derangeSet(N)                                 /*go and build the  derangements  set. */
say d  'derangements for'    N    "items are:"
say
      do i=1  for  d                             /*display the derangements for N items.*/
      say right('derangement', 22)       right(i, length(d) )        '───►'         $.i
      end   /*i*/
say                                              /* [↓]  count and calculate subfact !L.*/
      do L=0  to 2;  d= derangeSet(L)
      say L 'items:  derangement count='right(d, 6)",  !"L'='right( !s(L), 6)
      end   /*L*/
say
say right('!20=' , 22)     !s( 20)
say right('!200=', 22)     !s(200)
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
!s:         _=1;      do j=1  for arg(1);  if j//2  then _= j*_  -  1;     else _=j*_  + 1
                      end   /*j*/;                       return _
/*──────────────────────────────────────────────────────────────────────────────────────*/
derangeSet: procedure expose $.;  parse arg x;   $.=;    #=0;   p=x-1
            if x==0  then return 1;  if x==1  then return 0
            @.1=2;  @.2=1                                    /*populate 1st derangement.*/
              do i=3  to x;  @.i=i;  end  /*i*/              /*    "    the rest of 'em.*/
            parse value  @.p  @.x   with   @.x  @.p;   call .buildD x    /*swap & build.*/
                                                                         /*build others.*/
              do while .nextD(x, 0);  call .buildD x;   end;                  return #
/*──────────────────────────────────────────────────────────────────────────────────────*/
.buildD:              do j=1  for arg(1);   if @.j==j  then return;  end
            #=#+1;    do j=1  for arg(1);   $.#= $.# @.j;            end;     return
/*──────────────────────────────────────────────────────────────────────────────────────*/
.nextD:     procedure expose @.;  parse arg n,i

              do k=n-1  by -1  for n-1;  kp=k+1;     if @.k<@.kp  then do; i=k; leave; end
              end   /*k*/

              do j=i+1  while j<n;       parse value  @.j  @.n   with   @.n  @.j;   n=n-1
              end   /*j*/
            if i==0  then return 0
              do m=i+1  while @.m<@.i;   end  /*m*/          /* [↓]  swap two values.   */
            parse  value   @.m @.i   with   @.i @.m;                          return 1


def derangements(n)
  ary = (1 .. n).to_a
  ary.permutation.select do |perm|
    ary.zip(perm).all? {|a,b| a != b}
  end
end

def subfact(n)
  case n
  when 0 then 1
  when 1 then 0
  else (n-1)*(subfact(n-1) + subfact(n-2))
  end
end

puts "derangements for n = 4"
derangements(4).each{|d|p d}

puts "\n n   derange  subfact"
(0..9).each do |n|
  puts "%2d :%8d,%8d" % [n, derangements(n).size, subfact(n)]
end

puts "\nNumber of derangements"
(10..20).each do |n|
  puts "#{n} : #{subfact(n)}"
end


def derangements(n: Int) =
  (1 to n).permutations.filter(_.zipWithIndex.forall{case (a, b) => a - b != 1})

def subfactorial(n: Long): Long = n match {
  case 0 => 1
  case 1 => 0
  case _ => (n - 1) * (subfactorial(n - 1) + subfactorial(n - 2))
}

println(s"Derangements for n = 4")
println(derangements(4) mkString "\n")

println("\n%2s%10s%10s".format("n", "derange", "subfact"))
(0 to 9).foreach(n => println("%2d%10d%10d".format(n, derangements(n).size, subfactorial(n))))
(10 to 20).foreach(n => println(f"$n%2d${subfactorial(n)}%20d"))


(
d = { |array, n|
	Routine {
		n = n ?? { array.size.factorial };
		n.do { |i|
			var permuted = array.permute(i);
			if(array.every { |each, i| permuted[i] != each }) {
				permuted.yield
			};
		}
	};
};
f = { |n| d.((0..n-1)) };
x = f.(4);
x.all.do(_.postln); "";
)


package require Tcl 8.5;		# for arbitrary-precision integers
package require struct::list;		# for permutation enumerator

proc derangements lst {
    # Special case
    if {![llength $lst]} {return {{}}}
    set result {}
    for {set perm [struct::list firstperm $lst]} {[llength $perm]} \
	    {set perm [struct::list nextperm $perm]} {
	set skip 0
	foreach a $lst b $perm {
	    if {[set skip [string equal $a $b]]} break
	}
	if {!$skip} {lappend result $perm}
    }
    return $result
}

proc deranged1to n {
    for {set i 1;set r {}} {$i <= $n} {incr i} {lappend r $i}
    return [derangements $r]
}

proc countDeranged1to n {
    llength [deranged1to $n]
}

proc subfact n {
    if {$n == 0} {return 1}
    if {$n == 1} {return 0}
    set o 1
    set s 0
    for {set i 1} {$i < $n} {incr i} {
	set s [expr {$i * ($o + [set o $s])}]
    }
    return $s
}


import "/fmt" for Fmt
import "/big" for BigInt

var permute // recursive
permute = Fn.new { |input|
    if (input.count == 1) return [input]
    var perms = []
    var toInsert = input[0]
    for (perm in permute.call(input[1..-1])) {
        for (i in 0..perm.count) {
            var newPerm = perm.toList
            newPerm.insert(i, toInsert)
            perms.add(newPerm)
        }
    }
    return perms
}

var derange = Fn.new { |input|
    if (input.isEmpty) return [input]
    var perms = permute.call(input)
    var derangements = []
    for (perm in perms) {
        var deranged = true
        for (i in 0...perm.count) {
            if (perm[i] == i) {
                deranged = false
                break
            }
        }
        if (deranged) derangements.add(perm)
    }
    return derangements
}

var subFactorial // recursive
subFactorial = Fn.new { |n|
    if (n == 0) return BigInt.one
    if (n == 1) return BigInt.zero
    return (subFactorial.call(n-1) + subFactorial.call(n-2)) * (n - 1)
}

var input = [0, 1, 2, 3]
var derangements = derange.call(input)
System.print("There are %(derangements.count) derangements of %(input), namely:\n")
System.print(derangements.join("\n"))

System.print("\nN  Counted   Calculated")
System.print("-  -------   ----------")
for (n in 0..9) {
    var list = List.filled(n, 0)
    for (i in 0...n) list[i] = i
    var counted = derange.call(list).count
    Fmt.print("$d  $-9d $-9i", n, counted, subFactorial.call(n))
}
System.print("\n!20 = %(subFactorial.call(20))")


fcn subFact(n){
   if(n==0) return(1);
   if(n==1) return(0);
   (n-1)*(self.fcn(n-1) + self.fcn(n-2));
}

fcn derangements(n){
   // All deranged permutations of the integers 0..n-1 inclusive
   enum:=[0..n-1].pump(List);
   Utils.Helpers.permuteW(enum).filter('wrap(perm){
      perm.zipWith('==,enum).sum(0) == 0
   });
}
fcn derangers(n){  // just count # of derangements
   enum:=[0..n-1].pump(List);
   Utils.Helpers.permuteW(enum).reduce('wrap(sum,perm){
      sum + (perm.zipWith('==,enum).sum(0) == 0)
   },0);
}


F popcount(n)
   R bin(n).count(‘1’)

F is_prime(n)
   I n < 2
      R 0B
   L(i) 2 .. Int(sqrt(n))
      I n % i == 0
         R 0B
   R 1B

V i = 0
V cnt = 0
L
   I is_prime(popcount(i))
      print(i, end' ‘ ’)
      cnt++
      I cnt == 25
         L.break
   i++

print()
L(i) 888888877..888888888
   I is_prime(popcount(i))
      print(i, end' ‘ ’)


*        Pernicious numbers        04/05/2016
PERNIC   CSECT
         USING  PERNIC,R13         base register and savearea pointer
SAVEAREA B      STM-SAVEAREA(R15)
         DC     17F'0'
STM      STM    R14,R12,12(R13)    save registers
         ST     R13,4(R15)         link backward SA
         ST     R15,8(R13)         link forward SA
         LR     R13,R15            establish addressability
         SR     R7,R7              n=0
         MVC    PG,=CL80' '        clear buffer
         LA     R10,PG             pgi
         LA     R6,1               i=1
LOOPI1   C      R7,=F'25'          do i=1 while(n<25)
         BNL    ELOOPI1
         LR     R1,R6              i
         BAL    R14,POPCOUNT
         LR     R1,R0              popcount(i)
         BAL    R14,ISPRIME
         C      R0,=F'1'           if isprime(popcount(i))=1
         BNE    NOTPRIM1
         XDECO  R6,XDEC            edit i
         MVC    0(3,R10),XDEC+9    output i format I3
         LA     R10,3(R10)         pgi=pgi+3
         LA     R7,1(R7)           n=n+1
NOTPRIM1 LA     R6,1(R6)           i=i+1
         B      LOOPI1
ELOOPI1  XPRNT  PG,80              print buffer
         MVC    PG,=CL80' '        clear buffer
         LA     R10,PG             pgi
         L      R6,=F'888888877'   i=888888877
LOOPI2   C      R6,=F'888888888'   do i to 888888888
         BH     ELOOPI2
         LR     R1,R6              i
         BAL    R14,POPCOUNT
         LR     R1,R0              popcount(i)
         BAL    R14,ISPRIME
         C      R0,=F'1'           if isprime(popcount(i))=1
         BNE    NOTPRIM2
         XDECO  R6,XDEC            edit i
         MVC    0(10,R10),XDEC+2   output i format I10
         LA     R10,10(R10)        pgi=pgi+10
NOTPRIM2 LA     R6,1(R6)           i=i+1
         B      LOOPI2
ELOOPI2  XPRNT  PG,80              print buffer
         L      R13,4(0,R13)       restore savearea pointer
         LM     R14,R12,12(R13)    restore registers
         XR     R15,R15            return code = 0
         BR     R14 -------------- end main
POPCOUNT CNOP   0,4 -------------- popcount(xx) [R8,R11]
         ST     R14,POPCOUSA       save return address
         ST     R1,XX              store argument
         SR     R11,R11            rr=0
         SR     R8,R8              ii=0
LOOPII   C      R8,=F'31'          do ii=0 to 31
         BH     ELOOPII
         L      R1,XX              xx
         LR     R2,R8              ii
         BAL    R14,BTEST
         C      R0,=F'1'           if btest(xx,ii)=1
         BNE    NOTBTEST
         LA     R11,1(R11)         rr=rr+1
NOTBTEST LA     R8,1(R8)           ii=ii+1
         B      LOOPII
ELOOPII  LR     R0,R11             return(rr)
         L      R14,POPCOUSA
         BR     R14 -------------- end popcount
ISPRIME  CNOP   0,4 -------------- isprime(number) [R9]
         ST     R14,ISPRIMSA       save return address
         ST     R1,NUMBER          store argument
         C      R1,=F'2'           if number=2
         BNE    ELSE1
         MVC    ISPRIMEX,=F'1'     isprimex=1
         B      ELOOPJJ
ELSE1    L      R1,NUMBER
         C      R1,=F'2'           if number<2
         BL     EVEN
         L      R4,NUMBER
         SRDA   R4,32
         D      R4,=F'2'           mod(number,2)
         C      R4,=F'0'           if mod(number,2)=0
         BNE    ELSE2
EVEN     MVC    ISPRIMEX,=F'0'     isprimex=0
         B      ELOOPJJ
ELSE2    MVC    ISPRIMEX,=F'1'     isprimex=1
         LA     R9,3               jj=3
LOOPJJ   LR     R5,R9              jj
         MR     R4,R9              jj*jj
         C      R5,NUMBER          do jj=3 by 1 while jj*jj<=number
         BH     ELOOPJJ
         L      R4,NUMBER
         SRDA   R4,32
         DR     R4,R9              mod(number,jj)
         LTR    R4,R4              if mod(number,jj)=0
         BNZ    ITERJJ
         MVC    ISPRIMEX,=F'0'     isprimex=0
         L      R0,ISPRIMEX        return(isprimex)
         B      ISPRIMRT
ITERJJ   LA     R9,1(R9)           jj=jj+1
         B      LOOPJJ
ELOOPJJ  L      R0,ISPRIMEX        return(isprimex)
ISPRIMRT L      R14,ISPRIMSA
         BR     R14 -------------- end isprime
BTEST    CNOP   0,4 -------------- btest(word,n) [R0:R3]
         LA     R0,1               ok=1; return(1) if word(n)='1'b
         LR     R3,R2              i=n
LOOPB    LTR    R3,R3              if i=0
         BZ     ELOOPB
         SRL    R1,1               Shift Right Logical
         BCTR   R3,0               i=i-1
         B      LOOPB
ELOOPB   STC    R1,BTESTX          x=word
         TM     BTESTX,B'00000001' if bit(word,n)='1'b
         BO     BTESTRET
         LA     R0,0               ok=0; return(0) if word(n)='0'b
BTESTRET BR     R14 -------------- end btest
XX       DS     F                  paramter of popcount
NUMBER   DS     F                  paramter of isprime
ISPRIMEX DS     F                  return value of isprime
BTESTX   DS     X                  byte to see in btest
POPCOUSA DS     A                  return address of popcount
ISPRIMSA DS     A                  return address of isprime
PG       DS     CL80               buffer
XDEC     DS     CL12               edit zone
         YREGS
         END    PERNIC


with Ada.Text_IO, Population_Count; use Population_Count;

procedure Pernicious is

   Prime: array(0 .. 64) of Boolean;
     -- we are using 64-bit numbers, so the population count is between 0 and 64
   X: Num; use type Num;
   Cnt: Positive;
begin
   -- initialize array Prime; Prime(I) must be true if and only if I is a prime
   Prime := (0 => False, 1 => False, others => True);
   for I in 2 .. 8 loop
      if Prime(I) then
	 Cnt := I + I;
	 while Cnt <= 64 loop
	    Prime(Cnt) := False;
	    Cnt := Cnt + I;
	 end loop;
      end if;
   end loop;

   -- print first 25 pernicious numbers
   X := 1;
   for I in 1 .. 25 loop
      while not Prime(Pop_Count(X)) loop
	 X := X + 1;
      end loop;
      Ada.Text_IO.Put(Num'Image(X));
      X := X + 1;
   end loop;
   Ada.Text_IO.New_Line;

   -- print pernicious numbers between  888_888_877 and 888_888_888 (inclusive)
   for Y in Num(888_888_877) .. 888_888_888 loop
      if Prime(Pop_Count(Y)) then
	 Ada.Text_IO.Put(Num'Image(Y));
      end if;
   end loop;
   Ada.Text_IO.New_Line;
end;


# calculate various pernicious numbers                          #

# returns the population (number of bits on) of the non-negative integer n    #
PROC population = ( INT n )INT:
     BEGIN
        INT    number := n;
        INT    result := 0;
        WHILE number > 0 DO
            IF ODD number THEN result +:= 1 FI;
            number OVERAB 2
        OD;
        result
     END # population # ;

# as we are dealing with 32 bit numbers, the maximum possible population is 32 #
# so we only need a table of whether the integers 0 : 32 are prime or not      #
# we use the sieve of Eratosthenes...                                          #
INT max number = 32;
[ 0 : max number ]BOOL is prime;
is prime[ 0 ] := FALSE;
is prime[ 1 ] := FALSE;
FOR i FROM 2 TO max number DO is prime[ i ] := TRUE OD;
FOR i FROM 2 TO ENTIER sqrt( max number ) DO
    IF is prime[ i ] THEN FOR p FROM i * i BY i TO max number DO is prime[ p ] := FALSE OD FI
OD;

# returns TRUE if n is pernicious, FALSE otherwise                             #
PROC is pernicious = ( INT n )BOOL: is prime[ population( n ) ];

# find the first 25 pernicious numbers, 0 and 1 are not pernicious             #
INT pernicious count := 0;
FOR i FROM 2 WHILE pernicious count < 25 DO
    IF is pernicious( i ) THEN
        # found a pernicious number #
        print( ( whole( i, 0 ), " " ) );
        pernicious count +:= 1
    FI
OD;
print( ( newline ) );

# find the pernicious numbers between 888 888 877 and 888 888 888              #
FOR i FROM 888 888 877 TO 888 888 888 DO
    IF is pernicious( i ) THEN
        print( ( whole( i, 0 ), " " ) )
    FI
OD;
print( ( newline ) )


begin % find some pernicious numbers: numbers with a prime population count %
    % returns the population count of n                                     %
    integer procedure populationCount( integer value  n ) ;
    begin
        integer v, count;
        count := 0;
        v     := abs n;
        while v > 0 do begin
            if odd( v ) then count := count + 1;
            v := v div 2
        end while_v_gt_0 ;
        count
    end populationCount ;
    % sets p( 1 :: n ) to a sieve of primes up to n                         %
    procedure Eratosthenes ( logical array p( * ) ; integer value n ) ;
    begin
        p( 1 ) := false; p( 2 ) := true;
        for i := 3 step 2 until n do p( i ) := true;
        for i := 4 step 2 until n do p( i ) := false;
        for i := 3 step 2 until truncate( sqrt( n ) ) do begin
            integer ii; ii := i + i;
            if p( i ) then for pr := i * i step ii until n do p( pr ) := false
        end for_i ;
    end Eratosthenes ;
    % returns true if p is pernicious, false otherwise, s must be a sieve   %
    %         of primes upto 32                                             %
    logical procedure isPernicious ( integer value p; logical array s ( * ) ) ; p > 0 and s( populationCount( p ) );
    % find the pernicious numbers %
    begin
        % as we are dealing with 32 bit numbers, the maximum possible       %
        % population is 32                                                  %
        logical array isPrime ( 1 :: 32 );
        integer       p, pCount;
        Eratosthenes( isPrime, 32 );
        % show the first 25 pernicious numbers                              %
        pCount := 0;
        p      := 2; % 0 and 1 aren't pernicious, so start at 2             %
        while pCount < 25 do begin
            if isPernicious( p, isPrime ) then begin
                % have a pernicious number                                  %
                pCount := pCount + 1;
                writeon( i_w := 1, s_w := 0, " ", p )
            end if_pernicious_p ;
            p := P + 1
        end for_p ;
        write();
        % find the pernicious numbers between 888 888 877 and 888 888 888   %
        for p := 888888877 until 888888888 do begin
            if isPernicious( p, isPrime ) then writeon( i_w := 1, s_w := 0, " ", p )
        end for_p ;
        write();
    end
end.