Best shuffle: Difference between revisions
Underscore (talk | contribs) (Added Perl 6.) |
|||
| Line 161: | Line 161: | ||
up, pu, (0) |
up, pu, (0) |
||
a, a, (1))</lang> |
a, a, (1))</lang> |
||
=={{header|Perl 6}}== |
|||
{{works with|Rakudo Star|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> |
|||
=={{header|PicoLisp}}== |
=={{header|PicoLisp}}== |
||
Revision as of 21:17, 31 December 2010
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
D
<lang d>int bestShuffle(char[] s1) {
int countSamePositions(char[] r1, char[] r2, int len) {
int count;
for (int i; i < len; i++) {
if (r2[i] != '-' && r1[i] == r2[i]) {
count++;
}
}
return count;
}
const len = s1.length; char[] 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, len) > 0);
char pc = cast(char)problemChar[0];
for (int i; i < len; i++) {
if (s2[i] == '-') {
s2[i] = pc;
}
}
}
int samePos = countSamePositions(s1, s2, len);
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>
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)