(*
Calculation of the cross ratio
*)

(*
Using this package

This program needs also the packages "Tessellate.m", "CrossRatio.m" and
"Moebius.m", available using anonymous ftp at nic.funet.fi, directory
"pub/sci/math/riemann/mathematica".

Last modified: February 8th, 1993.

Send comments and bug reports to 
  Juha Haataja, Center for Scientific Computing (jhaataja@csc.fi).
*)

(*
Initialization

Read in the necessary packages:

*)

<<CrossRatio.m
<<Moebius.m
<<Tessellate.m

(*
Defining the fundamental 18-gon

Calculate the fundamental polygon (18-gon) for plotting:
*)

polygon18 = RegularPolygon[18, 2*Pi/3, 0];
polygonpict = DrawHypPolygons[polygon18, 
	Prolog -> {AbsoluteThickness[0.2]}];

(*
Defining some routines for forming generators

Define two angles for the fundamental polygon (in degrees):
*)

alfakulma = 60;
betakulma = 10;

(*
Convert the above angles to radians:
*)

alfar = alfakulma*Pi/180;
betar = betakulma*Pi/180;

(*
Make a routine for defining generators in numerical form:
*)

genN[phi_, ksi_, alfar_:(Pi/3), betar_:(Pi/18)] := 
    Block[{coshrho = Cos[alfar]/Sin[betar], 
        sinhrho = Sqrt[coshrho^2-1]},
    N[{{-I*Exp[I*(ksi - phi)/2]*coshrho, 
        I*Exp[I*(ksi + phi)/2]*sinhrho},
        {-I*Exp[-I*(ksi + phi)/2]*sinhrho, 
        I*Exp[-I*(ksi - phi)/2]*coshrho}}, 16]]

(*
Make a routine for defining generators in symbolical form:
*)

gen[phi_, ksi_, alfar_:(Pi/3), betar_:(Pi/18)] := 
    Block[{coshrho = Cos[alfar]/Sin[betar], 
        sinhrho = Sqrt[coshrho^2-1]},
    {{-I*Exp[I*(ksi - phi)/2]*coshrho, 
        I*Exp[I*(ksi + phi)/2]*sinhrho},
        {-I*Exp[-I*(ksi + phi)/2]*sinhrho, 
        I*Exp[-I*(ksi - phi)/2]*coshrho}}]

(*
Defining some generators
Define some elements of the group (using numerical matrix representation):
*)
Ag = genN[210*Pi/180, 130*Pi/180];
Bg = genN[150*Pi/180, 230*Pi/180];
Cg = genN[330*Pi/180, 50*Pi/180];
Dg = genN[30*Pi/180, 310*Pi/180];
ABg = MGenMult[{Ag,Bg}];
Big = Inverse[Bg];
BiAig = MGenMult[{Inverse[Bg], Inverse[Ag]}];
AiBig = MGenMult[{Inverse[Ag], Inverse[Bg]}];
Aig = Inverse[Ag];
BAg = MGenMult[{Bg,Ag}];
BABiAig = MGenMult[{Bg,Ag,Inverse[Bg],Inverse[Ag]}];
DCDiCig = MGenMult[{Dg,Cg,Inverse[Dg],Inverse[Cg]}];
DCg = MGenMult[{Dg,Cg}];
Cig = Inverse[Cg];
CiDig = MGenMult[{Inverse[Cg], Inverse[Dg]}];;
DiCig = MGenMult[{Inverse[Dg], Inverse[Cg]}];;
CDg = MGenMult[{Cg,Dg}];
ABAiBig = MGenMult[{Ag,Bg,Inverse[Ag],Inverse[Bg]}];
CDCiDig = MGenMult[{Cg,Dg,Inverse[Cg],Inverse[Dg]}];

(*
Testing the generators

Define two test routines: 
*)

