

(*********************************************************************

	FinitePlanes.m

	Program by Vedran Krcadinac, April 1996.
	Department of Mathematics, University of Zagreb

	Email: krcko@student.math.hr

**********************************************************************)




BeginPackage["FinitePlanes`"]



FinitePlanes::usage =
  "FinitePlanes.m is a package that implements finite projective and affine planes in Mathematica."

LoadFF::usage =
  StringJoin["LoadFF[",FromCharacterCode[34],"name",FromCharacterCode[34],"] loads a finite field into Mathematica. One can also load quasifields."]

FFPlus::usage = 
  "FFPlus[x,y] adds the elements x,y in the currently loaded finite field."

FFTimes::usage =
  "FFTimes[x,y] multiplies the elements x,y in the currently loaded finite field."

FFOrder::usage =
  "FFOrder is the order of the currently loaded finite field."

ProjectivePlane::usage =
  "ProjectivePlane returns a projective plane constructed from the currently loaded finite field."

DualProjectivePlane::usage = 
  "DualProjectivePlane constructs a plane dual to the one obtained from ProjectivePlane. If the construction starts from a finite field, the two planes coincide."

Points::usage = 
  "Points returns a list of points of the projective plane to construct, i.e. vectors that span one-dimensional subspaces of the three-dimensional vector space over the currently loaded finite field."

AffinePlane::usage =
  "AffinePlane returns an affine plane constructed from the currently loaded finite field."

DualAffinePlane::usage =
  "DualAffinePlane returns an affine plane dual to the one obtained from AffinePlane. If the construction starts from a finite field, the two planes coincide."

LeftDirections::usage = 
  "LeftDirections returns a list of one dimensional subspaces of the two-dimensional left vector space over the currently loaded finite field."

RightDirections::usage = 
  "RightDirections returns a list of one dimensional subspaces of the two-dimensional right vector space over the currently loaded finite field."

Normalize::usage =
  "Normalize is a transformation rule that converts ordered pairs constituting an affine plane to integers."

Paint::usage =
  "Paint[ap] , Paint[ls] makes a picture of the affine plane ap or the list of mutually orthogonal latin squares ls, respectively."

Color::usage =
  "Color is a function that determines how Paint colors pictures of affine planes and latin squares."

Color9::usage =
  "My favourite coloring for the affine plane of order 9."

BlackAndWhite::usage =
  "A black and white coloring for affine planes and latin squares."

ProjectiveToAffine::usage =
  "ProjectiveToAffine[pp,k] converts the projective plane pp to an affine plane by deleting the k-th line and all of its points."

AffineToProjective::usage =
  "AffineToProjective[ap] converts the affine plane ap to a projective plane by adding a line at infinity."

LatinSquares::usage =
  "LatinSquares returns a complete list of mutually orthogonal latin squares constructed from the currently loaded finite field."

AffineToLatin::usage =
  "AffineToLatin[ap] converts the affine plane ap to a complete list of mutually orthogonal latin squares."

OrthoTest::usage =
  "OrthoTest[ls] checks if the latin squares in the list ls are mutually orthogonal."

IncidenceMatrix::usage =
  "IncidenceMatrix[pp] , IncidenceMatrix[ap] returns the incidence matrix of the projective (affine) plane pp (ap), respectively."

TestMatrix::usage =
  "An incidence matrix M represents a projective plane iff M.Transpose[M] == TestMatrix."

Vee::usage =
  "Vee[plane,A,B] is the unique line through the points A, B in plane."

Vee::samearg =
  "Attempt to join point with itself."

Wedge::usage =
  "Wedge[plane,a,b] is the intersection of the lines a, b of plane."

Wedge::samearg =
  "Attempt to intersect line with itself."

Levi::usage =
  "Levi[plane] returns the Levi graph of plane."

WriteGraph::usage = "WriteGraph[g,f] writes graph g to file f using an edge list representation."


Begin["`Private`"]    


(*  Load Operations in a Finite Field  *)

LoadFF[name_] :=
 ( Clear[FFPlus,FFTimes]; Get[name]; )


