21
$\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?

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

14 Answers 14

Reset to default
18
$\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.

Improve this answer
$\endgroup$
3
  • $\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
    Commented Feb 4, 2012 at 23:12
  • $\begingroup$ the first method is very impressive $\endgroup$
    – acl
    Commented Feb 5, 2012 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
    Commented Apr 25, 2014 at 4:11
20
$\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.

Improve this answer
$\endgroup$
0
13
$\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}
Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ Nothing wrong, just a wish for perfection :-) $\endgroup$
    – faleichik
    Commented Feb 5, 2012 at 7:35
9
$\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}
*)
Improve this answer
$\endgroup$
9
$\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]]]]
Improve this answer
$\endgroup$
2
  • $\begingroup$ baroque! +1 though $\endgroup$
    – acl
    Commented Feb 5, 2012 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
    Commented Feb 5, 2012 at 3:16
8
$\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!).

Improve this answer
$\endgroup$
4
  • $\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
    Commented Feb 4, 2012 at 22:24
  • $\begingroup$ @rojo oops true! the first seems to work.. $\endgroup$
    – acl
    Commented Feb 4, 2012 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
    Commented Feb 5, 2012 at 7:11
  • $\begingroup$ @Rojo I see, I had not interpreted the question this way (ie that the order is important) $\endgroup$
    – acl
    Commented Feb 5, 2012 at 10:49
6
$\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}]
Improve this answer
$\endgroup$
6
$\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}
*)
Improve this answer
$\endgroup$
3
  • $\begingroup$ Better to write extra = OddQ[Length[x]], no? $\endgroup$
    – J. M.'s missing motivation ♦
    Commented Feb 5, 2012 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
    Commented Feb 5, 2012 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.'s missing motivation ♦
    Commented Feb 5, 2012 at 12:46
5
$\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}

Improve this answer
$\endgroup$
4
$\begingroup$

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

Improve this answer
$\endgroup$
3
$\begingroup$ 
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}}

Improve this answer
$\endgroup$
3
$\begingroup$ 
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}
Improve this answer
$\endgroup$
2
$\begingroup$

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}

Improve this answer
$\endgroup$
1
$\begingroup$

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

enter image description here

Improve this answer
$\endgroup$
4
  • 1
    $\begingroup$ 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}. $\endgroup$
    – Syed
    Commented Sep 12, 2023 at 3:47
  • 1
    $\begingroup$ Thanks mate! With the new function, I already obtain the correct results :-) $\endgroup$
    – E. Chan-López
    Commented Sep 12, 2023 at 4:09
  • 1
    $\begingroup$ Please use {a, 0, 0, 0, 0} as a test case. $\endgroup$
    – Syed
    Commented Sep 12, 2023 at 4:18
  • $\begingroup$ It's not as pretty anymore, but it works :-) $\endgroup$
    – E. Chan-López
    Commented Sep 12, 2023 at 5:16

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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