Kirkman's Schoolgirl Problem

Author

Eric W. Weisstein
January 29, 2022

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Combinatorics/KirkmansSchoolgirlProblem.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/KirkmansSchoolgirlProblem.html.

©2022 Wolfram Research, Inc. except for portions noted otherwise

Additional authors

Ed Pegg, Jr.
January 29, 2022

Construction

Dörrie

Don't format these in TraditionalForm.  The FE typesetting is buggy and will ignore any editing you do, always evaluating to the *original* matrix.

k1={{{x,a1,a2},{x,b1,b2},{x,c1,c2},{x,d1,d2},{x,e1,e2},{x,f1,f2},{x,g1,g2}},{{b1,d1,f1},{a1,d2,e2},{a1,d1,e1},{a1,b2,c2},{a2,b1,c1},{a1,b2,c1},{a1,b1,c2}},{{b2,e1,g1},{a2,f2,g2},{a2,f1,g1},{a2,f2,g1},{a1,f1,g2},{a2,d2,e1},{a2,d1,e2}},{{c1,d2,g2},{c1,d1,g1},{b1,d2,f2},{b1,e1,g2},{b2,d1,f2},{b1,e2,g1},{b2,d2,f1}},{{c2,e2,f2},{c2,e1,f1},{b2,e2,g2},{c1,e2,f1},{c2,d2,g1},{c2,d1,g2},{c1,e1,f2}}};

k2={{{x,a1,a2},{x,b1,b2},{x,c1,c2},{x,d1,d2},{x,e1,e2},{x,f1,f2},{x,g1,g2}},{{b1,d1,f1},{a1,d2,e2},{a1,d1,e1},{a2,b2,c2},{a1,b1,c1},{a1,b2,c1},{a1,b1,c2}},{{b2,e1,g1},{a2,f2,g2},{a2,f1,g1},{a1,f2,g1},{a2,f1,g2},{a2,d2,e1},{a2,d1,e2}},{{c1,d2,g2},{c1,d1,g1},{b1,d2,f2},{b1,e1,g2},{b2,d1,f2},{b1,e2,g1},{b2,d2,f1}},{{c2,e2,f2},{c2,e1,f1},{b2,e2,g2},{c1,e2,f1},{c2,d2,g1},{c2,d1,g2},{c1,e1,f2}}};

UnsortedUnion[x_] := Module[{f},
    f[y_] := (f[y] = Sequence[]; y);
    f /@ x
  ]

chars=CharacterRange["A","O"];

Map[StringJoin,
k1/.Thread[UnsortedUnion[Flatten[k1]]->chars],
{2}]//MatrixForm

Wrong

Map[StringJoin,
kirkman=k2/.Thread[UnsortedUnion[Flatten[k2]]->CharacterRange["A","O"]],
{2}]//MatrixForm

Correct

kirkman

Transpose[kirkman]

Union[Sort/@Join@@@Transpose[kirkman]]

Each day's arrangement contains each girl once

Map[Transpose,Transpose[kirkman],{1}]

Old figure (Pegg?)

Pegg

Construction

From Ed Pegg, Jr., Jan. 29, 2022:

"It's easy to get 35 triples on 1-15 that have a BitXor sum of zero.  Pairs of lines that share a point make GraphData[{"Grassmann", {2, {4, 2}}}]"

pts=Select[Subsets[Range[15],{3}],BitXor@@#==0&]

GraphData[{"Grassmann",{2,{4,2}}},"V"]

GraphData[{"Grassmann",{2,{4,2}}},"E"]

Select[Subsets[pts,{2}],Length[Intersection@@#]==2&]

Length[e=Select[Subsets[pts,{2}],Length[Intersection@@#]==1&]]

g=Graph[pts,UndirectedEdge@@@e]

RecognizeGraph[%]

GraphData[{"Grassmann",{2,{4,2}}},"Graph","All"]

Figure

Ed Pegg, Jr.
Jan. 29, 2022

"These also solve the Kirkman's Schoolgirl problem, shown as a doily. 
It's also PG(3,2), the smallest three-dimensional projective space."

ArcDraw2D[threepoints_]:= Module[{colinearitytest,circle,center,radius,angles,ends},
colinearitytest=Chop[N[Det[Append[#,1]&/@threepoints]]];
If[colinearitytest≠0,circle=Circumsphere[threepoints];
center=N[circle[[1]]];radius=N[circle[[2]]];
angles=Mod[N[Arg[(#-center).{1,I}]/Pi],2]&/@threepoints;
ends={angles[[1]],angles[[3]]};
If[angles==Sort[angles]||angles==Reverse[Sort[angles]],
Circle[center,radius,Pi ends],Circle[center,radius,Pi {Max[ends],2+Min[ends]}]],
Line[threepoints]]];

pg23={{2,10,8},{3,14,13},{11,15,4},{7,1,6},{12,5,9},{14,12,2},{15,8,7},{6,5,3},{4,13,9},{11,1,10},{14,7,9},{8,3,11},{2,6,4},{5,15,10},{1,13,12},{10,6,12},{9,2,11},{7,4,3},{14,15,1},{5,13,8},{1,4,5},{8,6,14},{13,2,15},{9,3,10},{12,7,11},{15,9,6},{13,10,7},{5,11,14},{1,3,2},{4,8,12},{6,11,13},{3,12,15},{8,9,1},{2,7,5},{10,14,4}};

BitXor@@#&/@pg23

numbers={8,2,14,5,1,3,6,7,15,13,11,4,9,10,12};
locations=Flatten[MapIndexed[RootReduce[{Sin[2 (#2[[2]]-2) Pi/5],Cos[2 (#2[[2]]-2) Pi/5]} {2,.5,-1.378}[[#2[[1]]]]]&,Partition[numbers,5],{2}],1];
newloc=Last/@Sort[Transpose[{numbers,locations}]];
colors={Black,Gray,Cyan,Green,Red,Purple,Blue};

Graphics[{AbsoluteThickness[1.6],MapIndexed[{colors[[Ceiling[#2[[1]]/5]]],ArcDraw2D[newloc[[#1]]]}&,pg23],MapIndexed[{{Black,Disk[#1,.12]},{White,Disk[#1,.11]},Style[Text[#2[[1]],#1],20]}&,newloc]},ImageSize->{500,500}]