Steiner Quadruple Systems

This is based on a description given in "A Short Course in Combinatorial Designs" by Ian Anderson and Iiro Honkala.

/*
 * Steiner Quadruple Systems
 *
 * A Steiner quadruple system of order v, denoted SQS(v), is a pair (X,B)
 * where X is a set of cardinality v, and B is a set of 4-subsets of X
 * (called blocks), with the property that any 3-subset of X is contained in
 * a unique block. SQS(v) exists if and only if v=2 or 4 (mod 6).
 */

% sqs(V, SQS) constructs the blocks of SQS(4), SQS(10), SQS(14) and,
%   recursively, SQS(2U) and SQS(3U-2) provided that SQS(U) can be constructed.
%   Valid values of V<100 are:
%   4,8,10,14,16,20,22,28,32,40,44,46,56,58,64,80,82,88,92,94.
sqs( 4, [[1,2,3,4]]):-!.
sqs(10, [[1,2,3,4],[1,2,5,8],[1,2,6,10],[1,2,7,9],[1,3,5,10],[1,3,6,9],
         [1,3,7,8],[1,4,5,9],[1,4,6,8],[1,4,7,10],[1,5,6,7],[1,8,9,10],
         [2,3,5,6],[2,3,7,10],[2,3,8,9],[2,4,5,7],[2,4,6,9],[2,4,8,10],
         [2,5,9,10],[2,6,7,8],[3,4,5,8],[3,4,6,7],[3,4,9,10],[3,5,7,9],
         [3,6,8,10],[4,5,6,10],[4,7,8,9],[5,6,8,9],[5,7,8,10],[6,7,9,10]]):-!.
sqs(14, [[1,2,3,4],[1,2,5,6],[1,2,7,8],[1,2,9,10],[1,2,11,12],[1,2,13,14],
         [1,3,5,7],[1,3,6,9],[1,3,8,11],[1,3,10,13],[1,3,12,14],[1,4,5,10],
         [1,5,9,11],[1,5,8,14],[1,5,12,13],[1,6,8,10],[1,7,10,12],[1,4,6,12],
         [1,8,9,12],[1,4,8,13],[1,7,9,13],[1,4,9,14],[1,4,7,11],[1,6,7,14],
         [1,6,11,13],[1,10,11,14],[2,3,5,9],[2,3,6,8],[2,3,7,12],[2,3,11,13],
         [2,3,10,14],[2,5,12,14],[2,6,9,12],[2,6,11,14],[2,4,8,14],[2,7,9,14],
         [2,4,9,11],[2,8,9,13],[2,8,10,12],[2,4,12,13],[2,4,5,7],[2,4,6,10],
         [2,5,8,11],[2,5,10,13],[2,6,7,13],[2,7,10,11],[3,6,7,10],[3,7,9,11],
         [3,8,9,14],[3,7,8,13],[3,4,7,14],[3,5,11,14],[3,6,13,14],[3,4,5,13],
         [3,4,6,11],[3,5,6,12],[3,5,8,10],[3,4,8,12],[3,4,9,10],[3,9,12,13],
         [3,10,11,12],[4,5,11,12],[4,5,6,14],[4,5,8,9],[4,6,7,8],[4,6,9,13],
         [4,7,9,12],[4,7,10,13],[4,8,10,11],[4,10,12,14],[4,11,13,14],
         [5,6,8,13],[5,7,8,12],[5,9,10,12],[5,6,7,9],[5,6,10,11],[5,7,10,14],
         [5,7,11,13],[5,9,13,14],[6,7,11,12],[6,8,9,11],[6,8,12,14],
         [6,9,10,14],[6,10,12,13],[7,8,9,10],[7,8,11,14],[7,12,13,14],
         [8,10,13,14],[8,11,12,13],[9,10,11,13],[9,11,12,14]]):-!.
sqs(V, SQSv):-
  V > 0,
  0 =:= V mod 2,         % V=2U
  U is V // 2,
  sqs(U, SQSu), !,
  findall(Block, sqs_1(SQSu, U, Block), SQSv0),
  sort(SQSv0, SQSv).
sqs(V, SQSv):-
  V > 4,
  0 =:= (V + 2) mod 3,   % V=3U-2
  U is (V + 2) // 3,
  sqs(U, SQSu),
  sqs(10, SQS10),
  sqs3u2(SQSu, SQS10, [], SQSv1),
  findall(I, for(2, U, I), Is),
  findall(J, for(0, 2, J), Js),
  findall(P, point(Is, Js, P), Ps),
  renumber(SQSv1, [p(0,0)|Ps], SQSv2),
  sort(SQSv2, SQSv).     % Sorts, and removes duplicate blocks

% On backtracking, returns all blocks of SQS(2U)
sqs_1(SQSu, _, Block):-
  member(Block, SQSu).
sqs_1(SQSu, U, Block):-
  add_1(SQSu, U, Ds),
  member(Block, Ds).
sqs_1(_, U, Block):-
  design(U, Ps),
  add(Ps, U, Qs),
  member_2(Ps, Qs, P, Q),
  member(A, P),
  member(B, Q),
  append(A, B, Block).

