How to tell Mathematica that the argument of a function is real?

Question

I want to define the following function in mathematica:
$$R(\psi)=\begin{bmatrix}1&0&0\\0&\cos 2\psi & \sin 2\psi\\0&-\sin 2\psi & \cos 2\psi\end{bmatrix}\qquad,\psi\in\mathbb R$$ So $$R(\psi)^{\dagger}=\begin{bmatrix}1&0&0\\0&\cos 2\psi &-\sin 2\psi\\0&\sin 2\psi &\cos 2\psi\end{bmatrix}$$

So far I have tried some codes like:

R[ψ_; ψ ∈ Reals] := {{1, 0, 0}, {0, Cos[2 ψ], 
   Sin[2 ψ]}, {0, -Sin[2 ψ], Cos[2 ψ]}}  

Or:

R[ψ_] := {{1, 0, 0}, {0, Cos[2 ψ], 
    Sin[2 ψ]}, {0, -Sin[2 ψ], 
    Cos[2 ψ]}} /; ψ ∈ Reals  

but running the code:

ConjugateTranspose[R[ψ]] // TraditionalForm  

I get:
$$\left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & \cos \left(2 \psi ^*\right) & -\left(\sin \left(2 \psi ^*\right)\right) \\ 0 & \sin \left(2 \psi ^*\right) & \cos \left(2 \psi ^*\right) \\ \end{array} \right)$$

P.S. I know that I can use the following code:

R[ψ_] := {{1, 0, 0}, {0, Cos[2 ψ], 
   Sin[2 ψ]}, {0, -Sin[2 ψ], Cos[2 ψ]}}  

Refine[ConjugateTranspose[R[ψ]], ψ ∈ 
   Reals] // TraditionalForm  

but I want to know how to define $R(\psi)$ inherently as a real function?

Answer 1

Declaring expressions as real

As others have already written you can set global $Assumptions, but then to get desired results you would need to, each time, use Refine, Simplify, or similar function that uses Assumptions.

If you want certain expressions to be treated as "real" automatically, without simplifying, you can override behavior of built-in functions like Conjugate, Re, etc. using UpValues.

Here is a small package, based on @rcollyer's idea, that allows us to declare certain patterns as "real". After declaring pattern as real, Mathematica will automatically simplify some expressions involving sub-expressions matching said pattern. It will also automatically use appropriate global assumptions when simplifying using Refine, Simplify etc.

BeginPackage["DeclareReal`"];
Unprotect["`*"];
ClearAll["`*"];


DeclareReal::usage =
"DeclareReal[patt1, patt2, ...] declares expressions matching patterns patt1, \
patt2, ... as real. Given patterns must contain symbols to which UpValues can \
be assigned.";

UndeclareReal::usage = 
"UndeclareReal[patt1, patt2, ...] removes given patterns patt1, patt2, ... \
from patterns declared as real.";


Begin["`Private`"];
ClearAll["`*"];


symbolWithUpValue[expr_, upValueSubExpr_] :=
    FirstCase[
        expr,
        atom_ /; AtomQ@Unevaluated[atom] :>
            With[
                {sym =
                    Replace[
                        Unevaluated[atom],
                        nonSym:Except[_Symbol] :> Head@Unevaluated[nonSym]
                    ]
                },
                sym /; Head[sym] === Symbol &&
                    !FreeQ[UpValues[sym], upValueSubExpr]
        ],
        Missing["NotFound"],
        All,
        Heads -> True
    ]


