Skip to main content

algebraic manipulation - Replacing patterns (determinants) in a rational multivariate function and/or getting `replacementFunction` to work on a multi-linear expression


Given a rational multivariate function known to contain determinants, what is the best way to rewrite the function in terms of the determinants?


A simple example:



det[aa_] := Det[Table[x[li1, li2], {li1, aa /@ {1, 2}}, {li2, aa /@ {3, 4}}]];
origExpr = det[a]*det[b]/det[c] + det[d]*det[e]/det[f] - det[g]*det[h]/det[i];
oeet = origExpr //Expand // Together;
(* I paste the long, crappy expression at the end of this quesion *)

That the entries of the matrix be x[i_,j_] isn't necessarily important, that just happens to be the problem I'm considering -- the determinants happen to be Gram determinants.


Question: Given the output of oeet, what is the best way to rediscover origExpr?


Edit 2: See "Edit 2" near the bottom of this post for an updated discussion of this problem.


One solution: This works for simple-enough examples:


vars = Union[Cases[oeet, x[a_[i_], _] :> a, Infinity]];(* Determine the variables *)

rep = Table[d[ti] == det[ti], {ti, vars}];
Simplify[oeet, rep]
(* (d[a] d[b])/d[c] + (d[d] d[e])/d[f] - (d[g] d[h])/d[i] *)

This doesn't do so well for $3\times 3$ determinants though:


det[aa_] := Det[Table[x[li1, li2], {li1, aa /@ {1, 2, 3}}, {li2, aa /@ {4, 5, 6}}]];

