Re: Golf Problem

• Previous message: Char: "Re: Help me with prolog"
• Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]

Date: Sun, 06 Mar 2005 23:32:55 +0000

Nameless wrote:

> Prologers might find this problem, originating in the sci.math
> newsgroup, both appropriate and challenging:

By now I have found what appears to me to be a much more suitable model
for this problem (compared to what I had tried previously): I am using a
Boolean matrix consisting of 15 rows (groups) and 12 columns (players).
A value of 1 an position (i,j) means that player j plays in group i.
Since group and player permutations do not matter, I impose
lexicographic ordering an both rows and columns to break symmetry
(lex_chain/1 is currently available in SWI Prolog CVS).

My question was previously how to make sure that each player plays with
every other at least once in some group. With the new model, this is
very easy to express. Concentrating exclusively on this requirement,
there are (12 choose 2) = 66 constraints to satisfy. I was not able to
satisfy them all within one hour, but I could satisfy 60 of them in less
than 4 seconds on a 2.4 GHz P4:

?- time(t(G,60,N)).
  % 8,997,888 inferences, 3.68 CPU in 3.78 seconds (97% CPU, 2445078 Lips)

  G = [[0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1], [0, 0, 0, 0, 1, 1, 1, 1, 0,
0, 0, 0], [0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1, 1], [0, 0, 0, 1, 0, 0, 0, 1,
1, 0, 0, 1], [0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 0], [0, 0, 0, 1, 0, 1, 1,
0, 0, 1, 0, 0], [0, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0, 0], [0, 0, 1, 0, 0, 0,
1, 1, 0, 0, 0, 1], [0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0], [0, 0, 1, 0, 1,
1, 0, 0, 0, 0, 0, 1], [0, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0], [0, 1, 0, 0,
1, 0, 1, 0, 0, 0, 1, 0], [1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0], [1, 1, 0,
0, 0, 0, 1, 0, 0, 0, 0, 1], [1, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0]]
  N = 60

I am appending the source in case anyone is interested. The lines I
marked with "try this:" are attempts to satisfy more constraints by
hand-tweaking the solution or imposing additional constraints that I
figured would not hurt too much and seemed a good idea. Bear in mind
that they could cause loss of valid solutions.

Best regards,
Markus.

:- use_module(library('clp/bounds')).

choosetwo([X|Xs],(X,Y)) :-
        member(Y,Xs).
choosetwo([_,X|Xs],Two) :-
        choosetwo([X|Xs],Two).

allpairs(List,Pairs) :-
        setof(Two,choosetwo(List,Two),Pairs).

%%%%%% transpose
allfirsts([],[]) -->
        [].
allfirsts([[First|Rest]|Fs], [Rest|Rs]) -->
        [First],
        allfirsts(Fs,Rs).

nil([]).

transpose(Lss,[]) :-
        maplist(nil,Lss).
transpose(Lss,[Ts|Tss]) :-
        phrase(allfirsts(Lss,Rest),Ts),
        transpose(Rest,Tss).
%%%%%%

multsum([], [], 0).
multsum([A1|A1s],[A2|A2s], Sum) :-
        Sum #= Sum1 + (A1*A2),
        multsum(A1s, A2s, Sum1).
        

notwopartners(_Gss, [], []).
notwopartners(Gss, [(P1,P2)|Pairs], [B|Bs]) :-
        maplist(nth1(P1),Gss,As1),
        maplist(nth1(P2),Gss,As2),
        multsum(As1, As2, Sum),
        Sum #=< 2, % try this: prohibit these two from playing too often in
the same group
        Sum #>= 1 #<=> B,
        notwopartners(Gss, Pairs, Bs).

nosamegroup(_Gss,[]).
nosamegroup(Gss,[(P1,P2)|Ps]) :-
        nth1(P1,Gss,G1),
        nth1(P2,Gss,G2),
        multsum(G1,G2,Sum),
        Sum #< 4,
        nosamegroup(Gss,Ps).

length12(L) :-
        length(L,12).

sum_n(N,Op,L) :-
        sum(L,Op,N).

t(Gss,Numsatisfied,N) :-
        length(Gss, 15),
        maplist(length12, Gss),
        Gss = [_FirstG,SecondG|_],
        nth1(12,SecondG,0), % try this: make the second group rather different
        transpose(Gss,Tss),
        flatten(Gss, Zs),
        Zs in 0..1,
        lex_chain(Tss),
        lex_chain(Gss),
        maplist(sum_n(6,#=<),Tss), % try this: each player plays at most 6 times
        maplist(sum_n(4,#=),Gss), % group = 4 players
        allpairs([1,2,3,4,5,6,7,8,9,10,11,12],AllPlayerPairs),
        notwopartners(Gss, AllPlayerPairs, Bs),
        sum(Bs,#>=,Numsatisfied),
        allpairs([1,2,3,4,5,6,7,8,9,10,11,12,13,14,15],AllGroupPairs),
        nosamegroup(Gss,AllGroupPairs), % try this: no group occurs twice
        label(Zs),
        sum(Bs,#=,N).

• Previous message: Char: "Re: Help me with prolog"
• Messages sorted by: [ date ] [ thread ] [ subject ] [ author ]