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

Question

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 Feb 04 '12 at 21:34 — Szabolcs, Feb 04 '12 at 21:34
Thank you all guys, it was fascinating! – faleichik Feb 05 '12 at 07:36 — faleichik, Feb 05 '12 at 07:36

Szabolcs · Answer 1 · 2012-02-04T21:36:48.563

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.

Mr.Wizard · Accepted Answer · 2014-04-25T04:16:50.717

18

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.

edited Apr 25 '14 at 04:16

answered Feb 04 '12 at 21:54

Mr.Wizard

271,378
34
587
1,371

@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 Feb 04 '12 at 23:12
the first method is very impressive – acl Feb 05 '12 at 00: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. – Mr.Wizard Apr 25 '14 at 04:11

David · Answer 3 · 2012-02-04T22:44:09.920

13

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}

edited Feb 04 '12 at 22:44

answered Feb 04 '12 at 21:31

David

14,911
6
51
81

1

Nothing wrong, just a wish for perfection :-) – faleichik Feb 05 '12 at 07:35

J. M.'s missing motivation · Answer 4 · 2012-02-05T04:03:39.990

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]], 
    Internal`Deflatten[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]]]]

@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, Feb 05 '12 at 03:16

score 9 · Answer 5 · answered Feb 05 '12 at 01:38

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}
*)

acl · Answer 6 · 2012-02-05T12:16:48.193

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, Feb 04 '12 at 22:24
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, Feb 05 '12 at 07:11
@Rojo I see, I had not interpreted the question this way (ie that the order is important) — acl, Feb 05 '12 at 10:49

Rojo · Answer 7 · 2012-02-05T04:57:06.767

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

score 6 · Answer 8 · answered Feb 05 '12 at 11:35

6

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}
*)

answered Feb 05 '12 at 11:35

celtschk

19,133
1
51
106

Better to write extra = OddQ[Length[x]], no? – J. M.'s missing motivation Feb 05 '12 at 12:27
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 Feb 05 '12 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... – J. M.'s missing motivation Feb 05 '12 at 12:46

kglr · Answer 9 · 2017-07-23T16:06:42.337

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}

Syed · Answer 10 · 2023-09-11T14:28:47.860

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

Addendum

After studying @kglr's recent answer:

h = Total@
    MapThread[#1[#2] &, {
      {Identity, Reverse}
      , PadLeft@
       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}}

score 3 · Answer 11 · answered Sep 11 '23 at 10:19

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

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

score 3 · Answer 12 · answered Sep 11 '23 at 12:16

3

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}

answered Sep 11 '23 at 12:16

kglr

394,356
18
477
896

score 2 · Answer 13 · answered Sep 11 '23 at 16:32

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}

E. Chan-López · Answer 14 · 2023-09-12T05:32:38.927

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, Sep 12 '23 at 03:47
Thanks mate! With the new function, I already obtain the correct results :-) — E. Chan-López, Sep 12 '23 at 04:09

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

14 Answers14

Linked