# How to neatly get the sum of symmetric elements in a list?

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

(*==> {a+f, b+e, c+d} *)

symmSum[{a, b, c, d, e}]

(*==> {a+e, b+d, c} *)


My clumsy solution is

symmSum[l_List] := Block[{n = Length@l, res},
res = Last@Last@Reap@Do[Sow[l[[i]] + l[[-i]]], {i, Ceiling[n/2]}];
If[OddQ@n, res[[-1]] /= 2];
res
];


I feel that this can be done without using Length, but how?

• See my update for a Length-less solution. Commented Feb 4, 2012 at 21:34
• Thank you all guys, it was fascinating! Commented Feb 5, 2012 at 7:36

Playing with patterns:

{a, b, c, d, e} //. {h_, b___, t : Except[_List]} :> {h + t, {b}} // Flatten


This can be written more efficiently, without the full rescanning inherent in //., using recursion:

f1 = # /. {h_, b___, t_} :> Prepend[f1 @ {b}, h + t] &;


Also as a DownValues definition which is a bit more efficient still:

f2[{h_, b___, t_}] := Prepend[f2 @ {b}, h + t]
f2[x_] := x

f2 @ {a, b, c, d, e}
f2 @ {a, b, c, d, e, f}

{a + e, b + d, c}
{a + f, b + e, c + d}


Disregarding elegance, this is the fastest method I could come up with for packed arrays:

