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

16

3

The task is to compute

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. – Szabolcs – 2012-02-04T21:34:34.320

Thank you all guys, it was fascinating! – faleichik – 2012-02-05T07:36:47.170

## Answers

15

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 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. – Mr.Wizard – 2014-04-25T04:11:08.030

@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). – Mr.Wizard – 2012-02-04T23:12:36.347

the first method is very impressive – acl – 2012-02-05T00:01:55.003

15

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. 10 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}  1Nothing wrong, just a wish for perfection :-) – faleichik – 2012-02-05T07:35:22.990 5 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} *)  4 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},
MapThread[
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 – 2012-02-04T22:24:59.947

@rojo oops true! the first seems to work.. – acl – 2012-02-04T22:39:47.383

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 – 2012-02-05T07:11:20.907

@Rojo I see, I had not interpreted the question this way (ie that the order is important) – acl – 2012-02-05T10:49:34.267

4

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 – 2012-02-05T00:06:38.957

4@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.) – rcollyer – 2012-02-05T03:16:23.923

2

What about

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}]


2

Using ListConvolve:

ClearAll[partsF, lcF]
partsF = Module[{fl = Floor[Length[#]/2], cl = Ceiling[Length[#]/2]}, {#[[1 + fl ;;]],
PadRight[#[[;; fl]], cl]}] &;
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}

1

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? – J. M.'s ennui – 2012-02-05T12:27:53.013

I just recently learned that the *Q functions are not the right choice if you want to check mathematical properties (see http://mathematica.stackexchange.com/q/601/129).

– celtschk – 2012-02-05T12:38:28.530

That's for symbolic evaluation. Here, you can almost always expect Length[x] to return some integer that OddQ[] certainly won't choke on... – J. M.'s ennui – 2012-02-05T12:46:44.620

0

sym[x_] :=
Plus[x, Reverse[x]][[;; Length[x]/2]]

sym[x_] /; OddQ @ Length[x] :=
sym @ Insert[x, 0, (Length[x] + 1)/2 + 1]

list = {a, b, c, d, e, f};

sym @ list


sym @ Most @ list


sym /@ NestList[Most@#&, list, Length@list - 1] // Column
`