How to split a list with respect to its nested sublists?

Question

I have a problem with the following task: having some nested list

list = {{k6},{k1,k3,k5},{k7}}

I would like to replace all sublists by their permutations and then split original list w.r.t. these permutations. So I started with permutations

list1 = {{{k6}},{{k1,k3,k5},{k1,k5,k3},{k3,k1,k5},{k3,k5,k1},{k5,k1,k3},{k5,k3,k1}},{{k7}}}

but I got stuck at this point - how to split this list w.r.t. sublists, i.e. to get:

list2 = {{{{k6}},{{k1,k3,k5}},{{k7}}},{{{k6}},{{k1,k5,k3}},{{k7}}},...}

Then I would like also to obtain a list of the form

{{k6,k1,k3,k5,k7},{k6,k1,k5,k3,k7},...}

Perhaps there is a simpler method to do this?

Obviously, if e.g.

list = {{k6},{k1,k3},{k2,k5},{k7}}

then the splitting should give list with all combinations of permutations of {k1,k3} and {k2,k5} taken into account preserving original order.

Answer 1

list = {{k6}, {k1, k3, k5}, {k7}};

Flatten /@ Tuples[Permutations /@ list]

{{k6, k1, k3, k5, k7}, {k6, k1, k5, k3, k7}, {k6, k3, k1, k5, k7}, 
  {k6, k3, k5, k1, k7}, {k6, k5, k1, k3, k7}, {k6, k5, k3, k1, k7}}

Answer 2

SlotSequence helps providing an elegant and terse style of Mathematica programming:

Outer[ ## &, ## & @@ list1, 1]

{{{{k6}, {k1, k3, k5}, {k7}}, {{k6}, {k1, k5, k3}, {k7}}, 
  {{k6}, {k3, k1, k5}, {k7}}, {{k6}, {k3, k5, k1}, {k7}}, 
  {{k6}, {k5, k1, k3}, {k7}}, {{k6}, {k5, k3, k1}, {k7}}}}

or satisfying another expectation in the question:

Apply[ ## &, %, {3}][[1]]

{{k6, k1, k3, k5, k7}, {k6, k1, k5, k3, k7}, {k6, k3, k1, k5, k7}, 
 {k6, k3, k5, k1, k7}, {k6, k5, k1, k3, k7}, {k6, k5, k3, k1, k7}}

Answer 3

A rule based approach:

l = {{k6}, {k1, k3, k5}, {k7}}
l1 = Permutations /@ l
l2 = ReplaceList[l1, {{___, a_, ___}, {___, b_, ___}, {___, c_, ___}} -> {a, b, c}]
(*
 {{{k6}, {k1, k3, k5}, {k7}}, 
  {{k6}, {k1, k5, k3}, {k7}}, 
  {{k6}, {k3, k1, k5}, {k7}}, 
  {{k6}, {k3, k5, k1}, {k7}}, 
  {{k6}, {k5, k1, k3}, {k7}}, 
  {{k6}, {k5, k3, k1}, {k7}}}
*)

You can do

 Flatten /@l2

If you want to get flattened lists as the result

Edit

The following works for variable number of lists. Perhaps not elegant, but I wanted to stick with ReplaceList[]:

l = {{k6}, {k1, k3, k5}, {k7}}
l1 = Permutations /@ l
l2 = ReplaceList[l1, Array[ToExpression["{___,x" <> ToString[#] <> "_,___}"] &, Length@l] -> 
                     Array[ToExpression["x" <> ToString[#]] &, Length@l]]

Or shorter (by @PinguinDirk)

ReplaceList[l1, With[{vars = (Unique["x"] & /@ Range[Length@l1])}, 
                     {___, Pattern[#, Blank[]], ___} & /@ vars -> vars]]

Answer 4

list1 = Permutations[#] & /@ list;
Flatten[{{First[list1] /. List -> Sequence, # /. List -> Sequence, 
     Last[list1] /. List -> Sequence}} & /@ list1[[2 ;; -2]][[1]], 1]

{{k6, k1, k3, k5, k7}, {k6, k1, k5, k3, k7}, {k6, k3, k1, k5, k7}, {k6, k3, k5, k1, k7}, {k6, k5, k1, k3, k7}, {k6, k5, k3, k1, k7}}