# How to Thread over lists with unequal lengths?

## Motivation

Consider the definition of tensor product of operators like $$$$x1\otimes x2 \otimes x3 \cdot y1\otimes y2 \otimes y3=x1 y1\otimes x2 y2\otimes x3y3$$$$ where $$x_i\in A_i$$. Intuitively one can imagine a spin chain, and $$x_i$$'s are e.g. spin operators acting on different sites of the spin chain.

We can realize it using NonCommutativeMultiply and CircleTimes

NonCommutativeMultiply[arg1_CircleTimes,arg2_CircleTimes]:=
Block[{NonCommutativeMultiply},
]


Here Block is to prevent the evaluation inside Thread. The results are desired

(x1\[CircleTimes]x2\[CircleTimes]x3)**(y1\[CircleTimes]y2\[CircleTimes]y3)


## Question

Now if we have a bilocal operator $$R: H_1\otimes H_2\to H_1\otimes H_2$$ acting on two sites (A concrete example of $$R$$ is the transposition operator $$R(x\otimes y)=y\otimes x$$), obeying the following rule $$$$x1\otimes R \cdot y1\otimes y2 \otimes y3=x1 y1\otimes R(y2 \otimes y3)$$$$

To realize the rule we need threading over lists with unequal lengths.

What I want is like the following examples:

Example 1

f[g[x1,R,x4],g[y1,y2,y3,y4]]//thread[#,g]&


returns

g[f[x1,y1],f[R,g[y2,y3]],f[x4,y4]]


Example 2

f[g[x1,R],g[R,y3]]//thread[#,g]&


returns unchanged

f[g[x1,R],g[R,y3]]


Example 3

f[g[x1,R],g[y1,R]]//thread[#,g]&


returns

f[g[x1,y1],g[R,R]]


That is to say, R behaves like a sequcence with length[R]=2, and the lists are threaded as possible as they can. Is there a simple way to realize this version of thread?

Example 4

A more complicated case is like: now introducing a new one T behavine like a sequcence with length[R]=3,

f[g[x1,T],g[y1,R,y4]]//thread[#,g]&


returns

g[f[x1,y1],f[T,g[R,y4]]]


Example 5

If the "effective" lengths are unequal, then abort the evalutation

f[g[x1,R],g[R]]


returns

Abort[]


since length@R=2 and length@{x1,R}=3;

• I forgot to say the attributes: SetAttributes[NonCommutativeMultiply,{Flat,OneIdentity}]; SetAttributes[CircleTimes,{Flat,OneIdentity}];. Sep 13, 2022 at 2:14

Code.

length[_]=1;
insert$dummy[(g_)[x___]]:=g@@Join@@Map[Join[{#},ConstantArray[$dummy,length[#]-1]]&,{x}];
f[insert$dummy[g[x]],insert$dummy[g[y]]],g],MemberQ[#2,$dummy]&]]/.{$dummy->Sequence[]}/.{g[s_]:>s};


If symbols have length unequal to one, one can specify them like so:

length[R]^=2;
length[T]^=3;


Examples. It works in the examples given by OP:

f[g[x1,R,x4],g[y1,y2,y3,y4]]//thread
(* g[f[x1,y1],f[R,g[y2,y3]],f[x4,y4]] *)

(* f[g[x1,R],g[R,y3]] *)

(* g[f[x1,y1],f[R,R]] *)

(* g[f[x1,y1],f[T,g[R,y4]]] *)


f[g[x1,T],g[y1,R,y4]]
-> f[g[x1,T,$$dummy,$$dummy],g[y1,R,$$dummy,y4]] (* insert$$dummy *)
-> g[f[x1,y1],f[T,R],f[$$dummy,$$dummy],f[$$dummy,y4]] (* Thread *) -> g[g[f[x1,y1]],g[f[T,R],f[$$dummy,$$dummy],f[$$dummy,y4]]] (* Split *)
-> g[f[g[x1],g[y1]],f[g[T,$$dummy,$$dummy],g[R,$$dummy,y4]]] (* Thread *) -> g[f[g[x1],g[y1]],f[g[T],g[R,y4]]] (* drop$$dummy *)