September Morn Update

Task/Permutations/Aime/permutations.aime

@@ -0,0 +1,24 @@
+void
+f1(record r, ...)
+{
+    if (~r) {
+        for (text s in r) {
+            r.delete(s);
+            rcall(f1, -2, 0, -1, s);
+            r[s] = 0;
+        }
+    } else {
+        ocall(o_, -2, 1, -1, " ", ",");
+        o_newline();
+    }
+}
+
+main(...)
+{
+    record r;
+
+    ocall(r_put, -2, 1, -1, r, 0);
+    f1(r);
+
+    0;
+}

Task/Permutations/AppleScript/permutations-1.applescript

@@ -2,23 +2,27 @@
 
 -- permutations :: [a] -> [[a]]
 on permutations(xs)
-    script firstElement
-        on |λ|(x)
-            script tailElements
-                on |λ|(ys)
-                    {{x} & ys}
+    script go
+        on |λ|(xs)
+            script h
+                on |λ|(x)
+                    script ts
+                        on |λ|(ys)
+                            {{x} & ys}
+                        end |λ|
+                    end script
+                    concatMap(ts, go's |λ|(|delete|(x, xs)))
                 end |λ|
             end script
 
-            concatMap(tailElements, permutations(|delete|(x, xs)))
+            if {} ≠ xs then
+                concatMap(h, xs)
+            else
+                {{}}
+            end if
         end |λ|
     end script
-
-    if length of xs > 0 then
-        concatMap(firstElement, xs)
-    else
-        {{}}
-    end if
+    go's |λ|(xs)
 end permutations
 
 
@@ -58,17 +62,6 @@ on |delete|(x, xs)
     end if
 end |delete|
 
--- map :: (a -> b) -> [a] -> [b]
-on map(f, xs)
-    tell mReturn(f)
-        set lng to length of xs
-        set lst to {}
-        repeat with i from 1 to lng
-            set end of lst to |λ|(item i of xs, i, xs)
-        end repeat
-        return lst
-    end tell
-end map
 
 -- Lift 2nd class handler function into 1st class script wrapper
 -- mReturn :: Handler -> Script

Task/Permutations/AppleScript/permutations-3.applescript

@@ -0,0 +1,124 @@
+-- permutations :: [a] -> [[a]]
+on permutations(xs)
+    script go
+        on |λ|(x, a)
+            script
+                on |λ|(ys)
+                    script infix
+                        on |λ|(n)
+                            if ys ≠ {} then
+                                take(n, ys) & {x} & drop(n, ys)
+                            else
+                                {x}
+                            end if
+                        end |λ|
+                    end script
+                    map(infix, enumFromTo(0, (length of ys)))
+                end |λ|
+            end script
+            concatMap(result, a)
+        end |λ|
+    end script
+    foldr(go, {{}}, xs)
+end permutations
+
+
+-- TEST ---------------------------------------------------
+on run
+
+    permutations({1, 2, 3})
+
+    --> {{1, 2, 3}, {2, 1, 3}, {2, 3, 1}, {1, 3, 2}, {3, 1, 2}, {3, 2, 1}}
+end run
+
+
+-- GENERIC ------------------------------------------------
+
+-- concatMap :: (a -> [b]) -> [a] -> [b]
+on concatMap(f, xs)
+    set lng to length of xs
+    set acc to {}
+    tell mReturn(f)
+        repeat with i from 1 to lng
+            set acc to acc & |λ|(item i of xs, i, xs)
+        end repeat
+    end tell
+    return acc
+end concatMap
+
+-- drop :: Int -> [a] -> [a]
+on drop(n, xs)
+    if n < length of xs then
+        items (1 + n) thru -1 of xs
+    else
+        {}
+    end if
+end drop
+
+-- enumFromTo :: Int -> Int -> [Int]
+on enumFromTo(m, n)
+    if m ≤ n then
+        set lst to {}
+        repeat with i from m to n
+            set end of lst to i
+        end repeat
+        return lst
+    else
+        return {}
+    end if
+end enumFromTo
+
+-- foldr :: (a -> b -> b) -> b -> [a] -> b
+on foldr(f, startValue, xs)
+    tell mReturn(f)
+        set v to startValue
+        set lng to length of xs
+        repeat with i from lng to 1 by -1
+            set v to |λ|(item i of xs, v, i, xs)
+        end repeat
+        return v
+    end tell
+end foldr
+
+-- Lift 2nd class handler function into 1st class script wrapper
+-- mReturn :: First-class m => (a -> b) -> m (a -> b)
+on mReturn(f)
+    if class of f is script then
+        f
+    else
+        script
+            property |λ| : f
+        end script
+    end if
+end mReturn
+
+-- map :: (a -> b) -> [a] -> [b]
+on map(f, xs)
+    tell mReturn(f)
+        set lng to length of xs
+        set lst to {}
+        repeat with i from 1 to lng
+            set end of lst to |λ|(item i of xs, i, xs)
+        end repeat
+        return lst
+    end tell
+end map
+
+-- min :: Ord a => a -> a -> a
+on min(x, y)
+    if y < x then
+        y
+    else
+        x
+    end if
+end min
+
+-- take :: Int -> [a] -> [a]
+-- take :: Int -> String -> String
+on take(n, xs)
+    if 0 < n then
+        items 1 thru min(n, length of xs) of xs
+    else
+        {}
+    end if
+end take

Task/Permutations/C/permutations-2.c

@@ -1,11 +1,10 @@
 #include <stdio.h>
 int main() {
-        char a[] = "4321";
-        int fact = 24;
+        char a[] = "4321";  //array
            int i, j;
-           int y=0;
-           char c;
-          while (y != fact) {
+           int f=24; 	    //factorial
+           char c;          //buffer
+          while (f--) {
           printf("%s\n", a);
           i=1;
           while(a[i] > a[i-1]) i++;
@@ -20,6 +19,5 @@ for (j = 0; j < i; i--, j++) {
   a[i] = a[j];
   a[j] = c;
       }
-y++;
    }
 }

Task/Permutations/Crystal/permutations.crystal

@@ -0,0 +1 @@
+puts [1, 2, 3].permutations

Task/Permutations/Curry/permutations.curry

@@ -0,0 +1,7 @@
+insert :: a -> [a] -> [a]
+insert x xs  = x : xs
+insert x (y:ys) = y : insert x ys
+
+permutation :: [a] -> [a]
+permutation []     = []
+permutation (x:xs) = insert x $ permutation xs

Task/Permutations/Go/permutations-2.go

@@ -0,0 +1,29 @@
+package main
+
+import "fmt"
+
+func main() {
+        var a = []int{1, 2, 3}
+        fmt.Println(a)
+        var n = len(a) - 1
+        var i, j int
+        for c := 1; c < 6; c++ { // 3! = 6:
+                i = n - 1
+                j = n
+                for a[i] > a[i+1] {
+                        i--
+                }
+                for a[j] < a[i] {
+                        j--
+                }
+                a[i], a[j] = a[j], a[i]
+                j = n
+                i += 1
+                for i < j {
+                        a[i], a[j] = a[j], a[i]
+                        i++
+                        j--
+                }
+                fmt.Println(a)
+        }
+}

Task/Permutations/Haskell/permutations-5.hs

@@ -0,0 +1,10 @@
+permutations :: [a] -> [[a]]
+permutations =
+  foldr (\x ac -> ac >>= (fmap . ins x) <*> (enumFromTo 0 . length)) [[]]
+  where
+    ins x xs n =
+      let (a, b) = splitAt n xs
+      in a ++ x : b
+
+main :: IO ()
+main = print $ permutations [1, 2, 3]

Task/Permutations/JavaScript/permutations-6.js

@@ -2,37 +2,38 @@
     'use strict';
 
     // permutations :: [a] -> [[a]]
-    const permutations = xs =>
-        xs.length ? concatMap(x => concatMap(ys => [
-                [x].concat(ys)
-            ],
-            permutations(delete_(x, xs))), xs) : [
-            []
-        ];
+    const permutations = xs => {
+        const go = xs => xs.length ? (
+            concatMap(
+                x => concatMap(
+                    ys => [[x].concat(ys)],
+                    go(delete_(x, xs))), xs
+                )
+        ) : [[]];
+        return go(xs);
+    };
 
-    // GENERIC FUNCTIONS
+    // GENERIC FUNCTIONS ----------------------------------
 
     // concatMap :: (a -> [b]) -> [a] -> [b]
-    const concatMap = (f, xs) => [].concat.apply([], xs.map(f));
-    //
-    // // delete :: Eq a => a -> [a] -> [a]
-    // const delete_ = (x, xs) =>
-    //     deleteBy((a, b) => a === b, x, xs);
+    const concatMap = (f, xs) =>
+        xs.reduce((a, x) => a.concat(f(x)), []);
 
-    // delete_ :: Eq a => a -> [a] -> [a]
-    const delete_ = (x, xs) =>
-        xs.length > 0 ? (
-            (x === xs[0]) ? (
-                xs.slice(1)
-            ) : [xs[0]].concat(delete_(x, xs.slice(1)))
-        ) : [];
 
-    // range :: Int -> Int -> [Int]
-    const range = (m, n) =>
-        Array.from({
-            length: Math.floor(n - m) + 1
-        }, (_, i) => m + i);
+    // delete :: Eq a => a -> [a] -> [a]
+    const delete_ = (x, xs) => {
+        const go = xs => {
+            return 0 < xs.length ? (
+                (x === xs[0]) ? (
+                    xs.slice(1)
+                ) : [xs[0]].concat(go(xs.slice(1)))
+            ) : [];
+        }
+        return go(xs);
+    };
 
     // TEST
-    return permutations(['Aardvarks', 'eat', 'ants']);
+    return JSON.stringify(
+        permutations(['Aardvarks', 'eat', 'ants'])
+    );
 })();

