Mathematica: Overriding `Listable` property of `Plus`

I would like to define a symbol pt to hold a point (and eventually cache some data related to that point):

pt::"usage" = "pt[{x,y}] represents a point at {x,y}";

I would like to be able to use such pt objects as points in as many ways as possible, an particularly, I would like to be able to write

{a0,a1}+pt[{b0,b1}]

and have it return pt[{a0+b0,a1+b1}] rather than {a0+pt[{b0,b1}],a1+pt[{b0,b1}]}. My original idea was to use:

pt /: Plus[pt[p0_], p1 : {_, _}] = pt[p0 + p1];

But this doesn't work开发者_如何转开发 (because Plus is Listable?). Is there a way to do this without unprotecting Plus?

Update: As Leonid points out, this is not possible without globally or locally hacking Plus, since the Listable attribute is considered before any *values. This is actually described very precisely in the evaluation tutorial.

Mathematica's evaluator seems not flexible enough to do this easily. UpValues for pt indeed are applied before DownValues for Plus, but threading over lists due to Listability happens even before that. In this particular case, the following might work for you:

eval = Function[code,Block[{Plus = Plus, attr = DeleteCases[Attributes[Plus], Listable]},
SetAttributes[Plus, attr]; code], HoldAll]

To use it, wrap it around a piece of code where you want your rule for pt to apply, e.g.:

eval[{a0, a1} + pt[{b0, b1}]]

You can use $Pre as $Pre = eval to avoid typing eval every time, although generally I would not recommend this. Blocking Plus is a softer way of disabling some or all of its Attributes temporarily. The advantage w.r.t. clearing and setting attributes without Block is that you can not end up in a global state with Listable attribute permanently disabled, even if exception is thrown or the computation is Abort-ed.

Since Listable attribute directly affects evaluation rather than pattern-matching (the latter may of course be affected indirectly if some pattern has to match the result of Plus threaded over a list), this should be ok in most cases. In theory, it may still lead to some unwanted effects in some cases, particularly where pattern-matching is involved. But in practice, it might be good enough. A cleaner but more complex solution would be to create a custom evaluator tailored to your needs.

The following is a bit wasteful, but it works: The idea is to simply watch for cases where the Listable attribute of Plus has put the same pt into all elements of a list (i.e. a raw point) -- and then pull it back out. First, define a function for adding pt objects:

SetAttributes[ptPlus, {Orderless}]
ptPlus[pt[pa : {_, _}], pt[pb : {_, _}], r___] := 
  ptPlus[pt[pa + pb], r];
ptPlus[p_pt] := p; 

Then we make sure that any Plus which involves a pt is mapped to ptPlus (an associate the rule with pt).

Plus[h___, a_pt, t___] ^:= ptPlus[h, a, t];

The above rules means that: {x0,y0}+pt[{x1,y1}] will be expanded from {x0+pt[{x1,y1}],y0+pt[{x1,y1}]} to {ptPlus[x0,pt[{x1,y1}]],ptPlus[y0,pt[{x1,y1}]]}. Now we just make a rule to transform this to pt[{x0,y0}]+pt[{x1,y1}] (note the deferred condition which checks that the pts are equal):

{ptPlus[x__], ptPlus[y__]} ^:= Module[{
    ptCases = Cases[{{x}, {y}}, _pt, {2}]},
  ptCases[[1]] + pt[Plus @@@ DeleteCases[{{x}, {y}}, _pt, {2}]] 
    /; Equal @@ ptCases]

A more opaque, but slightly more careful version which is easier to generalize to higher dimensions:

ptPlus /: p : {_ptPlus, _ptPlus} := Module[{ptCases, rest,
   lp = ReleaseHold@Apply[List, Hold[p], {2}]},
  ptCases = Cases[lp, _pt, {2}];
  rest = Plus @@@ DeleteCases[lp, _pt, {2}];
  ptCases[[1]] + pt[rest] /; And[Equal @@ ptCases, VectorQ@rest]]

This whole approach will of course lead to horribly subtle bugs when {a+pt[{0,0}],a+pt[{0,b}]} /. {a -> pt[{0,0}]} evaluates to pt[{0,0}] when c==0 and {pt[{0,0}],pt[{0,c}]} otherwise...

HTH -- said the guy to himself...