MHB Algorithm to arrange N people into groups of K

[Theia]

Hi all!

I've been trying to find a reasonable way to solve following problem:

N people meet each others in groups of K people such that no one meets more than once.

If I'm not mistaken, this requires two things:

• N must be divisible by K
• N - 1 must be divisible by K - 1.

Let's assume these conditions hold. How to proceed...? (Wondering) For a more concrete example one can use for example N = 15 and K = 3.

 

[Theia]

Thank you for your reply!

There appears to be different approaches that one can find using keyword "disjoint Steiner system" or "disjoint Kirkman system". The case N = 15, K = 3 is the famous Kirkman's schoolgirl problem.

It still took me some years to find time and suitable algorithm for this... The code below gives one solution to the problem I described in opening post - at least in the case N = 15 and K = 3

program zenz
implicit none
integer, parameter :: N = 15, K = 3
integer :: i, imax, j, jmax, v
integer, allocatable :: groups(:,:), joukko(:,:)
integer, allocatable :: valitsin(:), valitut(:), tb_valitsin(:)
logical :: tavattu(N,N) = .false.
!valitsin = generoi ryhmät taulukkoon groups
!groups = lista ryhmistä, jotka on mahdollista muodostaa
!valitut = lista ryhmien indekseistä taulukossa groups, mitkä on valittu tapaamisiin
!tavattu = true jos henkilöt i ja j ovat tavanneet
!table = listaa kierroksen ryhmät
!tb_valitsin = permutoi valitut ryhmät niin, että tapaamiset onnistuu
intrinsic sum, ubound, mod

allocate(groups(1:binomial(N,K),K))
allocate(valitut(1:N*(N-1)/(K*(K-1))))

!alustetaan tavattu-taulukko, sillä kukin henkilö on tavannut itsensä.
do i = 1,N
  tavattu(i,i) = .true.
end do

allocate(valitsin(1:N))
valitsin = 0
valitsin(N-K+1:N) = 1

i = 1
do while(sum(valitsin) > 0)
  groups(i,:) = collect(valitsin)
  valitsin = lex(valitsin)
  i = i + 1
end do

!sitten on koostettava listasta groups mukaan otetut ryhmät taulukkoon valitut

valitut = 0
i = 0 !edellinen täytetty paikka valitut-taulukossa
j = 0 !edellinen valittu ryhmä taulukosta groups
imax = ubound(valitut,1) !ryhmiä ei voi olla valittuna tätä enempää
jmax = ubound(groups,1) !ryhmien lukumäärä

do while(.not. all_met(tavattu))
  j = j + 1 !seuraava ryhmä, jota kokeillaan lisätä
  !jos ryhmät jo loppui
  if(j > jmax) then
    !otetaan uudeksi j:ksi edellinen lisätty ryhmä
    j = valitut(i)
    !valitut(i) = 0
    i = i - 1
    !poistetaan tämän indeksin kuvaamat tapaamiset
    tavattu = rem_gr(j,tavattu)
    cycle
  end if
  if(if_add_gr(j,tavattu)) then
    !jos ryhmä voidaan lisätä
    tavattu = add_gr(j,tavattu) !lisätään ryhmän tapaamiset
    i = i + 1
    valitut(i) = j
    !write(*,*) ''
    !write(*,*) valitut
    !write(*,*) ''
    !do v = 1,N
    !  write(*,*) tavattu(v,:)
    !end do
    cycle
  end if
end do

write(*,*) 'Ratkaisu löytynyt!'

!sitten täytyy koostaa kierrosten tapaamiset perustuen valitut-taulukon ryhmiin. yksi henkilö voi olla vain yhdessä tapaamisessa kullakin kierroksella.

v = ubound(valitut,1)

!yhdellä kierroksella on N/K ryhmää. alustetaan tb_valitsin
tb_valitsin = init(v,N/K)

!kootaan valitut ryhmät taulukkoon joukko
allocate(joukko(1:v,1:K))
do i = 1,v
  joukko(i,:) = groups(valitut(i),:)
end do