% e.g. add([[[1,2],[3,4]],[[5,6],[7,8]]], 4, [[[5,6],[7,8]],[[9,10],[11,12]]]).
add([], _, []).
add([Xss|Xsss], Y, [Zss|Zsss]):-
  add_1(Xss, Y, Zss),
  add(Xsss, Y, Zsss).

% e.g. add_1([[1,2],[3,4]], 4, [[5,6],[7,8]]).
add_1([], _, []).
add_1([Xs|Xss], Y, [Zs|Zss]):-
  add_2(Xs, Y, Zs),
  add_1(Xss, Y, Zss).

% e.g. add_2([1,2], 4, [5,6]).
add_2([], _, []).
add_2([X|Xs], Y, [Z|Zs]):-
  Z is X + Y,
  add_2(Xs, Y, Zs).

% e.g. member_2([1,2,3], [4,5,6], X, Y)
member_2([X|_], [Y|_], X, Y).
member_2([_|Xs], [_|Ys], X, Y):-
  member_2(Xs, Ys, X, Y).

% Constructs an sqs(3U-2) containing "pairs" from an sqs(U) and an sqs(10)
sqs3u2([], _, SQSv, SQSv).
sqs3u2([[1|As]|SQSu], SQS10, SQSv0, SQSv):-!,
  % Handle a block of SQSu which contains a 1
  findall(I, for(0, 2, I), Is),
  findall(P, point(As, Is, P), Ps),
  new_blocksA(SQS10, [p(0,0)|Ps], SQSv0, SQSv1),
  sqs3u2(SQSu, SQS10, SQSv1, SQSv).
sqs3u2([As|SQSu], SQS10, SQSv0, SQSv):-
  % Handle a block of SQSu which does not contain a 1
  findall(Zs, ijkl([0,1,2], Zs), Zss),
  new_blocksB(Zss, As, SQSv0, SQSv1),
  sqs3u2(SQSu, SQS10, SQSv1, SQSv).

% e.g. point([1,5,8], [1,2], X) gives on backtracking
%   X=p(A,I) for each element of As and each element of Is
point(As, Is, p(A1,I)):-
  member(A, As),
  A1 is A - 1,
  member(I, Is).

% e.g. new_blocksA([[1,3,5],[1,4,6],[2,3,6],[2,4,5]], 
%                 [p(1,1),p(1,2),p(5,1),p(5,2),p(8,1),p(8,2)], [], X) gives
%   X=[[p(1,1),p(5,1),p(8,1)],[p(1,1),p(5,2),p(8,2)],
%      [p(1,2),p(5,1),p(8,2)],[p(1,2),p(5,2),p(8,1)]]
new_blocksA([], _, SQS, SQS).
new_blocksA([As|SQS10], Ps, SQS0, [Bs|SQS]):-
  renumber_1(Bs, Ps, As),
  new_blocksA(SQS10, Ps, SQS0, SQS).

% e.g. new_blocksB([[0,0,0,0],[0,0,1,2]], [2,4,5,6], [], X) gives
%   X=[[p(2,0),p(4,0),p(5,1),p(6,2)],[p(2,0),p(4,0),p(5,0),p(6,0)]]
new_blocksB([], _, SQS, SQS).
new_blocksB([Zs|Zss], As, SQS0, SQS):-
  new_blocksB_1(As, Zs, Bs),
  new_blocksB(Zss, As, [Bs|SQS0], SQS).

% e.g. new_blocksB_1([2,4,5,6], [0,0,0,0], X) gives
%   X=[p(2,0),p(4,0),p(5,0),p(6,0)]
new_blocksB_1([], [], []). 
new_blocksB_1([A|As], [Z|Zs], [p(A1,Z)|Bs]):-
  A1 is A - 1,
  new_blocksB_1(As, Zs, Bs).

% e.g. ijkl([0,1,2], [0,0,0,0])
ijkl(As, [I,J,K,L]):-
  member(I, As),
  member(J, As),
  member(K, As),
  member(L, As),
  0 =:= (I+J+K+L) mod 3.

% Replaces each pair in Gss by its index in Ps.  Or, replaces each index in
%   Iss by the I-th element of Ps.
renumber([], _, []).
renumber([Gs|Gss], Ps, [Is|Iss]):-
  renumber_1(Gs, Ps, Is),
  renumber(Gss, Ps, Iss).

% e.g. renumber_1([p(1,1),p(5,1),p(8,1)],
%                 [p(1,1),p(1,2),p(5,1),p(5,2),p(8,1),p(8,2)], X)
%   gives X=[1,3,5]
% e.g. renumber_1(X, [p(1,1),p(1,2),p(5,1),p(5,2),p(8,1),p(8,2)], [1,3,5])
%   gives X=[p(1,1),p(5,1),p(8,1)]
renumber_1([], _, []):-!.
renumber_1([G|Gs], Ps, [I|Is]):-
  nth_member(Ps, I, 1, G), !,
  renumber_1(Gs, Ps, Is).

