22
\$\begingroup\$

For those of you who are unfamiliar, Kirkman's Schoolgirl Problem goes as follows:

Fifteen young ladies in a school walk out three abreast for seven days in succession: it is required to arrange them daily so that no two shall walk twice abreast.

We could look at this like a nested 3 by 5 list (or matrix):

[[a,b,c]
 [d,e,f]
 [g,h,i]
 [j,k,l]
 [m,n,o]]

Essentially, the goal of the original problem is to figure out 7 different ways to arrange the above matrix so that two letters never share a row more than once. From MathWorld (linked above), we find this solution:

[[a,b,c]   [[a,d,h]   [[a,e,m]   [[a,f,i]   [[a,g,l]   [[a,j,n]   [[a,k,o]
 [d,e,f]    [b,e,k]    [b,h,n]    [b,l,o]    [b,d,j]    [b,i,m]    [b,f,g]
 [g,h,i]    [c,i,o]    [c,g,k]    [c,h,j]    [c,f,m]    [c,e,l]    [c,d,n]
 [j,k,l]    [f,l,n]    [d,i,l]    [d,k,m]    [e,h,o]    [d,o,g]    [e,i,j]
 [m,n,o]]   [g,j,m]]   [f,j,o]]   [e,g,n]]   [i,k,n]]   [f,h,k]]   [h,l,m]]

Now, what if there were a different number of schoolgirls? Could there be an eighth day? This is our challenge.

In this case no††, but not necessarily for other array dimensions
††We can easily show this, since a appears in a row with every other letter.


The Challenge:

Given an input of dimensions (rows, than columns) of an array of schoolgirls (i.e. 3 x 5, 4 x 4, or [7,6], [10,10], etc.), output the largest possible set of 'days' that fit the requirements specified above.

Input:
The dimensions for the schoolgirl array (any reasonable input form you wish).

Output:
The largest possible series of arrays fitting the above requirements (any reasonable form).

Test Cases:

Input:  [1,1]
Output: [[a]]

Input:  [1,2]
Output: [[a,b]]

Input:* [2,1]
Output: [[a]
         [b]]

Input:  [2,2]
Output: [[a,b]  [[a,c]  [[a,d]
         [c,d]]  [b,d]]  [b,c]]

Input:  [3,3]
Output: [[a,b,c]  [[a,d,g]  [[a,e,i]  [[a,f,h]
         [d,e,f]   [b,e,h]   [b,f,g]   [b,d,i]
         [g,h,i]]  [c,f,i]]  [c,d,h]]  [c,e,g]]

Input:  [5,3]
Output: [[a,b,c]   [[a,d,h]   [[a,e,m]   [[a,f,i]   [[a,g,l]   [[a,j,n]   [[a,k,o]
         [d,e,f]    [b,e,k]    [b,h,n]    [b,l,o]    [b,d,j]    [b,i,m]    [b,f,g]
         [g,h,i]    [c,i,o]    [c,g,k]    [c,h,j]    [c,f,m]    [c,e,l]    [c,d,n]
         [j,k,l]    [f,l,n]    [d,i,l]    [d,k,m]    [e,h,o]    [d,o,g]    [e,i,j]
         [m,n,o]]   [g,j,m]]   [f,j,o]]   [e,g,n]]   [i,k,n]]   [f,h,k]]   [h,l,m]]

There may be more than one correct answer. 

*Thanks to @Frozenfrank for correcting test case 3: if there is only one column, there can only be one day, since row order does not matter.

This is competition - shortest answer wins.

\$\endgroup\$
  • \$\begingroup\$ Does this relate to finite projective planes in any way or am I thinking of a different problem? \$\endgroup\$ – Neil May 10 '17 at 18:51
  • \$\begingroup\$ @Neil I have no clue. I'm afraid I'm not qualified to answer that. ;-) \$\endgroup\$ – Scott Milner May 10 '17 at 18:58
  • \$\begingroup\$ Is there a time limit? \$\endgroup\$ – Artyer May 10 '17 at 19:05
  • \$\begingroup\$ @Artyer No, but I would like to be able to test the code... \$\endgroup\$ – Scott Milner May 10 '17 at 19:59
  • 2
    \$\begingroup\$ @Neil that was a fun wikipedia read. \$\endgroup\$ – Magic Octopus Urn Jul 18 '17 at 19:13