Task/Permutations/JavaScript/permutations-8.js

@@ -0,0 +1,42 @@
+(() => {
+    'use strict';
+
+    // permutations :: [a] -> [[a]]
+    const permutations = xs =>
+        xs.reduceRight(
+            (a, x) => concatMap(
+                xs => enumFromTo(0, xs.length)
+                .map(n => xs.slice(0, n)
+                    .concat(x)
+                    .concat(xs.slice(n))
+                ),
+                a
+            ),
+            [[]]
+        );
+
+    // GENERIC FUNCTIONS ----------------------------------
+
+    // concatMap :: (a -> [b]) -> [a] -> [b]
+    const concatMap = (f, xs) =>
+        xs.reduce((a, x) => a.concat(f(x)), []);
+
+    // ft :: Int -> Int -> [Int]
+    const enumFromTo = (m, n) =>
+        Array.from({
+            length: 1 + n - m
+        }, (_, i) => m + i);
+
+    // showLog :: a -> IO ()
+    const showLog = (...args) =>
+        console.log(
+            args
+            .map(JSON.stringify)
+            .join(' -> ')
+        );
+
+    // TEST -----------------------------------------------
+    showLog(
+        permutations([1, 2, 3])
+    );
+})();

Task/Permutations/Julia/permutations-1.julia

