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?

faleichik

Posted 2012-02-04T21:10:46.347

Reputation: 12 161

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.

Mr.Wizard

Posted 2012-02-04T21:10:46.347

Reputation: 259 163

@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.

Szabolcs

Posted 2012-02-04T21:10:46.347

Reputation: 213 047

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}

David

Posted 2012-02-04T21:10:46.347

Reputation: 14 421

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

Brett Champion

Posted 2012-02-04T21:10:46.347

Reputation: 19 284

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!).

acl

Posted 2012-02-04T21:10:46.347

Reputation: 19 146

...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]], 
    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]]]]

J. M.'s ennui

Posted 2012-02-04T21:10:46.347

Reputation: 115 520

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

Rojo

Posted 2012-02-04T21:10:46.347

Reputation: 40 993

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}

kglr

Posted 2012-02-04T21:10:46.347

Reputation: 302 076

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

celtschk

Posted 2012-02-04T21:10:46.347

Reputation: 18 543

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

enter image description here

sym @ Most @ list

enter image description here

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

enter image description here

eldo

Posted 2012-02-04T21:10:46.347

Reputation: 34 072