Best shuffle

Best shuffle
You are encouraged to solve this task according to the task description, using any language you may know.

Shuffle the characters of a string in such a way that as many of the character values are in a different position as possible. Print the result as follows: original string, shuffled string, (num characters ignored)

For example: tree, eetr, (0)

The words to test with are: abracadabra, seesaw, elk, grrrrrr, up, a

AWK

Translation of: Perl 6

Awk is a poor choice for this task, because Awk provides no array functions, except for split(). This Awk program uses its own code

• to sort an array,
• to insert an element into the middle of an array,
• to remove an element from the middle of an array (and close the gap),
• to pop an element from the end of an array, and
• to join the elements of an array into a string.

The equivalent programs for Perl 6 and for Ruby use several built-in array functions. But if those array functions seem strange to you, and if you can understand this bunch of for loops, then you might prefer this Awk program.

This algorithm calculates an order of positions, then fills a new string in this order, by moving each letter from the original string. It will never replace an old letter with an identical letter, unless the remainder of the original string has only this letter. The next position to fill is always the position of the old letter with the most occurrences among the remaining old letters. This special order can always change every old letter, unless some old letter occurs in more than half of the original string.

<lang awk># out["string"] = best shuffle of string _s_

1. out["score"] = number of matching characters

function best_shuffle(out, s, c, i, j, k, klen, p, pos, set, rlen, slen) { slen = length(s) for (i = 1; i <= slen; i++) { c = substr(s, i, 1)

# _set_ of all characters in _s_, with count set[c] += 1

# _pos_ classifies positions by letter, # such that pos[c, 1], pos[c, 2], ..., pos[c, set[c]] # are the positions of _c_ in _s_. pos[c, set[c]] = i }

# k[1], k[2], ..., k[klen] sorts letters from low to high count klen = 0 for (c in set) { # insert _c_ into _k_ i = 1 while (i <= klen && set[k[i]] <= set[c]) i++ # find _i_ to sort by insertion for (j = klen; j >= i; j--) k[j + 1] = k[j] # make room for k[i] k[i] = c klen++ }

# Fill pos[slen], ..., pos[3], pos[2], pos[1] with positions # in the order that we want to fill them. i = 1 while (i <= slen) { for (j = 1; j <= klen; j++) { c = k[j] if (set[c] > 0) { pos[i] = pos[c, set[c]] i++ delete pos[c, set[c]] set[c]-- } } }

# Now fill in _new_ with _letters_ according to each position # in pos[slen], ..., pos[1], but skip ahead in _letters_ # if we can avoid matching characteers that way. rlen = split(s, letters, "") for (i = slen; i >= 1; i--) { j = 1 p = pos[i] while (letters[j] == substr(s, p, 1) && j < rlen) j++ for (new[p] = letters[j]; j < rlen; j++) letters[j] = letters[j + 1] delete letters[rlen] rlen-- }

out["string"] = "" for (i = 1; i <= slen; i++) { out["string"] = out["string"] new[i] }

out["score"] = 0 for (i = 1; i <= slen; i++) { if (new[i] == substr(s, i, 1)) out["score"]++ } }

BEGIN { count = split("abracadabra seesaw elk grrrrrr up a", words) for (i = 1; i <= count; i++) { best_shuffle(result, words[i]) printf "%s, %s, (%d)\n", words[i], result["string"], result["score"] } }</lang>

Output:

<lang bash>$ awk -f best-shuffle.awk abracadabra, baarrcadaab, (0) seesaw, essewa, (0) elk, kel, (0) grrrrrr, rgrrrrr, (5) up, pu, (0) a, a, (1)</lang>

The output might change if the for (c in set) loop iterates the array in a different order. (Awk specifies not an order of iteration.)

C

This approach is totally deterministic, and is based on the final J implementation from the talk page.

In essence: we form cyclic groups of character indices where each cyclic group is guaranteed to represent each character only once (two instances of the letter 'a' must have their indices in separate groups), and then we rotate each of the cyclic groups. We then use the before/after version of these cycles to shuffle the original text. The only way a character can be repeated, here, is when a cyclic group contains only one character index, and this can only happen when more than half of the text uses that character. This is C99 code.

<lang c>#include <stdlib.h>

1. include <stdio.h>
2. include <string.h>
3. include <assert.h>

1. define DEBUG

void best_shuffle(const unsigned char* txt, unsigned char* result) {

   const int nchar = 256;
   const int len = (int)strlen((char*)txt);

1. ifdef DEBUG

   // txt and result must have the same length
   assert(len == (int)strlen((char*)result));

1. endif

   // how many of each character?
   int counts[nchar];
   memset(counts, '\0', nchar * sizeof(int));
   int fmax = 0;
   for (int i = 0; i < len; i++) {
       counts[txt[i]]++;
       const int fnew = counts[txt[i]];
       if (fmax < fnew)
            fmax = fnew;
   }

   // how long can our cyclic groups be?
   const int grp = 1 + (len - 1) / fmax;

   // how many of them are full length?
   const int lng = 1 + (len - 1) % fmax;

   // all character positions, grouped by character
   int ndx1[len];
   for (int ch = 0, i = 0; ch < nchar; ch++)
      if (counts[ch])
           for (int j = 0; j < len; j++)
               if (ch == txt[j]) {
                   ndx1[i] = j;
                   i++;
               }

   // regroup them for cycles
   int ndx2[len];
   for (int i = 0, n = 0, m = 0; i < len; i++) {
       ndx2[i] = ndx1[n];
       n += fmax;
       if (n >= len) {
           m++;
           n = m;
       }
   }

   // rotate each group
   for (int i = 0, j = 0; i < fmax; i++) {
       int first = ndx2[j];
       int glen = grp - (i < lng ? 0 : 1);
       for (int k = 1; k < glen; k++)
           ndx1[j + k - 1] = ndx2[j + k];
       ndx1[j + glen - 1] = first;
       j += glen;
   }

   // result is original permuted according to our cyclic groups
   result[len] = '\0';
   for (int i = 0; i < len; i++)
       result[ndx2[i]] = txt[ndx1[i]];

}

void display(char* txt1, char* txt2) {

   int len = (int)strlen(txt1);
   assert(len == (int)strlen(txt2));
   int score = 0;
   for (int i = 0; i < len; i++)
       if (txt1[i] == txt2[i])
           score++;
   (void)printf("%s, %s, (%d)\n", txt1, txt2, score);

}

int main() {

   char* data[] = {"abracadabra", "seesaw", "elk", "grrrrrr",
                   "up", "a", "aabbbbaa"};
   const int data_len = sizeof(data) / sizeof(data[0]);
   for (int i = 0; i < data_len; i++) {
       const int shuf_len = (int)strlen(data[i]) + 1;
       unsigned char shuf[shuf_len];

1. ifdef DEBUG

       memset(shuf, 0xFF, shuf_len * sizeof(unsigned char));
       shuf[shuf_len - 1] = '\0';

1. endif

       best_shuffle((unsigned char*)data[i], shuf);
       display(data[i], (char*)shuf);
   }

   return EXIT_SUCCESS;

}</lang> Output:

abracadabra, brabacadaar, (0)
seesaw, wssaee, (0)
elk, kel, (0)
grrrrrr, rrrrrrg, (5)
up, pu, (0)
a, a, (1)
aabbbbaa, bbaaaabb, (0)

Clojure

Uses same method as J

<lang Clojure>(defn score [before after]

  (->> (map = before after)

(filter true? ,) count))

(defn merge-vecs [init vecs]

 (reduce (fn [counts [index x]]

(assoc counts x (conj (get counts x []) index))) init vecs))

(defn frequency

 "Returns a collection of indecies of distinct items"
 [coll]
 (->> (map-indexed vector coll)
      (merge-vecs {} ,)))

(defn group-indecies [s]

 (->> (frequency s)
      vals
      (sort-by count ,)
      reverse))

(defn cycles [coll]

 (let [n (count (first coll))

cycle (cycle (range n)) coll (apply concat coll)]

   (->> (map vector coll cycle)

(merge-vecs [] ,))))

(defn rotate [n coll]

 (let [c (count coll)

n (rem (+ c n) c)]

   (concat (drop n coll) (take n coll))))

(defn best-shuffle [s]

 (let [ref (cycles (group-indecies s))

prm (apply concat (map (partial rotate 1) ref)) ref (apply concat ref)]

   (->> (map vector ref prm)

(sort-by first ,) (map second ,) (map (partial get s) ,) (apply str ,) (#(vector s % (score s %))))))

user> (->> ["abracadabra" "seesaw" "elk" "grrrrrr" "up" "a"] (map best-shuffle ,) vec) [["abracadabra" "bdabararaac" 0]

["seesaw" "eawess" 0]
["elk" "lke" 0]
["grrrrrr" "rgrrrrr" 5]
["up" "pu" 0]
["a" "a" 1]]</lang>

D

Translation of: C

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

extern(C) pure nothrow void* alloca(size_t size);

pure nothrow void bestShuffle(in char[] txt, char[] result) {

   enum int NCHAR = 256;
   const int len = txt.length;

   // txt and result must have the same length
   // allocate only when necessary
   if (result.length != len)
       result.length = len;

   // how many of each character?
   int[NCHAR] counts;
   int fmax = 0;
   foreach (char c; txt) {
       counts[c]++;
       if (fmax < counts[c])
           fmax = counts[c];
   }

   // how long can our cyclic groups be?
   const int grp = 1 + (len - 1) / fmax;

   // how many of them are full length?
   const int lng = 1 + (len - 1) % fmax;

   // all character positions, grouped by character
   int[] ndx1 = (cast(int*)alloca(len * int.sizeof))[0 .. len];
   for (int ch = 0, i = 0; ch < NCHAR; ch++)
      if (counts[ch])
           foreach (j; 0 .. len)
               if (ch == txt[j]) {
                   ndx1[i] = j;
                   i++;
               }

   // regroup them for cycles
   int[] ndx2 = (cast(int*)alloca(len * int.sizeof))[0 .. len];
   for (int i = 0, n = 0, m = 0; i < len; i++) {
       ndx2[i] = ndx1[n];
       n += fmax;
       if (n >= len) {
           m++;
           n = m;
       }
   }

   // rotate each group
   for (int i = 0, j = 0; i < fmax; i++) {
       int first = ndx2[j];
       int glen = grp - (i < lng ? 0 : 1);
       foreach (k; 1 .. glen)
           ndx1[j + k - 1] = ndx2[j + k];
       ndx1[j + glen - 1] = first;
       j += glen;
   }

   // result is original permuted according to our cyclic groups
   foreach (i; 0 .. len)
       result[ndx2[i]] = txt[ndx1[i]];

}

void main() {

   auto data = ["abracadabra", "seesaw", "elk",
                "grrrrrr", "up", "a", "aabbbbaa"];
   foreach (txt; data) {
       int l = txt.length;
       auto shuf = txt.dup;
       bestShuffle(txt, shuf);
       const nequal = count!q{a[0] == a[1]}(zip(txt, shuf));
       writefln("%s, %s, (%d)", txt, shuf, nequal);
   }

}</lang> Output:

abracadabra, brabacadaar, (0)
seesaw, wssaee, (0)
elk, kel, (0)
grrrrrr, rrrrrrg, (5)
up, pu, (0)
a, a, (1)
aabbbbaa, bbaaaabb, (0)

Using idea from J implementation notes at discussion page.

Works with: D version 2.051

<lang d>import std.stdio, std.string, std.conv, std.algorithm, std.range, std.random ;

string shuffle(const string txt, bool bRandom = true) {

   if(txt.length <= 3) return text(txt[1..$] ~ txt[0]) ;
   auto s = dtext(txt) ;
   int[][dchar] gpChar ;
   foreach(i, dc ; s) gpChar[dc] ~= i ;
   auto gpIdx = gpChar.values ;
   sort!"a.length > b.length"(gpIdx) ;// make sure largest group come first
   auto maxGpLen = gpIdx[0].length ;
   auto gpCyc = new int[][](maxGpLen);
   auto idx = 0 ;
   foreach(ix ; reduce!"a ~ b"(gpIdx))// regroup for cycles
       gpCyc[idx++ % maxGpLen] ~= ix ;

   auto raw = reduce!"a ~ b"(gpCyc) ; // get original idx order
   foreach(ref g;gpCyc) {             // cycling within group
       auto cut = (bRandom && g.length > 1) ? uniform(1, g.length) : 1 ;
       g = (g[cut..$] ~ g[0..cut]) ;
   }
   auto cyc = reduce!"a ~ b"(gpCyc) ; // get cyclic idx order

   auto r = new dchar[](s.length) ;   // make shuffled string
   foreach(ix;0..s.length)
       r[raw[ix]] = s[cyc[ix]] ;
   return text(r) ;

}

void main() {

   auto txt = ["abracadabra", "seesaw", "elk", "grrrrrr", "up", "a"] ;
   auto fmx = format("%%%ds", reduce!max(map!"a.length"(txt))) ;
   foreach(t;txt)
       writefln(fmx ~" -> "~fmx~" (%d)",
           t, shuffle(t), count!"a[0]==a[1]"(zip(t,shuffle(t)))) ;
   auto r ="11-22-333-44-55" ;
   writeln(r) ;
   foreach(loop;0..4)
       writefln("%s (%d)",
           shuffle(r), count!"a[0]==a[1]"(zip(r,shuffle(r)))) ;

}</lang> part of output:

11-22-333-44-55
-354431223--51- (0)
--34-35242-3511 (0)
--34435223--511 (0)
-354431223--51- (0)

Haskell

Translation of: Perl 6

<lang haskell>import Data.Function (on) import Data.List import Data.Maybe import Data.Array import Text.Printf

main = mapM_ f examples

 where examples = ["abracadabra", "seesaw", "elk", "grrrrrr", "up", "a"]
       f s = printf "%s, %s, (%d)\n" s s' $ score s s'
         where s' = bestShuffle s

score :: Eq a => [a] -> [a] -> Int score old new = length $ filter id $ zipWith (==) old new

bestShuffle :: (Ord a, Eq a) => [a] -> [a] bestShuffle s = elems $ array bs $ f positions letters

 where positions =
           concat $ sortBy (compare `on` length) $
           map (map fst) $ groupBy ((==) `on` snd) $
           sortBy (compare `on` snd) $ zip [0..] s
       letters = map (orig !) positions

       f [] [] = []
       f (p : ps) ls = (p, ls !! i) : f ps (removeAt i ls)
         where i = fromMaybe 0 $ findIndex (/= o) ls
               o = orig ! p

       orig = listArray bs s
       bs = (0, length s - 1)

removeAt :: Int -> [a] -> [a] removeAt 0 (x : xs) = xs removeAt i (x : xs) = x : removeAt (i - 1) xs</lang>

Here's a version of bestShuffle that's much simpler, but too wasteful of memory for inputs like "abracadabra":

<lang haskell>bestShuffle :: Eq a => [a] -> [a] bestShuffle s = minimumBy (compare `on` score s) $ permutations s</lang>

Icon and Unicon

The approach taken requires 2n memory and will run in O(n^2) time swapping once per final changed character. The algorithm is concise and conceptually simple avoiding the lists of indices, sorting, cycles, groups, and special cases requiring rotation needed by many of the other solutions. It proceeds through the entire string swapping characters ensuring that neither of the two characters are swapped with another instance of themselves in the original string.

Additionally, this can be trivially modified to randomize the shuffle. <lang icon>procedure main(args)

   while scram := bestShuffle(line := read()) do
       write(line," -> ",scram," (",unchanged(line,scram),")")

end

procedure bestShuffle(s)

   t := s
   # every !t :=: ?t    # Uncomment to get a random best shuffling
   every i := 1 to *t do
       every j := (1 to i-1) | (i+1 to *t) do
          if (t[i] ~== s[j]) & (s[i] ~== t[j]) then break t[i] :=: t[j]
   return t

end

procedure unchanged(s1,s2) # Number of unchanged elements

   every (count := 0) +:= (s1[i := 1 to *s1] == s2[i], 1)
   return count

end</lang>

The code works in both Icon and Unicon.

Sample output:

->scramble <scramble.data
abracadabra -> raaracababd (0)
seesaw -> wasese (0)
elk -> lke (0)
grrrrrr -> rgrrrrr (5)
up -> pu (0)
a -> a (1)
aardvarks are ant eaters -> sdaaaraaasv rer nt keter (0)
->

J

Based on Dan Bron's approach:

<lang j>bestShuf =: verb define

 yy=. (\:#&>)@:(<@I.@=) y
 y C.~ (;yy) </.~ (i.#y) |~ #>{. yy

)

fmtBest=:3 :0

 b=. bestShuf y
 y,', ',b,' (',')',~":+/b=y

) </lang>

Example:

<lang j> fmtBest&>;:'abracadabra seesaw elk grrrrrr up a' abracadabra, bdabararaac (0) seesaw, eawess (0) elk, lke (0) grrrrrr, rgrrrrr (5) up, pu (0) a, a (1) </lang>

JavaScript

Based on the J implementation (and this would be a lot more concise if we used something like jQuery):

<lang javascript>function raze(a) { // like .join() except producing an array instead of a string var r= []; for (var j= 0; j<a.length; j++) for (var k= 0; k<a[j].length; k++) r.push(a[j][k]); return r; } function bestShuf(txt) { var chs= txt.split(); var gr= {}; var mx= 0; for (var j= 0; j<chs.length; j++) { var ch= chs[j]; if (null == gr[ch]) gr[ch]= []; gr[ch].push(j); if (mx < gr[ch].length) mx++; } var inds= []; for (var ch in gr) inds.push(gr[ch]); var ndx= raze(inds); var cycles= []; for (var k= 0; k < mx; k++) cycles[k]= []; for (var j= 0; j<chs.length; j++) cycles[j%mx].push(ndx[j]); var ref= raze(cycles); for (var k= 0; k < mx; k++) cycles[k].push(cycles[k].shift()); var prm= raze(cycles); var shf= []; for (var j= 0; j<chs.length; j++) shf[ref[j]]= chs[prm[j]]; return shf.join(); }

function disp(ex) { var r= bestShuf(ex); var n= 0; for (var j= 0; j<ex.length; j++) n+= ex.substr(j, 1) == r.substr(j,1) ?1 :0; return ex+', '+r+', ('+n+')'; }</lang>

Example:

<lang html><html><head><title></title></head><body>

</body></html>

<script type="text/javascript"> /* ABOVE CODE GOES HERE */ var sample= ['abracadabra', 'seesaw', 'elk', 'grrrrrr', 'up', 'a'] for (var i= 0; i<sample.length; i++) document.getElementById('out').innerHTML+= disp(sample[i])+'\r\n'; </script></lang>

Produces:

<lang>abracadabra, bdabararaac, (0) seesaw, eawess, (0) elk, lke, (0) grrrrrr, rrrrrrg, (5) up, pu, (0) a, a, (1))</lang>

Perl 6

Works with: Rakudo Star version 2010.12

<lang perl6>sub best-shuffle (Str $s) {

   my @orig = $s.comb;

   my @pos;
   # Fill @pos with positions in the order that we want to fill
   # them. (Once Rakudo has &roundrobin, this will be doable in
   # one statement.)
   {
       my %pos = classify { @orig[$^i] }, keys @orig;
       my @k = map *.key, sort *.value.elems, %pos;
       while %pos {
           for @k -> $letter {
               %pos{$letter} or next;
               push @pos, %pos{$letter}.pop;
               %pos{$letter}.elems or %pos.delete: $letter;
           }
       }
       @pos .= reverse;
   }

   my @letters = @orig;
   my @new = Any xx $s.chars;
   # Now fill in @new with @letters according to each position
   # in @pos, but skip ahead in @letters if we can avoid
   # matching characters that way.
   while @letters {
       my ($i, $p) = 0, shift @pos;
       ++$i while @letters[$i] eq @orig[$p] and $i < @letters.end;
       @new[$p] = splice @letters, $i, 1;
   }

   my $score = elems grep ?*, map * eq *, do @new Z @orig;

   @new.join, $score;

}

printf "%s, %s, (%d)\n", $_, best-shuffle $_

   for <abracadabra seesaw elk grrrrrr up a>;</lang>

PicoLisp

<lang PicoLisp>(de bestShuffle (Str)

  (let Lst NIL
     (for C (setq Str (chop Str))
        (if (assoc C Lst)
           (con @ (cons C (cdr @)))
           (push 'Lst (cons C)) ) )
     (setq Lst (apply conc (flip (by length sort Lst))))
     (let Res
        (mapcar
           '((C)
              (prog1 (or (find <> Lst (circ C)) C)
                 (setq Lst (delete @ Lst)) ) )
           Str )
        (prinl Str " " Res " (" (cnt = Str Res) ")") ) ) )</lang>

Output:

: (bestShuffle "abracadabra")
abracadabra raarababadc (0)

: (bestShuffle "seesaw")
seesaw essewa (0)

: (bestShuffle "elk")
elk lke (0)

: (bestShuffle "grrrrrr")
grrrrrr rgrrrrr (5)

: (bestShuffle "up")
up pu (0)

: (bestShuffle "a")
a a (1)

PL/I

<lang PL/I> shuffle: procedure options (main); /* 14/1/2011 */

  declare (s, saves) character (20) varying, c character (1);
  declare t(length(s)) bit (1);
  declare (i, k, moves initial (0)) fixed binary;

  get edit (s) (L);
  put skip list (s);
  saves = s;
  t = '0'b;
  do i = 1 to length (s);
     if t(i) then iterate; /* This character has already been moved. */
     c = substr(s, i, 1);
     k = search (s, c, i+1);
     if k > 0 then
        do;
           substr(s, i, 1) = substr(s, k, 1);
           substr(s, k, 1) = c;
           t(k), t(i) = '1'b;
        end;
  end;

  do k = length(s) to 2 by -1;
     if ^t(k) then /* this character wasn't moved. */

all: do;

           c = substr(s, k, 1);
           do i = k-1 to 1 by -1;
              if c ^= substr(s, i, 1) then
                 if substr(saves, i, 1) ^= c then
                    do;
                       substr(s, k, 1) = substr(s, i, 1);
                       substr(s, i, 1) = c;
                       t(k) = '1'b;
                       leave all;
                    end;
           end;
        end;
  end;
  moves = length(s) - sum(t);
  put skip edit (s, trim(moves))(a, x(1));

search: procedure (s, c, k) returns (fixed binary);

  declare s character (*) varying;
  declare c character (1);
  declare k fixed binary;
  declare i fixed binary;

  do i = k to length(s);
     if ^t(i) then if c ^= substr(s, i, 1) then return (i);
  end;
  return (0); /* No eligible character. */

end search;

end shuffle;

OUTPUT:

abracadabra baaracadrab 0

prrrrrr rprrrrr 5

tree eert 0

A A 1 </lang>

Prolog

Works with SWI-Prolog <lang Prolog>:- dynamic score/2.

best_shuffle :- maplist(best_shuffle, ["abracadabra", "eesaw", "elk", "grrrrrr", "up", "a"]).

best_shuffle(Str) :- retractall(score(_,_)), length(Str, Len), assert(score(Str, Len)), calcule_min(Str, Len, Min), repeat, shuffle(Str, Shuffled), maplist(comp, Str, Shuffled, Result), sumlist(Result, V), retract(score(Cur, VCur)), ( V < VCur -> assert(score(Shuffled, V)); assert(score(Cur, VCur))), V = Min, retract(score(Cur, VCur)), writef('%s : %s (%d)\n', [Str, Cur, VCur]).

comp(C, C1, S):- ( C = C1 -> S = 1; S = 0).

% this code was written by P.Caboche and can be found here : % http://pcaboche.developpez.com/article/prolog/listes/?page=page_3#Lshuffle shuffle(List, Shuffled) :-

 length(List, Len),
 shuffle(Len, List, Shuffled).

shuffle(0, [], []) :- !.

shuffle(Len, List, [Elem|Tail]) :-

 RandInd is random(Len),
 nth0(RandInd, List, Elem),
 select(Elem, List, Rest),
 NewLen is Len - 1,
 shuffle(NewLen, Rest, Tail).

% letters are sorted out then packed % If a letter is more numerous than the rest % the min is the difference between the quantity of this letter and % the sum of the quantity of the other letters calcule_min(Str, Len, Min) :- msort(Str, SS), packList(SS, Lst), sort(Lst, Lst1), last(Lst1, [N, _]), ( N * 2 > Len -> Min is 2 * N - Len; Min = 0).

% almost the same code as in "run_length" page packList([],[]).

packList([X],1,X) :- !.

packList([X|Rest],[XRun|Packed]):-

   run(X,Rest, XRun,RRest),
   packList(RRest,Packed).

run(Var,[],[1,Var],[]).

run(Var,[Var|LRest],[N1, Var],RRest):-

   run(Var,LRest,[N, Var],RRest),
   N > 0,
   N1 is N + 1.

run(Var,[Other|RRest], [1,Var],[Other|RRest]):-

    dif(Var,Other).

</lang>

output :

 ?- test.
abracadabra : brabaracaad (0)
eesaw : sweea (0)
elk : kel (0)
grrrrrr : rrrgrrr (5)
up : pu (0)
a : a (1)
true .

PureBasic

This solution creates cycles of letters of letters that are then rotated to produce the final maximal shuffle. It includes an extra sort step that ensures the original string to be returned if it is repeatedly shuffled. <lang PureBasic>Structure charInfo

 Char.s
 List Position.i()
 count.i          ;number of occurrences of Char

EndStructure

Structure cycleInfo

 Char.s
 Position.i

EndStructure

Structure cycle

 List cycle.cycleInfo()

EndStructure

Procedure.s shuffleWordLetters(word.s)

 Protected i
 Dim originalLetters.s(len(word) - 1)
 For i = 1 To Len(word)
   originalLetters(i - 1) = Mid(word, i, 1)
 Next
 
 Dim shuffledLetters.s(0)
 CopyArray(originalLetters(), shuffledLetters())
 
 ;record original letters and their positions
 Protected curChar.s
 NewList letters.charInfo()
 NewMap *wordInfo.charInfo()
 For i = 0 To ArraySize(originalLetters())
   curChar = originalLetters(i)
   If FindMapElement(*wordInfo(), curChar)
     AddElement(*wordInfo()\position())
     *wordInfo()\position() = i
   Else
     *wordInfo(curChar) = AddElement(letters())
     If *wordInfo()
       *wordInfo()\Char = curChar
       AddElement(*wordInfo()\position())
       *wordInfo()\position() = i
     EndIf 
   EndIf 
 Next 
 
 ForEach letters()
   letters()\count = ListSize(letters()\Position())
 Next
 
 SortStructuredList(letters(), #PB_Sort_Ascending, OffsetOf(charInfo\Char), #PB_Sort_String) ;extra sort step, not strictly necessary
 SortStructuredList(letters(), #PB_Sort_Descending, OffsetOf(charInfo\count), #PB_Sort_integer)
 
 ;construct letter cycles
 FirstElement(letters())
 Protected maxLetterCount = letters()\count
 Dim letterCycles.cycle(maxLetterCount - 1)
 
 Protected curCycleIndex
 ForEach letters()
   ForEach letters()\Position()
     With letterCycles(curCycleIndex)
       AddElement(\cycle())
       \cycle()\Char = letters()\Char
       \cycle()\Position = letters()\position()
     EndWith
     curCycleIndex = (curCycleIndex + 1) % maxLetterCount
   Next 
 Next 
 
 ;rotate letters in each cycle
 Protected isFirst, prevChar.s, pos_1
 For i = 0 To maxLetterCount - 1
   With letterCycles(i)
     isFirst = #True
     ForEach \cycle()
       If Not isFirst
         shuffledLetters(\cycle()\Position) = prevChar
       Else
         pos_1 = \cycle()\Position
         isFirst = #False
       EndIf
       prevChar = \cycle()\Char
     Next 
     shuffledLetters(pos_1) = prevChar
   EndWith
 Next 
  
 ;score and display shuffle
 Protected shuffledWord.s, ignored
 For i = 0 To ArraySize(shuffledLetters())
   shuffledWord + shuffledLetters(i)
   If shuffledLetters(i) = originalLetters(i)
     ignored + 1
   EndIf
 Next
 
 PrintN(word + ", " + shuffledWord + ", (" + Str(ignored) + ")")
 ProcedureReturn shuffledWord

EndProcedure

If OpenConsole()

 shuffleWordLetters("abracadabra")
 shuffleWordLetters("seesaw")
 shuffleWordLetters("elk")
 shuffleWordLetters("grrrrrr")
 shuffleWordLetters("up")
 shuffleWordLetters("a")
 
 Print(#CRLF$ + #CRLF$ + "Press ENTER to exit"): Input()
 CloseConsole()

EndIf</lang> Sample output:

abracadabra, daabarbraac, (0)
seesaw, eawess, (0)
elk, lke, (0)
grrrrrr, rgrrrrr, (5)
up, pu, (0)
a, a, (1)

Python

This example may be incorrect. This example uses a different algorithm, which is not like the other examples. This algorithm can become stuck near the end of the string. The code now fixes the problem if a "final letter became stuck", but this might or might not fix all inputs. Please verify it and remove this message. If the example does not match the requirements or does not work, replace this message with Template:incorrect or fix the code yourself.

<lang python>#!/usr/bin/env python

def best_shuffle(s):

   # Count the supply of characters.
   from collections import defaultdict
   count = defaultdict(int)
   for c in s:
       count[c] += 1

   # Shuffle the characters.
   r = []
   for x in s:
       # Find the best character to replace x.
       best = None
       rankb = -2
       for c, rankc in count.items():
           # Prefer characters with more supply.
           # (Save characters with less supply.)
           # Avoid identical characters.
           if c == x: rankc = -1
           if rankc > rankb:
               best = c
               rankb = rankc

       # Add character to list. Remove it from supply.
       r.append(best)
       count[best] -= 1
       if count[best] == 0: del count[best]

   # If the final letter became stuck (as "ababcd" became "bacabd",
   # and the final "d" became stuck), then fix it.
   i = len(s) - 1
   if r[i] == s[i]:
       for j in range(i):
           if r[i] != s[j] and r[j] != s[i]:
               r[i], r[j] = r[j], r[i]
               break

   # Convert list to string. PEP 8, "Style Guide for Python Code",
   # suggests that .join() is faster than + when concatenating
   # many strings. See http://www.python.org/dev/peps/pep-0008/
   r = .join(r)

   score = sum(x == y for x, y in zip(r, s))

   return (r, score)

for s in "abracadabra", "seesaw", "elk", "grrrrrr", "up", "a":

   shuffled, score = best_shuffle(s)
   print("%s, %s, (%d)" % (s, shuffled, score))</lang>

Output:

abracadabra, raabarabacd, (0)
seesaw, wsaese, (0)
elk, kel, (0)
grrrrrr, rgrrrrr, (5)
up, pu, (0)
a, a, (1)

REXX

<lang rexx>/*REXX program to find best shuffle (of a character string). */

list='tree abracadabra seesaw elk grrrrrr up a'

                    /*find width of the longest word (prettify output).*/

L=0; do k=1 for words(list); L=max(L,length(word(list,k))); end; L=L+5

 do j=1 for words(list)               /*process the words in the list. */
 $=word(list,j)                       /*the original word in the list. */
 new=bestShuffle($)                   /*shufflized version of the word.*/
 say 'original:' left($,L) 'new:' left(new,L) 'count:' countSame($,new)
 end

exit

/*─────────────────────────────────────bestShuffle procedure────────────*/ bestShuffle: procedure; parse arg x 1 ox; Lx=length(x) if Lx<3 then return reverse(x) /*fast track these puppies. */

  do j=1 for Lx-1                     /*first take care of replications*/
  a=substr(x,j  ,1)
  b=substr(x,j+1,1)
  if a\==b then iterate
  _=verify(x,a); if _==0 then iterate /*switch 1st rep with some char. */
  y=substr(x,_,1); x=overlay(a,x,_); x=overlay(y,x,j)
  rx=reverse(x); _=verify(rx,a); if _==0 then iterate   /*¬ enuf unique*/
  y=substr(rx,_,1); _=lastpos(y,x)    /*switch 2nd rep with later char.*/
  x=overlay(a,x,_); x=overlay(y,x,j+1)   /*OVERLAYs: a fast way to swap*/
  end

     do j=1 for Lx                    /*take care of same o'-same o's. */
     a=substr(x, j,1)
     b=substr(ox,j,1)
     if a\==b then iterate
     if j==Lx then x=left(x,j-2)a||substr(x,j-1,1)  /*spec case of last*/
              else x=left(x,j-1)substr(x,j+1,1)a || substr(x,j+2)
     end

return x

/*─────────────────────────────────────countSame procedure──────────────*/ countSame: procedure; parse arg x,y; k=0

              do j=1 for min(length(x),length(y))
              k=k+(substr(x,j,1)==substr(y,j,1))
              end

return k</lang> Output (with a freebie thrown in):

original: tree             new: eert             count: 0
original: abracadabra      new: baaracadrab      count: 0
original: seesaw           new: eswase           count: 0
original: elk              new: lke              count: 0
original: grrrrrr          new: rrrrrrg          count: 5
original: up               new: pu               count: 0
original: a                new: a                count: 1

Ruby

Works with: Ruby version 1.9

Translation of: Perl 6

<lang ruby>def best_shuffle(s)

 # Fill _pos_ with positions in the order
 # that we want to fill them.
 pos = []
 catch {
   # g["a"] = [2, 4] implies that s[2] == s[4] == "a"
   g = (0...s.length).group_by { |i| s[i] }

   # k sorts letters from low to high count
   k = g.sort_by { |k, v| v.length }.map! { |k, v| k }

   until g.empty?
     k.each { |letter|
       g[letter] or next
       pos.push(g[letter].pop)
       g[letter].empty? and g.delete letter
     }
   end
   pos.reverse!
 }

 # Now fill in _new_ with _letters_ according to each position
 # in _pos_, but skip ahead in _letters_ if we can avoid
 # matching characters that way.
 letters = s.dup
 new = "?" * s.length
 until letters.empty?
   catch {
     i, p = 0, pos.shift
     i += 1 while letters[i] == s[p] and i < (letters.length - 1)
     new[p] = letters.slice! i
   }
 end

 score = new.chars.zip(s.chars).count { |c, d| c == d }
 [new, score]

end

%w(abracadabra seesaw elk grrrrrr up a).each { |word|

 printf "%s, %s, (%d)\n", word, *best_shuffle(word)

}</lang>

Output:

abracadabra, baarrcadaab, (0)
seesaw, essewa, (0)
elk, lke, (0)
grrrrrr, rgrrrrr, (5)
up, pu, (0)
a, a, (1)

Scheme

<lang scheme> (define count

 (lambda (str1 str2)
   (let ((len (string-length str1)))
     (let loop ((index 0)
                (result 0))
       (if (= index len)
           result
           (loop (+ index 1)
                 (if (eq? (string-ref str1 index)
                          (string-ref str2 index))
                     (+ result 1)
                     result)))))))

(define swap

 (lambda (str index1 index2)
   (let ((mutable (string-copy str))
         (char1 (string-ref str index1))
         (char2 (string-ref str index2)))
     (string-set! mutable index1 char2)
     (string-set! mutable index2 char1)
     mutable)))

(define shift

 (lambda (str)
   (string-append (substring str 1 (string-length str))
                  (substring str 0 1))))

(define shuffle

 (lambda (str)
   (let* ((mutable (shift str))
          (len (string-length mutable))
          (max-index (- len 1)))
     (let outer ((index1 0)
                 (best mutable)
                 (best-count (count str mutable)))
       (if (or (< max-index index1)
               (= best-count 0))
           best
           (let inner ((index2 (+ index1 1))
                       (best best)
                       (best-count best-count))
             (if (= len index2)
                 (outer (+ index1 1)
                        best
                        best-count)
                 (let* ((next-mutable (swap best index1 index2))
                        (next-count (count str next-mutable)))
                   (if (= 0 next-count)
                       next-mutable
                       (if (< next-count best-count)
                           (inner (+ index2 1)
                                  next-mutable
                                  next-count)
                           (inner (+ index2 1)
                                  best
                                  best-count)))))))))))

(for-each

(lambda (str)
  (let ((shuffled (shuffle str)))
    (display
     (string-append str " " shuffled " ("
                    (number->string (count str shuffled)) ")\n"))))
'("abracadabra" "seesaw" "elk" "grrrrrr" "up" "a"))

</lang>

Output:

abracadabra baacadabrar (0)
seesaw easews (0)
elk lke (0)
grrrrrr rrrrrrg (5)
up pu (0)
a a (1)

Tcl

Library: Tcllib (Package: struct::list)

<lang tcl>package require Tcl 8.5 package require struct::list

1. Simple metric function; assumes non-empty lists

proc count {l1 l2} {

   foreach a $l1 b $l2 {incr total [string equal $a $b]}
   return $total

}

1. Find the best shuffling of the string

proc bestshuffle {str} {

   set origin [split $str ""]
   set best $origin
   set score [llength $origin]
   struct::list foreachperm p $origin {

if {$score > [set score [tcl::mathfunc::min $score [count $origin $p]]]} { set best $p }

   }
   set best [join $best ""]
   return "$str,$best,($score)"

}</lang> Demonstration: <lang tcl>foreach sample {abracadabra seesaw elk grrrrrr up a} {

   puts [bestshuffle $sample]

}</lang> Output:

abracadabra,baabacadrar,(0)
seesaw,assewe,(0)
elk,kel,(0)
grrrrrr,rgrrrrr,(5)
up,pu,(0)
a,a,(1)

Ursala

An implementation based on the J solution looks like this. <lang Ursala>#import std

1. import nat

words = <'abracadabra','seesaw','elk','grrrrrr','up','a'>

shuffle = num; ^H/(*@K24) ^H\~&lS @rK2lSS *+ ^arPfarhPlzPClyPCrtPXPRalPqzyCipSLK24\~&L leql$^NS

1. show+

main = ~&LS <.~&l,@r :/` ,' ('--+ --')'+ ~&h+ %nP+ length@plrEF>^(~&,shuffle)* words</lang> A solution based on exponential search would use this definition of shuffle (cf. Haskell and Tcl). <lang Ursala>shuffle = ~&r+ length@plrEZF$^^D/~& permutations</lang> output:

abracadabra caarrbabaad (0)
seesaw wssaee (0)
elk lke (0)
grrrrrr rgrrrrr (5)
up pu (0)
a a (1)