Module[{ln = Length@#, x},
x  = #[[ ;; ⌈ln/2⌉ ]];
x += #[[ -1 ;; ⌊ln/2⌋ + 1 ;; -1 ]];
If[OddQ @ ln, x[[-1]] /= 2 ];
x
] &


I imagine it can be bested by compile-to-C in v8, but I don't have that.

• @Szabolcs Thanks! I like your iter better. I use that structure fairly often myself, and it always feels powerful (a little code goes a long way). Commented Feb 4, 2012 at 23:12
• the first method is very impressive
– acl
Commented Feb 5, 2012 at 0:01
• @Szabolcs I added an improved method to my answer that I like best of all now. I fear it may encroach upon your answer, however it is in essence my original method written recursively. Commented Apr 25, 2014 at 4:11

This is a simple though somewhat wasteful solution:

symmSum[l_List] := Take[l + Reverse[l], Ceiling[Length[l]/2]]


It will give you the middle element twice, not once. Is it important that you only get c (and not 2c) when applying this function to {a,b,c,d,e}? That's easy to do (avoiding computing elements twice is also easy), but will make the function slightly longer. These solutions all use Length though.

Here's a pattern-based solution which avoids Length:

iter[{result___}, {s_, mid___, e_}] := iter[{result, e + s}, {mid}]
iter[{result___}, {}] := {result}
iter[{result___}, {mid_}] := {result, mid}

symmSum[l_List] := iter[{}, l]


You may want to modify this as

symmSum[l_List] := Block[{$IterationLimit = Infinity}, iter[{}, l]]  to make it work for arbitrarily long lists. What's wrong with Length? It's a very efficient function to callculate (since lists are vectors internally, i.e. arrays of fixed size, whose length is precisely known to the program at all times). symSum = Module[{result, length = Length[#]}, result = (# + Reverse@#) [[1 ;; Ceiling[length/2]]]; If[OddQ[length], result[[-1]] /= 2]; result ] &; symSum@{a, b, c, d, e, f} symSum@{a, b, c, d, e}  {a + f, b + e, c + d} {a + e, b + d, c}  • Nothing wrong, just a wish for perfection :-) Commented Feb 5, 2012 at 7:35 Here's an approach using a specially constructed (sparse) matrix: symmSum[list_] := With[{n = Length[list]}, Take[ SparseArray[ {Band[{1, 1}] -> 1, Band[{1, -1}, Automatic, {1, -1}] -> 1}, {n, n} ].list, Ceiling[n/2] ] ]  Test cases: symmSum[{a, b, c, d, e, f}] (* ==> {a + f, b + e, c + d} *) symmSum[{a, b, c, d, e}] (* ==> {a + e, b + d, c} *)  With the conscious decision to eschew elegance for reliability, I present symSum[li_List] := Module[{k2 = Ceiling[Length[li]/2]}, Total[MapAt[Reverse, If[Apply[Equal, Length /@ #], #, MapAt[Function[l, PadLeft[l, k2]], #, {2}]] &[ Partition[li, k2, k2, {1, 1}, {}]], {2}]]]  or more compactly, symSum[li_List] := Module[{k2 = Ceiling[Length[li]/2]}, Total[MapAt[Reverse, PadLeft[Partition[li, k2, k2, {1, 1}, {}], {2, k2}], {2}]]]  Testing: list = {a, b, c, d, e, f}; symSum[list] {a + f, b + e, c + d} symSum[Most@list] {a + e, b + d, c}  Yet another variation: symSum[li_List] := Module[{k = Length[li], k2}, k2 = Ceiling[k/2]; Total[MapAt[ Composition[Reverse, If[EvenQ[k], Identity, RotateRight]], InternalDeflatten[PadRight[li, 2 k2], {2, k2}], {2}]]]  and we can keep on putting out variations until we're all blue in the face: symSum[li_List] := Module[{k = Length[li], k2}, k2 = Ceiling[k/2]; PadRight[Total[ Take[li, {#, # Quotient[k, 2], #}] & /@ {1, -1}], k2, test[[k2]]]]  • baroque! +1 though – acl Commented Feb 5, 2012 at 0:06 • @acl if it ain't baroque, don't fix it! (I so rarely get to use that pun, and I'd apologize for it, if I felt any remorse whatsoever.) Commented Feb 5, 2012 at 3:16 Recursive solution fr[l_] := Which[ l == {}, Sequence[{}], Drop[l, 1] == {}, l, True, {First[l] + Last[l], Sequence @@ fr[Take[l, {2, -2}]]} ]  so fr[{a, b, c, d, e}] fr[{a, b, c, d, e, f}] (* {a + e, b + d, c} {a + f, b + e, c + d} *)  For longer lists, one would need to increase the recursion limit like so Block[{$RecursionLimit = \[Infinity]},
fr[RandomInteger[{-5, 5}, 1000]]]
(*lots of stuff*)


Previous solutions

For lists of even length,

(#[[1 ;; -1 ;; 2]] + Reverse@#[[2 ;; -1 ;; 2]]) &


does what you want. For odd lengths, I don't see how to avoid Length.

length without Length

length[lst_] :=
Module[{i},
i = 1;
NestWhile[(i += 1; Rest@#) &, lst, Rest[#] \[NotEqual] {u} &];
i
]


a bit silly though.

Locating the centre of a list

Here is how to find the central position of an odd-length list (returns $Failed for even-length lists): findMiddle[lst_] := If[ # == {},$Failed,
First@First@#] &@Position[
Function[
{l},
Equal,
{l, Reverse@l}
]
]@MapIndexed[First@#2 &, lst],
True
]


(please note this is not serious, so do not point out inefficiencies!).

• ...asuming the odd list doesn't have any symmetrical elements other than the middle one. The one for even lists doesn't work, try it for a list of more than 4 elements
– Rojo
Commented Feb 4, 2012 at 22:24
• @rojo oops true! the first seems to work..
– acl
Commented Feb 4, 2012 at 22:39
• I run the first with {a, b, c, d, e, f} as input and get {a+f, c+d, b+e} instead of {a+f, b+e, c+d}
– Rojo
Commented Feb 5, 2012 at 7:11
• @Rojo I see, I had not interpreted the question this way (ie that the order is important)
– acl
Commented Feb 5, 2012 at 10:49

sumSym = Block[{$RecursionLimit = Infinity}, Flatten[ If[Length[#1] <= 1, #1, {Total[#1[[{1, -1}]]], #0[#1[[2 ;; -2]]]}] &[#]] &[#] ] &;  or cuter but slower, avoiding nesting 3 functions and the flatten Block[{$RecursionLimit = Infinity},
If[Length[#1] <= 1, #1, {Total[#1[[{1, -1}]]],
Sequence @@ #0[#1[[2 ;; -2]]]}]] &


An incredibly slow solution that uses Length (hehe, what am I posting this for) could be

ReplaceList[r, {{i___, b_, ___, e_, j___} /;
Length[{i}] == Length[{j}] :> b + e,
{i___, m_, j___} /; Length[{i}] == Length[{j}] :> m}]


Yet another possible solution:

sumSym[x_List]:=
Module[{len=Length[x]~Quotient~2,
extra=Length[x]~Mod~2==1,
result},
result = x[[Range[len]]] + x[[-Range[len]]];
If[extra,Append[result,x[[len+1]]],result]]


Example:

sumSym@{a,b,c,d,e,f}
(*
==> {a + f, b + e, c + d}
*)

sumSym@{a,b,c,d,e}
(*
==> {a + e, b + d, c}
*)

• Better to write extra = OddQ[Length[x]], no? Commented Feb 5, 2012 at 12:27
• I just recently learned that the *Q functions are not the right choice if you want to check mathematical properties (see mathematica.stackexchange.com/q/601/129). Commented Feb 5, 2012 at 12:38
• That's for symbolic evaluation. Here, you can almost always expect Length[x] to return some integer that OddQ[] certainly won't choke on... Commented Feb 5, 2012 at 12:46

Using ListConvolve:

ClearAll[partsF, lcF]
partsF = Module[{fl = Floor[Length[#]/2], cl = Ceiling[Length[#]/2]}, {#[[1 + fl ;;]],
lcF = First@ListConvolve[## & @@ partsF@#, {-1, 1}, {}, Plus, List] &;


Examples:

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


{a + f, b + e, c + d}

lcF[{a, b, c, d, e}]


{a + e, b + d, c}

Without using Length:

ClearAll[lcF2]
lcF2 = First@ListConvolve[#, #, {-1, 1}, {}, Plus,
Composition[Last /@ # /. Times -> (#2 &) &, Gather, List]] &;

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


{a + f, b + e, c + d}

lcF2[{a, b, c, d, e}]


{a + e, b + d, c}

Using TakeList:

Clear["Global*"];

edgeSum[k_List] := Module[{n = Length@k},
alt = Array[(-1)^(# + 1) &, n];
Sequence @@@ TakeList[k, alt] //
Partition[#, UpTo[2]] & //
Map[Total]
]

edgeSum /@ {{a}, {a, b}, {a, b, c}, {a, b, c, d}, {a, b, c, d, e}, {a,
b, c, d, e, f}}


h = Total@
{Identity, Reverse}
TakeList[#, {Ceiling@(Length@#/2), -Floor@(Length@#/2)}]
}
] &;
h /@ {{a}, {a, b}, {a, b, c}, {a, b, c, d}, {a, b, c, d, e}, {a, b, c,
d, e, f}}


Result

{{a}, {a + b}, {a + c, b}, {a + d, b + c}, {a + e, b + d, c}, {a + f, b + e, c + d}}

foo[dt_] :=
With[{le = Length @ dt},
Plus @@@
Map[dt[[#]]&,
Append[If[OddQ @ le, {-Ceiling[le/2]}, Nothing]] @

foo /@ {{a}, {a, b}, {a, b, c}, {a, b, c, d}, {a, b, c, d, e}, {a, b, c, d, e, f}}


{{a}, {a + b}, {a + c, b}, {a + d, b + c}, {a + e, b + d, c}, {a + f, b + e, c + d}}

symTotal = Total@PadRight@{#, Reverse@#2}&@@TakeDrop[#, Ceiling[Length[#]/2]]&;


Examples:

symTotal @ {a, b, c, d, e}

{a + e, b + d, c}

symTotal @ {a, b, c, d, e, f}

{a + f, b + e, c + d}


Taking advantage of the fact that Flatten may be used to transpose a 'ragged' array:

symPartition[lst_List]:=Flatten[#,{{2}}]&@MapAt[Reverse,-1]@Partition[lst,
UpTo[Ceiling[Length@lst/2]]]

symPartition/@{{a},{a,b},{a,b,c,d},{a,b,c,d,e}}

(* {
{{a}},
{{a,b}},
{{a,d},{b,c}},
{{a,e},{b,d},{c}}
} *)


To get the sum:

MapApply[Plus]@*symPartition/@{{a},{a,b},{a,b,c,d},{a,b,c,d,e}}

(* {
{a},
{a+b},
{a+d,b+c},
{a+e,b+d,c}
} *)


Just for fun:

TableForm[MapApply[Plus]@*symPartition/@(Alphabet[][[#]]&/@Range@Range[26])]


$$\begin{array}{ccccccccccccc} \text{a} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{b} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{c} & \text{b} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{d} & \text{b}+\text{c} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{e} & \text{b}+\text{d} & \text{c} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{f} & \text{b}+\text{e} & \text{c}+\text{d} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{g} & \text{b}+\text{f} & \text{c}+\text{e} & \text{d} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{h} & \text{b}+\text{g} & \text{c}+\text{f} & \text{d}+\text{e} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{i} & \text{b}+\text{h} & \text{c}+\text{g} & \text{d}+\text{f} & \text{e} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{j} & \text{b}+\text{i} & \text{c}+\text{h} & \text{d}+\text{g} & \text{e}+\text{f} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{k} & \text{b}+\text{j} & \text{c}+\text{i} & \text{d}+\text{h} & \text{e}+\text{g} & \text{f} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{l} & \text{b}+\text{k} & \text{c}+\text{j} & \text{d}+\text{i} & \text{e}+\text{h} & \text{f}+\text{g} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{m} & \text{b}+\text{l} & \text{c}+\text{k} & \text{d}+\text{j} & \text{e}+\text{i} & \text{f}+\text{h} & \text{g} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{n} & \text{b}+\text{m} & \text{c}+\text{l} & \text{d}+\text{k} & \text{e}+\text{j} & \text{f}+\text{i} & \text{g}+\text{h} & \text{} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{o} & \text{b}+\text{n} & \text{c}+\text{m} & \text{d}+\text{l} & \text{e}+\text{k} & \text{f}+\text{j} & \text{g}+\text{i} & \text{h} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{p} & \text{b}+\text{o} & \text{c}+\text{n} & \text{d}+\text{m} & \text{e}+\text{l} & \text{f}+\text{k} & \text{g}+\text{j} & \text{h}+\text{i} & \text{} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{q} & \text{b}+\text{p} & \text{c}+\text{o} & \text{d}+\text{n} & \text{e}+\text{m} & \text{f}+\text{l} & \text{g}+\text{k} & \text{h}+\text{j} & \text{i} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{r} & \text{b}+\text{q} & \text{c}+\text{p} & \text{d}+\text{o} & \text{e}+\text{n} & \text{f}+\text{m} & \text{g}+\text{l} & \text{h}+\text{k} & \text{i}+\text{j} & \text{} & \text{} & \text{} & \text{} \\ \text{a}+\text{s} & \text{b}+\text{r} & \text{c}+\text{q} & \text{d}+\text{p} & \text{e}+\text{o} & \text{f}+\text{n} & \text{g}+\text{m} & \text{h}+\text{l} & \text{i}+\text{k} & \text{j} & \text{} & \text{} & \text{} \\ \text{a}+\text{t} & \text{b}+\text{s} & \text{c}+\text{r} & \text{d}+\text{q} & \text{e}+\text{p} & \text{f}+\text{o} & \text{g}+\text{n} & \text{h}+\text{m} & \text{i}+\text{l} & \text{j}+\text{k} & \text{} & \text{} & \text{} \\ \text{a}+\text{u} & \text{b}+\text{t} & \text{c}+\text{s} & \text{d}+\text{r} & \text{e}+\text{q} & \text{f}+\text{p} & \text{g}+\text{o} & \text{h}+\text{n} & \text{i}+\text{m} & \text{j}+\text{l} & \text{k} & \text{} & \text{} \\ \text{a}+\text{v} & \text{b}+\text{u} & \text{c}+\text{t} & \text{d}+\text{s} & \text{e}+\text{r} & \text{f}+\text{q} & \text{g}+\text{p} & \text{h}+\text{o} & \text{i}+\text{n} & \text{j}+\text{m} & \text{k}+\text{l} & \text{} & \text{} \\ \text{a}+\text{w} & \text{b}+\text{v} & \text{c}+\text{u} & \text{d}+\text{t} & \text{e}+\text{s} & \text{f}+\text{r} & \text{g}+\text{q} & \text{h}+\text{p} & \text{i}+\text{o} & \text{j}+\text{n} & \text{k}+\text{m} & \text{l} & \text{} \\ \text{a}+\text{x} & \text{b}+\text{w} & \text{c}+\text{v} & \text{d}+\text{u} & \text{e}+\text{t} & \text{f}+\text{s} & \text{g}+\text{r} & \text{h}+\text{q} & \text{i}+\text{p} & \text{j}+\text{o} & \text{k}+\text{n} & \text{l}+\text{m} & \text{} \\ \text{a}+\text{y} & \text{b}+\text{x} & \text{c}+\text{w} & \text{d}+\text{v} & \text{e}+\text{u} & \text{f}+\text{t} & \text{g}+\text{s} & \text{h}+\text{r} & \text{i}+\text{q} & \text{j}+\text{p} & \text{k}+\text{o} & \text{l}+\text{n} & \text{m} \\ \text{a}+\text{z} & \text{b}+\text{y} & \text{c}+\text{x} & \text{d}+\text{w} & \text{e}+\text{v} & \text{f}+\text{u} & \text{g}+\text{t} & \text{h}+\text{s} & \text{i}+\text{r} & \text{j}+\text{q} & \text{k}+\text{p} & \text{l}+\text{o} & \text{m}+\text{n} \\ \end{array}$$

Using Table and Gather:

F[list_] := Module[{l, pl, dpl, pt},
l = Length @ list;
pl = Function[
Gather[
Table[(Part[#, i] + Part[#, -i]) / 2,
{i, Length @ #}
]
]
][list];
dpl = Map[Greater[#, 2] &, Map[Length, pl]];
pt = Catenate[Map[Partition[#, 2, 1] &, pl]];
Which[
Or[
And[SameQ[DuplicateFreeQ[list], True],
SameQ[FreeQ[dpl, True], True]
],
And[SameQ[DuplicateFreeQ[list], False],
SameQ[FreeQ[dpl, True], True]
]
],
Map[Total, pl],
And[SameQ[DuplicateFreeQ[list], False],
SameQ[FreeQ[dpl, True], False]
],
MapApply[Sequence,
{Map[Total, Most @ pt], Function[Total[# / 2]][Last @ pt]}
]
]
];


Test:

l1 = {a};
l2 = {a, b};
l3 = {a, b, c};
l4 = {a, b, c, d};
l5 = {a, b, c, d, e};
l6 = {a, b, c, d, e, f};
l7 = {a, b, c, d, e, f, g};
l8 = {a, b, c, c, b, a};
l9 = {a, 0, 0, 0, 0};(*An example suggested by Syed*)
l10 = {a, b, b, b, b};

F /@ {l1, l2, l3, l4, l5, l6, l7, l8, l9, l10} // Column


• Please call the second function with a different name. It is easier to check without getting Tag is Protected... errors. Use {a, b, c, c, b, a} as a test case. The result should be {2a, 2b, 2c}.
– Syed
Commented Sep 12, 2023 at 3:47
• Thanks mate! With the new function, I already obtain the correct results :-) Commented Sep 12, 2023 at 4:09
• Please use {a, 0, 0, 0, 0} as a test case.
– Syed
Commented Sep 12, 2023 at 4:18
• It's not as pretty anymore, but it works :-) Commented Sep 12, 2023 at 5:16