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?

Improve this question
$\endgroup$
6
  • 3
    $\begingroup$ Right, I need a coffee :) $\endgroup$ Commented Jan 23, 2015 at 21:37
  • 1
    $\begingroup$ Never mind project Euler, how about project Wizard? $\endgroup$ Commented Jan 23, 2015 at 22:41
  • $\begingroup$ @bobthechemist I'm not sure what that means really :-) $\endgroup$ Commented Jan 23, 2015 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$ Commented Jan 23, 2015 at 22:55
  • $\begingroup$ @bobthechemist Sorry for making you explain, but at least I understand now. Thanks. :-) $\endgroup$ Commented Jan 23, 2015 at 22:56

6 Answers 6

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

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

Improve this answer
$\endgroup$
4
  • $\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$ Commented Jan 23, 2015 at 21:36
  • 1
    $\begingroup$ @Mr.Wizard Ok, updated:) $\endgroup$ Commented Jan 23, 2015 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$ Commented Jan 23, 2015 at 23:24
  • $\begingroup$ @Mr.Wizard good point. $\endgroup$ Commented Jan 23, 2015 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}]
Improve this answer
$\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}, {}, {-∞}, {∞}, {-∞, ∞}}
Improve this answer
$\endgroup$
3
  • $\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$ Commented May 25, 2015 at 7:33
  • $\begingroup$ I am using this toolbar extension: (1043). Also useful: (1137) $\endgroup$ Commented May 25, 2015 at 11:25
  • $\begingroup$ @Mr.Wizard thank you that is helpful and I look forward to effectively using toolbar extension :) $\endgroup$ Commented May 25, 2015 at 11:36

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.