9
$\begingroup$

Give the following list,

list = {{a1, a2, a3}, {b1, b2, b3, b4}, {c1, c2, c3, c4, c5}};

I want to get

{F[{a1}]}
{F[{a1,a2}]}
{F[{a1,a2,a3}]}
{F[{a1,a2,a3}],F[{b1}]}
{F[{a1,a2,a3}],F[{b1,b2}]}
{F[{a1,a2,a3}],F[{b1,b2,b3}]}
{F[{a1,a2,a3}],F[{b1,b2,b3,b4}]}
{F[{a1,a2,a3}],F[{b1,b2,b3,b4}],F[{c1}]}
......

I have tried this, It is difficult to further promote, do you have a better way?

L1 = Rest@FoldList[Append, {}, #] & /@ list
L2 = MapAt[F, L1, Join @@ MapIndexed[#2 &, L1, {2}]]
Join[List /@ L2[[1]], {L2[[1, -1]], #} & /@ L2[[2]]] // Column
$\endgroup$

6 Answers 6

6
$\begingroup$

Define:

idx = Flatten[MapIndexed[#2 &, list, {-1}], 1];

Then:

    Function[grp, Values[GroupBy[grp, First, f @@ {Extract[list, #]} &]]] /@ 
       Map[idx[[1 ;; #]] &, Range[1, Length[idx]]] // Column
(* 
    {
 {{f[{a1}]}},
 {{f[{a1, a2}]}},
 {{f[{a1, a2, a3}]}},
 {{f[{a1, a2, a3}], f[{b1}]}},
 {{f[{a1, a2, a3}], f[{b1, b2}]}},
 {{f[{a1, a2, a3}], f[{b1, b2, b3}]}},
 {{f[{a1, a2, a3}], f[{b1, b2, b3, b4}]}},
 {{f[{a1, a2, a3}], f[{b1, b2, b3, b4}], f[{c1}]}},
 {{f[{a1, a2, a3}], f[{b1, b2, b3, b4}], f[{c1, c2}]}},
 {{f[{a1, a2, a3}], f[{b1, b2, b3, b4}], f[{c1, c2, c3}]}},
 {{f[{a1, a2, a3}], f[{b1, b2, b3, b4}], f[{c1, c2, c3, c4}]}},
 {{f[{a1, a2, a3}], f[{b1, b2, b3, b4}], f[{c1, c2, c3, c4, c5}]}}
}
*)
$\endgroup$
6
$\begingroup$

Here's an approach. If we flattened your input list and used FoldList, we'd get something resembling the desired output but missing the list structure. But we could recover the list structure afterward by grouping according to the length of each sublist in the original list. Let's put this idea into a function:

FoldOver[lists : {___List}] :=
  With[
    {lengths = Length /@ lists},
    Map[
      F,
      DeleteCases[
        TakeList[#, UpTo /@ lengths] & /@ FoldList[Append, {}, Flatten[lists, 1]],
        {},
        Infinity],
      {-2}]]

Applying this:

FoldOver[list]

gives {F[{}], {F[{a1}]}, ... , {F[{a1, a2, a3}], F[{b1, b2, b3, b4}], F[{c1, c2, c3, c4, c5}]}}

You can add something to remove the first element if you like.

This is a bit dense, so a suggestion for understanding it is to unroll it and roll it back up incrementally. So, start with this definition:

FoldOver[lists : {___List}] :=
  With[
    {lengths = Length /@ lists},
    FoldList[Append, {}, Flatten[lists, 1]]]

Which gives:

FoldOver[list]

{{}, {a1}, ... , {a1, a2, a3, b1, b2, b3, b4, c1, c2, c3, c4}, {a1, a2, a3, b1, b2, b3, b4, c1, c2, c3, c4, c5}}

And then:

FoldOver[lists : {___List}] :=
  With[
    {lengths = Length /@ lists},
    TakeList[#, UpTo /@ lengths] & /@ FoldList[Append, {}, Flatten[lists, 1]]]

And then:

FoldOver[lists : {___List}] :=
  With[
    {lengths = Length /@ lists},
    DeleteCases[
      TakeList[#, UpTo /@ lengths] & /@ FoldList[Append, {}, Flatten[lists, 1]],
      {},
      Infinity]]

Etcetera...

$\endgroup$
1
  • $\begingroup$ (+1) Add Rest@With... :-) $\endgroup$ Dec 20, 2022 at 17:13
5
$\begingroup$
Clear["Global`*"]
list = {{a1, a2, a3}, {b1, b2, b3, b4}, {c1, c2, c3, c4, c5}};
dlist = ReplaceList[Flatten@list, {x__, y__} :> {x}]

{{a1}, {a1, a2}, {a1, a2, a3}, {a1, a2, a3, b1}, {a1, a2, a3, b1,
b2}, {a1, a2, a3, b1, b2, b3}, {a1, a2, a3, b1, b2, b3, b4}, {a1,
a2, a3, b1, b2, b3, b4, c1}, {a1, a2, a3, b1, b2, b3, b4, c1, c2}, {a1, a2, a3, b1, b2, b3, b4, c1, c2, c3}, {a1, a2, a3, b1, b2, b3, b4, c1, c2, c3, c4}}

Now these need to be partitioned according to the original sublist lengths:

(res2 = Map[F, 
    TakeList[#, UpTo /@ (Length /@ list)] & /@ dlist /. {} -> 
      Nothing, {2}]) // TableForm

enter image description here

$\endgroup$
3
$\begingroup$

A little variant of Syed's answer is to get the partition of the list using Partition and Table:

slist = Table[First@Partition[Flatten@list, i], {i, 1, Length[Flatten@list]}]
(*{{a1}, {a1, a2}, {a1, a2, a3}, {a1, a2, a3, b1}, {a1, a2, a3, b1,   b2}, 
  {a1, a2, a3, b1, b2, b3}, {a1, a2, a3, b1, b2, b3, b4}, {a1, a2, a3, b1, b2, b3, b4, c1}, 
  {a1, a2, a3, b1, b2, b3, b4, c1, c2}, {a1, a2, a3, b1, b2, b3, b4, c1, c2, c3}, 
  {a1, a2, a3, b1, b2, b3, b4, c1, c2, c3, c4}, 
  {a1, a2, a3, b1, b2, b3, b4, c1, c2, c3, c4, c5}}*)

Then, using Syed's code:

(res2 = Map[F, 
TakeList[#, UpTo /@ (Length /@ list)] & /@ dlist /. {} -> 
  Nothing, {2}]) // TableForm

enter image description here

$\endgroup$
2
$\begingroup$

The code below produces the required output when applied on input list:

ClearAll[flat,wrap]
SetAttributes[flat,{Flat}]
flat/:wrap[flat[args__]]:=F[{args}]
list//Map[(Through[{First/*flat,Rest}[#]]&)/*Apply[FoldList[flat]]]/*Apply[Join]/*wrap/*Thread/*List/*Transpose/*FoldList[Join]

In what's following, I will provide an informal walkthrough of the code.

First thing's first, attribute Flat on a symbol: Flat instructs the evaluator to replace nested expressions with a flattened version of the expression, eg:

ClearAll[f]
SetAttributes[f, Flat]
f[1, f[2, 3], f[f[4], 5]]

evaluates to f[1, 2, 3, 4, 5].

Next, we'll talk about the Through part. Using it on every sublist of the original list, it prepares the input for the following expression.

Its effect is to split a list into its head and the rest of its body; it also wraps the head with flat, which is a symbol with attribute Flat:

{a1, a2, a3} // Through[{First/*flat, Rest}[#]]&

evaluates to {flat[a1], {a2, a3}}.

The following step, involves FoldList. To illustrate how it works, we'll present first a general case and then we'll specify how it helps to achieve the required output.

A plain use of FoldList like this:

FoldList[g, g[a1], {a2, a3}]

evaluates to {g[a1], g[g[a1], a2], g[g[g[a1], a2], a3]}.

Now, consider how this output would change, if symbol g were actually equipped with the Flat attribute. The answer is simply {g[a1], g[a1, a2], g[a1, a2, a3]}.

So far, we've actually produced a list with entries wrapped with a Flat symbol. In our original code, this list is produced after we Map over the sublists of list.

The next code snippet is

Apply[Join]/*wrap/*Thread

This simply joins together the respective sublists and wraps each entry with an auxiliary symbol (wrap).

Associated with wrap is a rule that transforms the arguments of its argument into the arguments of the designated function F.

Finally, List/*Transpose/*FoldList[Join] produces the desired output. The part List/*Transpose prepares the input for the operator form FoldList[Join], which eventually evaluates to the desired output.

Hope this helps

$\endgroup$
1
$\begingroup$

This solution is a basic Table with two levels which used Catenate to unpack and Extract (the third argument is used to apply your function).

ClearAll[fn];

fn[f_, data_] := Block[{lengths = Length /@ data},
 Catenate @ Table[Extract[list
    , If[listIndex > 1 (* start including previous items *)
      , Table[{i, ;;}, {i, listIndex - 1}]
      , {}]
     ~Join~
     {{listIndex, ;; itemIndex}}
    , f]
   
   , {listIndex, Length @ lengths}
   , {itemIndex, lengths[[listIndex]]}]
 ]

Also, you can use it with any number of sub-list.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.