# Factoring Custom Tensor Products

I have now made a post on the Computer Science stack exchange that talks about the general problems from an algorithmnic perspective here.

I have defined a custom tensor product function TProduct[a,b] -> $$a \otimes b$$ that behaves as you would expect:

TProduct /: TProduct[a_, b_] TProduct[c_, d_] := TProduct[a c, b d]
TProduct /: TProduct[a_, b_] (f_ + g_) :=
TProduct[a, b] f + TProduct[a, b] g
TProduct[c_ ?NumberQ  f_, g_] := c  TProduct[f, g]
TProduct[f_, c_ ?NumberQ  g_] := c  TProduct[f, g]
TProduct[0, g_] := 0
TProduct[g_, 0] := 0


I wrote a function FactorTProduct[expr_]that factors a given sum of TProduct expressions in a sensible way. Things like:

$$c_1 (a \otimes b) + c_2 (a \otimes d) \to a \otimes (c_1 b+c_2 d)$$.

Hard-coding in (I think) all of the possible cases leads to this:

FactorTProduct[expr_] :=
expr //. {n_?NumberQ  TProduct[a_, c_] +
m_?NumberQ  TProduct[b_, c_] :> TProduct[n  a + m  b, c],
n_?NumberQ  TProduct[a_, c_] - m_?NumberQ  TProduct[b_, c_] :>
TProduct[n  a - m  b, c],
n_?NumberQ  TProduct[a_, b_] + m_?NumberQ  TProduct[a_, c_] :>
TProduct[a, n  b + m  c],
n_?NumberQ  TProduct[a_, b_] - m_?NumberQ  TProduct[a_, c_] :>
TProduct[a, n  b - m  c],(**)
n_?NumberQ  TProduct[-a_, c_] +
m_?NumberQ  TProduct[-b_, c_] :> -TProduct[n  a + m  b, c],
n_?NumberQ  TProduct[a_, -c_] +
m_?NumberQ  TProduct[b_, -c_] :> -TProduct[n  a + m  b, c],
n_?NumberQ  TProduct[-a_, c_] - m_?NumberQ  TProduct[-b_, c_] :>
TProduct[n  b - m  a, c],
n_?NumberQ  TProduct[a_, -c_] - m_?NumberQ  TProduct[b_, -c_] :>
TProduct[n  b - m  a, c],(**)
n_?NumberQ  TProduct[a_, -b_] +
m_?NumberQ  TProduct[a_, -c_] :> -TProduct[a, n  b + m  c],
n_?NumberQ  TProduct[-a_, b_] +
m_?NumberQ  TProduct[-a_, c_] :> -TProduct[a, n  b + m  c],
n_?NumberQ  TProduct[a_, -b_] - m_?NumberQ  TProduct[a_, -c_] :>
TProduct[a, n  c - m  b],
n_?NumberQ  TProduct[-a_, b_] - m_?NumberQ  TProduct[-a_, c_] :>
TProduct[a, n  c - m  b],(**Handling implicit coefficients of 1**)
TProduct[a_, c_] + TProduct[b_, c_] :> TProduct[a + b, c],
TProduct[a_, c_] - TProduct[b_, c_] :> TProduct[a - b, c],
TProduct[a_, b_] + TProduct[a_, c_] :> TProduct[a, b + c],
TProduct[a_, b_] - TProduct[a_, c_] :> TProduct[a, b - c],
TProduct[-a_, c_] + TProduct[-b_, c_] :> -TProduct[a + b, c],
TProduct[a_, -c_] + TProduct[b_, -c_] :> -TProduct[a + b, c],
TProduct[-a_, c_] - TProduct[-b_, c_] :> TProduct[b - a, c],
TProduct[a_, -c_] - TProduct[b_, -c_] :> TProduct[b - a, c],
TProduct[a_, -b_] + TProduct[a_, -c_] :> -TProduct[a, b + c],
TProduct[-a_, b_] + TProduct[-a_, c_] :> -TProduct[a, b + c],
TProduct[a_, -b_] - TProduct[a_, -c_] :> TProduct[a, c - b],
TProduct[-a_, b_] - TProduct[-a_, c_] :> TProduct[a, c - b],(**
Handling cases where one coefficient is 1**)
TProduct[a_, c_] + n_?NumberQ  TProduct[b_, c_] :>
TProduct[a + n  b, c],
TProduct[a_, c_] - n_?NumberQ  TProduct[b_, c_] :>
TProduct[a - n  b, c],
n_?NumberQ  TProduct[a_, c_] + TProduct[b_, c_] :>
TProduct[n  a + b, c],
n_?NumberQ  TProduct[a_, c_] - TProduct[b_, c_] :>
TProduct[n  a - b, c],
TProduct[a_, b_] + n_?NumberQ  TProduct[a_, c_] :>
TProduct[a, b + n  c],
TProduct[a_, b_] - n_?NumberQ  TProduct[a_, c_] :>
TProduct[a, b - n  c],
n_?NumberQ  TProduct[a_, b_] + TProduct[a_, c_] :>
TProduct[a, n  b + c],
n_?NumberQ  TProduct[a_, b_] - TProduct[a_, c_] :>
TProduct[a, n  b - c]}


This is already deeply inelegant, but it fails in a number of places. In particular:

(1) $$(-a -b ) \otimes d + (a + b) \otimes e \not \to (a+b)\otimes (e-d)$$

In code: TProduct[-a-b,d] + TProduct[]

(2) $$(a+b)\otimes d + 2 (a+b) \otimes e \not \to (a+b) \otimes (d + 2 e)$$

In code: TProduct[a + b, d] + 2 TProduct[a + b, e].

I can easily fix (1) by putting something in like: TProduct[-a_ - b_, c_] :> -TProduct[a + b, c], and I could also do something similar for (2), but I would once again need to consider all of the cases of positive/negative coefficients, etc, etc, and it is getting tediuous. Even with all that, it wouldn't do anything to help with the case of $$(a+b+d) \otimes e + 2(a+b +d) \otimes f$$ and so on. There must me a more elegant way to do what I am trying to do.

In essence, a well defined version of my goal is I would like to take some long sum of TProduct[] expressions (I already have a good ExpandTProduct[]) function and then factor this long sum into the smallest number of TProducts as possible. An expression with fewer terms is always 'better'. For example I would like:

$$a \otimes d + 7a \otimes e + 2 a \otimes f + b \otimes d + 7b \otimes e + 2 b \otimes f \to (a+b)\otimes (d+7e+2f)$$.

• Hi. Before defining FactorTProduct, there is a serious problem. According to your MMA code, both TProduct[a, b] TProduct[c, d] and TProduct[c, d] TProduct[a, b] yield TProduct[a c, b d]. I don't think this is what you want. Commented Jul 3 at 2:21
• Amazingly, this is in fact what I would like. Though it is good to be careful. For me "a" and "b" are things like "Log[z]" and "PolyLog[3,z]" which commute
– Jack
Commented Jul 3 at 8:47