The analogous Simplify[oeet, rep] runs for over a minute before I kill it. The expressions that I'm actually manipulating are rational in the x[_,_]'s, and are not completely rational in in the determinants, and I think that adds complexity. (I couldn't come up with a non-trivial alteration to the minimal working example here.)


Additional attempts: I also tried to use the replacementFunction for example here (from @DanielLichtblau, I think?), but it appears not to even alter oeet:


aVars =Select[Union[Cases[oeet, x[__], Infinity]],! FreeQ[#, a, Infinity] &]

(* {x[a[1], a[3]], x[a[1], a[4]], x[a[2], a[3]], x[a[2], a[4]]} *)
replacementFunction[oeet, detA - det[a], aVars] - oeet
(* 0 (* Should be detA-depdendent *) *)

Assuming I'm somewhow misusing the function, I tried PolynomialReduce which does a fairly good job on the $2\times 2$ matrices, but misses the denominators.


xVars = Union[Cases[oeet, x[_, _], Infinity]]
redEqns = (safe[#] - det[#]) & /@ vars
PolynomialReduce[oeet, redEqns, xVars][[2]]
(*
(safe[c] safe[f] safe[g] safe[h])/((x[c[1], c[4]] x[c[2], c[3]] -

x[c[1], c[3]] x[c[2], c[4]]) (x[f[1], f[4]] x[f[2], f[3]] -
x[f[1], f[3]] x[f[2], f[4]]) (x[i[1], i[4]] x[i[2], i[3]] -
x[i[1], i[3]] x[i[2], i[4]])) - (safe[c] safe[d] safe[e]
safe[i])/((x[c[1], c[4]] x[c[2], c[3]] -
x[c[1], c[3]] x[c[2], c[4]]) (x[f[1], f[4]] x[f[2], f[3]] -
x[f[1], f[3]] x[f[2], f[4]]) (x[i[1], i[4]] x[i[2], i[3]] -
x[i[1], i[3]] x[i[2], i[4]])) - (safe[a] safe[b] safe[f]
safe[i])/((x[c[1], c[4]] x[c[2], c[3]] -
x[c[1], c[3]] x[c[2], c[4]]) (x[f[1], f[4]] x[f[2], f[3]] -
x[f[1], f[3]] x[f[2], f[4]]) (x[i[1], i[4]] x[i[2], i[3]] -

x[i[1], i[3]] x[i[2], i[4]]))
*)

It again takes a while on $3\times 3$ matrices.


Edit: Here is a simple example where the Groebner basis approach suggested in the first solution doesn't work:


det[aa_] := 
Det[Table[
x[li1, li2], {li1, aa /@ {1, 2, 3}}, {li2, aa /@ {4, 5, 6}}]];
origExpr = x[a[1], x[a[6]]] det[a] det[b]/det[c]; (* <- Alteration here *)
oeet = origExpr // Expand // Together;

varsx = Cases[oeet, x[a_[i_], _], \[Infinity]];
vars = Union[Cases[oeet, x[a_[i_], _] :> a, \[Infinity]]];
rep = Table[d[ti] == det[ti], {ti, vars}];
GroebnerBasis[{w == oeet}~Join~rep, w, varsx]
(* {} *)

It does work if I know to remove x[a[1],a[6]] from the "Elimination" argument of GroebnerBasis:


GroebnerBasis[{w == oeet}~Join~rep, w,DeleteCases[varsx, x[a[1], a[6]]]]
(* {w d[c] - d[a] d[b] x[a[1], a[6]]} *)


but given a general polynomial in the x[_,_]'s, I won't know which x[_,_]'s to remove from the elimination argument of GroebnerBasis. I guess in general I'm looking for something that can implement polynomial changes of variables in a multivariate rational function.


Edit 2: I'm now pretty sure the best way to do this is with the replacementFunction I already referenced. The function is effectively an iterative PolynomialReduce. It doesn't seem to like exactly multi-linear functions, such as determinants, however. Here's a version of replacementFunction that has an optional fourth argument that when set to ON prints output to track what's happening. This link has the barebones version of the function.


replacementFunction // ClearAll;
replacementFunction[expr_, rep_, vars_, TS_: 0] :=
Module[
{num = Numerator[expr], den = Denominator[expr], hed = Head[expr],
base, expon, out, tsp}
,
tsp[x_] := If[TS === ON, Print[x];];
If[

PolynomialQ[num, vars] && PolynomialQ[den, vars] && ! NumberQ[den]
,
tsp["T1 - A rational function"];
tsp[expr];
replacementFunction[num, rep, vars, TS]/replacementFunction[den, rep, vars, TS]
,
tsp["F1 - Not a rational function"];
tsp[expr];
If[
hed === Power && Length[expr] == 2

,
tsp["T2 - A power function"];
tsp[expr];
base = replacementFunction[expr[[1]], rep, vars, TS];
expon = replacementFunction[expr[[2]], rep, vars, TS];
out = PolynomialReduce[base^expon, rep, vars];
tsp["===T2out==="];
tsp[out // Flatten // TableForm];
out[[2]]
,

tsp["F2 - Not a power function"];
tsp[expr];
If[
Head[hed] === Symbol && MemberQ[Attributes[Evaluate[hed]], NumericFunction]
,
tsp["T3 - A numeric function"];
tsp[expr];
Map[replacementFunction[#, rep, vars, TS] &, expr]
,
tsp["F3 - Not a numeric function"];

tsp["***Reduce***"];
tsp["Divide ", expr];
tsp["by ", rep];
out = PolynomialReduce[expr, rep, vars];
tsp["===out==="];
tsp[out // Flatten // TableForm];
out[[2]]
], TS
]
]

];

This doesn't work on a simple determinant:


expr = (a[1, 1] a[2, 2] - a[1, 2] a[2, 1]);
replacementFunction[expr, expr + d, Variables[expr]]
(* Actually running will print out what the function is doing *)
(* -a[1, 2] a[2, 1] + a[1, 1] a[2, 2] (*Output*)*)

It appears to work when the expression is not multi-linear:


exprA = (a[1, 1] a[2, 2] - a[1, 2] a[2, 1]);

exprB = (b[1, 1] b[2, 2] - b[1, 2] b[2, 1]);
replacementFunction[(exprA + exprB)^2, {exprA - dA, exprB - dB}, Join[Variables[exprA],Variables[exprB]]]
(* dA^2 + 2 dA dB + dB^2 *)

But again breaks when the expression is multi-linear (like a determinant is):


replacementFunction[exprA exprB, {exprA - dA, exprB - dB},Join[Variables[exprA],Variables[exprB]]]
(* (-a[1, 2] a[2, 1] + a[1, 1] a[2, 2]) (-b[1, 2] b[2, 1] + b[1, 1] b[2, 2]) *)

Updated question: How do I get replacementFunction to work on multi-linear expressions such as determinants.


It appears to already solve the more general problem of changing variables in a polynomial. From what I can tell, replacementFunction jumps through every part at every level of the expression and performs PolynomialReduce where it can. I can't currently see why it doesn't catch the multi-linear terms.



Below is the crappy output of oeet.


(* The output from oeet = origExpr //Expand // Together:
(x[c[1], c[4]] x[c[2], c[3]] x[f[1], f[4]] x[f[2], f[3]] x[g[1],
g[4]] x[g[2], g[3]] x[h[1], h[4]] x[h[2], h[3]] -
x[c[1], c[3]] x[c[2], c[4]] x[f[1], f[4]] x[f[2], f[3]] x[g[1],
g[4]] x[g[2], g[3]] x[h[1], h[4]] x[h[2], h[3]] -
x[c[1], c[4]] x[c[2], c[3]] x[f[1], f[3]] x[f[2], f[4]] x[g[1],
g[4]] x[g[2], g[3]] x[h[1], h[4]] x[h[2], h[3]] +
x[c[1], c[3]] x[c[2], c[4]] x[f[1], f[3]] x[f[2], f[4]] x[g[1],
g[4]] x[g[2], g[3]] x[h[1], h[4]] x[h[2], h[3]] -

x[c[1], c[4]] x[c[2], c[3]] x[f[1], f[4]] x[f[2], f[3]] x[g[1],
g[3]] x[g[2], g[4]] x[h[1], h[4]] x[h[2], h[3]] +
x[c[1], c[3]] x[c[2], c[4]] x[f[1], f[4]] x[f[2], f[3]] x[g[1],
g[3]] x[g[2], g[4]] x[h[1], h[4]] x[h[2], h[3]] +
x[c[1], c[4]] x[c[2], c[3]] x[f[1], f[3]] x[f[2], f[4]] x[g[1],
g[3]] x[g[2], g[4]] x[h[1], h[4]] x[h[2], h[3]] -
x[c[1], c[3]] x[c[2], c[4]] x[f[1], f[3]] x[f[2], f[4]] x[g[1],
g[3]] x[g[2], g[4]] x[h[1], h[4]] x[h[2], h[3]] -
x[c[1], c[4]] x[c[2], c[3]] x[f[1], f[4]] x[f[2], f[3]] x[g[1],
g[4]] x[g[2], g[3]] x[h[1], h[3]] x[h[2], h[4]] +

x[c[1], c[3]] x[c[2], c[4]] x[f[1], f[4]] x[f[2], f[3]] x[g[1],
g[4]] x[g[2], g[3]] x[h[1], h[3]] x[h[2], h[4]] +
x[c[1], c[4]] x[c[2], c[3]] x[f[1], f[3]] x[f[2], f[4]] x[g[1],
g[4]] x[g[2], g[3]] x[h[1], h[3]] x[h[2], h[4]] -
x[c[1], c[3]] x[c[2], c[4]] x[f[1], f[3]] x[f[2], f[4]] x[g[1],
g[4]] x[g[2], g[3]] x[h[1], h[3]] x[h[2], h[4]] +
x[c[1], c[4]] x[c[2], c[3]] x[f[1], f[4]] x[f[2], f[3]] x[g[1],
g[3]] x[g[2], g[4]] x[h[1], h[3]] x[h[2], h[4]] -
x[c[1], c[3]] x[c[2], c[4]] x[f[1], f[4]] x[f[2], f[3]] x[g[1],
g[3]] x[g[2], g[4]] x[h[1], h[3]] x[h[2], h[4]] -

x[c[1], c[4]] x[c[2], c[3]] x[f[1], f[3]] x[f[2], f[4]] x[g[1],
g[3]] x[g[2], g[4]] x[h[1], h[3]] x[h[2], h[4]] +
x[c[1], c[3]] x[c[2], c[4]] x[f[1], f[3]] x[f[2], f[4]] x[g[1],
g[3]] x[g[2], g[4]] x[h[1], h[3]] x[h[2], h[4]] -
x[c[1], c[4]] x[c[2], c[3]] x[d[1], d[4]] x[d[2], d[3]] x[e[1],
e[4]] x[e[2], e[3]] x[i[1], i[4]] x[i[2], i[3]] +
x[c[1], c[3]] x[c[2], c[4]] x[d[1], d[4]] x[d[2], d[3]] x[e[1],
e[4]] x[e[2], e[3]] x[i[1], i[4]] x[i[2], i[3]] +
x[c[1], c[4]] x[c[2], c[3]] x[d[1], d[3]] x[d[2], d[4]] x[e[1],
e[4]] x[e[2], e[3]] x[i[1], i[4]] x[i[2], i[3]] -

x[c[1], c[3]] x[c[2], c[4]] x[d[1], d[3]] x[d[2], d[4]] x[e[1],
e[4]] x[e[2], e[3]] x[i[1], i[4]] x[i[2], i[3]] +
x[c[1], c[4]] x[c[2], c[3]] x[d[1], d[4]] x[d[2], d[3]] x[e[1],
e[3]] x[e[2], e[4]] x[i[1], i[4]] x[i[2], i[3]] -
x[c[1], c[3]] x[c[2], c[4]] x[d[1], d[4]] x[d[2], d[3]] x[e[1],
e[3]] x[e[2], e[4]] x[i[1], i[4]] x[i[2], i[3]] -
x[c[1], c[4]] x[c[2], c[3]] x[d[1], d[3]] x[d[2], d[4]] x[e[1],
e[3]] x[e[2], e[4]] x[i[1], i[4]] x[i[2], i[3]] +
x[c[1], c[3]] x[c[2], c[4]] x[d[1], d[3]] x[d[2], d[4]] x[e[1],
e[3]] x[e[2], e[4]] x[i[1], i[4]] x[i[2], i[3]] -

x[a[1], a[4]] x[a[2], a[3]] x[b[1], b[4]] x[b[2], b[3]] x[f[1],
f[4]] x[f[2], f[3]] x[i[1], i[4]] x[i[2], i[3]] +
x[a[1], a[3]] x[a[2], a[4]] x[b[1], b[4]] x[b[2], b[3]] x[f[1],
f[4]] x[f[2], f[3]] x[i[1], i[4]] x[i[2], i[3]] +
x[a[1], a[4]] x[a[2], a[3]] x[b[1], b[3]] x[b[2], b[4]] x[f[1],
f[4]] x[f[2], f[3]] x[i[1], i[4]] x[i[2], i[3]] -
x[a[1], a[3]] x[a[2], a[4]] x[b[1], b[3]] x[b[2], b[4]] x[f[1],
f[4]] x[f[2], f[3]] x[i[1], i[4]] x[i[2], i[3]] +
x[a[1], a[4]] x[a[2], a[3]] x[b[1], b[4]] x[b[2], b[3]] x[f[1],
f[3]] x[f[2], f[4]] x[i[1], i[4]] x[i[2], i[3]] -

x[a[1], a[3]] x[a[2], a[4]] x[b[1], b[4]] x[b[2], b[3]] x[f[1],
f[3]] x[f[2], f[4]] x[i[1], i[4]] x[i[2], i[3]] -
x[a[1], a[4]] x[a[2], a[3]] x[b[1], b[3]] x[b[2], b[4]] x[f[1],
f[3]] x[f[2], f[4]] x[i[1], i[4]] x[i[2], i[3]] +
x[a[1], a[3]] x[a[2], a[4]] x[b[1], b[3]] x[b[2], b[4]] x[f[1],
f[3]] x[f[2], f[4]] x[i[1], i[4]] x[i[2], i[3]] +
x[c[1], c[4]] x[c[2], c[3]] x[d[1], d[4]] x[d[2], d[3]] x[e[1],
e[4]] x[e[2], e[3]] x[i[1], i[3]] x[i[2], i[4]] -
x[c[1], c[3]] x[c[2], c[4]] x[d[1], d[4]] x[d[2], d[3]] x[e[1],
e[4]] x[e[2], e[3]] x[i[1], i[3]] x[i[2], i[4]] -

x[c[1], c[4]] x[c[2], c[3]] x[d[1], d[3]] x[d[2], d[4]] x[e[1],
e[4]] x[e[2], e[3]] x[i[1], i[3]] x[i[2], i[4]] +
x[c[1], c[3]] x[c[2], c[4]] x[d[1], d[3]] x[d[2], d[4]] x[e[1],
e[4]] x[e[2], e[3]] x[i[1], i[3]] x[i[2], i[4]] -
x[c[1], c[4]] x[c[2], c[3]] x[d[1], d[4]] x[d[2], d[3]] x[e[1],
e[3]] x[e[2], e[4]] x[i[1], i[3]] x[i[2], i[4]] +
x[c[1], c[3]] x[c[2], c[4]] x[d[1], d[4]] x[d[2], d[3]] x[e[1],
e[3]] x[e[2], e[4]] x[i[1], i[3]] x[i[2], i[4]] +
x[c[1], c[4]] x[c[2], c[3]] x[d[1], d[3]] x[d[2], d[4]] x[e[1],
e[3]] x[e[2], e[4]] x[i[1], i[3]] x[i[2], i[4]] -

x[c[1], c[3]] x[c[2], c[4]] x[d[1], d[3]] x[d[2], d[4]] x[e[1],
e[3]] x[e[2], e[4]] x[i[1], i[3]] x[i[2], i[4]] +
x[a[1], a[4]] x[a[2], a[3]] x[b[1], b[4]] x[b[2], b[3]] x[f[1],
f[4]] x[f[2], f[3]] x[i[1], i[3]] x[i[2], i[4]] -
x[a[1], a[3]] x[a[2], a[4]] x[b[1], b[4]] x[b[2], b[3]] x[f[1],
f[4]] x[f[2], f[3]] x[i[1], i[3]] x[i[2], i[4]] -
x[a[1], a[4]] x[a[2], a[3]] x[b[1], b[3]] x[b[2], b[4]] x[f[1],
f[4]] x[f[2], f[3]] x[i[1], i[3]] x[i[2], i[4]] +
x[a[1], a[3]] x[a[2], a[4]] x[b[1], b[3]] x[b[2], b[4]] x[f[1],
f[4]] x[f[2], f[3]] x[i[1], i[3]] x[i[2], i[4]] -

x[a[1], a[4]] x[a[2], a[3]] x[b[1], b[4]] x[b[2], b[3]] x[f[1],
f[3]] x[f[2], f[4]] x[i[1], i[3]] x[i[2], i[4]] +
x[a[1], a[3]] x[a[2], a[4]] x[b[1], b[4]] x[b[2], b[3]] x[f[1],
f[3]] x[f[2], f[4]] x[i[1], i[3]] x[i[2], i[4]] +
x[a[1], a[4]] x[a[2], a[3]] x[b[1], b[3]] x[b[2], b[4]] x[f[1],
f[3]] x[f[2], f[4]] x[i[1], i[3]] x[i[2], i[4]] -
x[a[1], a[3]] x[a[2], a[4]] x[b[1], b[3]] x[b[2], b[4]] x[f[1],
f[3]] x[f[2], f[4]] x[i[1], i[3]] x[i[2],
i[4]])/((x[c[1], c[4]] x[c[2], c[3]] -
x[c[1], c[3]] x[c[2], c[4]]) (x[f[1], f[4]] x[f[2], f[3]] -

x[f[1], f[3]] x[f[2], f[4]]) (x[i[1], i[4]] x[i[2], i[3]] -
x[i[1], i[3]] x[i[2], i[4]]))
*)


Comments

Popular posts from this blog

plotting - How to draw lines between specified dots on ListPlot?

I would like to create a plot where I have unconnected dots and some connected. So far, I have figured out how to draw the dots. My code is the following: ListPlot[{{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4,13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full] I have thought using ListLinePlot command, but I don't know how to specify to the command to draw only selected lines between the dots. Do have any suggestions/hints on how to do that? Thank you. Answer One possibility would be to use Epilog with Line : ListPlot[ {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4, 13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full, Epilog -> { Line[ ...

list manipulation - Selecting multiple columns from a matrix?

Sample data: data = { {{2013, 1, 1}, 24.13, 167.67, 231.82}, {{2013, 1, 2}, 32.15, 170.92, 225.99}, {{2013, 1, 3}, 35.43, 172.68, 221.67}, {{2013, 1, 4}, 36.73, 173.05, 218.32}, {{2013, 1, 5}, 58.19, 165.96, 197.05}, {{2013, 1, 6}, 69.99, 163.50, 187.52}, {{2013, 1, 7}, 71.37, 154.21, 175.58}, {{2013, 1, 8}, 72.51, 149.66, 163.25}}; I want a DateListPlot with three graphs, so for a matrix formed by columns 1 and 2, one for columns 1 and 3, and 1 for columns 1 and 4. At the moment I'm using this code: data2 = Transpose[{data[[All, 1]], data[[All, 2]]}]; data3 = Transpose[{data[[All, 1]], data[[All, 3]]}]; data4 = Transpose[{data[[All, 1]], data[[All, 4]]}]; DateListPlot[{data2, data3, data4}, Joined -> True, Filling -> {3 -> {1}}] but I have a hunch that this can be done more efficiently. I don't like the Transpose s in particular. Any ideas? edit (for extra credit) What if I need to multiply the second column by 2, which in my solution is simp...

plotting - How to draw some 2D curves in a 3D plot?

I want to plot several 2D curves ( Sin[x] at y=0 , Cos[x] at y=1 ) in a 3D plot, what function should i use? f[x_, y_] := Piecewise[{{0, y 0}, {Sin[x], y == 0}}] g[x_, y_] := Piecewise[{{0, y 1}, {Cos[x], y == 1}}] Plot3D[{f[x, y], g[x, y]}, {x, 0, 10}, {y, 0, 10}] doesn't work. Any ideas? Answer ParametricPlot3D[{{Sin[u], 0, u}, {Cos[u], 1, u}}, {u, 0, 20}, BoxRatios -> 1, PlotRange -> {{-2, 2}, {-.5, 2}, {0, 20}}] === update - general thoughts === I've seen the comments to this question and a few other approaches to the waterfall (or wire) plot are given in this question: Plotting several functions . Also I cannot not mention one of my favorite Mathematica blogs - Archery with this post on the story of discovery of 1st pulsar and an its infamous graphics - code is given in the post: