# How to group each element with each consecutive elements in one head

Suppose I have the following list:

list = {a, b, c, d}


I want to generate this result:

{{f[a, a], f[a, b], f[a, c], f[a, d]}, {f[b, b], f[b, c],
f[b, d]}, {f[c, c], f[c, d]}, {f[d, d]}}


What could be the shortest way?

The list elements can be anything and not necessarily sorted.

-
Very nice question, but I assume (because of your previous contributions) that you already have an answer (maybe not the shortest). If not, please excuse :) – eldo Jul 31 '14 at 19:14
@eldo yes I have an answer but as you said it is not short. – Algohi Jul 31 '14 at 19:43
+1. I like this question. – RunnyKine Jul 31 '14 at 19:58
@eldo (1) halirutan's method is not the shortest, yet the question clearly asks for the shortest way. "Moving the goalposts" is generally discouraged here. (2) You will note that I removed my "duplicate" comment and replaced it with a related link. (3) Even as a moderator I am free to voice my opinion, which is all I have done. This is not the first time that I have argued for or against a particular choice. For example (7687) was really an extended comment arguing the superiority of kguler's answer. – Mr.Wizard Aug 1 '14 at 23:50

Table[f @@ list[[{i, j}]], {i, 4}, {j, i, 4}]


If you want to use this for a general list, you should use Length[list] in the table iterators or maybe:

With[{n = Length[list]},
Table[f @@ list[[{i, j}]], {i, n}, {j, i, n}]
]

-
Long live Fortran? – alancalvitti Jul 31 '14 at 19:44
@haliturutan About to upvote, but couldn't you replace the static 4 with Length@list ??? – eldo Jul 31 '14 at 19:53
Your table is prettier than mine. – Timothy Wofford Jul 31 '14 at 19:56
+1 nice and simple. – Algohi Jul 31 '14 at 22:06
@eldo Hehe, haliturutan sounds a bit like Truthahn in German :-) I edited the answer. – halirutan Aug 1 '14 at 6:07

# Solutions

