program Schedule;
{$apptype CONSOLE}
{$R+}

const {n:word=48; g:word=4; t:word=10; ngroups:word=12;} crlf=#13#10;

{Schedule n=120 people in groups of g=6, repeated t=4 times
 without anyone seeing the same person again}

type list=array[0..200] of byte;
     soln=array[0..50] of list;
     byteset=set of byte;
     deja=array[0..200] of byteset;

var s,bests,saves  :soln;
    vu             :deja; {not used in current version}
    exchangelist  :list;
    exchangecount :byte;
    already   :array[0..200,0..200] of boolean;
    fout      :text;
    quiet     :boolean;
    mink      :byte;
    n         :byte;
    g,t,ngroups :word;
(*
procedure Reecord(r :byte);
          var i,j,k :byte;
          begin
          for i:=0 to pred(ngroups) do
            for j:=0 to pred(g) do
              for k:=0 to pred(g) do
                 vu[s[r,g*i+j]]:=vu[s[r,g*i+j]]+[s[r,g*i+k]];
          end;
function ConflictCount(r :byte):byte;
          var i,j,k :byte;
          begin
          result:=0;
          for i:=0 to pred(ngroups) do
            for j:=0 to pred(g) do
              for k:=succ(j) to pred(g) do
                if (s[r,g*i+k] in vu[s[r,g*i+j]]) then inc(result);
          writeln('Round ',r,': total conflicts=',result);
          end;
*)
procedure Reecord(r :byte);
          var i,j,k :byte;
          begin
          for i:=0 to pred(ngroups) do
            for j:=0 to pred(g) do
              for k:=0 to pred(g) do begin
                already[s[r,g*i+j],s[r,g*i+k]]:=true;
                already[s[r,g*i+k],s[r,g*i+j]]:=true;
                end;
          end;

procedure MakeExchangeList(r :byte);
          var i,j,k  :byte;
              didone :boolean;
          begin
          exchangecount:=0;
          for i:=0 to pred(ngroups) do begin
            didone:=false;
            for j:=0 to pred(g) do begin
              if (didone) then continue;
              k:=j;
              repeat inc(k) until (k=g) or (already[s[r,g*i+j],s[r,g*i+k]]);
              if (k<g) then begin
                exchangelist[exchangecount]:=g*i+j;
                didone:=true;
                end;
              end;
            if (didone) then inc(exchangecount);
            end;
          end;

function ConflictCount(r :byte):word;
          var i,j,k :byte;
          begin
          result:=0;
          for i:=0 to pred(ngroups) do
            for j:=0 to pred(g) do
              for k:=succ(j) to pred(g) do
                if already[s[r,g*i+k],s[r,g*i+j]] then inc(result);
          if (not quiet) then writeln('Round ',r,': total conflicts=',result);
          end;

procedure ShuffleCandidateList(r :byte);
          var i,j,swap :byte;
          begin
          for i:=0 to pred(n) do begin
            j:=random(n);
            swap:=s[r,i]; s[r,i]:=s[r,j]; s[r,j]:=swap;
            end;
          end;

procedure ShuffleExchangeList(r :byte);
          var i,j,swap :byte;
          begin
          if (exchangecount<=0) then exit;
          for i:=0 to pred(exchangecount) do begin
            j:=random(exchangecount);
            swap:=exchangelist[i]; exchangelist[i]:=exchangelist[j]; exchangelist[j]:=swap;
            end;
          end;

procedure Print(r :byte);
          var i,j :byte;
          begin
          for i:=0 to pred(ngroups) do begin
            write('(');
            for j:=0 to (g-2) do write(s[r,g*i+j],',');
            write(s[r,g*succ(i)-1],') ');
            end;
          writeln; writeln(mink);
          for i:=0 to pred(ngroups) do begin
            write(fout,'(');
            for j:=0 to (g-2) do write(fout,s[r,g*i+j],',');
            write(fout,s[r,g*succ(i)-1],') ');
            end;
          writeln(fout); writeln(fout,mink);
          end;