12
+50
\$\begingroup\$

Mathematica, 935 bytes

Inp={5,4};L=Length;T=Table;ST[t_,k_,n_]:=Binomial[n-1,t-1]/Binomial[k-1,t-1];H=ToExpression@Alphabet[];Lo=Inp[[1]]*Inp[[2]];H=H[[;;Lo]];Final={};ST[2,3,12]=4;ST[2,4,20]=5;If[Inp[[2]]==1,Column[Partition[H,{1}]],CA=Lo*Floor@ST[2,Inp[[2]],Lo];While[L@Flatten@Final!=CA,Final={};uu=0;S=Normal[Association[T[ToRules[H[[Z]]==Prime[Z]],{Z,L@H}]]];PA=Union[Sort/@Permutations[H,{Inp[[2]]}]];PT=Partition[H,Inp[[2]]];While[L@PA!=0,AppendTo[Final,PT];Test=Flatten@T[Times@@@Subsets[PT[[X]],{2}]/.S,{X, L@PT}];POK=T[Times@@@Subsets[PA[[Y]],{2}]/.S,{Y,L@PA}];Fin=Select[POK,L@Intersection[Test,#]==0&];Facfin=T[FactorInteger[Fin[[V]]],{V,L@Fin}];end=T[Union@Flatten@T[First/@#[[W]],{W,L@#}]&[Facfin[[F]]],{F,L@Facfin}]/.Map[Reverse,S];PA=end;PT=DeleteDuplicates[RandomSample@end,Intersection@##=!={}&];If[L@Flatten@PT<L@H,While[uu<1000,PT=DeleteDuplicates[RandomSample@end,Intersection@##=!={}&];If[L@Flatten@PT==L@H,Break[],uu++]]]]];Grid@Final]


this is for 26 ladies max

EDIT
I made some changes and I think it works! The code right now is set to solve [5,4] (which is the "social golfers problem") and gets the result in a few seconds. However [5,3] problem is tougher and you will have to wait 10-20 minutes but you will get a right combination for all days. For easier cases it is very quick.

anyway you can try it and see the results
Try it online here
copy and paste using ctrl-v
press shift+enter to run the code
you can change the input at the begining of the code -> Inp={5,4}
run the code multiple times to get different permutations

\$\endgroup\$
  • \$\begingroup\$ While this is impressive, and makes a lot of progress towards solving the problem, it is still incomplete. While it works for smaller test cases, it couldn't solve any larger ones, including the [5,3] test case this whole problem is based off of. In addition, this can be golfed more; there are several variable names that are larger than they need to be, and some functions can be shortened with @ or infix notation. I hope you'll keep working, though! \$\endgroup\$ – Scott Milner May 12 '17 at 3:04
  • \$\begingroup\$ thanks for checking it. I'll try to make this work first and then golf it... \$\endgroup\$ – J42161217 May 12 '17 at 10:05
  • 1
    \$\begingroup\$ You should be able to save a lot of bytes by making your variable names single letters, and assigning some functions you use more than once to variables and replacing the functions with those variables :) \$\endgroup\$ – numbermaniac May 15 '17 at 23:05
  • 2
    \$\begingroup\$ @numbermaniac By just replacing variable names, I was able to get it down to 914. It should be golfable down to around 850. \$\endgroup\$ – Scott Milner May 16 '17 at 0:42
  • 3
    \$\begingroup\$ I fixed the test case. First of all I want this to work. Thats why I haven't golfed it yet.Thanks for all your comments. I think now it is ready. \$\endgroup\$ – J42161217 May 16 '17 at 1:05

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.