(*  Construction of Projective Planes   *)

Points :=
  Join[{{0,0,1}},Table[{0,1,i},{i,0,FFOrder-1}],
       Flatten[Table[{1,i,j},{i,0,FFOrder-1},{j,0,FFOrder-1}],1]]

FFInner[l1_,l2_] := 
  Inner[FFTimes,l1,l2,FFPlus]

ProjectivePlane :=
  Module[{po,p,x,i} , po = Points; Do[p[i] = po[[i]]; ,{i,1,Length[po]}];
         Table[Flatten[Position[po,x_List /; FFInner[p[i],x]==0,{1}]],
               {i,1,Length[po]}]      
        ] 

DualProjectivePlane :=
  Module[{po,p,x,i} , po = Points; Do[p[i] = po[[i]]; ,{i,1,Length[po]}];
         Table[Flatten[Position[po,x_List /; FFInner[x,p[i]]==0,{1}]],
               {i,1,Length[po]}]      
        ] 


(*  Construction of Affine Planes  *)


LeftSpan[v_] := Table[FFTimes[i,v],{i,0,FFOrder-1}]

RightSpan[v_] := Table[FFTimes[v,i],{i,0,FFOrder-1}]

LeftDirections := 
  Map[LeftSpan,Join[{{0,1}},Table[{1,i},{i,0,FFOrder-1}]]] 

RightDirections :=
  Map[RightSpan,Join[{{0,1}},Table[{1,i},{i,0,FFOrder-1}]]]  