@@ -5,6 +5,7 @@ i = 0
 pcnt = factorial(length(term))
 print("All the permutations of ", term, " (", pcnt, "):\n    ")
 for p in permutations(split(term, ""))
+    global i
     print(join(p), " ")
     i += 1
     i %= 12

Task/Permutations/Julia/permutations-2.julia

@@ -0,0 +1,2 @@
+# Generate all permutations of size t from an array a with possibly duplicated elements.
+collect(Combinatorics.multiset_permutations([1,1,0,0,0],3))

Task/Permutations/Mathematica/permutations-1.math

@@ -0,0 +1,11 @@
+(***Standard list functions:*)
+fold[f_, x_, {}] := x
+fold[f_, x_, {h_, t___}] := fold[f, f[x, h], {t}]
+insert[L_, x_, n_] := Join[L[[;; n - 1]], {x}, L[[n ;;]]]
+
+(***Generate all permutations of a list S:*)
+
+permutations[S_] :=
+ fold[Join @@ (Function[{L},
+       Table[insert[L, #2, k + 1], {k, 0, Length[L]}]] /@ #1) &, {{}},
+   S]

Task/Permutations/Mercury/permutations.mercury

@@ -0,0 +1,37 @@
+:- module permutations2.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+
+:- import_module list.
+:- import_module set_ordlist.
+:- import_module set.
+:- import_module solutions.
+
+%% permutationSet(List, Set) is true if List is a permutation of Set:
+:- pred permutationSet(list(A)::out,set(A)::in) is nondet.
+
+%% Two ways to compute all permutations of a given list (using backtracking):
+:- func all_permutations1(list(int))=set_ordlist.set_ordlist(list(int)).
+:- func all_permutations2(list(int))=set_ordlist.set_ordlist(list(int)).
+
+:- implementation.
+
+
+permutationSet([],set.init).
+permutationSet([H|T], S) :- set.member(H,S), permutationSet(T,set.delete(S,H)).
+
+all_permutations1(L) =
+    solutions_set(pred(X::out) is nondet:-permutationSet(X,set.from_list(L))).
+
+%%Alternatively, using the imported list.perm predicate:
+all_permutations2(L) =
+    solutions_set(pred(X::out) is nondet:-perm(L,X)).
+
+main(!IO) :-
+    print(all_permutations1([1,2,3,4]),!IO),
+    nl(!IO),
+    print(all_permutations2([1,2,3,4]),!IO).

Task/Permutations/Modula-3/permutations-1.mod3

@@ -0,0 +1,58 @@
+MODULE Permutations EXPORTS Main;
+
+IMPORT IO, IntSeq;
+
+CONST n = 3;
+
+TYPE Domain = SET OF [ 1.. n ];
+
+VAR
+
+  chosen: IntSeq.T;
+  values := Domain { };
+
+PROCEDURE GeneratePermutations(VAR chosen: IntSeq.T; remaining: Domain) =
+(*
+  Recursively generates all the permutations of elements
+  in the union of "chosen" and "values".
+  Values in "chosen" have already been chosen;
+  values in "remaining" can still be chosen.
+  If "remaining" is empty, it prints the sequence and returns.
+  Otherwise, it picks each element in "remaining", removes it,
+  adds it to "chosen", recursively calls itself,
+  then removes the last element of "chosen" and adds it back to "remaining".
+*)
+BEGIN
+  FOR i := 1 TO n DO
+    (* check if each element is in "remaining" *)
+    IF i IN remaining THEN
+      (* if so, remove from "remaining" and add to "chosen" *)
+      remaining := remaining - Domain { i };
+      chosen.addhi(i);
+      IF remaining # Domain { } THEN
+        (* still something to process? do it *)
+        GeneratePermutations(chosen, remaining);
+      ELSE
+        (* otherwise, print what we've chosen *)
+        FOR j := 0 TO chosen.size() - 2 DO
+          IO.PutInt(chosen.get(j)); IO.Put(", ");
+        END;
+        IO.PutInt(chosen.gethi());
+        IO.PutChar('\n');
+      END;
+      (* add "i" back to "remaining" and remove from "chosen" *)
+      remaining := remaining + Domain { i };
+      EVAL chosen.remhi();
+    END;
+  END;
+END GeneratePermutations;
+
+BEGIN
+
+  (* initial setup *)
+  chosen := NEW(IntSeq.T).init(n);
+  FOR i := 1 TO n DO values := values + Domain { i }; END;
+
+  GeneratePermutations(chosen, values);
+
+END Permutations.

Task/Permutations/Modula-3/permutations-2.mod3

@@ -0,0 +1,28 @@
+GENERIC INTERFACE GenericPermutations(DomainSeq, DomainSet, DomainSeqSeq);
+
+(*
+  "Domain" is where the things to permute come from (unused in interface).
+  "DomainSeq" is a "Sequence" of "Domain".
+  "DomainSet" is a "Set" of "Domain".
+  "DomainSeqSeq" is a "Sequence" of "DomainSeq".
+*)
+
+PROCEDURE GeneratePermutations(
+  READONLY chosen: DomainSeq.T;
+  READONLY remaining: DomainSet.T;
+  READONLY result: DomainSeqSeq.T
+);
+(*
+  Recursively generates all the permutations of elements
+  in the union of "chosen" and "remaining".
+  Values in "chosen" have already been chosen;
+  values in "remaining" can still be chosen.
+  If "remaining" is empty, it adds the permutation to "result".
+  Otherwise, it picks each element in "remaining", removes it,
+  adds it to "chosen", recursively calls itself,
+  then removes the last element of "chosen" and adds it back to "remaining".
+  Although the parameters are modified, we can describe them as "READONLY"
+  because we do not re-assign them.
+*)
+
+END GenericPermutations.

Task/Permutations/Modula-3/permutations-3.mod3

@@ -0,0 +1,71 @@
+GENERIC MODULE GenericPermutations(Domain, DomainSeq, DomainSet, DomainSeqSeq);
+
+(*
+  "Domain" is where the things to permute come from.
+  "DomainSeq" is a "Sequence" of "Domain".
+  "DomainSet" is a "Set" of "Domain".
+  "DomainSeqSeq" is a "Sequence" of "DomainSeq".
+*)
+
+PROCEDURE GeneratePermutations(
+  READONLY chosen: DomainSeq.T;
+  READONLY remaining: DomainSet.T;
+  READONLY result: DomainSeqSeq.T
+) =
+
+(*
+  Recursively generates all the permutations of elements
+  in the union of "chosen" and "remaining".
+  Values in "chosen" have already been chosen;
+  values in "remaining" can still be chosen.
+  If "remaining" is empty, it adds the permutation to "result".
+  Otherwise, it picks each element in "remaining", removes it,
+  adds it to "chosen", recursively calls itself,
+  then removes the last element of "chosen" and adds it back to "remaining".
+*)
+
+VAR
+
+  r: Domain.T; (* element added to permutation *)
+
+  iterator := remaining.iterate(); (* to iterate through remaining elements *)
+
+  values := NEW(DomainSeq.T).init(remaining.size());
+  (* used to store values for iteration *)
+
+BEGIN
+
+  (* cannot safely modify a set while iterating, so we'll store the values *)
+  WHILE iterator.next(r) DO values.addhi(r); END;
+
+  (* now loop through the stored values *)
+  FOR i := 0 TO values.size() - 1 DO
+
+    (* remove from "remaining" and add to "chosen" *)
+    r := values.get(i);
+    EVAL remaining.delete(r);
+    chosen.addhi(r);
+
+    (* if this is not the last remaining elements, call recursively *)
+    IF remaining.size() # 0 THEN
+      GeneratePermutations(chosen, remaining, result);
+    ELSE
+      (* we have a new permutation; add a copy to the set *)
+      VAR newPerm := NEW(DomainSeq.T).init(chosen.size());
+      BEGIN
+        FOR i := 0 TO chosen.size() - 1 DO
+          newPerm.addhi(chosen.get(i));
+        END;
+        result.addhi(newPerm);
+      END;
+    END;
+
+    (* move r back from chosen *)
+    EVAL remaining.insert(chosen.remhi());
+
+  END;
+
+END GeneratePermutations;
+
+BEGIN
+END GenericPermutations.

Task/Permutations/Modula-3/permutations-4.mod3

@@ -0,0 +1,43 @@
+MODULE GPermutations EXPORTS Main;
+
+IMPORT IO, IntSeq, IntSetTree, IntSeqSeq, IntPermutations;
+
+CONST
+
+  n = 7;
+
+VAR
+
+  chosen: IntSeq.T;
+  remaining: IntSetTree.T;
+  result: IntSeqSeq.T;
+
+PROCEDURE Factorial(n: CARDINAL): CARDINAL =
+VAR result := 1;
+BEGIN
+  FOR i := 2 TO n DO
+    result := result * i;
+  END;
+  RETURN result;
+END Factorial;
+
+BEGIN
+
+  (* initial setup *)
+  chosen := NEW(IntSeq.T).init(n);
+  remaining := NEW(IntSetTree.T).init();
+  result := NEW(IntSeqSeq.T).init(Factorial(n));
+  FOR i := 1 TO n DO EVAL remaining.insert(i); END;
+
+  IntPermutations.GeneratePermutations(chosen, remaining, result);
+
+  IO.Put("Printing "); IO.PutInt(result.size());
+  IO.Put(" permutations of "); IO.PutInt(n); IO.Put(" elements \n");
+  FOR i := 0 TO result.size() - 1 DO
+    FOR j := 0 TO result.get(i).size() - 1 DO
+      IO.PutInt(result.get(i).get(j)); IO.PutChar(' ');
+    END;
+    IO.PutChar('\n');
+  END;
+
+END GPermutations.

Task/Permutations/Nim/permutations-2.nim

@@ -0,0 +1,38 @@
+# nim implementation of the (very fast) Go example
+# http://rosettacode.org/wiki/Permutations#Go
+# implementing a recursive https://en.wikipedia.org/wiki/Steinhaus–Johnson–Trotter_algorithm
+
+proc perm( s: openArray[int], emit: proc(emit:openArray[int]) ) =
+    var s = @s
+    if s.len == 0:
+        emit(s)
+        return
+
+    var rc : proc(np: int)
+    rc = proc(np: int) =
+
+        if np == 1:
+            emit(s)
+            return
+
+        var
+            np1 = np - 1
+            pp = s.len - np1
+
+        rc(np1) # recurs prior swaps
+
+        for i in countDown(pp, 1):
+            swap s[i], s[i-1]
+            rc(np1) # recurs swap
+
+        let w = s[0]
+        s[0..<pp] = s[1..pp]
+        s[pp] = w
+
+    rc(s.len)
+
+var se = @[0, 1, 2, 3] #, 4, 5, 6, 7, 8, 9, 10]
+
+perm(se, proc(seq: openArray[int])=
+    echo seq
+    )

Task/Permutations/OpenEdge-Progress/permutations.openedge

@@ -0,0 +1,35 @@
+DEFINE VARIABLE charArray AS CHARACTER EXTENT 3 INITIAL ["A","B","C"].
+DEFINE VARIABLE sizeofArray AS INTEGER.
+
+sizeOfArray = EXTENT(charArray).
+
+RUN GetPermutations(1).
+
+PROCEDURE GetPermutations:
+    DEFINE INPUT PARAMETER n AS INTEGER.
+
+    DEFINE VARIABLE i AS INTEGER.
+    DEFINE VARIABLE j AS INTEGER.
+    DEFINE VARIABLE currentPermutation AS CHARACTER.
+
+    REPEAT i = n TO sizeOfArray:
+        RUN swapValues(i,n).
+        RUN GetPermutations(n + 1).
+        RUN swapValues(i,n).
+    END.
+    IF n = sizeOfArray THEN DO:
+        DO j = 1 TO EXTENT(charArray):
+            currentPermutation = currentPermutation + charArray[j].
+        END.
+        DISPLAY currentPermutation WITH FRAME A DOWN.
+    END.
+END PROCEDURE.
+
+PROCEDURE swapValues:
+    DEFINE INPUT PARAMETER a AS INTEGER.
+    DEFINE INPUT PARAMETER b AS INTEGER.
+    DEFINE VARIABLE temp AS CHARACTER.
+    temp = charArray[a].
+    charArray[a] = charArray[b].
+    charArray[b] = temp.
+END PROCEDURE.

Task/Permutations/Perl-6/permutations-2.pl6

@@ -10,7 +10,7 @@ sub next_perm ( @a is copy ) {
     my $r = @a.end;
     my $s = $j + 1;
     @a[ $r--, $s++ ] .= reverse while $r > $s;
-    return $(@a);
+    return @a;
 }
 
 .say for [<a b c>], &next_perm ...^ !*;

Task/Permutations/Perl/permutations-1.pl

@@ -1,5 +1,7 @@
-use ntheory qw/forperm/;
-my @tasks = (qw/party sleep study/);
-forperm {
-  print "@tasks[@_]\n";
-} scalar(@tasks);
+sub permutation {
+	my ($perm,@set) = @_;
+	print "$perm\n" || return unless (@set);
+	permutation($perm.$set[$_],@set[0..$_-1],@set[$_+1..$#set]) foreach (0..$#set);
+}
+my @input = (qw/a b c d/);
+permutation('',@input);

Task/Permutations/Perl/permutations-2.pl

@@ -1,7 +1,5 @@
-sub permutation {
-	my ($perm,@set) = @_;
-	print "$perm\n" || return unless (@set);
-	permutation($perm.$set[$_],@set[0..$_-1],@set[$_+1..$#set]) foreach (0..$#set);
-}
-my @input = (qw/a 2 c 4/);
-permutation('',@input);
+use ntheory qw/forperm/;
+my @tasks = (qw/party sleep study/);
+forperm {
+  print "@tasks[@_]\n";
+} @tasks;

Task/Permutations/Python/permutations-5.py

@@ -0,0 +1,13 @@
+def permutations(xs):
+    ac = [[]]
+    for x in xs:
+        ac_new = []
+        for ts in ac:
+            for n in range(0,ts.__len__()+1):
+                new_ts = ts[:]  #(shallow) copy of ts
+                new_ts.insert(n,x)
+                ac_new.append(new_ts)
+        ac=ac_new
+    return ac
+
+print(permutations([1,2,3,4]))

Task/Permutations/Python/permutations-6.py

@@ -0,0 +1,86 @@
+'''Permutations of a list, string or tuple'''
+
+from functools import (reduce)
+from itertools import (chain)
+
+
+# permutations :: [a] -> [[a]]
+def permutations(xs):
+    '''Type-preserving permutations of xs.
+    '''
+    ps = reduce(
+        lambda a, x: concatMap(
+            lambda xs: (
+                xs[n:] + [x] + xs[0:n] for n in range(0, 1 + len(xs)))
+        )(a),
+        xs, [[]]
+    )
+    t = type(xs)
+    return ps if list == t else (
+        [''.join(x) for x in ps] if str == t else [
+            t(x) for x in ps
+        ]
+    )
+
+
+# TEST ----------------------------------------------------
+
+# main :: IO ()
+def main():
+    '''Permutations of lists, strings and tuples.'''
+
+    print(
+        fTable(__doc__ + ':\n')(repr)(showList)(
+            permutations
+        )([
+            [1, 2, 3],
+            'abc',
+            (1, 2, 3),
+        ])
+    )
+
+
+# GENERIC -------------------------------------------------
+
+# concatMap :: (a -> [b]) -> [a] -> [b]
+def concatMap(f):
+    '''A concatenated list over which a function has been mapped.
+       The list monad can be derived by using a function f which
+       wraps its output in a list,
+       (using an empty list to represent computational failure).'''
+    return lambda xs: list(
+        chain.from_iterable(map(f, xs))
+    )
+
+
+# FORMATTING ----------------------------------------------
+
+# fTable :: String -> (a -> String) ->
+#                     (b -> String) -> (a -> b) -> [a] -> String
+def fTable(s):
+    '''Heading -> x display function -> fx display function ->
+                     f -> xs -> tabular string.
+    '''
+    def go(xShow, fxShow, f, xs):
+        ys = [xShow(x) for x in xs]
+        w = max(map(len, ys))
+        return s + '\n' + '\n'.join(map(
+            lambda x, y: y.rjust(w, ' ') + ' -> ' + fxShow(f(x)),
+            xs, ys
+        ))
+    return lambda xShow: lambda fxShow: lambda f: lambda xs: go(
+        xShow, fxShow, f, xs
+    )
+
+
+# showList :: [a] -> String
+def showList(xs):
+    '''Stringification of a list.'''
+    return '[' + ','.join(showList(x) for x in xs) + ']' if (
+        isinstance(xs, list)
+    ) else repr(xs)
+
+
+# MAIN ---
+if __name__ == '__main__':
+    main()

Task/Permutations/R/permutations-1.r

@@ -1,48 +1,35 @@
-next.perm <- function(p) {
-  n <- length(p)
-  i <- n - 1
-  r = T
-  for (i in seq(n - 1, 1)) {
-    if (p[i] < p[i + 1]) {
-      r = F
-      break
+next.perm <- function(a) {
+  n <- length(a)
+  i <- n
+  while (i > 1 && a[i - 1] >= a[i]) i <- i - 1
+  if (i == 1) {
+    NULL
+  } else {
+    j <- i
+    k <- n
+    while (j < k) {
+      s <- a[j]
+      a[j] <- a[k]
+      a[k] <- s
+      j <- j + 1
+      k <- k - 1
     }
-  }
-
-  j <- i + 1
-  k <- n
-  while (j < k) {
-    x <- p[j]
-    p[j] <- p[k]
-    p[k] <- x
-    j <- j + 1
-    k <- k - 1
-  }
-
-  if(r) return(NULL)
-
-  j <- n
-  while (p[j] > p[i]) j <- j - 1
-  j <- j + 1
-
-  x <- p[i]
-  p[i] <- p[j]
-  p[j] <- x
-  return(p)
-}
-
-print.perms <- function(n) {
-  p <- 1:n
-  while (!is.null(p)) {
-    cat(p, "\n")
-    p <- next.perm(p)
+    s <- a[i - 1]
+    j <- i
+    while (a[j] <= s) j <- j + 1
+    a[i - 1] <- a[j]
+    a[j] <- s
+    a
   }
 }
 
-print.perms(3)
-# 1 2 3
-# 1 3 2
-# 2 1 3
-# 2 3 1
-# 3 1 2
-# 3 2 1
+perm <- function(n) {
+  e <- NULL
+  a <- 1:n
+  repeat {
+    e <- cbind(e, a)
+    a <- next.perm(a)
+    if (is.null(a)) break
+  }
+  unname(e)
+}

Task/Permutations/R/permutations-2.r

@@ -1,11 +1,5 @@
-# list of the vectors by inserting x in s at position 0...end.
-linsert <- function(x,s) lapply(0:length(s), function(k) append(s,x,k))
-
-# list of all permutations of 1:n
-perm <- function(n){
-    if (n == 1) list(1)
-    else unlist(lapply(perm(n-1), function(s) linsert(n,s)),
-                recursive = F)}
-
-# permutations of a vector s
-permutation <- function(s) unique(lapply(perm(length(s)), function(i) s[i]))
+> perm(3)
+     [,1] [,2] [,3] [,4] [,5] [,6]
+[1,]    1    1    2    2    3    3
+[2,]    2    3    1    3    1    2
+[3,]    3    2    3    1    2    1

Task/Permutations/R/permutations-3.r

@@ -1,18 +1,11 @@
-> permutation(letters[1:3])
-[[1]]
-[1] "c" "b" "a"
+# list of the vectors by inserting x in s at position 0...end.
+linsert <- function(x,s) lapply(0:length(s), function(k) append(s,x,k))
 
-[[2]]
-[1] "b" "c" "a"
+# list of all permutations of 1:n
+perm <- function(n){
+    if (n == 1) list(1)
+    else unlist(lapply(perm(n-1), function(s) linsert(n,s)),
+                recursive = F)}
 
-[[3]]
-[1] "b" "a" "c"
-
-[[4]]
-[1] "c" "a" "b"
-
-[[5]]
-[1] "a" "c" "b"
-
-[[6]]
-[1] "a" "b" "c"
+# permutations of a vector s
+permutation <- function(s) lapply(perm(length(s)), function(i) s[i])

Task/Permutations/R/permutations-4.r

@@ -0,0 +1,18 @@
+> permutation(letters[1:3])
+[[1]]
+[1] "c" "b" "a"
+
+[[2]]
+[1] "b" "c" "a"
+
+[[3]]
+[1] "b" "a" "c"
+
+[[4]]
+[1] "c" "a" "b"
+
+[[5]]
+[1] "a" "c" "b"
+
+[[6]]
+[1] "a" "b" "c"

Task/Permutations/Racket/permutations.rkt

@@ -11,3 +11,50 @@
         (append-map (λ(x) (loop (remq x l) (cons x tail))) l))))
 (perms '(A B C))
 ;; -> '((C B A) (B C A) (C A B) (A C B) (B A C) (A B C))
+
+;; permutations in lexicographic order
+(define (lperms s)
+  (cond [(empty? s) '()]
+        [(empty? (cdr s)) (list s)]
+        [else
+         (let splice ([l '()][m (car s)][r (cdr s)])
+           (append
+            (map (lambda (x) (cons m x)) (lperms (append l r)))
+            (if (empty? r) '()
+                (splice (append l (list m)) (car r) (cdr r)))))]))
+(display (lperms '(A B C)))
+;; -> ((A B C) (A C B) (B A C) (B C A) (C A B) (C B A))
+
+;; permutations in lexicographical order using generators
+(require racket/generator)
+(define (splice s)
+  (generator ()
+             (let outer-loop ([l '()][m (car s)][r (cdr s)])
+               (let ([permuter (lperm (append l r))])
+                 (let inner-loop ([p (permuter)])
+                   (when (not (void? p))
+                     (let ([q (cons m p)])
+                       (yield q)
+                       (inner-loop (permuter))))))
+               (if (not (empty? r))
+                   (outer-loop (append l (list m)) (car r) (cdr r))
+                   (void)))))
+(define (lperm s)
+  (generator ()
+             (cond [(empty? s) (yield '())]
+                   [(empty? (cdr s)) (yield s)]
+                   [else
+                    (let ([splicer (splice s)])
+                      (let loop ([q (splicer)])
+                        (when (not (void? q))
+                          (begin
+                            (yield q)
+                            (loop (splicer))))))])
+             (void)))
+(let ([permuter (lperm '(A B C))])
+  (let next-perm ([p (permuter)])
+    (when (not (void? p))
+      (begin
+        (display p)
+        (next-perm (permuter))))))
+;; -> (A B C)(A C B)(B A C)(B C A)(C A B)(C B A)