Topswops: Difference between revisions

Content added Content deleted

Inline

Revision as of 01:11, 11 July 2016

Topswops is a card game created by John Conway in the 1970's.

Assume you have a particular permutation of a set of n cards numbered 1..n on both of their faces, for example the arrangement of four cards given by [2, 4, 1, 3] where the leftmost card is on top. A round is composed of reversing the first m cards where m is the value of the topmost card. rounds are repeated until the topmost card is the number 1 and the number of swaps is recorded. For our example the swaps produce:

    [2, 4, 1, 3]    # Initial shuffle
    [4, 2, 1, 3]
    [3, 1, 2, 4]
    [2, 1, 3, 4]
    [1, 2, 3, 4]

For a total of four swaps from the initial ordering to produce the terminating case where 1 is on top.

For a particular number n of cards, topswops(n) is the maximum swaps needed for any starting permutation of the n cards.

Task

The task is to generate and show here a table of n vs topswops(n) for n in the range 1..10 inclusive.

Note

Topswops is also known as Fannkuch from the German Pfannkuchen meaning pancake.

Cf.

Ada

This is a straightforward approach that counts the number of swaps for each permutation. To generate all permutations over 1 .. N, for each of N in 1 .. 10, the package Generic_Perm from the Permutations task is used [[1]].

<lang Ada>with Ada.Integer_Text_IO, Generic_Perm;

procedure Topswaps is

  function Topswaps(Size: Positive) return Natural is
     package Perms is new Generic_Perm(Size);
     P: Perms.Permutation;
     Done: Boolean;
     Max: Natural;
     
     function Swapper_Calls(P: Perms.Permutation) return Natural is

Q: Perms.Permutation := P; I: Perms.Element := P(1);

     begin

if I = 1 then return 0; else for Idx in 1 .. I loop Q(Idx) := P(I-Idx+1); end loop; return 1 + Swapper_Calls(Q); end if;

     end Swapper_Calls;
     
  begin
     Perms.Set_To_First(P, Done);
     Max:= Swapper_Calls(P);
     while not Done loop

Perms.Go_To_Next(P, Done); Max := natural'Max(Max, Swapper_Calls(P));

     end loop;
     return Max;
  end Topswaps;

begin

  for I in 1 .. 10 loop
     Ada.Integer_Text_IO.Put(Item => Topswaps(I), Width => 3);
  end loop;

end Topswaps;</lang>

Output:

  0  1  2  4  7 10 16 22 30 38

AutoHotkey

