######################################################################
# Author: Louis Lamarche                                             #
#         Institute of Research of Hydro-Quebec (IREQ)               #
#         Science des données et haute performance                   #
#         2018/02/20                                                 #
#                                                                    #
#         Function name: ExpandQop (x)                               #
#               Purpose: Compute the tensor product of two quantum   #
#                        operators in Dirac notations                #
#              Argument: x - a simple quantum operator               #
#   Future improvements: Manage all +, -, *, /, ^, mod  operations   #
#                        in the argument                             #
#               Version: 1.0                                         #
######################################################################
restart;

with(Physics):
interface(imaginaryunit=i):
Setup(mathematicalnotation=true);

Setup(quantumoperators={A,B,C,Cn});
Setup(noncommutativeprefix={a,b});

ExpandQop:=proc(x)
    local ret,j,lkb,cbk,rkb,no;
    ret:=1; lkb:=0; cbk:=0; rkb:=0; no:=nops(x);
    if (no > 3 ) then
        for j from 1 to no do
            if (j>1) then
                 if(lkb=0) then
                     if( type(op(j-1,x),Ket) and
                         type(op(j,x),Bra) ) then lkb:=j-1; fi;
                 else
                     if( type(op(j-1,x),Ket) and
                         type(op(j,x),Bra) ) then rkb:=j;   fi;
                 fi;
                 if( type(op(j-1,x),Bra) and type(op(j,x),Ket) )
                                             then cbk:=j;   fi;
            fi;
        end do;
        if ( (lkb < cbk) and (cbk<rkb) ) then
            for j from 1     to lkb   do ret := ret*op(j,x); end do;
            for j from cbk   to no    do ret := ret*op(j,x); end do;
            for j from lkb+1 to cbk-1 do ret := ret*op(j,x); end do;
        else
            ret:=x;
        fi;
    else
        ret:=x;
    fi;
    return ret;
end proc:

# Let A be an operator in a first Hilbert space of dimension n
#  using the associated orthonormal ket and bra vectors
#
#
kets1:=Ket(a1)*Ket(a2)*Ket(a3)*Ket(a4)*Ket(a5):
A:=kets1*Dagger(kets1);


# Let B be an operator in a second Hilbert (Ketspace of dimension m
#  using the associated orthonormal ket and bra vectors
#
#
kets2:=Ket(b1)*Ket(b2)*Ket(b3):
B:=kets2*Dagger(kets2);


# The tensor product of the two operators acts on a n+m third
# Hilbert space   unsing the appropriately ordered ket
# and bra  vectors of the two preceding spaces. The rule for
# building this operator in Dirac notation is as follows,
#
#


print("Maple do not compute the tensor product of operators,");
print("C=A*B gives:");
C:=A*B;

print("ExpandQop(C) gives the expected result:");
Cn:=ExpandQop(C);

kets3:=kets1*kets2;
bras3:=Dagger(kets3);
print("Matrix element computed with C appears curious");
'bras3.C. kets3'="...";
bras3.C.kets3;
print("Matrix element computed with Cn as expected");
'bras3.Cn.kets3'=bras3.Cn.kets3;