For a given expression: if it appears, remove it, but if it is absent, add it

Question

While reformatting Szabolcs's code from (42660) I noticed this interesting operation:

expr /.
  {{-∞, mid___, ∞} :> {    mid   },
   {-∞, mid___   } :> {    mid, ∞},
   {    mid___, ∞} :> {-∞, mid   },
   {    mid___   } :> {-∞, mid, ∞}}

Essentially if a given expression (-∞) at the beginning of a List is present, remove it, but if it is absent, add it. Likewise for ∞ at the end of the list. An empty list {} should become {-∞, ∞}, while {-∞, ∞} itself should become {}. Examples:

Replace[
  {{1, 2, 3}, {-∞, 1, 2}, {1, 2, ∞}, {-∞, 1, 2, ∞}, {-∞, ∞}, {∞}, {-∞}, {}},

  {{-∞, mid___, ∞} :> {    mid   },
   {-∞, mid___   } :> {    mid, ∞},
   {    mid___, ∞} :> {-∞, mid   },
   {    mid___   } :> {-∞, mid, ∞}},

  {1}
]

{{-∞, 1, 2, 3, ∞}, {1, 2, ∞}, {-∞, 1, 2}, {1, 2}, {}, {-∞}, {∞}, {-∞, ∞}}

How might this operation be done with a single replacement rule, or cleanly with a different method?

Answer 1

Similar approach to Mr Wizard's but using a silly trick with pure functions rather than the auxiliary function f:

Replace[{{1, 2, 3}, {-∞, 1, 2}, {1, 2, ∞}, {-∞, 1, 2, ∞}, {-∞, ∞}, {∞}, {-∞}, {}},
  {a : (-∞ | PatternSequence[]), Shortest[x___], b : (∞ | PatternSequence[])} :> 
   {#2 &[a, Unevaluated[], -∞], x, #2 &[b, Unevaluated[], ∞]},
 {1}]

Answer 2

I set out to condense the rules shown in the question by use of "vanishing patterns" but I found it rather difficult. The best I could come up with is this:

f[x_ | __] := x

Replace[
 {{1, 2, 3}, {-∞, 1, 2}, {1, 2, ∞}, {-∞, 1, 2, ∞}, {-∞, ∞}, {∞}, {-∞}, {}},
 {a : -∞ ..., Shortest[s___], b : ∞ ...} :> {f[a, -∞], s, f[b, ∞]},
 {1}
]

{{-∞, 1, 2, 3, ∞}, {1, 2, ∞}, {-∞, 1, 2}, {1, 2}, {}, {-∞}, {∞}, {-∞, ∞}}

I find this less than clean due to the need for auxiliary function f. Further this requires that the input have at most one matching expression at the head or tail, otherwise e.g. {1, 2, ∞, ∞} will result in both ∞ being removed. This can be corrected by replacing e.g. ∞ ... with Repeated[∞, {0, 1}] at the expense of yet longer code. (See: Function with zero or one arguments.)

Answer 3

Let me relax rules a bit just to write some compact code without external functions. I can add -∞ and ∞ and delete double infinities

Replace[{{1, 2, 3}, {-∞, 1, 2}, {1, 2, ∞}, {-∞, 1, 2, ∞}, {-∞, ∞}, {∞}, {-∞}, {}}, 
  {mid___} :> ({-∞, mid, ∞} /. {x_, x_, y___} :> {y} /. {y___, x_, x_} :> {y}), {1}]
(* {{-∞, 1, 2, 3, ∞}, {1, 2, ∞}, {-∞, 1, 2}, {1, 2}, {}, {-∞}, {∞}, {-∞, ∞}} *)

Answer 4

expr = {{1, 2, 3}, {-∞, 1, 2}, {1, 2, ∞}, {-∞, 1, 2, ∞}, {-∞, ∞}, {∞}, {-∞}, {}};

Not general but useful:

Flatten[Replace[Split[{-∞, ##, ∞}], {x_, x_} :> Sequence[], {1}]] & @@@ expr

Not working if in the list are repeated elements already.

Also Flatten should be restricted if we are dealing with more complex structures.

Answer 5

The most clean formulation, I believe, is “add an element and delete a pair if one occures”. Thus, I would just use something similar to

idempotentAppend[{most___, x_}, x_] := {most};
idempotentAppend[l_List, x_] := Append[l, x];
idempotentPrepend[{x_, most___}, x_] := {most};
idempotentPrepend[l_List, x_] := Prepend[l, x]

with “idempotent” in the $P^2=\mathrm{id}$ sense.

As for “single rule” solutions, this is the best one I came up with:

Replace[ {-∞, ##, ∞} & @@@
         {{1, 2, 3}, {-∞, 1, 2}, {1, 2, ∞}, {-∞, 1, 2, ∞}, {-∞, ∞}, {∞}, {-∞}, {}}
, Thread[{ PatternSequence[-∞, -∞] | PatternSequence[-∞, -∞] | PatternSequence[]
         , most___
         , PatternSequence[∞, ∞] | PatternSequence[] | PatternSequence[∞, ∞]}
  , Alternatives] :> {most}
, {1}]

Answer 6

This is merely to participate. Just bookending and removing doubled ups...

f[x_] := Fold[#1 /. #2 &, 
  Join[{-Infinity}, 
   x, {Infinity}], {{-Infinity, -Infinity, m___} :> {m}, {m___, 
     Infinity, Infinity} :> {m}}]

so,

w = {{1, 2, 3}, {-∞, 1, 2}, {1, 2, ∞}, {-∞, 1, 2, ∞}, {-∞, ∞}, {∞}, {-∞}, {}}
f /@ w

yields:

{{-∞, 1, 2, 3, ∞}, {1, 2, ∞}, {-∞, 1, 2}, {1, 2}, {}, {-∞}, {∞}, {-∞, ∞}}