Constructing a function with Flat and OneIdentity attribute with the property that otimes[a]:>a

Question

I want to have a function (called otimes) with the following two properties:

1. it has the attribute OneIdentity and Flat
2. if evaluated with a single argument it returns that argument

The built-in function Times has these properties; e.g., evaluating Times[a] yields a.

I am struggling with implementing my own function having the same behavior. What I tried is the obvious implementation

SetAttributes[otimes,{OneIdentity,Flat}]
otimes[a_]:=a

However this does not work and leads to an infinite recursion when I evaluate

otimes[a,b]

I do not know how to implement the desired behavior consistently. Maybe somebody can help?

Answer 1

I see now. The problem arises with Flat then. Just set the attributes after setting the definitions. Or at least the Flat attribute

ClearAll[otimes];
SetAttributes[otimes, OneIdentity]
otimes[a_] := a
SetAttributes[otimes, Flat]

Check out this answer for more details on why this works.

Basically, MMA remembers if the symbol was Flat or not at the time each DownValue is defined. The infinite recursion is more related to this:

SetAttributes[f, Flat];
Replace[Hold@f[2], Hold@f[i_] :> Hold[i]]

So, when you did otimes[2] and it checked the otimes[a_]:=a downvalue, it matched a with otimes[2], so you got your infinite recursion

Answer 2

Update

I came up with a better answer in my response to (174384), and since that question was closed as a duplicate of this question, I thought it might be nice to include it here. Basically, one can avoid the iteration error caused by the Flat pattern matcher by inserting a Verbatim into the definition. So use:

SetAttributes[otimes, {OneIdentity, Flat}];
Verbatim[otimes][a_] := a

Examples:

otimes[a, b]
otimes[a]

otimes[a, b]

a

Original answer

Another possibility is to use something like:

SetAttributes[otimes, {OneIdentity,Flat}]
a_otimes /; Length[Unevaluated[a]]==1 := First @ Unevaluated @ a

Then,

otimes[a]

a

No recursion issues!

Answer 3

I'm guessing a bit at what you're doing here, so I do hope some of this is relevant. Trying to define your own version of multiplication is essentially trying to implement a group structure in mathematics. Here's how I would implement the dihedral group using NonCommutativeMultiply. At the end, you'll notice that I do need to deal with expressions like NonCommutativeMultiply[a].

The dihedral group of order $2n$ has presentation $$\langle a,b : a^2=b^2=(ab)^n=1 \rangle.$$

Given a finite string of $a$s and $b$s representing an element of the dihedral group, there is a standard procedure to place that string into one of the following four canonical forms: $(ab)^m$, $(ab)^m b$, $(ba)^m$, or ($ba)^m a$, where $m$ is an integer such that $0\leq m<n$. To do so, simply remove each consecutive pair of identical symbols and then reduce the exponent of $ab$ or $ba$ modulo $n$. This solves the so called Word Problem for the dihedral group.

To implement this in Mathematica, first associate UpValues with a and b representing the order of those elements.

a /: a ** a = 1;
b /: b ** b = 1;
a /: a ** 1 = a;
b /: b ** 1 = b;
a /: 1 ** a = a;
b /: 1 ** b = b;

Now, let's generate a long product of $a$s and $b$s.

SeedRandom[1];
w = NonCommutativeMultiply @@ RandomChoice[{a, b}, 100]

a ** b ** a ** b ** a ** b ** a ** b ** a ** b ** a ** b ** a ** b ** a ** b

The result is much shorter than 100 because cancellation has already occurred. Now let's put it in it's final form. Assuming you're working in $D_6$, you can do the following:

n = 3;
finalForm[w : NonCommutativeMultiply[a, ___, b]] :=
  (a ** b)^Mod[Length[w]/2, n];
finalForm[w : NonCommutativeMultiply[a, ___, a]] :=
  (a ** b)^Mod[(Length[w] - 1)/2, n] ** a;
finalForm[w : NonCommutativeMultiply[b, ___, a]] :=
  (b ** a)^Mod[Length[w]/2, n];
finalForm[w : NonCommutativeMultiply[b, ___, b]] :=
  (b ** a)^Mod[(Length[w] - 1)/2, n] ** b;
finalForm[w]

(a ** b)^2

Well, that's cool but what about this example:

finalForm[a ** a ** a]

finalForm[a]

We've run into exactly the problem you've described. To fix it, simply associate DownValues with finalForm.

finalForm[a] = a;
finalForm[b] = b;
finalForm[a ** a ** a]

a

More generally, you might define a function simplify with the property that

simplify[NonCommutativeMultiply[a_]] := a

Answer 4

If I understand the question it's an issue I sent to MathGroup about ten years ago. Alan Hayes solved it for me, and it's all discused at http://www.verbeia.com/mathematica/tips/HTMLLinks/Tricks_A-K_27.html Go there and read the part, "A problem with the Flat attribute and how to solve it".