<lang AutoHotkey>Topswops(Obj, n){ R := [] for i, val in obj{ if (i <=n) res := val (A_Index=1?"":",") res else res .= "," val } Loop, Parse, res, `, R[A_Index]:= A_LoopField return R }</lang> Examples:<lang AutoHotkey>Cards := [2, 4, 1, 3] Res := Print(Cards) while (Cards[1]<>1) { Cards := Topswops(Cards, Cards[1]) Res .= "`n"Print(Cards) } MsgBox % Res

Print(M){ for i, val in M Res .= (A_Index=1?"":"`t") val return Trim(Res,"`n") }</lang>

Outputs:

C

An algorithm that doesn't go through all permutations, per Knuth tAoCP 7.2.1.2 exercise 107 (possible bad implementation on my part notwithstanding): <lang c>#include <stdio.h>

include <string.h>

typedef struct { char v[16]; } deck; typedef unsigned int uint;

uint n, d, best[16];

void tryswaps(deck *a, uint f, uint s) {

define A a->v
define B b.v

if (d > best[n]) best[n] = d; while (1) { if ((A[s] == s || (A[s] == -1 && !(f & 1U << s))) && (d + best[s] >= best[n] || A[s] == -1)) break;

if (d + best[s] <= best[n]) return; if (!--s) return; }

d++; deck b = *a; for (uint i = 1, k = 2; i <= s; k <<= 1, i++) { if (A[i] != i && (A[i] != -1 || (f & k))) continue;

for (uint j = B[0] = i; j--;) B[i - j] = A[j]; tryswaps(&b, f | k, s); } d--; }

int main(void) { deck x; memset(&x, -1, sizeof(x)); x.v[0] = 0;

for (n = 1; n < 13; n++) { tryswaps(&x, 1, n - 1); printf("%2d: %d\n", n, best[n]); }

return 0; }</lang> The code contains critical small loops, which can be manually unrolled for those with OCD. POSIX thread support is useful if you got more than one CPUs. <lang c>#define _GNU_SOURCE

include <stdio.h>
include <string.h>
include <pthread.h>
include <sched.h>

define MAX_CPUS 8 // increase this if you got more CPUs/cores

typedef struct { char v[16]; } deck;

int n, best[16];

// Update a shared variable by spinlock. Since this program really only // enters locks dozens of times, a pthread_mutex_lock() would work // equally fine, but RC already has plenty of examples for that.

define SWAP_OR_RETRY(var, old, new) \

if (!__sync_bool_compare_and_swap(&(var), old, new)) { \ volatile int spin = 64; \ while (spin--); \ continue; }

void tryswaps(deck *a, int f, int s, int d) {

define A a->v
define B b->v

while (best[n] < d) { int t = best[n]; SWAP_OR_RETRY(best[n], t, d); }

define TEST(x) \

case x: if ((A[15-x] == 15-x || (A[15-x] == -1 && !(f & 1<<(15-x)))) \ && (A[15-x] == -1 || d + best[15-x] >= best[n])) \ break; \ if (d + best[15-x] <= best[n]) return; \ s = 14 - x

switch (15 - s) { TEST(0); TEST(1); TEST(2); TEST(3); TEST(4); TEST(5); TEST(6); TEST(7); TEST(8); TEST(9); TEST(10); TEST(11); TEST(12); TEST(13); TEST(14); return; }

undef TEST

deck *b = a + 1; *b = *a; d++;

define FLIP(x) \

if (A[x] == x || ((A[x] == -1) && !(f & (1<<x)))) { \ B[0] = x; \ for (int j = x; j--; ) B[x-j] = A[j]; \ tryswaps(b, f|(1<<x), s, d); } \ if (s == x) return;

FLIP(1); FLIP(2); FLIP(3); FLIP(4); FLIP(5); FLIP(6); FLIP(7); FLIP(8); FLIP(9); FLIP(10); FLIP(11); FLIP(12); FLIP(13); FLIP(14); FLIP(15);

undef FLIP

}

int num_cpus(void) { cpu_set_t ct; sched_getaffinity(0, sizeof(ct), &ct);

int cnt = 0; for (int i = 0; i < MAX_CPUS; i++) if (CPU_ISSET(i, &ct)) cnt++;

return cnt; }

struct work { int id; deck x[256]; } jobs[MAX_CPUS]; int first_swap;

void *thread_start(void *arg) { struct work *job = arg; while (1) { int at = first_swap; if (at >= n) return 0;

SWAP_OR_RETRY(first_swap, at, at + 1);

memset(job->x, -1, sizeof(deck)); job->x[0].v[at] = 0; job->x[0].v[0] = at; tryswaps(job->x, 1 | (1 << at), n - 1, 1); } }

int main(void) { int n_cpus = num_cpus();

for (int i = 0; i < MAX_CPUS; i++) jobs[i].id = i;

pthread_t tid[MAX_CPUS];

for (n = 2; n <= 14; n++) { int top = n_cpus; if (top > n) top = n;

first_swap = 1; for (int i = 0; i < top; i++) pthread_create(tid + i, 0, thread_start, jobs + i);

for (int i = 0; i < top; i++) pthread_join(tid[i], 0);

printf("%2d: %2d\n", n, best[n]); }

return 0; }</lang>

D

Permutations generator from: http://rosettacode.org/wiki/Permutations#Faster_Lazy_Version

Translation of: Haskell

<lang d>import std.stdio, std.algorithm, std.range, permutations2;

int topswops(in int n) pure @safe {

   static int flip(int[] xa) pure nothrow @safe @nogc {
       if (!xa[0]) return 0;
       xa[0 .. xa[0] + 1].reverse();
       return 1 + flip(xa);
   }
   return n.iota.array.permutations.map!flip.reduce!max;

}

void main() {

   foreach (immutable i; 1 .. 11)
       writeln(i, ": ", i.topswops);

}</lang>

Output:

D: Faster Version

Translation of: C

<lang d>import std.stdio, std.typecons;

__gshared uint[32] best;

uint topswops(size_t n)() nothrow @nogc {

   static assert(n > 0 && n < best.length);
   size_t d = 0;

   alias T = byte;
   alias Deck = T[n];

   void trySwaps(in ref Deck deck, in uint f) nothrow @nogc {
       if (d > best[n])
           best[n] = d;

       foreach_reverse (immutable i; staticIota!(0, n)) {
           if ((deck[i] == i || (deck[i] == -1 && !(f & (1U << i))))
               && (d + best[i] >= best[n] || deck[i] == -1))
           break;
           if (d + best[i] <= best[n])
               return;
       }

       Deck deck2 = void;
       foreach (immutable i; staticIota!(0, n)) // Copy.
           deck2[i] = deck[i];

       d++;
       foreach (immutable i; staticIota!(1, n)) {
           enum uint k = 1U << i;
           if (deck[i] != i && (deck[i] != -1 || (f & k)))
               continue;

           deck2[0] = T(i);
           foreach_reverse (immutable j; staticIota!(0, i))
               deck2[i - j] = deck[j]; // Reverse copy.
           trySwaps(deck2, f | k);
       }
       d--;
   }

   best[n] = 0;
   Deck deck0 = -1;
   deck0[0] = 0;
   trySwaps(deck0, 1);
   return best[n];

}

void main() {

   foreach (immutable i; staticIota!(1, 14))
       writefln("%2d: %d", i, topswops!i());

}</lang>

Output:

With templates to speed up the computation, using the DMD compiler it's almost as fast as the second C version.

Eiffel

<lang Eiffel> class TOPSWOPS

create make

feature

make (n: INTEGER) -- Topswop game. local perm, ar: ARRAY [INTEGER] tcount, count: INTEGER do create perm_sol.make_empty create solution.make_empty across 1 |..| n as c loop create ar.make_filled (0, 1, c.item) across 1 |..| c.item as d loop ar [d.item] := d.item end permute (ar, 1) across 1 |..| perm_sol.count as e loop tcount := 0 from until perm_sol.at (e.item).at (1) = 1 loop perm_sol.at (e.item) := reverse_array (perm_sol.at (e.item)) tcount := tcount + 1 end if tcount > count then count := tcount end end solution.force (count, c.item) end end

solution: ARRAY [INTEGER]

feature {NONE}

perm_sol: ARRAY [ARRAY [INTEGER]]

reverse_array (ar: ARRAY [INTEGER]): ARRAY [INTEGER] -- Array with 'ar[1]' elements reversed. require ar_not_void: ar /= Void local i, j: INTEGER do create Result.make_empty Result.deep_copy (ar) from i := 1 j := ar [1] until i > j loop Result [i] := ar [j] Result [j] := ar [i] i := i + 1 j := j - 1 end ensure same_elements: across ar as a all Result.has (a.item) end end

permute (a: ARRAY [INTEGER]; k: INTEGER) -- All permutations of array 'a' stored in perm_sol. require ar_not_void: a.count >= 1 k_valid_index: k > 0 local i, t: INTEGER temp: ARRAY [INTEGER] do create temp.make_empty if k = a.count then across a as ar loop temp.force (ar.item, temp.count + 1) end perm_sol.force (temp, perm_sol.count + 1) else from i := k until i > a.count loop t := a [k] a [k] := a [i] a [i] := t permute (a, k + 1) t := a [k] a [k] := a [i] a [i] := t i := i + 1 end end end

end </lang> Test: <lang Eiffel> class APPLICATION

create make

feature

make do create topswop.make (10) across topswop.solution as t loop io.put_string (t.item.out + "%N") end end

topswop: TOPSWOPS

end </lang>

Output:

Elixir

Translation of: Erlang

<lang elixir>defmodule Topswops do

 def get_1_first( [1 | _t] ), do: 0
 def get_1_first( list ), do: 1 + get_1_first( swap(list) )
 
 defp swap( [n | _t]=list ) do
   {swaps, remains} = Enum.split( list, n )
   Enum.reverse( swaps, remains )
 end
 
 def task do
   IO.puts "N\ttopswaps"
   Enum.map(1..10, fn n -> {n, permute(Enum.to_list(1..n))} end)
   |> Enum.map(fn {n, n_permutations} -> {n, get_1_first_many(n_permutations)} end)
   |> Enum.map(fn {n, n_swops} -> {n, Enum.max(n_swops)} end)
   |> Enum.each(fn {n, max} -> IO.puts "#{n}\t#{max}" end)
 end
 
 def get_1_first_many( n_permutations ), do: (for x <- n_permutations, do: get_1_first(x))
 
 defp permute([]), do: [[]]
 defp permute(list), do: for x <- list, y <- permute(list -- [x]), do: [x|y]

end

Topswops.task</lang>

Output:

N       topswaps
1       0
2       1
3       2
4       4
5       7
6       10
7       16
8       22
9       30
10      38

Erlang

This code is using the permutation code by someone else. Thank you. <lang Erlang> -module( topswops ).

-export( [get_1_first/1, swap/1, task/0] ).

get_1_first( [1 | _T] ) -> 0; get_1_first( List ) -> 1 + get_1_first( swap(List) ).

swap( [N | _T]=List ) -> {Swaps, Remains} = lists:split( N, List ), lists:reverse( Swaps ) ++ Remains.

task() -> Permutations = [{X, permute:permute(lists:seq(1, X))} || X <- lists:seq(1, 10)], Swops = [{N, get_1_first_many(N_permutations)} || {N, N_permutations} <- Permutations], Topswops = [{N, lists:max(N_swops)} || {N, N_swops} <- Swops], io:fwrite( "N topswaps~n" ), [io:fwrite("~p ~p~n", [N, Max]) || {N, Max} <- Topswops].

get_1_first_many( N_permutations ) -> [get_1_first(X) || X <- N_permutations]. </lang>

Output:

42> topswops:task().
N       topswaps
1       0
2       1
3       2
4       4
5       7
6       10
7       16
8       22
9       30
10      38

Fortran

<lang Fortran>module top implicit none contains recursive function f(x) result(m)

 integer :: n, m, x(:),y(size(x)), fst
 fst = x(1)
 if (fst == 1) then
   m = 0
 else
   y(1:fst) = x(fst:1:-1)
   y(fst+1:) = x(fst+1:)
   m = 1 + f(y)
 end if

end function

recursive function perms(x) result(p) integer, pointer :: p(:,:), q(:,:) integer :: x(:), n, k, i n = size(x) if (n == 1) then

 allocate(p(1,1))
 p(1,:) = x

else

 q => perms(x(2:n))
 k = ubound(q,1)
 allocate(p(k*n,n))
 p = 0
 do i = 1,n
   p(1+k*(i-1):k*i,1:i-1) = q(:,1:i-1)
   p(1+k*(i-1):k*i,i) = x(1)
   p(1+k*(i-1):k*i,i+1:) = q(:,i:)
 end do

end if end function end module

program topswort use top implicit none integer :: x(10) integer, pointer :: p(:,:) integer :: i, j, m

forall(i=1:10)

 x(i) = i

end forall

do i = 1,10

 p=>perms(x(1:i))
 m = 0
 do j = 1, ubound(p,1)
   m = max(m, f(p(j,:)))
 end do
 print "(i3,a,i3)", i,": ",m

end do end program </lang>

Go

<lang go>// Adapted from http://www-cs-faculty.stanford.edu/~uno/programs/topswops.w // at Donald Knuth's web site. Algorithm credited there to Pepperdine // and referenced to Mathematical Gazette 73 (1989), 131-133. package main

import "fmt"

const ( // array sizes

   maxn = 10 // max number of cards
   maxl = 50 // upper bound for number of steps

)

func main() {

   for i := 1; i <= maxn; i++ {
       fmt.Printf("%d: %d\n", i, steps(i))
   }

}

func steps(n int) int {

   var a, b [maxl][maxn + 1]int
   var x [maxl]int
   a[0][0] = 1
   var m int
   for l := 0; ; {
       x[l]++
       k := int(x[l])
       if k >= n {
           if l <= 0 {
               break
           }
           l--
           continue
       }
       if a[l][k] == 0 {
           if b[l][k+1] != 0 {
               continue
           }
       } else if a[l][k] != k+1 {
           continue
       }
       a[l+1] = a[l]
       for j := 1; j <= k; j++ {
           a[l+1][j] = a[l][k-j]
       }
       b[l+1] = b[l]
       a[l+1][0] = k + 1
       b[l+1][k+1] = 1
       if l > m-1 {
           m = l + 1
       }
       l++
       x[l] = 0
   }
   return m

}</lang>

Output:

Haskell

<lang Haskell>import Data.List (permutations)

topswops :: Int -> Int topswops n = maximum $ map tops $ permutations [1 .. n]

   where
       tops    (1 : _) = 0
       tops xa@(x : _) = 1 + tops reordered
           where
               reordered = reverse (take x xa) ++ drop x xa

main = mapM_

       (\x -> putStrLn $ show x ++ ":\t" ++ show (topswops x))
       [1 .. 10]</lang>

Output:

Alternate version
Uses only permutations with all elements out of place. <lang Haskell>import Data.List import Control.Arrow import Control.Monad

derangements = filter (and . zipWith (/=) [1..] ). permutations topswop = ((uncurry (++). first reverse).). splitAt topswopIter = takeWhile((/=1).head). iterate (topswop =<< head) swops = map (length. topswopIter). derangements

topSwops :: [Int] -> [(Int, Int)] topSwops = zip [1..]. map (maximum. (0:). swops). tail. inits</lang> Output

*Main> mapM_ print $ take 10 $ topSwops [1..]
(1,0)
(2,1)
(3,2)
(4,4)
(5,7)
(6,10)
(7,16)
(8,22)
(9,30)
(10,38)

Icon and Unicon

This doesn't compile in Icon only because of the use of list comprehension to build the original list of 1..n values.

<lang unicon>procedure main()

   every n := 1 to 10 do {
       ts := 0
       every (ts := 0) <:= swop(permute([: 1 to n :]))
       write(right(n, 3),": ",right(ts,4))
       }

end

procedure swop(A)

   count := 0
   while A[1] ~= 1 do {
       A := reverse(A[1+:A[1]]) ||| A[(A[1]+1):0]
       count +:= 1
       }
   return count

end

procedure permute(A)

   if *A <= 1 then return A
   suspend [(A[1]<->A[i := 1 to *A])] ||| permute(A[2:0])

end</lang>

Sample run:

J

Solution:<lang j> swops =: ((|.@:{. , }.)~ {.)^:a:</lang> Example (from task introduction):<lang j> swops 2 4 1 3 2 4 1 3 4 2 1 3 3 1 2 4 2 1 3 4 1 2 3 4</lang> Example (topswops of all permutations of the integers 1..10):<lang j> (,. _1 + ! >./@:(#@swops@A. >:)&i. ])&> 1+i.10

10 38</lang> Notes: Readers less familiar with array-oriented programming may find an alternate solution written in the structured programming style more accessible.

Java

Translation of: D

<lang java>public class Topswops {

   static final int maxBest = 32;
   static int[] best;

   static private void trySwaps(int[] deck, int f, int d, int n) {
       if (d > best[n])
           best[n] = d;

       for (int i = n - 1; i >= 0; i--) {
           if (deck[i] == -1 || deck[i] == i)
               break;
           if (d + best[i] <= best[n])
               return;
       }

       int[] deck2 = deck.clone();
       for (int i = 1; i < n; i++) {
           final int k = 1 << i;
           if (deck2[i] == -1) {
               if ((f & k) != 0)
                   continue;
           } else if (deck2[i] != i)
               continue;

           deck2[0] = i;
           for (int j = i - 1; j >= 0; j--)
               deck2[i - j] = deck[j]; // Reverse copy.
           trySwaps(deck2, f | k, d + 1, n);
       }
   }

   static int topswops(int n) {
       assert(n > 0 && n < maxBest);
       best[n] = 0;
       int[] deck0 = new int[n + 1];
       for (int i = 1; i < n; i++)
           deck0[i] = -1;
       trySwaps(deck0, 1, 0, n);
       return best[n];
   }

   public static void main(String[] args) {
       best = new int[maxBest];
       for (int i = 1; i < 11; i++)
           System.out.println(i + ": " + topswops(i));
   }

}</lang>

Output:

jq

The following uses permutations and is therefore impractical for n>10 or so.

Infrastructure: <lang jq># "while" as defined here is included in recent versions (>1.4) of jq: def until(cond; next):

 def _until:
   if cond then . else (next|_until) end;
 _until;

Generate a stream of permutations of [1, ... n].
This implementation uses arity-0 filters for speed.

def permutations:

 # Given a single array, insert generates a stream by inserting (length+1) at different positions
 def insert: # state: [m, array]
    .[0] as $m | (1+(.[1]|length)) as $n
    | .[1]
    | if $m >= 0 then (.[0:$m] + [$n] + .[$m:]), ([$m-1, .] | insert) else empty end;

 if .==0 then []
 elif . == 1 then [1]
 else
   . as $n | ($n-1) | permutations | [$n-1, .] | insert
 end;</lang>

Topswops: <lang jq># Input: a permutation; output: an integer def flips:

 # state: [i, array]
 [0, .]
 | until( .[1][0] == 1;
          .[1] as $p | $p[0] as $p0

| [.[0] + 1, ($p[:$p0] | reverse) + $p[$p0:] ] )

 | .[0];

input: n, the number of items

def fannkuch:

 reduce permutations as $p
   (0; [., ($p|flips) ] | max);</lang>

Example: <lang jq>range(1; 11) | [., fannkuch ]</lang>

Output:

<lang sh>$ jq -n -c -f topswops.jq [1,0] [2,1] [3,2] [4,4] [5,7] [6,10] [7,16] [8,22] [9,30] [10,38]</lang>

Julia

Fast, efficient version <lang julia>function fannkuch(n) n == 1 && return 0 n == 2 && return 1 p = [1:n] q = copy(p) s = copy(p) sign = 1; maxflips = sum = 0 while true q0 = p[1] if q0 != 1 for i = 2:n q[i] = p[i] end flips = 1 while true qq = q[q0] #?? if qq == 1 sum += sign*flips flips > maxflips && (maxflips = flips) break end q[q0] = q0 if q0 >= 4 i = 2; j = q0-1 while true t = q[i] q[i] = q[j] q[j] = t i += 1 j -= 1 i >= j && break end end q0 = qq flips += 1 end end #permute if sign == 1 t = p[2] p[2] = p[1] p[1] = t sign = -1 else t = p[2] p[2] = p[3] p[3] = t sign = 1 for i = 3:n sx = s[i] if sx != 1 s[i] = sx-1 break end i == n && return maxflips s[i] = i t = p[1] for j = 1:i p[j] = p[j+1] end p[i+1] = t end end end end</lang>

Output:

julia> function main()
for i = 1:10
	println(fannkuch(i))
end
end
# methods for generic function main
main() at none:2

julia> @time main()
0
1
2
4
7
10
16
22
30
38
elapsed time: 0.299617582 seconds

Mathematica

An exhaustive search of all possible permutations is done <lang Mathematica>flip[a_] :=

Block[{a1 = First@a},
 If[a1 == Length@a, Reverse[a], 
  Join[Reverse[a;; a1], aa1 + 1 ;;]]]

swaps[a_] := Length@FixedPointList[flip, a] - 2

Print[#, ": ", Max[swaps /@ Permutations[Range@#]]] & /@ Range[10];</lang>

Output:

PARI/GP

Naive solution: <lang parigp>flip(v:vec)={

 my(t=v[1]+1);
 if (t==2, return(0));
 for(i=1,t\2, [v[t-i],v[i]]=[v[i],v[t-i]]);
 1+flip(v)

} topswops(n)={

 my(mx);
 for(i=0,n!-1,
   mx=max(flip(Vecsmall(numtoperm(n,i))),mx)
 );
 mx;

} vector(10,n,topswops(n))</lang>

Output:

%1 = [0, 1, 2, 4, 7, 10, 16, 22, 30, 38]

An efficient solution would use PARI, following the C solution.

Perl

Recursive backtracking solution, starting with the final state and going backwards. <lang perl> sub next_swop {

 my( $max, $level, $p, $d ) = @_;
 my $swopped = 0;
 for( 2..@$p ){ # find possibilities
   my @now = @$p;
   if( $_ == $now[$_-1] ) {
     splice @now, 0, 0, reverse splice @now, 0, $_;
     $swopped = 1;
     next_swop( $max, $level+1, \@now, [ @$d ] );
   }
 }
 for( 1..@$d ) { # create possibilities
   my @now = @$p;
   my $next = shift @$d;
   if( not $now[$next-1] ) {
     $now[$next-1] = $next;
     splice @now, 0, 0, reverse splice @now, 0, $next;
     $swopped = 1;
     next_swop( $max, $level+1, \@now, [ @$d ] );
   }
   push @$d, $next;
 }
 $$max = $level if !$swopped and $level > $$max;

}

sub topswops {

 my $n = shift;
 my @d = 2..$n;
 my @p = ( 1, (0) x ($n-1) );
 my $max = 0;
 next_swop( \$max, 0, \@p, \@d );
 return $max;

}

printf "Maximum swops for %2d cards: %2d\n", $_, topswops $_ for 1..10; </lang>

Output:

Maximum swops for  1 cards:  0
Maximum swops for  2 cards:  1
Maximum swops for  3 cards:  2
Maximum swops for  4 cards:  4
Maximum swops for  5 cards:  7
Maximum swops for  6 cards: 10
Maximum swops for  7 cards: 16
Maximum swops for  8 cards: 22
Maximum swops for  9 cards: 30
Maximum swops for 10 cards: 38

Perl 6

<lang perl6>sub postfix:<!>(@a) {

   @a == 1
       ?? [@a]
       !! do for @a -> $a {
               [ $a, @$_ ] for @a.grep(* != $a)!
          }

}

sub swops(@a is copy) {

   my $count = 0;
   until @a[0] == 1 {
       @a[ ^@a[0] ] .= reverse;
       $count++;
   }
   return $count;

} sub topswops($n) { [max] map &swops, (1 .. $n)! }

say "$_ {topswops $_}" for 1 .. 10;</lang>

Output follows that of Python.

Phix

Originally contributed by Jason Gade as part of the Euphoria version of the Great Computer Language Shootout benchmarks. <lang Phix>function fannkuch(integer n) sequence start = tagset(n),

        perm,
        perm1 = start,
        count = start

integer maxFlipsCount = 0, r = n+1 integer perm0, flipsCount, k, k2, j, j2

   while 1 do
       while r!=1 do count[r-1] = r r -= 1 end while
       if not (perm1[1]=1 or perm1[n]=n) then
           perm = perm1
           flipsCount = 0
           k = perm[1]
           while k!=1 do
               k2 = floor((k+1)/2)
               perm = reverse(perm[1..k]) & perm[k+1..n]
               flipsCount += 1
               k = perm[1]
           end while
           if flipsCount>maxFlipsCount then
               maxFlipsCount = flipsCount
           end if
       end if
       -- Use incremental change to generate another permutation
       while 1 do
           if r>n then return maxFlipsCount end if
           perm0 = perm1[1]
           j2 = 1
           while j2<r do
               j = j2+1
               perm1[j2] = perm1[j]
               j2 = j
           end while
           perm1[r] = perm0
           count[r] = count[r]-1
           if count[r]>1 then exit else r += 1 end if
       end while
   end while

end function -- fannkuch

for i=1 to 10 do

   ? fannkuch(i)

end for</lang>

Output:

PL/I

<lang PL/I> (subscriptrange): topswap: procedure options (main); /* 12 November 2013 */

  declare cards(*) fixed (2) controlled, t fixed (2);
  declare dealt(*) bit(1) controlled;
  declare (count, i, m, n, c1, c2) fixed binary;
  declare random builtin;

  do n = 1 to 10;
     allocate cards(n), dealt(n);
     /* Take the n cards, in order ... */
     do i = 1 to n; cards(i) = i; end;
     /* ... and shuffle them. */
     do i = 1 to n;
        c1 = random*n+1; c2 = random*n+1;
        t = cards(c1); cards(c1) = cards(c2); cards(c2) = t;
     end;
     /* If '1' is the first card, game is trivial; swap it with another. */
     if cards(1) = 1 & n > 1 then
        do; t = cards(1); cards(1) = cards(2); cards(2) = t; end;

     count = 0;
     do until (cards(1) = 1);
        /* take the value of the first card, M, and reverse the first M cards. */
        m = cards(1);
        do i = 1 to m/2;
           t = cards(i); cards(i) = cards(m-i+1); cards(m-i+1) = t;
        end;
        count = count + 1;
     end;
     put skip edit (n, ':', count) (f(2), a, f(4));
  end;

end topswap; </lang>

Potion

<lang potion>range = (a, b):

 i = 0, l = list(b-a+1)
 while (a + i <= b):
   l (i) = a + i++.
 l.

fannkuch = (n):

 flips = 0, maxf = 0, k = 0, m = n - 1, r = n
 perml = range(0, n), count = list(n), perm = list(n)

 loop:
   while (r != 1):
     count (r-1) = r
     r--.

   if (perml (0) != 0 and perml (m) != m):
     flips = 0, i = 1
     while (i < n):
       perm (i) = perml (i)
       i++.
     k = perml (0)
     loop:
       i = 1, j = k - 1
       while (i < j):
         t = perm (i), perm (i) = perm (j), perm (j) = t
         i++, j--.
       flips++
       j = perm (k), perm (k) = k, k = j
       if (k == 0): break.
     .
     if (flips > maxf): maxf = flips.
   .

   loop:
     if (r == n):
       (n, maxf) say
       return (maxf).

     i = 0, j = perml (0)
     while (i < r):
       k = i + 1
       perml (i) = perml (k)
       i = k.
     perml (r) = j

     j = count (r) - 1
     count (r) = j
     if (j > 0): break.
     r++

_ n

n = argv(1) number if (n<1): n=10. fannkuch(n) </lang>

Output follows that of Perl6 and Python, ~2.5x faster than perl5

Python

This solution uses cards numbered from 0..n-1 and variable p0 is introduced as a speed optimisation <lang python>>>> from itertools import permutations >>> def f1(p): i = 0 while True: p0 = p[0] if p0 == 1: break p[:p0] = p[:p0][::-1] i += 1 return i

>>> def fannkuch(n): return max(f1(list(p)) for p in permutations(range(1, n+1)))

>>> for n in range(1, 11): print(n,fannkuch(n))

1 0 2 1 3 2 4 4 5 7 6 10 7 16 8 22 9 30 10 38 >>> </lang>

Python: Faster Version

Translation of: C

<lang python>try:

   import psyco
   psyco.full()

except ImportError:

   pass

best = [0] * 16

def try_swaps(deck, f, s, d, n):

   if d > best[n]:
       best[n] = d

   i = 0
   k = 1 << s
   while s:
       k >>= 1
       s -= 1
       if deck[s] == -1 or deck[s] == s:
           break
       i |= k
       if (i & f) == i and d + best[s] <= best[n]:
           return d
   s += 1

   deck2 = list(deck)
   k = 1
   for i2 in xrange(1, s):
       k <<= 1
       if deck2[i2] == -1:
           if f & k: continue
       elif deck2[i2] != i2:
           continue

       deck[i2] = i2
       deck2[:i2 + 1] = reversed(deck[:i2 + 1])
       try_swaps(deck2, f | k, s, 1 + d, n)

def topswops(n):

   best[n] = 0
   deck0 = [-1] * 16
   deck0[0] = 0
   try_swaps(deck0, 1, n, 0, n)
   return best[n]

for i in xrange(1, 13):

   print "%2d: %d" % (i, topswops(i))</lang>

Output:

Racket

Simple search, only "optimization" is to consider only all-misplaced permutations (as in the alternative Haskell solution), which shaves off around 2 seconds (from ~5).

lang racket

(define (all-misplaced? l)

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

(define (topswops n)

 (for/fold ([m 0]) ([p (in-permutations (range 1 (add1 n)))]
                    #:when (all-misplaced? p))
   (let loop ([p p] [n 0])
     (if (= 1 (car p))
       (max n m)
       (loop (let loop ([l '()] [r p] [n (car p)])
               (if (zero? n) (append l r)
                   (loop (cons (car r) l) (cdr r) (sub1 n))))
             (add1 n))))))

(for ([i (in-range 1 11)]) (printf "~a\t~a\n" i (topswops i))) </lang>

Output:

REXX

The deckSets subroutine is a modified permSets (permutation sets) subroutine,
and is optimized somewhat to take advantage by eliminating one-swop "decks". <lang rexx>/*REXX pgm gens N decks of numbered cards and finds the maximum "swops".*/ parse arg things .; if things== then things=10; thingsX= things>9

     do n=1  for things;    #=deckSets(n,n)           /*create "decks".*/
     mx= n\==1                        /*handle case of a one-card deck.*/
                do i=1  for #
                mx=max(mx,swops(!.i))
                end   /*i*/
     say '──────── maximum swops for a deck of' right(n,2) ' cards is' right(mx,4)
     end   /*n*/

exit /*stick a fork in it, we're done.*/ /*──────────────────────────────────DECKSETS subroutine─────────────────*/ deckSets: procedure expose !. /*X things taken Y at a time.*/ parse arg x,y,,$ @.; #=0; call .deckset 1 /*set $ & @. to null.*/ return # /*return # permutations (decks).*/ .deckset: procedure expose @. x y $ # !.; parse arg ? if ?>y then do; _=@.1; do j=2 to y; _=_ @.j; end /*j*/; #=#+1; !.#=_

           end
      else do
           ?m=?-1                     /*used in the FOR for faster  DO.*/
           if ?==1 then qs=2          /*¬ use 1-swops that start with 1*/
                   else do
                        qs=1
                        if @.1==? then qs=2   /*skip 1-swops:  3 x 1 x */
                        end
             do q=qs  to x            /*build permutation recursively. */
                do k=1  for ?m;   if @.k==q  then iterate q;   end  /*k*/
             @.?=q;               call .deckset(?+1)
             end    /*q*/
           end

return /*──────────────────────────────────SWOPS subroutine────────────────────*/ swops: parse arg z; do _=1; t=word(z,1)

                        if word(z,t)==1  then return _
                        if thingsX       then do h=10  to things
                                              z=changestr(h,z,d2x(h))
                                              end   /*h*/
                        z=reverse(subword(z,1,t))  subword(z,t+1)
                        if thingsX       then do d=10  to things
                                              z=changestr(d2x(d),z,d)
                        end   /*_*/</lang>

Some older REXXes don't have a changestr bif, so one is included here ──► CHANGESTR.REX.

output when using the default input

──────── maximum swops for a deck of  1  cards is    0
──────── maximum swops for a deck of  2  cards is    1
──────── maximum swops for a deck of  3  cards is    2
──────── maximum swops for a deck of  4  cards is    4
──────── maximum swops for a deck of  5  cards is    7
──────── maximum swops for a deck of  6  cards is   10
──────── maximum swops for a deck of  7  cards is   16
──────── maximum swops for a deck of  8  cards is   22
──────── maximum swops for a deck of  9  cards is   30
──────── maximum swops for a deck of 10  cards is   38

Ruby

Translation of: Python

<lang ruby>def f1(a)

 i = 0
 while (a0 = a[0]) > 1
   a[0...a0] = a[0...a0].reverse
   i += 1
 end
 i

end

def fannkuch(n)

 [*1..n].permutation.map{|a| f1(a)}.max

end

for n in 1..10

 puts "%2d : %d" % [n, fannkuch(n)]

end</lang>

Output:

Faster Version

Translation of: Java

<lang ruby>def try_swaps(deck, f, d, n)

 @best[n] = d  if d > @best[n]
 (n-1).downto(0) do |i|
   break  if deck[i] == -1 || deck[i] == i
   return if d + @best[i] <= @best[n]
 end
 deck2 = deck.dup
 for i in 1...n
   k = 1 << i
   if deck2[i] == -1
     next  if f & k != 0
   elsif deck2[i] != i
     next
   end
   deck2[0] = i
   deck2[1..i] = deck[0...i].reverse
   try_swaps(deck2, f | k, d+1, n)
 end

end

def topswops(n)

 @best[n] = 0
 deck0 = [-1] * (n + 1)
 try_swaps(deck0, 1, 0, n)
 @best[n]

end

@best = [0] * 16 for i in 1..10

 puts "%2d : %d" % [i, topswops(i)]

end</lang>

Scala

Library: Scala

<lang Scala>object Fannkuch extends App {

 def fannkuchen(l: List[Int], n: Int, i: Int, acc: Int): Int = {
   def flips(l: List[Int]): Int = (l: @unchecked) match {
     case 1 :: ls => 0
     case (n :: ls) =>
       val splitted = l.splitAt(n)
       flips(splitted._2.reverse_:::(splitted._1)) + 1
   }

   def rotateLeft(l: List[Int]) =
     l match {
       case Nil => List()
       case x :: xs => xs ::: List(x)
     }

   if (i >= n) acc
   else {
     if (n == 1) acc.max(flips(l))
     else {
       val split = l.splitAt(n)
       fannkuchen(rotateLeft(split._1) ::: split._2, n, i + 1, fannkuchen(l, n - 1, 0, acc))
     }
   }
 } // def fannkuchen(

 val result = (1 to 10).map(i => (i, fannkuchen(List.range(1, i + 1), i, 0, 0)))
 println("Computing results...")
 result.foreach(x => println(s"Pfannkuchen(${x._1})\t= ${x._2}"))
 assert(result == Vector((1, 0), (2, 1), (3, 2), (4, 4), (5, 7), (6, 10), (7, 16), (8, 22), (9, 30), (10, 38)), "Bad results")
 println(s"Successfully completed without errors. [total ${scala.compat.Platform.currentTime - executionStart} ms]")

}</lang>

Output:

Computing results...
Pfannkuchen(1)	= 0
Pfannkuchen(2)	= 1
Pfannkuchen(3)	= 2
Pfannkuchen(4)	= 4
Pfannkuchen(5)	= 7
Pfannkuchen(6)	= 10
Pfannkuchen(7)	= 16
Pfannkuchen(8)	= 22
Pfannkuchen(9)	= 30
Pfannkuchen(10)	= 38
Successfully completed without errors. [total 7401 ms]

Process finished with exit code 0

Tcl

Library: Tcllib (Package: struct::list)

Probably an integer overflow at n=10.

<lang tcl>package require struct::list

proc swap {listVar} {

   upvar 1 $listVar list
   set n [lindex $list 0]
   for {set i 0; set j [expr {$n-1}]} {$i<$j} {incr i;incr j -1} {

set tmp [lindex $list $i] lset list $i [lindex $list $j] lset list $j $tmp

}

proc swaps {list} {

   for {set i 0} {[lindex $list 0] > 1} {incr i} {

swap list

   }
   return $i

}

proc topswops list {

   set n 0
   ::struct::list foreachperm p $list {

set n [expr {max($n,[swaps $p])}]

   }
   return $n

}

proc topswopsTo n {

   puts "n\ttopswops(n)"
   for {set i 1} {$i <= $n} {incr i} {

puts $i\t[topswops [lappend list $i]]

}

topswopsTo 10</lang>

Output:

n	topswops(n)
1	0
2	1
3	2
4	4
5	7
6	10
7	16
8	22
9	30
10	38

XPL0

<lang XPL0>code ChOut=8, CrLf=9, IntOut=11; int N, Max, Card1(16), Card2(16);

proc Topswop(D); \Conway's card swopping game int D; \depth of recursion int I, J, C, T; [if D # N then \generate N! permutations of 1..N in Card1

    [for I:= 0 to N-1 do
       [for J:= 0 to D-1 do    \check if object (letter) already used
           if Card1(J) = I+1 then J:=100;
       if J < 100 then
           [Card1(D):= I+1;    \card number not used so append it
           Topswop(D+1);       \recurse next level deeper
           ];
       ];
    ]

else [\determine number of topswops to get card 1 at beginning

    for I:= 0 to N-1 do Card2(I):= Card1(I);   \make working copy of deck
       C:= 0;                  \initialize swop counter
       while Card2(0) # 1 do
           [I:= 0;  J:= Card2(0)-1;
           while I < J do
               [T:= Card2(I);  Card2(I):= Card2(J);  Card2(J):= T;
               I:= I+1;  J:= J-1;
               ];
           C:= C+1;
           ];  
    if C>Max then Max:= C;
    ];

];

[for N:= 1 to 10 do

   [Max:= 0;
   Topswop(0);
   IntOut(0, N);  ChOut(0, ^ );  IntOut(0, Max);  CrLf(0);
   ];

]</lang>

Output:

XPL0: Faster Version

Translation of: C

<lang XPL0>code CrLf=9, IntOut=11, Text=12; int N, D, Best(16);

proc TrySwaps(A, F, S); int A, F, S; int B(16), I, J, K; [if D > Best(N) then Best(N):= D; loop [if A(S)=-1 ! A(S)=S then quit;

       if D+Best(S) <= Best(N) then return;
       if S = 0 then quit;
       S:= S-1;
       ];

D:= D+1; for I:= 0 to S do B(I):= A(I); K:= 1; for I:= 1 to S do

       [K:= K<<1;
       if B(I)=-1 & (F&K)=0 ! B(I)=I then
               [J:= I;  B(0):= J;
               while J do [J:= J-1;  B(I-J):= A(J)];
               TrySwaps(B, F!K, S);
               ];
       ];

D:= D-1; ];

int I, X(16); [for I:= 0 to 16-1 do

       [X(I):= -1;  Best(I):= 0];

X(0):= 0; for N:= 1 to 13 do

       [D:= 0;
       TrySwaps(X, 1, N-1);
       IntOut(0, N);  Text(0, ": ");  IntOut(0, Best(N));  CrLf(0);
       ];

]</lang>

Output:

zkl

Translation of: D

Slow version <lang zkl>fcn topswops(n){

  flip:=fcn(xa){
     if (not xa[0]) return(0);
     xa.reverse(0,xa[0]+1);  // inplace, ~4x faster than making new lists
     return(1 + self.fcn(xa));
  };
  (0).pump(n,List):Utils.Helpers.permute(_).apply("copy").apply(flip).reduce("max");

}

foreach n in ([1 .. 10]){ println(n, ": ", topswops(n)) }</lang>

Output: