Inheritance in Mathematica using pattern matching on UpValues

Question

Edit:

---

I think in my original post, I missed emphasizing the main point. This is mainly a pattern matching question. If you're interested in the 'why' of this question, please read the original post below. The short question:

Suppose I have a newly defined, unevaluated Head, called NewHead. I define a function associated with NewHead as (I add in the x & y to emphasize that the argument list can be arbitrary so long as it contains n_NewHead)

In[1]= NewHead /: func[x_, n_NewHead, y_] := n

This has

In[2]= UpValues[NewHead]
Out[2]= {HoldPattern[func[x_, n_NewHead, y_]] :> n}

I would like to use pattern matching so I can transform this UpValue list like

In[3]= UpValues[NewHead] /. (* Some pattern matching here resulting in: *)
Out[3]= {HoldPattern[func[x_, d_DerivedHead, y_]] :> func[x, d[[1]], y]}

The point is to make a 'class' DerivedHead that inherits all the functions of the 'class' NewHead. A NewHead object would be stored in Part 1 of a DerivedHead object. For an example, read the original post below.

The thing I can't figure out is how to pattern match on n_NewHead (in Out[2]) . The name of the pattern _NewHead can, in principle, be anything, and the argument list to func is similarly arbitrary.

Any advice is appreciated! - Seth

Original post below:

---

I have read some posts here on object oriented programming as well as many pattern matching posts, but nothing (I have found) seems to address this case, so I thought I'd ask a question.

I am trying to implement some features of object oriented programming in Mathematica, most notably inheritance. Imagine I have a polygon class with Head Poly created like

ToPoly[l : {{_, _} ..}] :=
Module[{},
  If[Length@l < 3, Print["Poly object must have at least 3 points"]; Abort[]];
  Poly @@ l
]

It has functions associated with it like (note TagSetDelayed)

distance[{x1_, y1_}, {x2_, y2_}] := Sqrt[(x2 - x1)^2 + (y2 - y1)^2]
Poly /: Perimeter[p_Poly] :=
Module[{pts, ptsShift},
  pts = List @@ p;
  ptsShift = Join[{Last@pts}, Most@pts];
  Total@MapThread[distance, {pts, ptsShift}]
]
Poly /: Vertices[p_Poly] := Length@p

Now, I want to create a quadrilateral sub-class with Head Quad. Suppose a Quad can have a color associated with it. So we have

ToQuad[l : {{_, _} ..}, color_String] :=
Module[{},
  If[Length@l =!= 4, Print["Quad object must have exactly 4 points"]; Abort[]];
  Quad[ToPoly[l], color]
]

Quad /: QuadColor[q_Quad]:=q[[2]]

At this point, I would like to be able to inherit Perimeter and Vertices from the Poly class. Since they have been defined with TagSetDelayed, I can see those definitions using

UpValues[Poly]

(* {HoldPattern[Perimeter[p_Poly]] :> 
    Module[{pts, ptsShift}, pts = List @@ p; 
    ptsShift = Join[{Last[pts]}, Most[pts]]; 
    Total[MapThread[distance, {pts, ptsShift}]]], 
    HoldPattern[Vertices[p_Poly]] :> Length[p]} *)

Then, I want to define a function that assigns those UpValues to Quad like:

SuperClass[x_]:=x[[1]]
DefineDerivedClass[class_,superClass_]:=
Module[{},

  (* Assign UpValues associated with superClass to class *)

]

So, after this is called like

DefineDerivedClass[Quad,Poly]

I would have

UpValues[Quad]

(* {HoldPattern[Perimeter[q_Quad]] :>  Perimeter[SuperClass[q]],
  HoldPattern[Vertices[q_Quad]] :> Vertices[SuperClass[q]], 
  HoldPattern[QuadColor[q_Quad]] :> q[[2]]} *)

The problem is that I cannot figure out the pattern matching to turn the UpValues of Poly into the correct form for Quad for a generic pattern sequence. I can use Part to get inside the HoldPattern, but I cannot match on the p_Poly part. So far, the only way I can figure out to do this is by converting the UpValue expressions into strings, but that is very inelegant. Any ideas?

Thanks,

Seth

Answer 1

I believe the crux of your problem is, as you say, how to match n_NewHead. Let's look at the FullForm:

FullForm[n_NewHead]

Pattern[n, Blank[NewHead]]

As you can see this is composed of Blank and Pattern, both of which are special heads with regard to pattern matching. You therefore need to wrap them in Verbatim to make a literal match:

MatchQ[
 n_NewHead,
 Verbatim[Pattern][_, Verbatim[Blank][NewHead]]
]

True

You can use the same methods to extract the parts:

n_NewHead /. Verbatim[Pattern][name_, Verbatim[Blank][head_]] :> {name, head}

{n, NewHead}

As a more complete example perhaps you want something like this:

SetAttributes[replace, HoldAll]

replace[old_, new_, body_] :=
 Replace[
  UpValues[old],
  (lhs_ :> rhs_) :> (Replace[lhs, 
      Verbatim[Pattern][_, Verbatim[Blank][old]] :> new, {2}] :> body),
  {1}
 ]

Now:

NewHead /: func[x_, n_NewHead, y_] := n

replace[NewHead, d_DerivedHead, func[x, d[[1]], y]]

{HoldPattern[func[x_, d_DerivedHead, y_]] :> func[x, d[[1]], y]}

Also see: Pattern matching a pattern with patterns