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.
<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)