11
$\begingroup$

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?

$\endgroup$
  • 3
    $\begingroup$ Right, I need a coffee :) $\endgroup$ – Kuba Jan 23 '15 at 21:37
  • 1
    $\begingroup$ Never mind project Euler, how about project Wizard? $\endgroup$ – bobthechemist Jan 23 '15 at 22:41
  • $\begingroup$ @bobthechemist I'm not sure what that means really :-) $\endgroup$ – Mr.Wizard Jan 23 '15 at 22:45
  • $\begingroup$ Paraphrasing the project euler website, I would propose that "The motivation for <answering your questions>, is to provide a platform for the inquiring mind to delve into unfamiliar areas and learn new <Mathematica> concepts in a fun and recreational context." Granted, I found it wittier before I tried to explain it. $\endgroup$ – bobthechemist Jan 23 '15 at 22:55
  • $\begingroup$ @bobthechemist Sorry for making you explain, but at least I understand now. Thanks. :-) $\endgroup$ – Mr.Wizard Jan 23 '15 at 22:56
5
$\begingroup$

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}, {}, {-∞}, {∞}, {-∞, ∞}} *)
$\endgroup$
  • $\begingroup$ Thank you. I'm not sure I can consider this more clean than the original but like it nevertheless. $\endgroup$ – Mr.Wizard Jan 23 '15 at 23:30
  • $\begingroup$ I am accepting this because it is the only alternative posted that I would use in practice. $\endgroup$ – Mr.Wizard Jan 29 '15 at 2:18
6
$\begingroup$

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

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

$\endgroup$
  • 2
    $\begingroup$ I was just looking at something similar, but using a : Longest[(-Infinity | PatternSequence[])] as the head/tail patterns $\endgroup$ – Simon Woods Jan 23 '15 at 22:16
  • $\begingroup$ @Simon I variation I hadn't considered. Post it if you like. $\endgroup$ – Mr.Wizard Jan 23 '15 at 22:17
3
$\begingroup$
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.

$\endgroup$
  • $\begingroup$ No, this merely adds the given elements at the beginning and end. Note that the operation must also remove the elements in the case they appear. It is not merely a matter of removing duplicates. Thanks for taking interest however. :-) $\endgroup$ – Mr.Wizard Jan 23 '15 at 21:36
  • 1
    $\begingroup$ @Mr.Wizard Ok, updated:) $\endgroup$ – Kuba Jan 23 '15 at 23:18
  • 1
    $\begingroup$ I quite like this and I'm glad you posted it. (+1) However note that even in the original application this might not work since Interval can have duplicates, e.g. Interval[{1, 3}, {7, 11}, {22, 22}]. $\endgroup$ – Mr.Wizard Jan 23 '15 at 23:24
  • $\begingroup$ @Mr.Wizard good point. $\endgroup$ – Kuba Jan 23 '15 at 23:26
1
$\begingroup$

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

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}, {}, {-∞}, {∞}, {-∞, ∞}}
$\endgroup$
  • $\begingroup$ @Mr.Wizard I accept my answer is rather uninspiring. May I ask how isthe infinity symbol appearance in most answers and similarly Greek characters? I am obviously missing something...just issue of readability and my ignorance. $\endgroup$ – ubpdqn May 25 '15 at 7:33
  • $\begingroup$ I am using this toolbar extension: (1043). Also useful: (1137) $\endgroup$ – Mr.Wizard May 25 '15 at 11:25
  • $\begingroup$ @Mr.Wizard thank you that is helpful and I look forward to effectively using toolbar extension :) $\endgroup$ – ubpdqn May 25 '15 at 11:36

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.