i = 1
do
  !tarkistetaan, onko nykyinen permutaatio sopiva
  if(sopiva(tb_valitsin,joukko)) then
    !jos on, niin tulostetaan tulos...
    write(*,*) i
    do j = 1, ubound(tb_valitsin,1)
      if(tb_valitsin(j) > 0) write(*,*) joukko(j,:)
    end do
    write(*,*) ''
    i = i + 1
    !...ja poistetaan löydetty tulos listoista.
    call refresh(tb_valitsin,joukko)
    if(ubound(tb_valitsin,1) == N/K) then
      write(*,*) i
      do j = 1,N/K
        write(*,*) joukko(j,:)
      end do
      exit
    end if
  end if
  !ellei, niin tutkitaan seuraava permutaatio
  tb_valitsin = lex(tb_valitsin)
end do

contains

subroutine refresh(cho, grs)
implicit none
integer, allocatable, intent(inout) :: cho(:), grs(:,:)
integer, allocatable :: gros(:,:)
integer :: iii, ub, jjj
intrinsic ubound
ub = ubound(cho,1)
jjj = 1
allocate(gros(1:ub-N/K,1:K))
do iii = 1,ub
  if(cho(iii) == 0) then
    gros(jjj,:) = grs(iii,:)
    jjj = jjj + 1
  end if
end do
deallocate(grs)
grs = gros
cho = init(ub-N/K,N/K)
end subroutine refresh

function sopiva(cho,grs) result(joovai)
implicit none
!tutkii, onko valitsimen cho osoittama ryhmäkokoelma grs:stä sopiva tapaamiskierrokseksi
integer, allocatable, intent(in) :: cho(:), grs(:,:)
logical :: joovai, rivi(1:N)
integer :: iii, jjj
intrinsic ubound
rivi = .false.
do iii = 1, ubound(cho,1)
  if(cho(iii) > 0) then
    do jjj = 1,K
      rivi(grs(iii,jjj)) = .true.
    end do
  end if
end do
joovai = all(rivi)
end function sopiva

function init(pit,lkm) result(lista)
implicit none
!alustaa valitsimen, pituus pit niin, että lopussa on lkm verran ykkösiä. loput nollia.
integer, intent(in) :: pit, lkm
integer, allocatable :: lista(:)
allocate(lista(1:pit))
lista = 0
lista(pit-lkm+1:pit) = 1
end function init

function if_add_gr(nro,ref) result(r)
implicit none
!tutkii, voiko ryhmän numero nro tapaamiset lisätä tapaamistaulukkoon ref
integer, intent(in) :: nro
logical, intent(in) :: ref(N,N)
integer :: gta(1:K), ii, jj
logical :: r
gta = groups(nro,:) !group to add
r = .false. !eli ei voi lisätä
do ii = 1,K-1
  do jj = ii+1,K
    if(ref(gta(ii),gta(jj)) .eqv. .true.) return
    if(ref(gta(jj),gta(ii)) .eqv. .true.) return
  end do
end do
r = .true.
end function if_add_gr

function add_gr(nro,ref) result(new_ref)
implicit none
!lisää ryhmän numero nro tapaamiset tapaamistaulukkoon ref
integer, intent(in) :: nro
logical, intent(in) :: ref(N,N)
integer :: gta(1:K), ii, jj
logical :: new_ref(N,N)
gta = groups(nro,:) !group to add
new_ref = ref
do ii = 1,K-1
  do jj = ii+1,K
    new_ref(gta(ii),gta(jj)) = .true.
    new_ref(gta(jj),gta(ii)) = .true.
  end do
end do
end function add_gr

function rem_gr(nro,ref) result(new_ref)
implicit none
!poistaa ryhmän numero nro tapaamiset tapaamistaulukosta ref
integer, intent(in) :: nro
logical, intent(in) :: ref(N,N)
integer :: gta(1:K), ii, jj
logical :: new_ref(N,N)
gta = groups(nro,:) !group to remove
new_ref = ref
do ii = 1,K-1
  do jj = ii+1,K
    new_ref(gta(ii),gta(jj)) = .false.
    new_ref(gta(jj),gta(ii)) = .false.
  end do
end do
end function rem_gr