procedure CreateRandomList(r :byte);
          var i :byte;
          begin
          {for i:=0 to pred(n) do s[r,i]:=i;}
          s[r]:=s[pred(r)];
          ShuffleCandidateList(r);
          end;

procedure PerformExchanges(r :byte);
          var i,swap :byte;
          begin
          if (exchangecount>1) then
            for i:=0 to pred(exchangecount div 2) do begin
              swap:=s[r,exchangelist[2*i]]; s[r,exchangelist[2*i]]:=s[r,exchangelist[2*i+1]]; s[r,exchangelist[2*i+1]]:=swap;
              end;
          end;

procedure TryExchangingToResolveConflicts(r :byte);
          var i,k :word;
          begin
          k:=100;
          while (k>0) and (i<3000) do begin
             inc(i); if (not quiet) then write(i:3,': ');
             MakeExchangeList(r);
             ShuffleExchangeList(r);
             PerformExchanges(r);
             k:=ConflictCount(r);
             if (k<mink) then begin
               mink:=k;
               bests:=s;
               i:=0;
               end;
             end;
          end;

procedure CreateListForRound(r :byte);
          var i,k,j :word;
          begin
          j:=0; mink:=100;
          repeat
            CreateRandomList(r);
            i:=0; k:=100;
            while (k>0) and (i<3000) do begin
              inc(i); if (not quiet) then write(i:3,': ');
              MakeExchangeList(r);
              ShuffleExchangeList(r);
              PerformExchanges(r);
              k:=ConflictCount(r);
              if (k<mink) then begin
                mink:=k;
                bests:=s;
                i:=0;
                end;
              end;
              inc(j);
          until (k=0) or (j=10000);
          s:=bests;
          writeln;
          Reecord(r);
          Print(r);
          end;

(*
procedure CrossLink(r :byte);
          var i,j,k :byte;
              p,gg  :byte;
          begin
          gg:=g*pred(g); {30}
          p:=n div gg; {120/30=4}
          for i:=0 to pred(p) do {4x}
            for j:=0 to pred(g) do {6x}
              for k:=0 to pred(g) do {6x}
                s[r,gg*i+
          end;
*)

procedure InitializeConflictList;
          var i,j :byte;
          begin
          for i:=0 to pred(n) do vu[i]:=[];
          for i:=0 to pred(n) do
            for j:=0 to pred(n) do
              already[i,j]:=false;
          end;

var i,j :byte;
    ready :boolean;
    instr     :string;
begin
repeat
  writeln('This program will schedule groups of people so as to maximize');
  writeln('  heterogeneity.  The program seeks to avoid, as far as it can,');
  writeln('  the number of times each person sees each other person in the');
  writeln('  same group.');
  write('Number of groups each round: '); readln(ngroups);
  write('Size of each group: '); readln(g);
  write('Number of rounds: '); readln(t);
  n:=ngroups*t;
  writeln(crlf,'Seeking to schedule ',t,' rounds, dividing ',n,' individuals into ',g,' groups.');
  write('  Is this correct (Y/N)? '); readln(instr);
  ready:=(upcase(instr[1])='Y');
until ready;
quiet:=true;
assign(fout,'schedule.out'); {$I-} append(fout); {$I+}
if (ioresult>0) then rewrite(fout);
writeln(fout,crlf,crlf,'----------------------------------------------------------------------');
randomize;
InitializeConflictList;
for i:=0 to pred(n) do s[0,i]:=i;
Reecord(0);
Print(0);
for i:=1 to t-1 do CreateListForRound(i);
write('Done...'); readln;
close(fout);
end.

saves:=s;
InitializeConflictList;
for i:=0 to pred(t) do begin
  s[i]:=saves[pred(t)-i];
  Reecord(i);
  mink:=ConflictCount(i);
  TryExchangingToResolveConflicts(i);
  Print(i);
  end;
write('Done...'); readln;
close(fout);
end.