Pick[
Outer[f, list, list],
UpperTriangularize@ConstantArray[True, {#, #} &@Length@list]
]


Using the new Composition shorthand:

Thread@*f @@@ MapIndexed[{#, list[[First@#2 ;;]]} &, list]


# Timings

Testing with

list = Range[1000];


the first method takes 0.363 seconds to complete and the second takes 0.120 to complete. As a comparison, halirutan's Table method took 1.183 to complete. RunnyKine's is the fastest I have tested of the others, taking just 0.336 to complete. All times were measured with AbsoluteTiming.

-
@Uh, I like the use of the new Composition operator! Also, I would have gone with MapIndexed too but maybe combined it with Outer(but I don't have Mathematica to test right now) – sebhofer Jul 31 '14 at 23:03
6 significant digits for the timing results? Is this warranted (even if there is no variation in timing between several runs)? – Peter Mortensen Jul 31 '14 at 23:17
@PeterMortensen Thanks for pointing this out; I was mindlessly copying what AbsoluteTiming told me, and didn't think about it. I looked through some other posts and they used three decimal numbers, so I updated and did the same. – C. E. Jul 31 '14 at 23:25
Nice use of @* -- reasonably short and notably faster than my code. +1 :-) – Mr.Wizard Aug 1 '14 at 16:19

A few obfuscations via Listable:

Block[{f, op},
SetAttributes[f, Listable];
op[x_] := {f[x, x]};
op[x_, y__] := Sequence[f[x, {x, y}], op[y]];
{op @@ list}
]

Block[{f},
SetAttributes[f, Listable];
f @@@ Table[{list[[i]], list[[i ;;]]}, {i, 4}]
]

Module[{op1, op2},
op1 = Function[{x, l}, f[x, l], Listable];
op2 = {op1[#, {##}], Sequence @@ If[{##2} =!= {}, op2[##2], {}]} &;
op2 @@ list
]


### Update

The second method above is actually pretty good. The others aren't bad, but they are limited by \$RecursionLimit. This one is slightly faster:

f4 = Block[{f},
SetAttributes[f, Listable];
f[First[#], #] & /@ NestList[Rest, #, Length[#] - 1]
] &;


Timings

f1 = With[{n = Length[#]},
Table[f @@ #[[{i, j}]], {i, n}, {j, i, n}]] &;

f2 = MapIndexed[#[[#2[[1]] ;;]] &, Outer[f, #, #]] &;

f3[x_] := Thread@*f @@@ MapIndexed[{#, x[[First@#2 ;;]]} &, x];

f4 = Block[{f},
SetAttributes[f, Listable];
f[First[#], #] & /@ NestList[Rest, #, Length[#] - 1]
] &;

Needs["GeneralUtilities"]

BenchmarkPlot[{f1, f2, f3, f4}, RandomInteger[999, #] &, 2^Range[12]]


-

This is not the shortest, but faster than all except Pickett's (almost just as fast)

f4 = Thread@f[#[[1]], #] & /@ Partition[#, Length@#, 1, {1, 1}, {}] &


OR

 dP = DeveloperPartitionMap;


Then:

f5 = dP[Thread@f[#[[1]], #] &, #, Length@#, 1, {1, 1}, {}] &


Timings:

Needs["GeneralUtilities"]

f1 = With[{n = Length[#]}, Table[f @@ #[[{i, j}]], {i, n}, {j, i, n}]] &;

f2 = MapIndexed[#[[#2[[1]] ;;]] &, Outer[f, #, #]] &;

f3[x_] := Thread@*f @@@ MapIndexed[{#, x[[First@#2 ;;]]} &, x];

BenchmarkPlot[{f1, f2, f3, f4, f5}, RandomInteger[999, #] &, 2^Range[12


-

I don't believe anyone has posted exactly this formulation:

MapIndexed[#[[#2[[1]] ;;]] &, Outer[f, #, #]] &


Not terribly efficient but the question asked for shortest, not fastest.

### Argument

Although not optimal my method is both more efficient and shorter than the presently Accepted one.
The question clearly asked for the shortest way. You should not alter your standard after the fact.

Update: also including Pickett's code

f1 = With[{n = Length[#]}, Table[f @@ #[[{i, j}]], {i, n}, {j, i, n}]] &;

f2 = MapIndexed[#[[#2[[1]] ;;]] &, Outer[f, #, #]] &;

f3[x_] := Thread@*f @@@ MapIndexed[{#, x[[First@#2 ;;]]} &, x];

Needs["GeneralUtilities"]

BenchmarkPlot[{f1, f2, f3}, RandomInteger[999, #] &, 2^Range[12]]


-

There is probably something neater but the following works:

l = {a, b, c, d};
s = SplitBy[Tuples[l, {2}], First];
list = Take[s[[#]], #2] & @@@ Thread@{Range@Length@l, Range[-Length@l, -1]}
Map[f[Sequence @@ #] &, list, {-2}]

{{f[a, a], f[a, b], f[a, c], f[a, d]}, {f[b, b], f[b, c], f[b, d]},
{f[c, c], f[c, d]}, {f[d, d]}}

-

Here is a straightforward implementation...

Table[Table[f[list[[i]], list[[j]]], {j, i, Length@list}], {i, Length@list}]


Here is my flattened table: If list is a sorted list of unique elements

list = {a, b, c, d}
g[a_, b_] := f @@ Sort@{a, b};
Union@Flatten@Outer[g, list, list]

-
My table is flat... – Timothy Wofford Jul 31 '14 at 19:24
no the list is not sorted. it is random – Algohi Jul 31 '14 at 19:38
Thread[f[First@#, #]] & /@
NestList[Drop[#, 1] &, list, Length[list] - 1]


The above is a refinement of less efficient 1st attempt:

First@Outer[f, #, #] & /@
NestList[Drop[#, 1] &, list, Length[list] - 1]

-

A few more just for fun:

ReplaceList[list, {___, a__} :> Thread @ f[#& @ a, {a}]]

Pick[Outer[f, list, list], # <= #2 & ~Array~ {4, 4}]

-
Outer[f, list, list] /.
f[x_, y_] /;
First@First@Position[list, x] >  First@First@Position[list, y] :>
Sequence[]


What's annoying here is projecting #[[1,1]]&. How to make {{1}} <= {{2}} evaluate True?

-

Building up an Association

len=Length@list;
asso=<||>;
(asso[#]=list[[-#]])&/@Range@len;


and then

Array[Function[x,Array[f[x,#]&,x,{x,1}]],len,{len,1}]/.asso

-

Throwing my hat to the ring

Clear[splitList]
splitList[f_, list_List] :=
SplitBy[DeleteDuplicates[Sort /@ Tuples[Sort[Hold[f] @@ list], 2]], First] // ReleaseHold

splitList[f, {a, b, c, d}]
(* {{f[a, a], f[a, b], f[a, c], f[a, d]}, {f[b, b], f[b, c],
f[b, d]}, {f[c, c], f[c, d]}, {f[d, d]}} *)

splitList[Plus, {a, b, c, d}]
(* {{2 a, a + b, a + c, a + d}, {2 b, b + c, b + d}, {2 c, c + d}, {2 d}} *)

-
@RunnyKine I fixed my answer based on your suggestion. Try splitList[f, {a, b, c, 6, d, 5, b}] and let me know what you think. – seismatica Aug 1 '14 at 18:24