/*
 * Resolvable Designs
 *
 * A (v,k,lambda) design is a pair (X,B) where X is a set of cardinality v,
 * and B is a set of k-subsets of X (called blocks), with the property that
 * any 2-subset of X is contained in exactly lambda blocks. It is required
 * that 2 <= k < v and lambda > 0.
 * The number of blocks is denoted by b. The number of blocks in which each
 * element of X occurs is denoted by r.
 * A (v,k,1) design is resolvable if its blocks can be partitioned into
 * r collections Bi each consisting of b/r = v/k of the blocks, and every
 * element of X appears in exactly one block in Bi for all i. The subsets
 * Bi are called parallel classes.
 */

% Creates the partitions of a (N,2,1) resolvable design for even N
% e.g. design(4, [[[1,4],[2,3]],[[1,3],[2,4]],[[1,2],[3,4]]]).
design(N, Partitions):-
  N mod 2 =:= 0,
  integers(1, N, Ints),
  findall(Comb, comb(2, Ints, Comb), Combs),
  two_i_mod_two_n_minus_1(1, N, Is),
  add_class_index(Combs, N, Is, Yss),
  sort(Yss, Zss),
  resolve(Zss, Partitions).

% Creates 2I mod (2N - 1) for I = 1 to 2N - 1
% e.g. two_i_mod_two_n_minus_1(1, 6, [2,4,1,3,0]).
two_i_mod_two_n_minus_1(N, N, []):-!.
two_i_mod_two_n_minus_1(I, N, [J|Js]):-
  J is (2 * I) mod (N - 1),
  I1 is I + 1,
  two_i_mod_two_n_minus_1(I1, N, Js).

% Puts the index of the parallel class in front of each A,B
add_class_index([], _, _, []).
add_class_index([[A,N]|Xss], N, Is, [[A,A,N]|Yss]):-!,
  % The index is a if b = 2n
  add_class_index(Xss, N, Is, Yss).
add_class_index([[A,B]|Xss], N, Is, [[D,A,B]|Yss]):-
  % Otherwise the index is the value of i for which
  %   2i mod (2n-1) = (a+b) mod (2n-1)
  C is (A + B) mod (N - 1),
  nth_member(Is, D, 1, C), !,
  add_class_index(Xss, N, Is, Yss).

% e.g. resolve([[1,2,3],[1,1,4],[2,2,4],[2,1,3],[3,3,4],[3,1,2]],
%              [[[2,3],[1,4]], [[2,4],[1,3]], [[3,4],[1,2]]]).
resolve([[_|As]], [[As]]):-!.
resolve([[A|As],[A|Bs]|Bss], [[As|Dss]|Dsss]):-!,
  resolve([[A|Bs]|Bss], [Dss|Dsss]).
resolve([[_|As],Bs|Bss], [[As],Dss|Dsss]):-
  resolve([Bs|Bss], [Dss|Dsss]).

/*
 * Library Procedures
 */

/* for(I, J, K) is true if K is an integer between I and J inclusive.        */
for(I, J, I):-I =< J.
for(I, J, K):-I < J, I1 is I + 1, for(I1, J, K).

/* comb(N, Xs, Ys) is true if Ys is a subset of cardinality N resulting      */
/*   from picking N things from the set Xs.                                  */
comb(0, _, []):-!.
comb(I, Xs, [Y|Ys]):-
  I1 is I - 1,
  rest(Y, Xs, Xs1),
  comb(I1, Xs1, Ys).

/* integers(M, N, Is) is true if Is is the list of integers from M to N      */
/*   inclusive.                                                              */
integers(N, N, [N]):-!.
integers(I, N, [I|Is]):-I < N, I1 is I + 1, integers(I1, N, Is).

/* nth_member(+Xs, ?N, ?B, ?X) is true if X is the N-th (base B) element of  */
/*   the list Xs.                                                            */
nth_member(Xs, N, B, X):-nth_member_1(Xs, X, B, N).

nth_member_1([X|_], X, I, I).
nth_member_1([_|Xs], X, I0, I):-
  I1 is I0 + 1,
  nth_member_1(Xs, X, I1, I).

/* rest(X, Ys, Zs) is true if X is a member of the list Ys, and the          */
/*   list Zs is the rest of the list following X.                            */
rest(X, [X|Ys], Ys).
rest(X, [_|Ys], Zs):-rest(X, Ys, Zs).

/* append(Xs, Ys, Zs) is true if Zs is the result of appending the list Xs   */
/*   to the list Ys.                                                         */
%append([], Ys, Ys).
%append([X|Xs], Ys, [X|Zs]):-append(Xs, Ys, Zs).

/* length(Xs, L) is true if L is the number of elements in the list Xs.      */
%length(Xs, L):-length_1(Xs, 0, L).

/* length_1(Xs, L0, L) is true if L is equal to L0 plus the number of        */
/*   elements in the list Xs.                                                */
%length_1([], L, L).
%length_1([_|Xs], L0, L):-L1 is L0 + 1, length_1(Xs, L1, L).

/* member(X, Xs) is true if the element X is contained in the list Xs.       */
%member(X, [X|_]).
%member(X, [_|Xs]):-member(X, Xs).

LPA Index     Home Page

Valid HTML 4.0!