(***********************************************************************
This file was generated automatically by the Mathematica front end.
It contains Initialization cells from a Notebook file, which typically
will have the same name as this file except ending in ".nb" instead of
".m".

This file is intended to be loaded into the Mathematica kernel using
the package loading commands Get or Needs.  Doing so is equivalent to
using the Evaluate Initialiation Cells menu command in the front end.

DO NOT EDIT THIS FILE.  This entire file is regenerated automatically 
each time the parent Notebook file is saved in the Mathematica front end.
Any changes you make to this file will be overwritten.
***********************************************************************)







<< symmetric-functions.m
<<discriminant.m;
Off[General::spell];
Off[General::spell1];




Clear[f,a,b,c,d]
f = x^4 + a x^3 + b x^2 + c x + d
Expand[f/. x -> y-a/4]








resolvantCubic[g_] := Module[{theta1, theta2,theta3,h, clh, a0, a1,a2,p,q,r,
			rulespqr},
		clg = CoefficientList[g,x];
		p = clg[[3]];
		q = clg[[2]];
		r = clg[[1]];
		rulespqr = {\[Epsilon][4] -> r, \[Epsilon][3] -> -q,  \[Epsilon][2] ->p,
		 \[Epsilon][1] ->0};
theta1 = (x[1]+x[2])(x[3]+x[4]);
	theta2 = (x[1] + x[3])(x[2] + x[4]);
		theta3 = (x[1] + x[4])(x[2] + x[3]);
h = Expand[(y-theta1)(y-theta2)(y-theta3)	];
clh = CoefficientList[h,y];
NumbVars = n = 4;
			X = Array[x,n]; 
a0 = elementaryExpand[clh[[1]]] /. rulespqr;
a1= elementaryExpand[clh[[2]]] /. rulespqr;
a2 = elementaryExpand[clh[[3]]] /. rulespqr;
h = x^3 + a2 x^2 + a1 x + a0
		]



IrreducibleQ[f_] := Module[{f1},
		f1 = f*Denominator[Together[f]];
		Factor[f1]===f1	
]
galois[f_] := Module[{clf,clff,ff,  g,h,h1, hroots, theta, clg, p,q,r},
		clf = CoefficientList[f,x];
	
		If[Length[clf] !=5, Print[" Polynomial is not quartic."];
			Return[]];
	If[Not[IrreducibleQ[f]], Print[ "Polynomial is not irreducible."];Return[]
	];
			ff = Expand[(1/clf[[5]])*f];
		clff = CoefficientList[ff,x];
	 g = Expand[ff /.x -> x-clf[[4]]/4];
			clg = CoefficientList[g,x];
		p = clg[[3]];
		q = clg[[2]];
		r = clg[[1]];
		h = Together[resolvantCubic[g]];
		h1 = h*Denominator[h];
		disc = Discriminant[f];
	If[
	IntegerQ[Sqrt[disc]],
		If[
			IrreducibleQ[h1], Print ["Galois group is A_4"]; Return[],
			Print ["Galois group is V"]; Return[]
			] (*endif*),

			If[
					IrreducibleQ[h1], Print[ "Galois group is S_4"]; Return[],
				Print ["Galois group is Z_4 or D_4"]
			     ] (*endif*)
	
	] (*endif*);

		If[disc < 0, Print["Negative Discriminant implies Galois group is D_4."];
      Return[]
			];
		hroots = x /. Solve[h1==0,x];
theta = Select[hroots,( IntegerQ[#] || Head[#]==Rational)&][[1]];
		clg = CoefficientList[g,x];
		p = clg[[3]];
		q = clg[[2]];
		r = clg[[1]];
H = (x^2 + theta)(x^2 + (theta-p) x + r);
	Hroots = x/.Solve[H==0,x];
		Print["Roots of resolvant cubic are:     ",
				hroots];
		Print["Square root of discriminant is     ",
			Sqrt[disc]];
		Print["Roots of auxilliary polynomial H are:    ",
				Hroots];
		]






















