6
$\begingroup$

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?

$\endgroup$
  • $\begingroup$ You could consider having a global assumption that psi is real: $Assumptions = {Element[ψ, Reals]}. See also the documentation for $Assumptions. $\endgroup$ – MarcoB Oct 1 '15 at 18:13
  • $\begingroup$ Is there a particular reason for use ConjugateTranspose instead of Transpose? Please note: I can't comment yet so take this as a comment. In another "answer" of mine, which was deleted, I was suggested to "comment on your own posts, and once you have sufficient reputation you will be able to comment on any post." Which I found a pointless advice as I don't want to comment meaningless stuff in order to comment where I want. $\endgroup$ – rpanai Oct 1 '15 at 19:21
  • 1
    $\begingroup$ A few basic things:Your conditional syntax is wrong, should be /; and Element is not a conditional test but an assertion. $\endgroup$ – george2079 Oct 1 '15 at 19:26
  • $\begingroup$ I know that I can use Transpose instead of ConjugateTranspose but I wanted 1) obey the general notation 2) Learn the concept how to define a functions with variables in certain domains $\endgroup$ – Sepideh Abadpour Oct 1 '15 at 19:27
  • $\begingroup$ note setting $Assumptions saves you from adding the assumption to Refine, but you still need to use Refine or Simplify or similar function for the $Assumption to be applied. $\endgroup$ – george2079 Oct 1 '15 at 19:29
8
$\begingroup$

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].

$\endgroup$
3
$\begingroup$

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

Mathematica graphics

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.