Source code in the picat programming language

import util.
import cp.

%
% Solve the task in the description.
%
go ?=>
  sets(1,Sets,SetLen,NumSets),
  print_cards(Sets),
  set_puzzle(Sets,SetLen,NumSets,X),
  print_sol(Sets,X),
  nl,
  fail, % check for other solutions
  nl.
go => true.

%
% Generate and solve a random instance with NumCards cards,
% giving exactly NumSets sets.
%
go2 =>
  _ = random2(),
  NumCards = 9, NumSets = 4, SetLen = 3,
  generate_and_solve(NumCards,NumSets,SetLen),
  fail, % prove unicity
  nl.

go3 =>
  _ = random2(),
  NumCards = 12, NumSets = 6, SetLen = 3,
  generate_and_solve(NumCards,NumSets,SetLen),  
  fail, % prove unicity)
  nl.

%
% Solve a Set Puzzle.
%
set_puzzle(Cards,SetLen,NumWanted, X) =>
  Len = Cards.length,
  NumFeatures = Cards[1].length,

  X = new_list(NumWanted),
  foreach(I in 1..NumWanted)
    Y = new_array(SetLen), 
    foreach(J in 1..SetLen)
      member(Y[J], 1..Len)
    end,
    % unicity and symmetry breaking of Y
    increasing2(Y), 
    % ensure unicity of the selected cards in X
    if I > 1 then
      foreach(J in 1..I-1) X[J] @< Y  end
    end,
    foreach(F in 1..NumFeatures)
       Z = [Cards[Y[J],F] : J in 1..SetLen],
       (allequal(Z) ; alldiff(Z))
    end,
    X[I] = Y
  end.

% (Strictly) increasing
increasing2(List) => 
  foreach(I in 1..List.length-1)
    List[I] @< List[I+1]
  end.

% All elements must be equal
allequal(List) => 
  foreach(I in 1..List.length-1)
    List[I] = List[I+1]
  end.

% All elements must be different
alldiff(List) => 
  Len = List.length,
  foreach(I in 1..Len, J in 1..I-1)
    List[I] != List[J]
  end.

% Print a solution
print_sol(Sets,X) =>
  println("Solution:"),
  println(x=X),
  foreach(R in X)
    println([Sets[R[I]] : I in 1..3])
  end,
  nl.

% Print the cards
print_cards(Cards) =>
  println("Cards:"),
  foreach({Card,I} in zip(Cards,1..Cards.len))
     println([I,Card])
  end,  
  nl.

%
% Generate a problem instance with NumSets sets (a unique solution).
%
% Note: not all random combinations of cards give a unique solution so
%       it might generate a number of deals.
%
generate_instance(NumCards,NumSets,SetLen, Cards) =>
  println([numCards=NumCards,numWantedSets=NumSets,setLen=SetLen]),
  Found = false,
  % Check that this instance has a unique solution.
  while(Found = false) 
    if Cards = random_deal(NumCards), 
      count_all(set_puzzle(Cards,SetLen,NumSets,_X)) = 1
    then
      Found := true
    end
  end.

%
% Generate a random problem instance of N cards.
%
random_deal(N) = Deal.sort() =>
  all_combinations(Combinations),
  Deal = [], 
  foreach(_I in 1..N)
    Len = Combinations.len,
    Rand = random(1,Len),
    Comb = Combinations[Rand],
    Deal := Deal ++ [Comb],
    Combinations := delete_all(Combinations, Comb)
  end.

%
% Generate a random instance and solve it.
%
generate_and_solve(NumCards,NumSets,SetLen) => 
  generate_instance(NumCards,NumSets,SetLen, Cards),
  print_cards(Cards),  
  set_puzzle(Cards,SetLen,NumSets,X), % solve it
  print_sol(Cards,X),
  nl.


%
% All the 81 possible combinations (cards)
%
table
all_combinations(All) =>
   Colors = [red, green, purple],
   Symbols = [oval, squiggle, diamond],
   Numbers = [one, two, three],
   Shadings = [solid, open, striped],
   All = findall([Color,Symbol,Number,Shading],
                  (member(Color,Colors),
                   member(Symbol,Symbols),
                   member(Number,Numbers),
                   member(Shading,Shadings))).

%
% From the task description.
%
% Solution: [[1,6,9],[2,3,4],[2,6,8],[5,6,7]]
%
sets(1,Sets,SetLen,Wanted) => 
  Sets = 
  [
    [green, one, oval, striped], % 1 
    [green, one, diamond, open], % 2 
    [green, one, diamond, striped], % 3
    [green, one, diamond, solid], % 4
    [purple, one, diamond, open], % 5
    [purple, two, squiggle, open], % 6
    [purple, three, oval, open], % 7
    [red, three, oval, open], % 8
    [red, three, diamond, solid] % 9
 ],
 SetLen = 3,
 Wanted = 4.

go4 => 
  NumCards = 18,
  NumWanted = 9,
  SetLen = 3,
  time(generate_instance2(NumCards,NumWanted, SetLen,Sets)),

  print_cards(Sets),
  println(setLen=SetLen),
  println(numWanted=NumWanted),
  SetsConv = convert_sets_to_num(Sets),

  set_puzzle_cp(SetsConv,SetLen,NumWanted, X),

  println(x=X),
  foreach(Row in X)
    println([Sets[I] : I in Row])
  end,
  nl,
  fail, % more solutions?
  nl.

set_puzzle_cp(Cards,SetLen,NumWanted, X) =>
  NumFeatures = Cards[1].len,
  NumSets = Cards.len,
  X = new_array(NumWanted,SetLen),
  X :: 1..NumSets,

  foreach(I in 1..NumWanted)
    % ensure unicity of the selected sets
    all_different(X[I]),
    increasing_strict(X[I]), % unicity and symmetry breaking of Y

    foreach(F in 1..NumFeatures)
      Z = $[ S : J in 1..SetLen, matrix_element(Cards, X[I,J],F, S) ],
      % all features are different or all equal
      (
        (sum([ Z[J] #!= Z[K] : J in 1..SetLen, K in 1..SetLen, J != K ])
                                            #= SetLen*SetLen - SetLen)
        #\/
        (sum([ Z[J-1] #= Z[J] : J in 2..SetLen]) #= SetLen-1)
      )
    end
  end,

  % Symmetry breaking (lexicographic ordered rows)
  lex2(X),

  solve($[ff,split],X).

%
% Symmetry breaking
% Ensure that the rows in X are lexicographic ordered
%
lex2(X) =>
   Len = X[1].length,
   foreach(I in 2..X.length) 
      lex_lt([X[I-1,J] : J in 1..Len], [X[I,J] : J in 1..Len])
   end.

%
% Convert sets of "verbose" instances to integer
% representations.
%
convert_sets_to_num(Sets) = NewSets =>
   Maps = new_map([
            red=1,green=2,purple=3,
            1=1,2=2,3=3,
            one=1,two=2,three=3,
            oval=1,squiggle=2,squiggles=2,diamond=3,
            solid=1,open=2,striped=3
         ]),
   NewSets1 = [],
   foreach(S in Sets)
     NewSets1 := NewSets1 ++ [[Maps.get(T) : T in S]]
   end,
   NewSets = NewSets1.


%
% Plain random problem instance, no check of solvability.
%
generate_instance2(NumCards,_NumSets,_SetLen, Cards) =>
  Cards = random_deal(NumCards).