DrawGenTest[phi_, ksi_, plabel_String:""] :=
    Block[{gen = genN[phi, ksi], 
        pt = First[RegularPolygon[18, 2*Pi/3, 0]], 
        testpts, imagepts, middlept, middleimgpt,
        arc1pict, arc2pict, origpict, imagepict, imagearcpict},
    testpts = N[{RotatePoint[pt,phi-Pi/18], 
        RotatePoint[pt,phi+Pi/18]}];
    imagepts = ApplyMGen[gen,testpts];
    middlept = HypMiddleOfArc[testpts];
    middleimgpt = ApplyMGen[gen,middlept];
    arc1pict = DrawArcs[{testpts}, DisplayFunction -> Identity, 
        Prolog -> {AbsoluteThickness[2]}];
    arc2pict = DrawArcs[{imagepts}, DisplayFunction -> Identity, 
        Prolog -> {AbsoluteThickness[0.5]}];
    origpict = DrawPoints[{middlept}, 
        Prolog -> {AbsolutePointSize[8]},
        DisplayFunction -> Identity];
    imagepict = DrawPoints[{middleimgpt}, 
        Prolog -> {AbsolutePointSize[5]},
        DisplayFunction -> Identity];
    imagearcpict = DrawArcs[{{middlept,middleimgpt}}, 
        DisplayFunction -> Identity];
    Show[Graphics[UnitCircle], 
        arc1pict, arc2pict, imagepict, origpict, imagearcpict,
        DisplayFunction -> $DisplayFunction, PlotLabel -> plabel, 
        AspectRatio -> Automatic, PlotRange -> {{-1,1},{-1,1}}]]

DrawGenPointTest[{pt1_, pt2_}, gen_List, plabel_String:""] :=
    Block[{testpts = N[{pt1, pt2}], imagepts, 
        middlept, middleimgpt, arc1pict, arc2pict, 
        origpict, imagepict, imagearcpict},
    imagepts = ApplyMGen[gen,testpts];
    middlept = HypMiddleOfArc[testpts];
    middleimgpt = ApplyMGen[gen,middlept];
    arc1pict = DrawArcs[{testpts}, DisplayFunction -> Identity, 
        Prolog -> {AbsoluteThickness[2]}];
    arc2pict = DrawArcs[{imagepts}, DisplayFunction -> Identity, 
        Prolog -> {AbsoluteThickness[0.5]}];
    origpict = DrawPoints[{middlept},	
        Prolog -> {AbsolutePointSize[8]},
	    DisplayFunction -> Identity];
    imagepict = DrawPoints[{middleimgpt}, 
        Prolog -> {AbsolutePointSize[5]},
        DisplayFunction -> Identity];
    imagearcpict = DrawArcs[{{middlept,middleimgpt}}, 
        DisplayFunction -> Identity];
    Show[Graphics[UnitCircle], 
        arc1pict, arc2pict, imagepict, origpict, imagearcpict,
        DisplayFunction -> $DisplayFunction, PlotLabel -> plabel, 
        AspectRatio -> Automatic, PlotRange -> {{-1,1},{-1,1}}]]

(*
Give two angles to define a generator and draw a picture for testing. 
*)

phi := 210*Pi/180; ksi := 130*Pi/180;
DrawGenTest[phi, ksi, "Generaattori A"]

(*
Define two points (for example, giving the angle phi) and a generator, 
and draw a test picture. 
*)

angle := 130*Pi/180;
pt = First[RegularPolygon[18, 2*Pi/3, 0]];
testpts = N[{RotatePoint[pt,angle-Pi/18], 
    RotatePoint[pt,angle+Pi/18]}];
DrawGenPointTest[testpts, Aig, "Generaattori A^(-1)"]

(*
Calculation of the cross ratio

Define generators h1, h2 and h3 in function form using 
the matrix representation from above:
*)
h1[z_] = ApplyMGen[Aig,z];
h2[z_] = ApplyMGen[Bg,z];
h3[z_] = ApplyMGen[BAg,z];

(*
Compute the imaginary part of the cross ratio.  
Approximate computing time on a Macintosh IIfx is 4 minutes.
*)

vars = {x, y};
poly = CrossRatioPoly[{h1, h2, h3}, vars];
numpoly = N[poly, numprecision = 16];

(*
Plotting of the zero curves

Plot the zero curves of the polynomial calculated from the cross ratio 
using the ContourPlot function of Mathematica.  
Approximate computing time on a Macintosh IIfx is 1 minutes 
using resolution of 100 points.
*)

curvepict = PlotPoly[numpoly, vars, 
	pictresolution = 50];

(*
Show the combined plot:
*)

polylabel = "[I, Ai, B, BA]";
Show[curvepict, polygonpict, PlotLabel -> polylabel, 
    DisplayFunction -> $DisplayFunction, 
    AspectRatio -> Automatic, PlotRange -> {{-1,1},{-1,1}}]]