extractUpValueTag[patt_] :=
    Module[{dummy, upValueTag, upSetSuccess = True},
        Internal`InheritedBlock[{Message},
            Unprotect[Message];
            Message[UpSet::write, HoldForm[tag_], HoldForm[_dummy]] := (
                upValueTag = tag;
                upSetSuccess = False;
            );
            dummy[patt] ^= dummy;
        ];
        If[upSetSuccess,
            upValueTag = symbolWithUpValue[patt, dummy];
            With[{upValueTag = upValueTag}, upValueTag /: dummy[patt] =.]
        ];
        {upValueTag, upSetSuccess}
    ]


updateAssumptions[oldRealPattern_, newRealPattern_] :=
    Module[{found = False},
        $Assumptions =
            $Assumptions /. 
                Verbatim@Element[oldRealPattern, Reals] :> (
                    found = True; 
                    Element[newRealPattern, Reals]
                );
        If[!found,
            $Assumptions = $Assumptions && Element[newRealPattern, Reals]
        ];
    ]


$realPattern = Alternatives[dummy];


DeclareReal[patt_] :=
    With[{tagSuccessPair = extractUpValueTag[patt]},
        With[{tag = First[tagSuccessPair], success = Last[tagSuccessPair]},
            Condition[
                tag /: Element[patt, Reals] = True;
                tag /: Im[patt] = 0;
                tag /: Re[expr : patt] := expr;
                tag /: Abs[expr : patt] := Sign[expr] expr;
                tag /: Arg[expr : patt] := Piecewise[{{Pi, Sign[expr] < 0}}];
                tag /: Conjugate[expr : patt] := expr;
                updateAssumptions[
                    $realPattern,
                If[MemberQ[$realPattern, Verbatim[patt]],
                        $realPattern
                (* else *),
                    AppendTo[$realPattern, patt]
                    ]
                ];
                tag
                ,
                If[!success,
                    Message[DeclareReal::write,
                        HoldForm@tag, HoldForm@DeclareReal[patt]
                    ]
                ];
                success
            ]
        ]
    ]
DeclareReal[patts : Repeated[_, {2, Infinity}]] := DeclareReal /@ {patts}


UndeclareReal[patt_] :=
    With[{tagSuccessPair = extractUpValueTag[patt]},
        With[{tag = First[tagSuccessPair], success = Last[tagSuccessPair]},
            Condition[
                Quiet[
                    tag /: Element[patt, Reals] =.;
                    tag /: Im[patt] =.;
                    tag /: Re[expr : patt] =.;
                    tag /: Abs[expr : patt] =.;
                    tag /: Arg[expr : patt] =.;
                    tag /: Conjugate[expr : patt] =.;
                    ,
                    TagUnset::norep
                ]
                updateAssumptions[
                    $realPattern,
                $realPattern = DeleteCases[$realPattern, Verbatim[patt]]
                ];
                tag
                ,
                If[!success,
                    Message[UndeclareReal::write,
                        HoldForm@tag, HoldForm@DeclareReal[patt]
                    ]
                ];
                success
            ]
        ]
    ]
UndeclareReal[patts : Repeated[_, {2, Infinity}]] := UndeclareReal /@ {patts}


End[];
Protect["`*"];
EndPackage[]

Let's declare some example patterns as real:

ClearAll[f, g, x, y, a, b]
DeclareReal[x, f[_], HoldPattern@g[_Integer, _Integer], a + b]
(* DeclareReal::write: Tag Plus in DeclareReal[a+b] is Protected. >> *)
(* {x, f, g, DeclareReal[a + b]} *)

DeclareReal function returned list of symbols, to which appropriate, UpValues where assigned. a + b expression caused an error, because its head is Plus, which is protected, and we can't assign upvalue to it.

Since x is real its real value is just x:

Re[x]
(* x *)

We declared f with one argument as real, but not f with two arguments.

Im[f[y]]
(* 0 *)
Im[f[x, y]]
(* Im[f[x, y]] *)

g is real with two integer arguments:

Conjugate[g[1, 2]]
(* g[1, 2] *)
Conjugate[g[1, y]]
(* Conjugate[g[1, y]] *)

a+b expression was not affected

Conjugate[a + b]
(* Conjugate[a + b] *)

Now let's undo above declarations

UndeclareReal[x, f[_], HoldPattern@g[_Integer, _Integer]]
(* {x, f, g} *)
Re[x]
(* Re[x] *)
Im[f[y]]
(* Im[f[y]] *)
Conjugate[g[1, 2]]
(* Conjugate[g[1, 2]] *)

---

Problem from question

Now let's go back to function from question.

ClearAll[r]
r[x_] := {{1, 0, 0}, {0, Cos[2 x], Sin[2 x]}, {0, -Sin[2 x], Cos[2 x]}}

Check how it behaves for real and complex arguments and arguments for which it doesn't know whether they are real or not.

ClearAll[x, ψ]
DeclareReal[ψ];

r[2]
(* {{1, 0, 0}, {0, Cos[4], Sin[4]}, {0, -Sin[4], Cos[4]}} *)
% // ConjugateTranspose
(* {{1, 0, 0}, {0, Cos[4], -Sin[4]}, {0, Sin[4], Cos[4]}} *)

r[2 + I]
(* {{1, 0, 0}, {0, Cos[4 + 2 I], Sin[4 + 2 I]}, {0, -Sin[4 + 2 I], Cos[4 + 2 I]}} *)
% // ConjugateTranspose
(* {{1, 0, 0}, {0, Cosh[2 + 4 I], I Sinh[2 + 4 I]}, {0, -I Sinh[2 + 4 I], Cosh[2 + 4 I]}} *)

r[x]
(* {{1, 0, 0}, {0, Cos[2 x], Sin[2 x]}, {0, -Sin[2 x], Cos[2 x]}} *)
% // ConjugateTranspose
(* {{1, 0, 0}, {0, Cos[2 Conjugate[x]], -Sin[2 Conjugate[x]]}, {0, Sin[2 Conjugate[x]], Cos[2 Conjugate[x]]}} *)

r[ψ]
(* {{1, 0, 0}, {0, Cos[2 ψ], Sin[2 ψ]}, {0, -Sin[2 ψ], Cos[2 ψ]}} *)
% // ConjugateTranspose
(* {{1, 0, 0}, {0, Cos[2 ψ], -Sin[2 ψ]}, {0, Sin[2 ψ], Cos[2 ψ]}} *)

Note that there's nothing "real" in r function, it works for all types of arguments. What is "real" here is number 2 and ψ symbol.

If we really want a "real function", we first need to specify what precisely that means. Say we want a function which domain is set of real numbers and we expect following behavior. Function should:

• evaluate when Mathematica can be sure that argument of function is real,
• fail, with some error message, when Mathematica can be sure that arguments of function is not real,
• remain unevaluated when Mathematica can't decide whether argument is real or not.

Moreover we want Mathematica to know that, for any valid argument, value of function can be considered real (in this particular case matrix of expressions that represent real numbers), so function in unevaluated form should be considered real.

Above conditions are fulfilled by following function:

ClearAll[r]
r::domain = "`1` is not in domain of r function.";
r[x_ /; x ∈ Reals] :=
    {{1, 0, 0}, {0, Cos[2 x], Sin[2 x]}, {0, -Sin[2 x], Cos[2 x]}}
r[x_ /; Not[x ∈ Reals]] := (Message[r::domain, HoldForm[x]]; $Failed)
DeclareReal[HoldPattern@r[_]];

ClearAll[x, ψ]
DeclareReal[ψ];

r[2]
(* {{1, 0, 0}, {0, Cos[4], Sin[4]}, {0, -Sin[4], Cos[4]}} *)
% // Conjugate
(* {{1, 0, 0}, {0, Cos[4], Sin[4]}, {0, -Sin[4], Cos[4]}} *)

r[2 + I]
(* r::domain: 2+I is not in domain of r function. *)
(* $Failed *)
% // Conjugate
(* Conjugate[$Failed] *)

r[x]
(* r[x] *)
% // Conjugate
(* r[x] *)

r[ψ]
(* {{1, 0, 0}, {0, Cos[2 ψ], Sin[2 ψ]}, {0, -Sin[2 ψ], Cos[2 ψ]}} *)
% // Conjugate
(* {{1, 0, 0}, {0, Cos[2 ψ], Sin[2 ψ]}, {0, -Sin[2 ψ], Cos[2 ψ]}} *)

Note that even for unevaluated r[x] Mathematica knows that it's real and its conjugation returns r[x].

Answer 2

If you use numbers you can define

R[ψ_Real] := {{1, 0, 0}, {0, Cos[2 ψ], Sin[2 ψ]}, {0, -Sin[2 ψ], Cos[2 ψ]}}

For symbolic analysis you will need to use Simplify in conjunction with assumptions as indicated by george2079.

It would look something like this:

R[ψ_] := {{1, 0, 0}, {0, Cos[2 ψ], Sin[2 ψ]}, {0, -Sin[2 ψ], Cos[2 ψ]}}

and then

Simplify[ConjugateTranspose[R[ψ]], ψ ∈ Reals] // TraditionalForm

produces