Best shuffle
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)
You are encouraged to solve this task according to the task description, using any language you may know.
For example: tree, eetr, (0)
The words to test with are: abracadabra, seesaw, elk, grrrrrr, up, a
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.
<lang C>#include<assert.h>
- include<stdio.h>
- include<stdlib.h>
- include<string.h>
extern char* bestShuf(unsigned char*); extern void display(unsigned char*, unsigned char*); int main(int n, unsigned char **v) { int i; for (i= 1; i<n; i++) { char* shuf= bestShuf(v[i]); display(v[i], shuf); free(shuf); } }
char* bestShuf(unsigned char* txt) { int len= strlen(txt); int mx= 0; int counts[256]; int i, ch, j, n, m, k; for (i= 0; i<256; i++) counts[i]= 0; for (i= 0; i<len; i++) /* how many of each character? */ if (mx < ++counts[txt[i]]) mx= counts[txt[i]]; int *ndx1= malloc(len*sizeof (int)); for (ch= 0, i= 0; ch<256; ch++) /* all character positions, grouped by character */ if (counts[ch]) for (j= 0; j<len; j++) if (ch == txt[j]) ndx1[i++]= j; int *ndx2= malloc(len*sizeof (int)); for (i= 0, n= 0, m= 0; i<len; i++) { /* regroup them for cycles */ ndx2[i]= ndx1[n]; n+= mx; if (n >= len) n= ++m; } int *ndx3= malloc(len*sizeof (int)); int grp= 1+(len-1)/mx; /* how long can our cyclic groups be? */ int lng= 1+(len-1)%mx; /* how many of them are full length? */ for (i= 0, j= 0; i < mx; i++) { /* rotate each group */ int first= ndx2[j]; int glen= grp-(i<lng ?0 :1); for (k= 1; k<glen; k++) ndx3[j+k-1]= ndx2[j+k]; ndx3[j+k-1]= first; j+= glen; } char *r= malloc(1+len); r[len]= 0; for (i= 0; i<len; i++) /* result is original permuted according to our cyclic groups */ r[ndx2[i]]= txt[ndx3[i]]; free(ndx1); free(ndx2); free(ndx3); return r; }
void display(unsigned char* txt1, unsigned char* txt2) { int len= strlen(txt1); assert(len == strlen(txt2)); int score= 0; int i; for (i= 0; i<len; i++) if (txt1[i]==txt2[i]) score++; printf("%s, %s, (%d)\n", txt1, txt2, score); }</lang>
Required example:
<lang>$ make bestshuf && ./bestshuf abracadabra seesaw elk grrrrrr up a make: `bestshuf' is up to date. abracadabra, brabacadaar, (0) seesaw, wssaee, (0) elk, kel, (0) grrrrrr, rrrrrrg, (5) up, pu, (0) a, a, (1)</lang>
D
<lang d>int bestShuffle(dchar[] s1) {
int countSamePositions(dchar[] r1, dchar[] r2) {
return count!("a[0] == a[1] && a[1] != b")(zip(r1, r2), '-');
}
const len = s1.length; dchar[] s2 = s1.dup;
if (len < 3) {
s2.reverse;
} else {
s2.sort;
auto problemChar = sort!("a[1] > b[1]")(array(group(s2)))[0];
if ((problemChar[1] - len / 2) > 0) {
int numToRemove = problemChar[1] - (len - problemChar[1]);
for (int i, j; i < len && j < numToRemove; i++) {
if (s2[i] == problemChar[0]) {
s2[i] = '-';
j++;
}
}
}
do {
for (int i = len; i > 1; i--) {
swap(s2[i-1], s2[uniform(0, i)]);
}
} while(countSamePositions(s1, s2) > 0);
for (int i; i < len; i++) {
if (s2[i] == '-') {
s2[i] = problemChar[0];
}
}
}
int samePos = countSamePositions(s1, s2);
writefln("%s %s (%s)", s1, s2, samePos);
return samePos;
}</lang>
output:
abracadabra caararbdaab (0) seesaw essawe (0) elk lke (0) grrrrrr rrrrrgr (5) up pu (0) a a (1)
<lang d>unittest {
assert(bestShuffle("abracadabra".dup) == 0);
assert(bestShuffle("seesaw".dup) == 0);
assert(bestShuffle("elk".dup) == 0);
assert(bestShuffle("grrrrrr".dup) == 5);
assert(bestShuffle("up".dup) == 0);
assert(bestShuffle("a".dup) == 1);
}</lang>
Haskell
<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>
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
<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)
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 .
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
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
<lang tcl>package require Tcl 8.5 package require struct::list
- Simple metric function; assumes non-empty lists
proc count {l1 l2} {
foreach a $l1 b $l2 {incr total [string equal $a $b]}
return $total
}
- 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
- import nat
words = <'abracadabra','seesaw','elk','grrrrrr','up','a'>
shuffle = num; ^H/(*@K24) ^H\~&lS @rK2lSS *+ ^arPfarhPlzPClyPCrtPXPRalPqzyCipSLK24\~&L leql$^NS
- 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)