Necesitamos tu apoyo para difundir nuestras crónicas referente a las ciencias informáticas.
Solución:
Aquí hay una ligera variación de su método para generar una matriz complementaria (Frobenius). Esta versión también produce una matriz de Hessenberg superior, pero los coeficientes (representados) aparecen en la parte superior en lugar de en la parte más a la derecha de la matriz:
frobeniusCompanion[poly_, x_] /; PolynomialQ[poly, x] :=
Module[n = Exponent[poly, x], coef,
coef = CoefficientList[poly, x]; coef = -Most[coef]/Last[coef];
SparseArray[1, j_ :> coef[[-j]], Band[2, 1] -> 1, n, n]]
Un ejemplo:
MatrixForm[mat = frobeniusCompanion[5 + 4 x + 3 x^2 + 2 x^3 + x^4 + x^5, x]]
$$ begin pmatrix -1 & -2 & -3 & -4 & -5 \ 1 & 0 & 0 & 0 & 0 \ 0 & 1 & 0 & 0 & 0 \ 0 & 0 & 1 & 0 & 0 \ 0 & 0 & 0 & 1 & 0 \ end pmatrix $$
CharacteristicPolynomial[mat, x]
-5 - 4 x - 3 x^2 - 2 x^3 - x^4 - x^5
Resulta que hay un incorporado, pero indocumentado función para generar la matriz compañera de Frobenius a partir de un polinomio (en un formato ligeramente diferente):
MatrixForm[mat =
NRoots`CompanionMatrix[CoefficientList[5 + 4 x + 3 x^2 + 2 x^3 + x^4 + x^5, x]]
$$ begin pmatrix 0 & 1 & 0 & 0 & 0 \ 0 & 0 & 1 & 0 & 0 \ 0 & 0 & 0 & 1 & 0 \ 0 & 0 & 0 & 0 & 1 -5 y -4 y -3 y -2 y -1 \ end pmatrix $$
Tenga en cuenta que esto produce un más bajo Matriz de Hessenberg, con los coeficientes monicizados que aparecen en la parte inferior. La transposición de esta matriz producirá el formato dado en el PO.
Cabe señalar que la matriz compañera de Frobenius no es la única matriz compañera posible para un polinomio. Hay toda una clase de “matrices agradables” (vea esto también). Un desarrollo reciente interesante es una matriz compañera pentadiagonal debido a Miroslav Fiedler:
fiedlerCompanion[poly_, x_] /; PolynomialQ[poly, x] :=
Module[n = Exponent[poly, x], coef,
coef = CoefficientList[poly, x]; coef = -Most[coef]/Last[coef];
SparseArray[
(k - j == 2 && OddQ[k]) :> 1, n, n]]
Usando el mismo polinomio que el anterior,
MatrixForm[mat = fiedlerCompanion[5 + 4 x + 3 x^2 + 2 x^3 + x^4 + x^5, x]]
$$ begin pmatrix -1 & -2 & 1 & 0 & 0 \ 1 & 0 & 0 & 0 & 0 \ 0 & -3 & 0 & -4 & 1 \ 0 & 1 & 0 & 0 & 0 \ 0 & 0 & 0 & -5 & 0 \ end pmatrix $$
CharacteristicPolynomial[mat, x]
-5 - 4 x - 3 x^2 - 2 x^3 - x^4 - x^5
Siguiendo el comentario de @ JM, tenemos las siguientes funciones.
Convertir el código de MathWorld en una función da:
mathWorldCompanionMatrix[p_, x_] := Module[n, w = CoefficientList[p, x],
w = -w/Last[w]; n = Length[w] - 1;
SparseArray[i_, n :> w[[i]], i_, j_ /; i == j + 1 -> 1, n, n]]
Tenga en cuenta también que el mathWorldCompanionMatrix La función normalizará un polinomio arbitrario para que sea monico.
Pasando el código de la documentación para CharacteristicPolynomial en una función da:
docsCompanionMatrix[p_, x_] := Module[n, cl = CoefficientList[p, x],
n = Length[cl] - 1;
SparseArray[i_, n :> -cl[[i]], Band[2, 1] -> 1, n, n]]
Si bien todos estos dan el mismo resultado (y ambas funciones son mucho más limpias), obtengo los siguientes resultados de sincronización:
p = RandomInteger[9, 10000].x^Range[0, 9999] + x^10000; (*test function*)
companionMatrix[p]; // Timing (*function from the original question*)
0.625, Null
docsCompanionMatrix[p,x];//Timing
47.375, Null
mathWorldCompanionMatrix[p,x];//Timing
104.125, Null
Un polinomio de prueba tal vez irrazonablemente grande, pero revelador de todos modos. No soy un experto, pero presumiblemente las funciones en MathWorld y Docs pierden mucho tiempo en la coincidencia de patrones / Mathematica es rápido en correr IdentityMatrix. Ambas funciones nuevas también devuelven matrices dispersas, que también se pueden lograr mediante
SparseArray[companionMatrix[p]];//Timing
0.641, Null
Presumiblemente, se podría construir una versión aún mejor usando ArrayFlatten.
Decidí escribir otra respuesta, ya que lo siguiente generaliza las matrices complementarias que aparecen en mi otra respuesta.
De Terán, Dopico y Mackey, en su artículo, muestran un método para construir una matriz complementaria de Fiedler generalizada, que tiene las matrices de Frobenius y Fiedler en mi otra respuesta como casos especiales. Aquí hay un Mathematica implementación de su algoritmo:
generalizedFiedler[perm_, poly_, x_] /; PolynomialQ[poly, x] &&
Sort[perm] == Range[Exponent[poly, x]] :=
Module[n = Exponent[poly, x], coef, diff, idx,
coef = CoefficientList[poly, x]; coef = -Most[coef]/Last[coef];
diff = Sign[Differences[InversePermutation[perm]]];
idx = Thread[If[diff[[1]] > 0, Identity, Reverse]
[2, 1, 1, 1, 1, 2] -> Append[Take[coef, 2], 1]];
Do[idx = If[diff[[k + 1]] > 0,
Join[Thread[1, 1, 1, 2 -> coef[[k + 2]], 1],
MapAt[# + 1, Boole[Last[#] > 1] &, #, 1] & /@ idx],
Join[Thread[1, 1, 2, 1 -> coef[[k + 2]], 1],
MapAt[# + Boole[First[#] > 1], 1 &, #, 1] & /@ idx]],
k, n - 2];
SparseArray[idx, n, n]]
perm puede ser cualquier permutación de Range[n], dónde n es el grado del polinomio.
Usando un polinomio cúbico como ejemplo:
MatrixForm[generalizedFiedler[#, z^3 + C[2] z^2 + C[1] z + C[0], z]] & /@
Permutations[Range[3]]
$$ small left begin pmatrix -c_2 & 1 & 0 \ -c_1 & 0 & 1 \ -c_0 & 0 & 0 \ end pmatrix, begin pmatrix -c_2 & -c_1 & 1 \ 1 & 0 & 0 \ 0 & -c_0 & 0 \ end pmatrix, begin pmatrix -c_2 & 1 & 0 \ -c_1 & 0 & -c_0 \ 1 & 0 & 0 \ end pmatrix, begin pmatrix -c_2 & 1 & 0 \ -c_1 & 0 & -c_0 \ 1 & 0 & 0 \ end pmatrix, begin pmatrix -c_2 & -c_1 & 1 \ 1 & 0 & 0 \ 0 & -c_0 & 0 \ end pmatrix, begin pmatrix -c_2 & -c_1 & -c_0 \ 1 & 0 & 0 \ 0 & 1 & 0 \ end pmatrix right $$
Tenga en cuenta que la primera y la última entrada son matrices de Frobenius, mientras que la segunda y la cuarta son las matrices de Fiedler habituales.
Diferentes permutaciones pueden producir la misma matriz complementaria de Fiedler generalizada. Para demostrarlo, el siguiente fragmento agrupa permutaciones de $ (1 ; 2 ; 3 ; 4) $ por si producen la misma matriz compañera para un polinomio cuártico:
With[n = 4,
Values[Sort /@ GroupBy[generalizedFiedler[#, z^n + Sum[C[j] z^j, j, 0, n - 1], z],
# & /@ Permutations[Range[n]], First -> Last]]]
1, 2, 3, 4,
1, 2, 4, 3, 1, 4, 2, 3, 4, 1, 2, 3,
1, 3, 2, 4, 1, 3, 4, 2, 3, 1, 2, 4, 3, 1, 4, 2, 3, 4, 1, 2,
1, 4, 3, 2, 4, 1, 3, 2, 4, 3, 1, 2,
2, 1, 3, 4, 2, 3, 1, 4, 2, 3, 4, 1,
2, 1, 4, 3, 2, 4, 1, 3, 2, 4, 3, 1, 4, 2, 1, 3, 4, 2, 3, 1,
3, 2, 1, 4, 3, 2, 4, 1, 3, 4, 2, 1,
4, 3, 2, 1
En general, para un grado$ n $ polinomio p[x], tenemos las identidades
frobeniusCompanion[p[x], x] == generalizedFiedler[Range[n, 1, -1], p[x], x]
y
perm = Flatten[If[OddQ[n], Identity, Reverse][GatherBy[Range[n], OddQ]]];
fiedlerCompanion[p[x], x] == generalizedFiedler[perm, p[x], x]
Nos encantaría que puedieras comunicar esta noticia si lograste el éxito.