# Smarter Shuffle of a List

I have a 2D matrix representing a keyboard:

{{"Q", "W", "E", "R", "T", "Y", "U", "I", "O", "P"},
{"A", "S", "D", "F", "G", "H", "J", "K", "L"},
{"Z", "X", "C", "V", "B", "N", "M"}}


I want to 'shuffle' the list, such that the length of all the sub-lists stay the same, but the actual letters within them are randomly re-distributed (between all the lists, not just within their sub-list).

I thought of initializing a list with the same structure but all 0's instead of letters and then randomly pulling letters for a ReplacePart, but that means some letters would repeat, which I don't want (a shuffle).

How can this be accomplished in Mathematica?

You may Flatten the list and then take a RandomSample before partitioning to the original dimensions with Length and TakeList.

With keys the list in the OP then

TakeList[RandomSample @ Flatten @ keys, Length /@ keys]


Hope this helps.

• Yep... simple... elegant (+1). Commented Jun 29, 2018 at 2:42
• No need All in RandomSample (+1) Commented Jun 29, 2018 at 4:12
• For pre-TakeList versions of MMA: InternalPartitionRagged instead of TakeList. Commented Jun 29, 2018 at 6:13
• @OkkesDulgerci Good suggestion. May update later today. (+1) Commented Jun 29, 2018 at 11:42

Here is another approach that is applicable to all shapes of nested lists. It is a minor modification of halirutan's unflatten from "Unflattening" a list.

deepShuffle[l_] :=
Module[{i = 1, l1 = RandomSample @ Flatten[l]},
Function[, l1[[i++]], Listable][l]
]


Test:

in = {{"Q", "W", "E", "R", "T", "Y", "U", "I", "O", "P"},
{"A", "S", "D", "F", "G", "H", "J", "K", "L"},
{"Z", "X", "C", "V", "B", "N", "M"}};

SeedRandom[1]

deepShuffle[in]
deepShuffle[in]

{{"Y", "Q", "I", "N", "E", "R", "V", "Z", "J", "G"},
{"W", "H", "K", "X", "C", "A", "F", "U", "L"},
{"B", "T", "S", "P", "D", "M", "O"}}

{{"A", "Z", "K", "J", "E", "H", "G", "M", "D", "W"},
{"P", "Y", "X", "T", "L", "O", "V", "I", "B"},
{"F", "Q", "S", "N", "U", "R", "C"}}


• The linked unflatten and your subsequent deepShuffle are very elegant. (+1) Commented Jun 29, 2018 at 11:38

Here's a different approach:

keyboard =
{{"Q", "W", "E", "R", "T", "Y", "U", "I", "O", "P"},
{"A", "S", "D", "F", "G", "H", "J", "K", "L"},
{"Z", "X", "C", "V", "B", "N", "M"}}

With[{rule = CharacterRange["A", "Z"] //
# -> RandomSample[#] & // Thread},
keyboard /. rule]

{{"P", "X", "B", "G", "K", "U", "L", "O", "Z", "Q"},
{"F", "M", "W", "J", "V", "R", "T", "Y", "S"},
{"I", "E", "N", "A", "D", "C", "H"}}

ClearAll[f1, f2, f3]
f1 = Module[{l = #, i = Position[#, _, {-1}, Heads -> False]},
ReplacePart[l, Thread[RandomSample[i] -> Extract[l, i]]]] &;


and a modification of Ray Koopman's copyPartition

f2 = Module[{i = 1, l = RandomSample @ Flatten @ #}, Map[l[[i++]] &, #, {-1}]] &;


Examples:

lst = {{"Q", "W", "E", "R", "T", "Y", "U", "I", "O", "P"}, {"A", "S",
"D", "F", "G", "H", "J", "K", "L"}, {"Z", "X", "C", "V", "B", "N", "M"}};
lst2 = {{"Q", "W", "E", "R", {"T", "Y", "U", "I"}, "O", "P"},
{"A",  "S", "D", "F", {"G", {"H", "J"}}, "K", "L"},
{"Z", "X", "C", "V",  "B", "N", "M"}};

f1 @ lst


{{"C", "H", "X", "I", "P", "Q", "O", "V", "D", "U"},
{"S", "E", "L", "R", "A", "F", "W", "T", "K"},
{"Z", "G", "J", "Y", "B", "M", "N"}}

f2 @ lst


{{"U", "A", "D", "Z", "E", "R", "N", "L", "S", "O"},
{"X", "V", "J", "B", "H", "P", "I", "K", "T"},
{"M", "C", "F", "G", "Q", "W", "Y"}}

f1 @ lst2


{{"O", "B", "P", "D", {"E", "A", "J", "Q"}, "I", "H"},
{"T", "R", "Y", "C", {"N", {"L", "S"}}, "U", "W"},
{"V", "Z", "K", "M", "G", "X", "F"}}

f2 @ lst2


{"F", "J", "K", "Y", {"Z", "D", "W", "A"}, "P", "R"},
{"L", "T", "G", "H", {"I", {"U", "S"}}, "V", "E"},
{"N", "C", "B", "Q", "O", "M", "X"}}

Table[f1[lst], {3}] // Grid // TeXForm


$\small\begin{array}{ccc} \{\text{Q},\text{Z},\text{P},\text{B},\text{J},\text{U},\text{I},\text{S},\text{E},\text{M}\} & \{\text{T},\text{H},\text{F},\text{D},\text{W},\text{Y},\text{K},\text{O},\text{R}\} & \{\text{X},\text{C},\text{V},\text{G},\text{L},\text{A},\text{N}\} \\ \{\text{Q},\text{S},\text{I},\text{V},\text{T},\text{R},\text{Z},\text{X},\text{N},\text{F}\} & \{\text{U},\text{H},\text{E},\text{B},\text{G},\text{W},\text{O},\text{K},\text{C}\} & \{\text{Y},\text{D},\text{M},\text{A},\text{P},\text{L},\text{J}\} \\ \{\text{X},\text{V},\text{B},\text{M},\text{L},\text{K},\text{F},\text{H},\text{E},\text{T}\} & \{\text{I},\text{R},\text{U},\text{O},\text{N},\text{Q},\text{S},\text{C},\text{J}\} & \{\text{A},\text{Z},\text{G},\text{Y},\text{D},\text{P},\text{W}\} \\ \end{array}$

Table[f1[lst2], {3}] // Grid // TeXForm


$\small\begin{array}{ccc} \{\text{Y},\text{Q},\text{J},\text{P},\{\text{W},\text{T},\text{I},\text{L}\},\text{K},\text{O}\} & \{\text{G},\text{A},\text{S},\text{N},\{\text{M},\{\text{C},\text{H}\}\},\text{F},\text{V}\} & \{\text{D},\text{B},\text{R},\text{Z},\text{U},\text{X},\text{E}\} \\ \{\text{A},\text{E},\text{L},\text{M},\{\text{H},\text{T},\text{U},\text{Z}\},\text{F},\text{I}\} & \{\text{N},\text{D},\text{X},\text{O},\{\text{S},\{\text{B},\text{J}\}\},\text{V},\text{C}\} & \{\text{G},\text{Y},\text{W},\text{R},\text{P},\text{K},\text{Q}\} \\ \{\text{H},\text{T},\text{N},\text{A},\{\text{E},\text{G},\text{K},\text{U}\},\text{B},\text{P}\} & \{\text{Y},\text{V},\text{W},\text{L},\{\text{D},\{\text{S},\text{Z}\}\},\text{F},\text{X}\} & \{\text{Q},\text{R},\text{J},\text{M},\text{O},\text{C},\text{I}\} \\ \end{array}$

This is a solution using Fold

                   (* Join result *)
shuffleKeyboard[]:=Apply[Join][Fold[
(* #1 = available chars, #2 = list length *)
With[{rsmpl = RandomSample[#1[[-1, -1]], #2]},
{Join[#1[[1]], {rsmpl}], {Complement[#1[[-1, -1]], rsmpl]}}
] &, {{}, {CharacterRange["A", "Z"]}}, {10, 9}]
]


Using it in a reproducible way:

assoc = With[{seed = RandomInteger[{10^5, 10^6}]},
BlockRandom[
Association["seed" -> seed, "layout" -> shuffleKeyboard[]],
RandomSeeding -> seed
]
]


evaluates to

<|"seed" -> 953127,
"layout" -> {
{"U", "Q", "N", "Z", "V", "M", "J", "I", "B", "A"},
{"L", "X", "T", "H", "F", "C", "D", "P", "R"},
{"E", "G", "K", "O", "S", "W", "Y"}}|>


As a sanity check I added

Sort[Flatten[assoc["layout"]]] == CharacterRange["A", "Z"]


which hopefully evaluates to True` (it does).