Parallels[dir_] :=
  If[MemberQ[dir,{0,1}] ,
     Table[ Map[FFPlus[#,{i,0}] & , dir] , {i,0,FFOrder-1}] ,
     Table[ Map[FFPlus[#,{0,i}] & , dir] , {i,0,FFOrder-1}]
    ]

AffinePlane := Module[{d}, d = RightDirections;
    Table[Parallels[d[[j]]], {j, 1, FFOrder+1}]]

DualAffinePlane := Module[{d}, d = LeftDirections;
    Table[Parallels[d[[j]]], {j, 1, FFOrder+1}]]

Normalize := {x_Integer,y_Integer} -> 1+x+FFOrder*y;


(*  Visualisation of Affine Planes  *)

Square[{x_,y_}] := {Polygon[{{x,y},{x+1,y},{x+1,y+1},{x,y+1}}],
 {GrayLevel[0],Line[{{x,y},{x+1,y},{x+1,y+1},{x,y+1},{x,y}}]}}

MakePicture[Af_,color_] :=
  Table[ Graphics[   Table[ {color[j] ,
         Table[ Square[ Af[[i,j,k]] ] , {k,1,FFOrder}] } ,
         {j,1,FFOrder}],AspectRatio->1 ], {i,1,FFOrder+1}  ] 

ToMatrix[x_List] :=
  Module[ {l,d},
          l = Length[x];
          d = Ceiling[N[Sqrt[l]]];
          Join[Partition[x,d],{Take[x,Floor[N[l/d]]*d-l]}]
        ]

ToMatrix[x_List ] := 
  Append[Partition[x,3],{Graphics[{}],Last[x],Graphics[{}]}] /; Length[x] == 10

Paint[af_ /; Depth[af] == 5,opt___] :=
 Show[GraphicsArray[ToMatrix[
  MakePicture[af,Color /. {opt} /. Options[Paint] ]]]]

Options[Paint] = { Color -> (Hue[(#-1)/(FFOrder-1)*.8] &) };   

BlackAndWhite = (GrayLevel[(#-1)/(FFOrder-1)] &)

Color9[1] = RGBColor[1., 0., 0.] 
Color9[2] = RGBColor[1., 0.5, 0.]
Color9[3] = RGBColor[1., 1., 0.]
Color9[4] = RGBColor[0., 1., 0.]
Color9[5] = RGBColor[0, 0.65, 0]
Color9[6] = RGBColor[0., 1., 1.]
Color9[7] = RGBColor[0., 0., 1.]
Color9[8] = RGBColor[0, 0, 0.65]
Color9[9] = RGBColor[1., 0., 1.]


(*  Relation between Projective and Affine Planes  *)

AffineToProjective[Af_] :=
  Module[ {i,j,a,b},
          a = Af /. Normalize;
          b = Table[Transpose[Join[Transpose[ a[[i]] ],
                             {Table[i+FFOrder^2,{j,1,FFOrder}]}
                                  ]
                             ] , {i,1,FFOrder+1}
                   ];
          a = Flatten[b,1];
          Join[a,{Table[i+FFOrder^2,{i,1,FFOrder+1}]}]
        ]

ProjectiveToAffine[pp_,pos_] :=
  Module[ {line} ,
          line = pp[[pos]];
          DeleteCases[Delete[pp,pos] , x_Integer /;
                      MemberQ[line,x] , -1          ]
        ]              


(*  Construction of Latin Squares  *)
 
AffineToLatin[af_] :=
  Table[MakeSquare[af[[i]] /.
        {x_Integer,y_Integer}->{x+1,y+1}],{i,3,FFOrder+1}]

MakeSquare[x_] :=
  Module[ {sq,i,j},
          sq = Table[0,{i,1,FFOrder},{j,1,FFOrder}];
          For[i=1,i<=FFOrder,i++,
              For[j=1,j<=FFOrder,j++,
                  sq = ReplacePart[sq,i,x[[i,j]] ]
                 ]
             ];
          sq
        ]

LatinSquares := AffineToLatin[AffinePlane]


(*  Orthogonality Test  *)

Superimpose[sq1_, sq2_] :=
  Table[{sq1[[i,j]], sq2[[i,j]]}, {i, 1, Dimensions[sq1][[1]]},
   {j, 1, Dimensions[sq1][[2]]}]

Test[x_, y_] := Sort[Flatten[Superimpose[x, y], 1]]

OrthoTest[sq_] :=
 Module[{t,l,i,j},
        t = Flatten[Table[{i,j},{i,1,FFOrder},{j,1,FFOrder}],1];
        l = {};
        For[i=1,i<FFOrder-1,i++,
            For[j=i+1,j<=FFOrder-1,j++,
                AppendTo[l,Test[sq[[i]],sq[[j]]] == t] ]
           ];
        l
       ]


(*  Visualisation of Latin Squares  *)

Square[x_,y_,d_] :=
 { Polygon[{{x-d/2,y-d/2},{x+d/2,y-d/2},{x+d/2,y+d/2},
   {x-d/2,y+d/2}}], {GrayLevel[0] , Thickness[.001] ,
    Line[{{x-d/2,y-d/2},{x+d/2,y-d/2},{x+d/2,y+d/2},
    {x-d/2,y+d/2},{x-d/2,y-d/2}}] }
 }

Square[x_,y_,1] :=
  { Polygon[{{x-.5,y-.5},{x+.5,y-.5},{x+.5,y+.5},{x-.5,y+.5}}],
     {GrayLevel[0] , Thickness[.005] , Line[{{x-.5,y-.5},
     {x+.5,y-.5},{x+.5,y+.5},{x-.5,y+.5},{x-.5,y-.5}}] }
  }  

LatinPicture[sq_,color_] :=
  Table[ {color[(sq[[k,j,i]])] ,
          Square[i,j,(FFOrder-k)/(FFOrder-1)]
         } , {i,1,FFOrder},{j,1,FFOrder},{k,1,FFOrder-1}
       ]

Paint[ls_ /; Depth[ls] ==4 , opt___] :=
  Show[Graphics[LatinPicture[ LatinSquares ,
       Color /. {opt} /. Options[Paint] ] ] ]


(*  Incidence Matrices  *)

IncidenceMatrix[plane_] :=
 Module[ {po,pl,i,j},
          po = Union[Flatten[plane,2]];
          pl = If[Depth[plane] > 3,Flatten[plane,1],plane];
          Table[If[MemberQ[pl[[i]],po[[j]]],1,0],
                {j,1,Length[po]}, {i,1,Length[pl]} ]
       ]


TestMatrix := FFOrder*IdentityMatrix[FFOrder^2 + FFOrder + 1] + 
   Table[1, {FFOrder^2 + FFOrder + 1}, {FFOrder^2 + FFOrder + 1}]

(* Joining Points and Intersecting Lines *)

Vee[plane_,A_,B_] := 
  If[A==B, Message[Vee::samearg]; $Failed,
           Position[plane, x_ /; MemberQ[x,A] && MemberQ[x,B],{1}][[1,1]] ]

Wedge[plane_,a_,b_] :=
  If[a==b, Message[Wedge::samearg]; $Failed,
           Intersection[plane[[a]],plane[[b]]][[1]] ]

(* 19. 6. 1996. *)
(* The Levi graph of a plane *)

Levi[plane_List] :=
 Module[{incM,dimx,dimy,bigM},
        incM = IncidenceMatrix[plane];
        {dimx,dimy} = Dimensions[incM];
        bigM = Join[Transpose[Join[Table[0,{dimx},{dimx}],Transpose[incM]]],
                    Transpose[Join[incM,Table[0,{dimy},{dimy}]]]];
        Global`Graph[bigM,CircularVertices[dimx+dimy]]
       ]

(* The following functions are taken from the package Combinatorica 
   by Steven S. Skiena. They are needed to produce Levi graphs and
   save them to a file.                                              *)

CircularVertices[0] := {}

CircularVertices[n_Integer] :=
	Module[{i,x = N[2 Pi / n]},
		Chop[ Table[ N[{ (Cos[x i]), (Sin[x i]) }], {i,n} ] ]
	]

CircularVertices[Graph[g_,_]] := Graph[ g, CircularVertices[ Length[g] ] ]
 
WriteGraph[g_Global`Graph,file_] := 
	Module[{edges=ToAdjacencyLists[g],v=N[NormalizeVertices[Vertices[g]]],i,x,y},
		OpenWrite[file];
		Do[
			WriteString[file,"	",ToString[i]];
			{x,y} = Chop[ v [[i]] ];
			WriteString[file,"	",ToString[x],"	",ToString[y]];
			Scan[
				(WriteString[file,"	",ToString[ # ]])&,
				edges[[i]]
			];
			Write[file],
			{i,V[g]}
		];
		Close[file];
	]
 
ToAdjacencyLists[Global`Graph[g_,_]] :=
	Map[ (Flatten[ Position[ #, _?(Function[n, n!=0])] ])&, g ]

TranslateVertices[v_List,{x_,y_}] := Map[ (# + {x,y})&, v ]
TranslateVertices[Global`Graph[g_,v_],{x_,y_}] := Global`Graph[g, TranslateVertices[v,{x,y}] ]

DilateVertices[v_List,d_] := (d * v)
DilateVertices[Global`Graph[e_,v_],d_] := Global`Graph[e, DilateVertices[v,d]]

RotateVertices[v_List,t_] := 
	Module[{d,theta},
		Map[
			(If[# == {0,0}, {0,0},
				d=Sqrt[#[[1]]^2 + #[[2]]^2];
			 	theta = t + Arctan[#];
			 	N[{d Cos[theta], d Sin[theta]}]
			])&,
			v
		]
	]
RotateVertices[Global`Graph[g_,v_],t_] := Global`Graph[g, RotateVertices[v,t]]

Arctan[{x_,y_}] := Arctan1[Chop[{x,y}]]
Arctan1[{0,0}] := 0
Arctan1[{x_,y_}] := ArcTan[x,y]

NormalizeVertices[v_List] := 
	Module[{v1},
		v1 = TranslateVertices[v,{-Min[v],-Min[v]}];
		DilateVertices[v1, 1/Max[v1,0.01]]
	]

NormalizeVertices[Global`Graph[g_,v_]] := Global`Graph[g, NormalizeVertices[v]]
 
Vertices[Global`Graph[_,v_]] := v

V[Global`Graph[e_,_]] := Length[e]

End[]         



EndPackage[] 
