/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   A simple greedy heuristic based on the *freedom* of sets of golfers
   is able to solve instance 8-4-9 of the social golfer problem, thus
   matching the best results obtained so far with constraint-based
   approaches.

   Written by Markus Triska (triska@metalevel.at), 2008-2021
   Public domain code.

   Tested with Scryer Prolog.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


:- use_module(library(assoc)).
:- use_module(library(clpz)).
:- use_module(library(between)).
:- use_module(library(lists)).
:- use_module(library(reif)).
:- use_module(library(format)).
:- use_module(library(dcgs)).
:- use_module(library(debug)).

greedy(G, P, W, S) :-
        init(G, P, N, S0),
        phrase(week(0, W, N, S0), S).

init(G, P, N1, State) :-
        N #= G * P,
        N1 #= N - 1,
        Bitmap #= (1 << N) - 1,
        findall(Player-Bitmap, between(0,N1,Player), State0),
        list_to_assoc(State0, State).

week(N, N, _, _)   --> !.
week(N0, N, P, S0) --> [Gs],
        { numlist(0, P, Ps),
          groups(Ps, S0, S1, Gs, []),
          N1 #= N0 + 1 },
        week(N1, N, P, S1).

groups([], S, S)   --> !.
groups(Ps0, S0, S) --> [[A,B,C,D]],
        { list_pairs(Ps0, S0, Pairs0, []), keysort(Pairs0, Pairs1),
          member(_-p(A,B,NA,NB), Pairs1),
          member(_-p(C,D,NC,ND), Pairs1),
          A #\= C, A #\= D, B #\= C, B #\= D,
          Pattern #= (1 << A) \/ (1<<B) \/ (1<<C) \/ (1 << D),
          (   NA /\ NB /\ NC /\ ND) /\ Pattern #= Pattern,
          all_delete([A,B,C,D], Ps0, Ps1),
          eliminate([B,C,D], A, S0, S1), eliminate([A,C,D], B, S1, S2),
          eliminate([A,B,D], C, S2, S3), eliminate([A,B,C], D, S3, S4) },
        groups(Ps1, S4, S).

eliminate([A,B,C], P, S0, S) :-
        get_assoc(P, S0, CP0),
        put_assoc(P, S0, CP1, S),
        CP1 #= (\ (1<<A) /\ \ (1<<B) /\ \ (1<<C)) /\ CP0.

all_delete([], Ds, Ds).
all_delete([A|As], Ds0, Ds) :-
        tfilter(dif(A), Ds0, Ds1),
        all_delete(As, Ds1, Ds).

list_pairs([], _)      --> [].
list_pairs([L|Ls], S0) -->
        { get_assoc(L, S0, NL) },
        pair_up(Ls, S0, NL, L),
        list_pairs(Ls, S0).

pair_up([], _, _, _)       --> [].
pair_up([B|Bs], S0, NA, A) -->
        { get_assoc(B, S0, NB),
          Num #= popcount(NA/\NB) },
        (   {  NA /\ (1<<B) #\= 0, Num #>= 4 } ->
            [Num-p(A,B,NA,NB)]
        ;   []
        ),
        pair_up(Bs, S0, NA, A).

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

   A solution for instance 8-4-9:

    ?- greedy(8, 4, 9, Ws),
       maplist(portray_clause, Ws).
    [[0,1,2,3],[4,5,6,7],[8,9,10,11],[12,13,14,15],[16,17,18,19],[20,21,22,23],[24,25,26,27],[28,29,30,31]].
    [[0,4,8,12],[1,5,9,13],[2,6,10,14],[3,7,11,15],[16,20,24,28],[17,21,25,29],[18,22,26,30],[19,23,27,31]].
    [[0,16,5,21],[1,17,4,20],[2,18,7,23],[3,19,6,22],[8,24,13,29],[9,25,12,28],[10,26,15,31],[11,27,14,30]].
    [[0,26,6,28],[1,27,7,29],[2,24,4,30],[3,25,5,31],[8,18,14,20],[9,19,15,21],[10,16,12,22],[11,17,13,23]].
    [[0,11,18,25],[1,10,19,24],[2,9,16,27],[3,8,17,26],[4,15,22,29],[5,14,23,28],[6,13,20,31],[7,12,21,30]].
    [[0,13,7,10],[1,12,6,11],[2,15,5,8],[3,14,4,9],[16,29,23,26],[17,28,22,27],[18,31,21,24],[19,30,20,25]].
    [[0,19,14,29],[1,18,15,28],[2,17,12,31],[3,16,13,30],[4,23,10,25],[5,22,11,24],[6,21,8,27],[7,20,9,26]].
    [[0,20,15,27],[1,21,14,26],[2,22,13,25],[3,23,12,24],[4,16,11,31],[5,17,10,30],[6,18,9,29],[7,19,8,28]].
    [[0,17,9,24],[1,16,8,25],[2,19,11,26],[3,18,10,27],[4,21,13,28],[5,20,12,29],[6,23,15,30],[7,22,14,31]].
       Ws = [[[0,1,2,3],[4,5,6,7],[8,9,10,11],[12,13,14,15],[16,17,18,19],[20,21,22|...],[24,25|...],[28|...]],[[0,4,8,12],[1,5,9,13],[2,6,10,14],[3,7,11,15],[16,20,24|...],[17,21|...],[18|...],...],[[0,16,5,21],[1,17,4,20],[2,18,7,23],[3,19,6|...],[8,24|...],[9|...],...|...],[[0,26,6,28],[1,27,7,29],[2,24,4|...],[3,25|...],[8|...],...|...],[[0,11,18,25],[1,10,19|...],[2,9|...],[3|...],...|...],[[0,13,7|...],[1,12|...],[2|...],...|...],[[0,19|...],[1|...],...|...],[[0|...],...|...],[...|...]]
    ;  ...
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */