polynomialmatrices.nb

单模多项式矩阵的分解算法

                  otherwise\ lower\ the\ degree\ of\ these\ non - 
                    zero\ elements*) If[
                  Onenonzero[f[\([Range[k, l + p], kcl]\)], x], done = True, 
                  For[i = k + 1, i \[LessEqual] l + p, \(i++\), 
                    If[f[\([i, kcl]\)] =!= 0, 
                      lambda = 
                        PolynomialQuotient[f[\([i, kcl]\)], f[\([k, kcl]\)], 
                          x]; \[IndentingNewLine]f = 
                        ReplacePart[f, 
                          Expand[f[\([i]\)] - f[\([k]\)] \((lambda)\), x], 
                          i]; \[IndentingNewLine]v = 
                        ReplacePart[v, 
                          Expand[v[\([i]\)] - v[\([k]\)] \((lambda)\), x], 
                          i]]] (*endfor*) ] (*endif*) ] (*endwhile*) \ \(kcl\
++\)];  (*endfor*)  (*Count\ the\ number\ of\ last\ zero\ rows\ in\ f*) j = 
            l + p; \[IndentingNewLine]While[
            j \[GreaterEqual] 1 && f[\([j]\)] === Table[0, {m}], 
            j = j - 1]; \[IndentingNewLine]If[
            ch, {a, v, 
                f} = {a, v, f} /. {x^\((n : _)\) \[Rule] x^\(-n\), 
                  x \[Rule] x^\(-1\)}]; \[IndentingNewLine]lambda = 
            v[\([Range[j + 1, l + p], 
                Range[1, 
                  l]]\)]; \[IndentingNewLine] (*Return\ the\ right\ GCD\ and\ \
\(\(if\)\([\)\(Flatten[lambda] =!= {}\ return\ also\ a\ left\ lcm\)\)*) {If[
              m > \((p + l)\), 
              Transpose[
                Flatten[{f[\([Range[1, p + l], Range[1, m]]\)], 
                    Table[0, {m - p - l}, {m}]}, 1]], 
              f[\([Range[1, m], Range[1, m]]\)]], 
            If[Flatten[lambda] =!= {}, 
              If[m < p + l, EliminateDep[Expand[lambda . a, x], x], 
                Expand[lambda . a, x], {}], {}]}];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(\(RGCD[at_, bt_, xt_: {}] := 
        Module[{a = at, b = bt, x = xt}, 
            If[x === {} && Length[Variables[{a, b}]] > 1, 
              Message[General::badarg]; \[IndentingNewLine]Return[$Failed], 
              If[x === {}, 
                x = Variabile[{a, 
                      b}]]]; \[IndentingNewLine]\(If[# =!= $Failed, \
#[\([1]\)], #] &\)[AuxRGCDlcm[a, b, x]]] /; 
          MatrixQ[at] && 
            MatrixQ[bt] && \(Dimensions[at]\)[\([2]\)] \[Equal] \(Dimensions[
                  bt]\)[\([2]\)];\)\(\ \)\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(Llcm[at_, bt_, xt_: {}] := 
        Module[{a = at, b = bt, x = xt}, 
            If[x === {} && Length[Variables[{a, b}]] > 1, 
              Message[General::badarg]; \[IndentingNewLine]Return[$Failed], 
              If[x === {}, 
                x = Variabile[{a, 
                      b}]]]; \[IndentingNewLine]\(If[# =!= $Failed, \
#[\([2]\)], #] &\)[AuxRGCDlcm[a, b, x]]] /; 
          MatrixQ[at] && 
            MatrixQ[bt] && \(Dimensions[at]\)[\([2]\)] \[Equal] \(Dimensions[
                  bt]\)[\([2]\)];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(RCoprime[at_, bt_, xt_: {}] := 
        Module[{a = at, b = bt, x = xt, d}, 
            If[x === {} && Length[Variables[{a, b}]] > 1, 
              Message[General::badarg]; \[IndentingNewLine]Return[$Failed], 
              If[x === {}, x = Variabile[{a, b}]]]; \[IndentingNewLine]If[
              Not[ExtPolQ[{a, b}, x]], Message[General::pol]; 
              Return[$Failed]]; \[IndentingNewLine]If[
              Not[Apply[
                  And, \(PolynomialQ[#, x] &\) /@ Flatten[{a, b}]]], \({a, 
                    b} = {a, 
                      b} /. {\((x^\((n : _)\))\) \[Rule] \((x^\(-n\))\)};\)]; \
\[IndentingNewLine]d = 
              Det[RGCD[a, b]]; \[IndentingNewLine]\((FreeQ[d, x] && 
                d \[NotEqual] 0)\)] /; 
          MatrixQ[at] && 
            MatrixQ[bt] && \(Dimensions[at]\)[\([2]\)] \[Equal] \(Dimensions[
                  bt]\)[\([2]\)];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(LCoprime[at_, bt_, xt_: {}] := 
        Module[{a = at, b = bt, x = xt, d}, 
            If[x === {} && Length[Variables[{a, b}]] > 1, 
              Message[General::badarg]; \[IndentingNewLine]Return[$Failed], 
              If[x === {}, x = Variabile[{a, b}]]]; \[IndentingNewLine]If[
              Not[ExtPolQ[{a, b}, x]], Message[General::pol]; 
              Return[$Failed]]; \[IndentingNewLine]If[
              Not[Apply[
                  And, \(PolynomialQ[#, x] &\) /@ Flatten[{a, b}]]], \({a, 
                    b} = {a, 
                      b} /. {\((x^\((n : _)\))\) \[Rule] \((x^\(-n\))\)};\)]; \
\[IndentingNewLine]d = 
              Det[LGCD[a, b]]; \[IndentingNewLine]\((FreeQ[d, x] && 
                d \[NotEqual] 0)\)] /; 
          MatrixQ[at] && 
            MatrixQ[bt] && \(Dimensions[at]\)[\([1]\)] \[Equal] \(Dimensions[
                  bt]\)[\([1]\)];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(LDivision[at_, bt_, xt_: {}] := 
        Module[{a = at, b = bt, x = xt, l, m, u, esp, lambda, delta, 
            ch = False}, 
          If[x === {} && Length[Variables[{a, b}]] > 1, 
            Message[General::badarg]; \[IndentingNewLine]Return[$Failed], 
            If[x === {}, x = Variabile[{a, b}]]]; \[IndentingNewLine]If[
            Not[MatrixQ[at] && 
                MatrixQ[
                  bt] && \(Dimensions[at]\)[\([1]\)] === \(Dimensions[
                      bt]\)[\([1]\)] === \(Dimensions[bt]\)[\([2]\)] && 
                Det[Coefficient[b, x, Max[Exponent[b, x]]]] =!= 0], 
            Message[LDivision::badarg, "\<LDivision\>", "\<l x l\>"]; 
            Return[$Failed]]; \[IndentingNewLine]If[Not[ExtPolQ[{a, b}, x]], 
            Message[General::pol]; Return[$Failed]]; \[IndentingNewLine]If[
            Not[Apply[And, \(PolynomialQ[#, x] &\) /@ Flatten[{a, b}]]], {a, 
                b} = {a, 
                  b} /. {\((x^\((n : _)\))\) \[Rule] \((x^\(-n\))\)}; \
\[IndentingNewLine]ch = True]; \[IndentingNewLine] (*Inizialization : 
              delta\ is\ the\ inverse\ of\ the\ leading\ coefficient\ matrix\ \
of\ matrix\ b*) \[IndentingNewLine]{l, m} = 
            Dimensions[a]; \[IndentingNewLine]u = 
            Table[0, {l}, {m}]; \[IndentingNewLine]delta = 
            Inverse[Coefficient[b, x, 
                Max[Exponent[b, x]]]]; \[IndentingNewLine] (*Main\ \(loop : 
                go\ on\ until\ deg[a] < deg[b]\)*) While[
            Max[Exponent[a, x]] \[GreaterEqual] Max[Exponent[b, x]], 
            lambda = 
              delta . Coefficient[a, x, 
                  Max[Exponent[a, x]]]; \[IndentingNewLine]esp = 
              Max[Exponent[a, x]] - 
                Max[Exponent[b, 
                    x]]; \[IndentingNewLine] (*Decrease\ the\ degree\ of\ \
matrix\ a*) a = Expand[a - b . \((lambda*x^esp)\), x]; \[IndentingNewLine]u = 
              Expand[u + lambda*x^esp, x]]; \[IndentingNewLine]If[
            ch, {u, a} = {u, a} /. {x^\((n : _)\) \[Rule] x^\(-n\), 
                  x \[Rule] x^\(-1\)}]; \[IndentingNewLine]{u, 
            a}];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(LQuotient[at_, bt_, xt_: {}] := 
        Module[{a = at, b = bt, 
            x = xt}, \(If[# =!= $Failed, #[\([1]\)], #] &\)[
            LDivision[a, b, x]]];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(LRemainder[at_, bt_, xt_: {}] := 
        Module[{a = at, b = bt, 
            x = xt}, \(If[# =!= $Failed, #[\([2]\)], #] &\)[
            LDivision[a, b, x]]];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(RDivision[at_, bt_, xt_: {}] := 
        Module[{a = at, b = bt, x = xt, l, m, u, esp, lambda, delta, 
            ch = False}, 
          If[x === {} && Length[Variables[{a, b}]] > 1, 
            Message[General::badarg]; \[IndentingNewLine]Return[$Failed], 
            If[x === {}, x = Variabile[{a, b}]]]; \[IndentingNewLine]If[
            Not[MatrixQ[at] && 
                MatrixQ[
                  bt] && \(Dimensions[at]\)[\([2]\)] === \(Dimensions[
                      bt]\)[\([1]\)] === \(Dimensions[bt]\)[\([2]\)] && 
                Det[Coefficient[bt, x, Max[Exponent[bt, x]]]] =!= 0], 
            Message[LDivision::badarg, "\<RDivision\>", "\<m x m\>"]; 
            Return[$Failed]]; \[IndentingNewLine]If[Not[ExtPolQ[{a, b}, x]], 
            Message[General::pol]; Return[$Failed]]; \[IndentingNewLine]If[
            Not[Apply[And, \(PolynomialQ[#, x] &\) /@ Flatten[{a, b}]]], {a, 
                b} = {a, 
                  b} /. {\((x^\((n : _)\))\) \[Rule] \((x^\(-n\))\)}; \
\[IndentingNewLine]ch = True]; \[IndentingNewLine] (*Some\ inizialization, 
            delta\ is\ the\ inverse\ of\ the\ leading\ coefficient\ matrix\ \
of\ matrix\ b*) {l, m} = Dimensions[a]; \[IndentingNewLine]u = 
            Table[0, {l}, {m}]; \[IndentingNewLine]delta = 
            Inverse[Coefficient[b, x, 
                Max[Exponent[b, x]]]]; \[IndentingNewLine] (*Main\ \(loop : 
                go\ on\ until\ deg[a] < deg[b]\)*) While[
            Max[Exponent[a, x]] \[GreaterEqual] Max[Exponent[b, x]], 
            lambda = 
              Coefficient[a, x, Max[Exponent[a, x]]] . 
                delta; \[IndentingNewLine]esp = 
              Max[Exponent[a, x]] - 
                Max[Exponent[b, 
                    x]]; \[IndentingNewLine] (*Decrease\ the\ degree\ of\ \
matrix\ a*) a = Expand[a - \((lambda*x^esp)\) . b, x]; \[IndentingNewLine]u = 
              Expand[u + lambda*x^esp, x]]; \[IndentingNewLine]If[
            ch, {u, a} = {u, a} /. {x^\((n : _)\) \[Rule] x^\(-n\), 
                  x \[Rule] x^\(-1\)}]; \[IndentingNewLine]{u, 
            a}];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(RQuotient[at_, bt_, xt_: {}] := 
        Module[{a = at, b = bt, 
            x = xt}, \(If[# =!= $Failed, #[\([1]\)], #] &\)[
            RDivision[a, b, x]]];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(RRemainder[at_, bt_, xt_: {}] := 
        Module[{a = at, b = bt, 
            x = xt}, \(If[# =!= $Failed, #[\([2]\)], #] &\)[
            RDivision[a, b, x]]];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(Rank[at_] := 
        Module[{a = at, x = xt, p, m}, {p, m} = 
              Dimensions[a]; \[IndentingNewLine]a = 
              RowReduce[a]; \[IndentingNewLine]Return[
              p - Count[a, n_ /; n === Table[0, {m}]]]] /; 
          MatrixQ[at] || Message[General::mtrx, "\<Rank\>"];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(FullRowRankQ[at_] := 
        Module[{p = \(Dimensions[at]\)[\([1]\)]}, Return[Rank[at] === p]] /; 
          MatrixQ[at] || 
            Message[General::mtrx, "\<FullRowRankQ\>"];\)\)], "Input",
  InitializationCell->True],

Cell[BoxData[
    \(\(PolynomialColumnReduce[at_, xt_: {}] := 
        Module[{a = at, x = xt, u, p, m, Ahc, v, deg, degmax, k, ch = False}, 
            If[x === {}, 
              If[Length[Variables[a]] > 1, 
                Message[General::badarg]; \[IndentingNewLine]Return[$Failed], 
                x = Variabile[a]]]; \[IndentingNewLine]If[Not[ExtPolQ[a, x]], 
              Message[General::pol]; Return[$Failed]]; \[IndentingNewLine]If[
              Not[Apply[And, \(PolynomialQ[#, x] &\) /@ Flatten[a]]], 
              a = a /. {\((x^\((n : _)\))\) \[Rule] \((x^\(-n\))\)}; \
\[IndentingNewLine]ch = 
                True]; \[IndentingNewLine]If[\(! FullRowRankQ[
                  Transpose[a]]\), Message[PolynomialColumnReduce::badarg]; 
              Return[$Failed]]; \[IndentingNewLine]{p, m} = 
              Dimensions[a]; \[IndentingNewLine]u = 
              IdentityMatrix[
                m]; \[IndentingNewLine] (*Ahc\ is\ the\ matrix\ composed\ by\ \
the\ coefficients\ of\ the\ highest\ degree\ terms\ within\ each\ column*) 
              Ahc = Transpose[\(Table[
                      Coefficient[#[\([i]\)], x, 
                        Max[Exponent[#[\([i]\)], x]]], {i, 1, m}] &\)[
                  Transpose[
                    a]]]; \[IndentingNewLine] (*go\ on\ until\ Ahc\ has\ full\
\ column\ rank\ \((i . e . a\ is\ column\ reduced)\)*) 
              While[\(! FullRowRankQ[Transpose[Ahc]]\), 
              v = \(NullSpace[Ahc]\)[\([1]\)]; \[IndentingNewLine]deg = 
                Table[Max[Exponent[\(Transpose[a]\)[\([i]\)], x]], {i, 1, 
                    m}]; \[IndentingNewLine]k = \(Flatten[
                    Position[deg, 
                      degmax = 
                        Max[Table[
                            Exponent[\(Transpose[a]\)[\([i]\)]*v[\([i]\)], 
                              x], {i, 1, 
                              m}]]]]\)[\([1]\)]; \[IndentingNewLine] (*lower\ \
the\ degree\ of\ column\ k*) {u, a} = \({u . #, a . #} &\)[
                  Transpose[
                    ReplacePart[IdentityMatrix[m], 
                      Table[v[\([i]\)]*x^\((degmax - deg[\([i]\)])\), {i, 1, 
                          m}], k]]]; \[IndentingNewLine]Ahc = 
                Transpose[\(Table[
                        Coefficient[#[