15
$\begingroup$

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?

$\endgroup$
  • $\begingroup$ See my update for a Length-less solution. $\endgroup$ – Szabolcs Feb 4 '12 at 21:34
  • $\begingroup$ Thank you all guys, it was fascinating! $\endgroup$ – faleichik Feb 5 '12 at 7:36

10 Answers 10

14
$\begingroup$

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.

$\endgroup$
  • $\begingroup$ @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). $\endgroup$ – Mr.Wizard Feb 4 '12 at 23:12
  • $\begingroup$ the first method is very impressive $\endgroup$ – acl Feb 5 '12 at 0:01
  • $\begingroup$ @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. $\endgroup$ – Mr.Wizard Apr 25 '14 at 4:11
14
$\begingroup$

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.

$\endgroup$
10
$\begingroup$

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}
$\endgroup$
  • $\begingroup$ Nothing wrong, just a wish for perfection :-) $\endgroup$ – faleichik Feb 5 '12 at 7:35
5
$\begingroup$

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}
*)
$\endgroup$
4
$\begingroup$

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]]]]
$\endgroup$
  • $\begingroup$ baroque! +1 though $\endgroup$ – acl Feb 5 '12 at 0:06
  • 4
    $\begingroup$ @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.) $\endgroup$ – rcollyer Feb 5 '12 at 3:16
3
$\begingroup$

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

$\endgroup$
  • $\begingroup$ ...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 $\endgroup$ – Rojo Feb 4 '12 at 22:24
  • $\begingroup$ @rojo oops true! the first seems to work.. $\endgroup$ – acl Feb 4 '12 at 22:39
  • $\begingroup$ 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} $\endgroup$ – Rojo Feb 5 '12 at 7:11
  • $\begingroup$ @Rojo I see, I had not interpreted the question this way (ie that the order is important) $\endgroup$ – acl Feb 5 '12 at 10:49
2
$\begingroup$

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}]
$\endgroup$
2
$\begingroup$

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}

$\endgroup$
1
$\begingroup$

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}
*)
$\endgroup$
  • $\begingroup$ Better to write extra = OddQ[Length[x]], no? $\endgroup$ – J. M. will be back soon Feb 5 '12 at 12:27
  • $\begingroup$ 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). $\endgroup$ – celtschk Feb 5 '12 at 12:38
  • $\begingroup$ That's for symbolic evaluation. Here, you can almost always expect Length[x] to return some integer that OddQ[] certainly won't choke on... $\endgroup$ – J. M. will be back soon Feb 5 '12 at 12:46
0
$\begingroup$
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

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.