How can Mathematica automatically replace NonCommutativeMultiply[x] with x for a single argument x? [duplicate]

Question

By default, an expression like NoncommutativeMultiply[x] does not simplify to x, unlike Times[x] or Plus[x]. My attempts to implement an automatic replacement e.g.:

Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply /: NonCommutativeMultiply[x_] := x;
Protect[NonCommutativeMultiply];

tend to go into infinite loops e.g. when typing x**y. I understand why this is the case for a function like NonCommutativeMultiply with attribute Flat. However, I have been unable to find a way to overcome this behaviour and obtain replacements like for Plus and Times.

Similarly, I also cannot find a way to automatically replace NonCommutativeMultiply[] with 1 without causing infinite loops (again, Plus and Times work fine giving 0 and 1, respectively).

Any help would be greatly appreciated.

Answer 1

@QuantumDot provided a hack that can be used to achieve your goal, but I don't think it's very robust. For instance, the cloud uses Language`ExtendedDefinition to transfer definitions when needed, and the hack doesn't survive this transfer. Here's the hack:

Unprotect[NonCommutativeMultiply];

ClearAttributes[NonCommutativeMultiply, Flat];
NonCommutativeMultiply /: NonCommutativeMultiply[x_] := x;
SetAttributes[NonCommutativeMultiply, Flat];

Protect[NonCommutativeMultiply];

It works:

x**y
NonCommutativeMultiply[x]

x ** y

x

Now, let's see what happens when the definition is transferred using Language`ExtendedDefinition:

defn = Language`ExtendedDefinition[NonCommutativeMultiply]

Language`DefinitionList[NonCommutativeMultiply->{OwnValues->{},SubValues->{},UpValues->{},DownValues->{HoldPattern[NonCommutativeMultiply[x_]]:>x},NValues->{},FormatValues->{},DefaultValues->{},Messages->{},Attributes->{Flat,OneIdentity,Protected}}]

Reset the definition:

Language`ExtendedDefinition[NonCommutativeMultiply] = defn;

The hack no longer works:

x**y
NonCommutativeMultiply[x]

$IterationLimit::itlim: Iteration limit of 4096 exceeded.

Hold[x ** y]

x

An alternative is to insert Verbatim into your definition so that the Flat pattern matching (which causes the iteration error) is avoided:

Unprotect[NonCommutativeMultiply];
Clear[NonCommutativeMultiply]

Verbatim[NonCommutativeMultiply][a_]:=a

Protect[NonCommutativeMultiply];

Then:

x**y
NonCommutativeMultiply[x]

x ** y

x

work as desired. Also, the behavior is unaffected by transferring definitions using Language`ExtendedDefinition.

Answer 2

Just get rid of the Flat attribute before adding the definition. Then put the attribute back.

Unprotect[NonCommutativeMultiply];
ClearAttributes[NonCommutativeMultiply, Flat];
NonCommutativeMultiply /: NonCommutativeMultiply[x_] := x;
SetAttributes[NonCommutativeMultiply, Flat];
Protect[NonCommutativeMultiply];