function all_met(ref) result(r)
implicit none
logical, intent(in) :: ref(N,N)
integer :: am, ii
logical :: r
intrinsic all
am = 0
r = .false.
do ii = 1,N
  if(all(ref(ii,:))) am = am + 1
end do
if(am == N) r = .true.
end function all_met

function collect(t) result(g)
implicit none
!muodostaa ryhmäkandidaatit osanottajalistasta valitsimen t avulla.
integer, intent(in) :: t(N)
integer :: g(K), i, j
j = 1
do i = 1,N
  if(t(i) > 0) then
    g(j) = i
    j = j + 1
    if(j > K) return
  end if
end do
end function collect

recursive function binomial(n,k) result(b)
implicit none
integer, intent(in) :: n, k
integer :: b
if(k > n) then
  b = 0
  return
end if
if((k == 0) .or. (k == n) ) then
  b = 1
  return
end if
b = binomial(n - 1, k - 1) + binomial(n - 1,k)
end function binomial
!
function lex(taul) result(ntaul)
implicit none
integer, allocatable, intent(in) :: taul(:)
integer, allocatable :: ntaul(:), t(:)
integer :: k, m, apu
t = taul
ntaul = t
k = find_k(taul)
if(k == -1) then
  ntaul = 0
  return
end if
m = find_m(taul,k)

apu = t(k)
t(k) = t(m)
t(m) = apu

ntaul = reverse(t,k)
end function lex
!
function reverse(taul,k) result(t)
implicit none
integer, allocatable, intent(in) :: taul(:)
integer, intent(in) :: k
integer :: a, b, apu, z
integer, allocatable :: t(:), alku(:), loppu(:)
intrinsic ubound
z = ubound(taul,1)
allocate(alku(z),loppu(z),t(z))
alku = 0
loppu = 0
alku(1:k) = taul(1:k)
loppu(k+1:z) = taul(k+1:z)
a = k + 1
b = z
do
  apu = loppu(a)
  loppu(a) = loppu(b)
  loppu(b) = apu
  a = a + 1
  b = b - 1
  if(a >= b) exit
end do
t = alku + loppu
end function reverse
!
function find_m(taul,k) result(m)
implicit none
integer, intent(in) :: k
integer, allocatable, intent(in) :: taul(:)
integer :: m, z
intrinsic ubound
z = ubound(taul,1)
m = z
do
  if(taul(k) < taul(m)) return
  m = m - 1
  if(m == k) exit
end do
m = -1
end function find_m
!
function find_k(taul) result(k)
implicit none
integer, allocatable, intent(in) :: taul(:)
integer :: k, z
intrinsic ubound
z = ubound(taul,1)
do k = z - 1, 1, -1
  if(taul(k) < taul(k + 1)) return
end do
k = -1
end function find_k
!
end program zenz

 

[pbuk]

It still took me some years to find time and suitable algorithm for this...

That's a shame. If MHB had been part of PF in 2021 you might have been pointed towards this: https://cs.lmu.edu/~ray/notes/kirkman/.

 

[PeroK]

Hi all!

I've been trying to find a reasonable way to solve following problem:

N people meet each others in groups of K people such that no one meets more than once.

If I'm not mistaken, this requires two things:

• N must be divisible by K
• N - 1 must be divisible by K - 1.

Let's assume these conditions hold. How to proceed...? (Wondering) For a more concrete example one can use for example N = 15 and K = 3.

Why is this not a solution for $N =3, K =2$?

A meets B, A meets C, B meets C?

 

[Theia]

Why is this not a solution for $N =3, K =2$?

A meets B, A meets C, B meets C?

In each round, all people must be in exactly one meeting. This approach puts either all people into two meetings at the same time, or leaves one person without a meeting. Thus it's not considered as a solution this time.

 

[pbuk]

In each round, all people must be in exactly one meeting.

But you didn't specify that - you didn't even mention rounds!

Kirkman's Schoolgirl Problem and its generalizations are well documented (e.g. https://en.wikipedia.org/wiki/Kirkman's_schoolgirl_problem), if you have a question relating to a specific problem it would probably be best to refer to or quote an existing definition in full.