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?

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

14 Answers 14

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.

$\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
    Feb 4, 2012 at 23:12
  • $\begingroup$ the first method is very impressive $\endgroup$
    – acl
    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
    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.

$\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}
$\endgroup$
1
  • 1
    $\begingroup$ Nothing wrong, just a wish for perfection :-) $\endgroup$
    – faleichik
    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}
*)
$\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]]]]
$\endgroup$
2
  • $\begingroup$ baroque! +1 though $\endgroup$
    – acl
    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
    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!).

$\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
    Feb 4, 2012 at 22:24
  • $\begingroup$ @rojo oops true! the first seems to work.. $\endgroup$
    – acl
    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
    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
    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}]
$\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}
*)
$\endgroup$
3
  • $\begingroup$ Better to write extra = OddQ[Length[x]], no? $\endgroup$ 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
    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$ 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}

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

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

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

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

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