Disciminant and Resultant

Programming

Off[General::spell1]\(<< \ "Algebra`SymmetricPolynomials`"
<< \ 
        "DiscreteMath`Combinatorica`"\)\(Off[General::"spell1"]


    
 (*\ Define\ elementary\ symmetric\ polynomials\ *) \)Clear[eps]\(eps[X_, 0]\  = \ 0; 

    eps[X_, \ k_Integer]\  := \ 

      If[k <= \ Length[X], 
SymmetricPolynomial[X, k]\ , 0]\)\(eps[X_, \ lambda_List]\  := \ 
      Expand[Product[eps[X, \ lambda[[i]]], \ {i, \ 1, \ Length[lambda]}]]

    \)\(power[X_List, lambda_List]\  := \ \ 
      If[Length[lambda]\  <= \ Length[X], \ 
        Product[X[[i]]^lambda[[i]], {i, 1, Length[lambda]}], 0]


    
 (*Expansion\ in\ elementary\ symmetric\ functions*) \)Clear[logg]logg[x[k_],  k_]  :=  1logg[x[k_]^a_,  k_]  :=  alogg[y___*x[k_],  k_]  :=  1logg[y___*x[k_]^a_,  k_]  :=  alogg[z_, k_]  :=  0  /;  FreeQ[z,  x[k]]\(	llambda[z_]\  := \ Table[logg[z, k], \ {k, 1, NumbVars}]\)myorderQ[a_, b_]  :=  OrderedQ[llambda[a],  llambda[b]]mysort[p_]  :=  Sort[Apply[List,  p],   myorderQ[{#1,  #2}]&]\(leadingTerm[p_]\  := 
		
      If[Head[p] === Plus, \ \(mysort[p]\)[[1]], p]\)leadingPartition[p_]  :=  llambda[leadingTerm[p]]\(leadingMonomial[p_]\  := \ 
      Module[{a}, 
		a = \ leadingPartition[p]; 
		
        Product[x[i]^a[[i]], \ {i, 1, NumbVars}]]\)leadingCoefficient[p_]  :=  leadingTerm[p]/leadingMonomial[p]\(Clear[ϵ]

\)\(elementaryExpand[p_]\  := \ 
      Module[{p1, plist, \ ϵϵ}, 
		n\  = \ NumbVars; 

        		ϵϵ := \ Array[ϵ, \ n]; 
		
        p1 = \ Expand[p]; 
	plist\  = \ {}; 
		
        While[Not[p1\  === \ 0], 
		
          plist\  = \ 
            Append[plist, 
              \ {leadingCoefficient[p1], 
                TransposePartition[leadingPartition[p1]]}]; 
			
          p1\  = \ 
			
            Expand[p1\  - \ 
                leadingCoefficient[p1]*
                  eps[X, TransposePartition[leadingPartition[p1]]]]; 

          			]; 

	
        plist\ \  = 
          Apply[Plus, \ 
            Map[#[[1]]*
                  Product[\ 
                    ϵϵ[[#[[2, i]]]]\ \ , {i, 1, 
                      Length[#[[2]]]}]&, plist]]
		]


    
 (*\ Compute\ monomial\ symmetric\ function\ corresponding\ to\ a\ 
        partition . \ An\ alphabet\ of\ variables\ must\ be\ 
        \(specified . \)*) 
\)\(monomialSymmetric[X_, \ lambda_List]\  := \ 
      Module[{permlist, mu}, 
		mu\  = \ lambda //. \ {a__, 0}\  -> \ {a}; 
        
	If[Length[mu]\  > \ Length[X], \ Return[0]]; 
		
        While[Length[mu]\  < \ Length[X], \ mu\  = \ Append[mu, 0]]; 
		
        permlist\  = \ DistinctPermutations[mu]; 
		
        permlist\  = \ Apply[Plus, Map[\ power[X, #]\ &\ , \ permlist]]
]


    


\)\(Discr[X_]\  := 

      Product[X[[i]] - X[[j]], 
          \ {i, 1, Length[X] - 1}, {j, i + 1, Length[X]}]^2


	
\)

The discriminant

The discriminant polynomial is defined as follows:

Discr[X_] := 
      ((((∏_(i = 1)^(Length[X] - 1
                ))(∏_(j = i + 1)^(Length[X]))(
                X[[i]] - 
                  X[[j]])))^2)

The discriminant polynomial is a symmetric polynomial, so can be expanded in the elementary symmetric polynomials.
Here is the discriminant polynomial in 4 variables and its expansion in elementary symmetric polynomials.  This would be rather painful to compute by hand.

\(n\  = \ \ \(NumbVars = \ 4\); 
X = Array[x, n]; 
Discr[X]\)elementaryExpand[Discr[X]]

Here is the same thing in 5 variables; even my computer found it somewhat painful to do this computation.

\(n\  = \ \ \(NumbVars = \ 5\); 
X = Array[x, n]; 
Discr[X]\)elementaryExpand[Discr[X]]

The discriminant of a polynomial of degree n is defined to be the leading coefficient raised to the 2n-2 power times the discriminant polynomial in the roots.  Let us consider first the case of a monic polynomial.  Here the discriminant is a symmetric polynomial in the roots, and therefore a polynomial in the coefficients.  One can compute the discriminant by first computing the expansion in elementary symmetric polynomials of the discriminant polynomial in n variables and then substituting
 (Subscript[ϵ, k  ]) =   
              (((-1))^(n - k)) (Subscript[a, n - k])  , where f(x) = (∑_(k = 0)^n) (Subscript[a, k]) (x^k)
 
 It is rather inefficient to compute the expansion in elementary symmetric functions of the disriminant polynomial  for n ≥ 5,  but once the expansion has been done once for a given n, it can be remembered and used for any polynomial of degree n.  So after an initial investment, the method becomes rather efficient.
 This method of computing the discriminant is available here via the command
 discriminant[f].

Programming

Clear[disc]\(disc[n_]\  := \ 
      \(disc[n]\  = \ \ 
        Module[{a}, 
				NumbVars\  = \ n; 
			X\  = \ Array[x, n]; 
          
		a\  = \ Discr[X]; 
			elementaryExpand[a]
			]\)\)

Clear[discriminant]\(discriminant[f_]\  := \ 
      Module[{cl, \ n, \ signlist, rules, cmax}, 

        cl\  = \ CoefficientList[f, x]; 

        n\  = \ \(NumbVars\  = \ Length[cl] - 1\); 
		
        cmax\  = \ cl[\([n + 1]\)]; 
		cl\  = \ \((1/cmax)\)*cl; 

        signlist\  = \ Table[\((\(-1\))\)^\((n - i + 1)\), \ {i, 1, n + 1}]; 
        
cl\  = \ cl*signlist; 

        rules\  = \ 
          Table[\ ϵ[i] -> \ 
              cl[\([n - i + 1]\)]\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ , {i, 1, n}]; 
        
cmax^\((2  n - 2)\)\ \ \((disc[n] //. \ rules\ )\)
		]
\)

Examples:

f  =  3  x^4  -  17 x^2  +  14discriminant[f]

Here is a quintic example.  The first time this is computed, a lot of time will be needed to compute the expansion of the discriminant polynomial.  Subsequent computations for quintics will be faster.

g  =  2  x^5  -  4  x^3  +  2  x  - 3discriminant[g]

The resultant of two polynomials is a polynomial in the coefficients  of the two polynomials which is zero precisely when the two polynomials have a non-trivial common factor.  The resultant can be computed as a determinant involving coefficeints of  the two polynomials.   Details can be found in many texts, including  F. Goodman, Algebra, Abstract and Concrete, Prentice Hall, 1998.  The discriminant of a polynomial  f can be computed as  plus or minus the resultant of   f    and      f'.   This method of computing the discriminant is available here via the command 
Discriminant[f].

Programming  (The  code is taken from a program posted on the web by faculty members at Scarborough College, University of Toronto)

\(\(
 (*\ PHYSICAL\ SCIENCES\ DIVISION, \ SCARBOROUGH\ COLLEGE, \ 
      UNIVERSITY\ OF\ TORONTO\ *) 


    Discriminant::usage\  = \ 
      "Discriminant[f] computes the discriminant of the polynomial
						f[x]. The built-in function Resultant is replaced by a more
						efficient function  resultant ."; 
						\ 

    stagger[a_List, \ b_List]\  := \ 
      Module[{i, \ j, \ m, \ n}, 
				n\  = \ Length[a]\  - 1; 
				
        m\  = \ Length[b]\  - 1; 
				
        Table[Table[
            If[\((i\  >= \ j)\)\  && \ \((i\  < \ j\  + \ n\  + \ 1)\), 

              \ \ 				a[\([i + 1 - j]\)], \ 0], \ {j, \ m}, 
            \ {i, \ n + m}]]
\ \ 				]; 


    resultant[f_, \ g_]\  := \ 
      Module[{aa, \ bb, \ v, \ w}, 
			
        aa\  = \ Reverse[CoefficientList[f, x]]; 
			
        bb\  = \ Reverse[CoefficientList[g, x]]; 
			
        v\  = \ stagger[aa, \ bb]; 
			w\  = \ stagger[bb, \ aa]; 
			
        Return[Det[Join[v, \ w]]]
			]; \  (*replaces\ Resultant*) 


    Discriminant[f_]\  := \ 
      Module[{cl}, 
			cl\  = \ CoefficientList[f, \ x]; 
			
        Return[Expand[

            \((\((\(-1\))\)^Binomial[Length[cl] - 1, \ 2])\) 
              resultant[f, \ D[f, \ x]]\ /\ Last[cl]]]
\ \ 			]; \)\)

g  =  2  x^5  -  4  x^3  +  2  x  - 3Discriminant[g]