% This is a program to find suloutions to sudoku puzzles.
% Copyright Martijn van Oosterhout <kleptog@svana.org> Oct 2005

% http://www.sudokusolver.co.uk/solvemethods.html
% http://www.goobix.com/games/sudoku/?level=very-hard

problem(1,X) :- X = [ [_,5,8,_,6,2,_,3,_],
                    [1,_,6,_,_,_,4,_,5],
                    [_,_,2,_,_,4,_,_,_],
                    [_,_,_,5,_,_,9,_,3],
                    [3,_,5,_,_,8,_,_,_],
                    [9,_,1,_,3,_,_,_,7],
                    [_,_,7,_,8,_,_,_,_],
                    [_,2,_,_,_,9,8,7,_],
                    [_,4,_,7,_,_,1,_,6] ].
problem(2,X) :- X = [[_,8,9,_,6,_,2,_,_],
                   [_,3,_,_,2,_,_,1,_],
                   [_,7,2,_,_,_,_,_,6],
                   [_,_,_,_,_,8,9,2,3],
                   [_,_,_,1,3,9,_,_,_],
                   [7,9,3,2,_,_,_,_,_],
                   [3,_,_,_,_,_,4,8,_],
                   [_,4,_,_,8,_,_,3,_],
                   [_,_,5,_,4,_,6,9,_]].
problem(3,X) :- X = [[2,_,5,1,_,_,_,_,8],
                   [_,_,_,_,_,_,7,2,_],
                   [4,_,8,9,_,2,_,_,1],
                   [_,_,3,_,6,7,_,_,_],
                   [_,_,_,3,_,1,_,_,_],
                   [_,_,_,8,5,_,2,_,_],
                   [8,_,_,6,_,3,9,_,4],
                   [_,2,4,_,_,_,_,_,_],
                   [5,_,_,_,_,8,6,_,2]].
problem(4,X) :- X = [[_,8,_,_,7,_,_,_,_],
                     [_,_,7,_,_,1,_,_,3],
                     [_,_,_,9,_,_,_,7,_],
                     [_,4,_,_,_,_,9,_,_],
                     [1,_,_,2,_,3,_,_,4],
                     [_,_,9,_,_,_,_,8,_],
                     [_,6,_,_,_,7,_,_,_],
                     [5,_,_,3,_,_,1,_,_],
                     [_,_,_,_,1,_,_,6,_]].
problem(5,X) :- X = [[_,8,_,_,_,3,9,1,_],
                     [_,_,_,6,5,_,_,3,_],
                     [9,_,_,1,7,_,_,_,4],
                     [_,_,9,_,_,_,4,7,3],
                     [_,_,_,_,_,_,_,_,_],
                     [4,1,8,_,_,_,5,_,_],
                     [3,_,_,_,8,4,_,_,9],
                     [_,9,_,_,1,6,_,_,_],
                     [_,4,2,3,_,_,_,8,_]].
% Supposedly one of the hardest
problem(6,X) :- X = [[_,5,_,_,6,_,_,_,_],
                     [_,_,1,_,_,_,_,9,_],
                     [_,_,_,_,_,7,_,_,4],
                     [2,4,_,9,_,_,_,_,_],
                     [_,_,8,_,_,_,6,_,_],
                     [_,_,_,_,_,5,_,3,7],
                     [7,_,_,8,_,_,_,_,_],
                     [_,9,_,_,_,_,2,_,_],
                     [_,_,_,_,3,_,_,1,_]].
problem(7,X) :- X = [[_,_,1,_,2,_,7,_,_],
                     [_,5,_,_,_,_,_,9,_],
                     [_,_,_,4,_,_,_,_,_],
                     [_,8,_,_,_,5,_,_,_],
                     [_,9,_,_,_,_,_,_,_],
                     [_,_,_,_,6,_,_,_,2],
                     [_,_,2,_,_,_,_,_,_],
                     [_,_,6,_,_,_,_,_,5],
                     [_,_,_,_,_,9,_,8,3]].
% Given a set of cells (an extract row, column of box from the grid) return
% the unused numbers. Unbound cells are ignored.
available( In, Out ) :- available2( In, [1,2,3,4,5,6,7,8,9], Out ).

available2( [H|T], X, Z ) :- nonvar(H), delete( X, H, Y ), available2( T, Y, Z ).
available2( [H|T], X, Z ) :- var(H), available2( T, X, Z ).
available2( [], X, X ).

% Predicate for Rin and Cin determines the range of possible values for that cell
possibles( P, Rin, Cin, Out ) :- row( P, Rin, R ), available( R, RA ),
                                 nth1( Cin, R, Val ), var(Val),            % Verify unbound
                                 col( P, Cin, C ), available( C, CA ),
                                 findbox( Rin, Cin, Bin ), box( P, Bin, B ), available( B, BA ),
                                 intersection( RA, CA, RC ), intersection( RC, BA, Out ).

possiblesset( P, K ) :- findall( [R,C,Y], possibles(P, R, C, Y), K).      % Build possibles set

newsolve( P ) :- possiblesset( P, K ),
                 newsolve2( P, K ).
% Are we done?
newsolve2( _, [] ) :- !, write( 'Success!' ), nl.
% Type 0: No empty sets
newsolve2( P, _ ) :- member( [_,_,[]], P ), !, write( 'Contradiction!' ), nl.
% Type 1: Single value possibles
newsolve2( P, K ) :- findall( [R,C,V], member( [R,C,[V]], K ), Res ), assign( 'Type1', P, Res ), !, newsolve( P ).
% Type 2: Find cells containing possible values unique to a row, col or box
newsolve2( P, K ) :- findall( Res, (findsets(K, Set), findunique( Set, Res )), Res2), assign( 'Type2', P, Res2 ), !, newsolve(P).
% Type 3: Locked candidates, described here: http://www.angusj.com/sudoku/hints.php
newsolve2( P, K ) :- findall( Merged, singleexclude( K, Merged, _ ), Res ),
                     applypossibles( Res, K, Kout ), 
                     K \= Kout, !,                     % Make sure we changed something...
                     write( 'Locked Candidates' ), nl,
                     newsolve2( P, Kout ).
                     
% Type 4: Solve Method F, Basically restrict the range of some, hopefully leading to a match elsewhere
% Described here: http://www.sudokusolver.co.uk/solvemethods.html
newsolve2( P, K ) :- findall( Merged, methodf( K, Merged ), Res ),
                     applypossibles( Res, K, Kout ), 
                     K \= Kout, !,                     % Make sure we changed something...
                     write( 'Method F' ), nl,
                     newsolve2( P, Kout ).
% If we get here, we can't solve if with our methods. Die rather than trying randomly.
newsolve2( P, K ) :- write( 'done as much as possible' ), nl, draw( P ), write(K), nl.

methodf( K, Merged ) :- findsets( K, Set ), mysubset( SubSet, Set ),     % Find sets an iterate subsets
                        SubSet \= [], SubSet \= Set, matchcount( SubSet ),  % Exclude obvious and find matches
                        mergecells( SubSet, Merged ).

% If a number is a particular row/col only appears in a single box, you can
% exclude that number from the rest of the box. This is extended to other
% possibilities. AKA Locked Candidates
singleexclude( K, [CellList,Out], [Pred1,Y,Pred2] ) :- 
                              select( Pred1, [inbox, incol, inrow], Preds ),  % Select any two in all orders, but one must be box
                              select( Pred2, Preds, PredRemain ),
                              PredRemain \= [inbox],
                              member( Y, [1,2,3,4,5,6,7,8,9] ),
                              sublist( call(Pred1,Y), K, Set ),               % Select main set
                              findall( [X,0,V], (member([R,C,V],Set), call(Pred2,X,[R,C,V])), Res ), % Divide by cross direction
                              combinebyfirst( Res, Combined ),                % Merge common values
                              select( [Z,_,Vals], Combined, Rest ),           % For each possibility
                              subtractsubs( Vals, Rest, Out ), Out \= [],     % Subtract other, if something left
                              sublist( call(Pred2,Z), Set, Cells ),           % Find relevent cells
                              findall( [R,C], member([R,C,_], Cells), CellList).  % Collect coordinates
                         


% Turn [ [1, Vals1], [1, Vals2], [2, Vals3] ] => [ [1, union(Vals1,Vals2)], [2,Vals3] ]
% The zeros are so we can use subtractsubs
combinebyfirst( In, Out ) :- combinebyfirst( In, [], Out ).
combinebyfirst( [[M,0,V]|T], Set, Out ) :- select( [M,0,V2], Set, Rest ), !,   % No backtrack if found 
                                         union(V,V2,V3), combinebyfirst(T,[[M,0,V3]|Rest],Out ).
combinebyfirst( [[M,0,V]|T], Set, Out ) :- combinebyfirst(T,[[M,0,V]|Set],Out ).
combinebyfirst( [], Out, Out ).

applypossibles( [H|T], Kin, Kout ) :- applypossiblesone( H, Kin, K2 ), applypossibles( T, K2, Kout ).
applypossibles( [], K, K ).

applypossiblesone( [Cells,Vals], [[R,C,V]|T1], [[R,C,V]|T2] ) :-    % If cell is in set, skip
                    member( [R,C], Cells ), !, applypossiblesone( [Cells,Vals], T1, T2 ).
applypossiblesone( [Cells,Vals], [[R,C,V]|T1], [[R,C,V2]|T2] ) :- 
                    forall( member( Cell, Cells ), related(Cell,[R,C]) ), !,  % Related to all in set
                    subtract( V, Vals, V2 ), applypossiblesone( [Cells,Vals], T1, T2 ). % subtract and recurse
applypossiblesone( M, [H|T1], [H|T2] ) :- applypossiblesone( M, T1, T2 ).     % No change
applypossiblesone( _, [], [] ).

mergecells( [[R,C,V]|T], [[[R,C]|Cells],Vals2] ) :- mergecells( T, [Cells, Vals] ), union( V, Vals, Vals2 ).
mergecells( [], [[],[]] ). 

% Note: Out is not the set of results. Instead, it succeeds with Out set for
% each possible answer, hence findall can find them later.
findunique( In, Out ) :- findunique2( In, In, Out ).
findunique2( [[R,C,Vals]|_], Set, [R,C,V] ) :- 
               subtract( Set, [[R,C,Vals]], Rest ),      % Remove the one we're matching from list
               subtractsubs( Vals, Rest, [V] ).          % Subtract all other values from this one
                                                         % If we unify to single result, continue
findunique2( [_|T], Set, Out ) :- findunique2(T,Set,Out ).  % Try next
findunique2( [], _, [] ) :- fail.

subtractsubs( Vals, [[_,_,V]|T], Out ) :- subtract( Vals, V, Vals2 ), subtractsubs( Vals2, T, Out ).
subtractsubs( Vals, [], Vals ).

assign( _, _, [] ) :- fail.   % Applying a blank list not allowed, must try another way
assign( S, P, [H] ) :- assignone( P, H ), write(S), nl, draw(P).
assign( S, P, [H1 | T] ) :- assignone( P, H1 ), assign( S, P, T ).

assignone( P, [R,C,V] ) :- nth1( R, P, Row ), nth1( C, Row, V ).
% Copy rows except the right one, assign to that row
%assignone( [_|P], [R,C,V] ) :- R =\= 1, R2 is R-1, assignone( P, [R2,C,V] ).
%assignone( [H|_], [1,C,V] ) :- assignone( H, [C,V] ).
% Search this row, copying until the right value
%assignone( [_|P], [C,V] ) :- C =\= 1, C2 is C-1, assignone( P, [C2,V] ).
%assignone( [V|_], [1,V] ).

% Extract a column
col( [H1|T1], Col, [H2|T2] ) :- nth1( Col, H1, H2 ), col( T1, Col, T2 ).
col( [], _, [] ).

% Extract a row
row(Prob,Row,Set) :- nth1( Row, Prob, Set ).

% Determine which box a cell is in. Note you can use this produce all the
% answers, eg, if you wanted to get the rows where col 6 is in box 5.

div3( 1, 1 ). div3( 2, 1 ). div3( 3, 1 ). 
div3( 4, 2 ). div3( 5, 2 ). div3( 6, 2 ). 
div3( 7, 3 ). div3( 8, 3 ). div3( 9, 3 ). 

findbox( R, C, B ) :- div3( R, R2 ), div3( C, C2 ), findbox2( R2, C2, B ).

findbox2( 1, 1, 1 ). findbox2( 1, 2, 2 ). findbox2( 1, 3, 3 ). 
findbox2( 2, 1, 4 ). findbox2( 2, 2, 5 ). findbox2( 2, 3, 6 ). 
findbox2( 3, 1, 7 ). findbox2( 3, 2, 8 ). findbox2( 3, 3, 9 ).

% Extract a box (*much* more complicated)
box( Prob, B, Set ) :- findbox2( R, C, B ), box2( Prob, R, C, Set ).

% Selects rows
box2( [A,B,C,_,_,_,_,_,_], 1, X, Set ) :- box3( [A,B,C], X, Set ).
box2( [_,_,_,A,B,C,_,_,_], 2, X, Set ) :- box3( [A,B,C], X, Set ).
box2( [_,_,_,_,_,_,A,B,C], 3, X, Set ) :- box3( [A,B,C], X, Set ).
% Selects cols
box3( [[S1,S2,S3,_,_,_,_,_,_],
       [S4,S5,S6,_,_,_,_,_,_],
       [S7,S8,S9,_,_,_,_,_,_]], 1, [S1, S2, S3, S4, S5, S6, S7, S8, S9] ).
box3( [[_,_,_,S1,S2,S3,_,_,_],
       [_,_,_,S4,S5,S6,_,_,_],
       [_,_,_,S7,S8,S9,_,_,_]], 2, [S1, S2, S3, S4, S5, S6, S7, S8, S9] ).
box3( [[_,_,_,_,_,_,S1,S2,S3],
       [_,_,_,_,_,_,S4,S5,S6],
       [_,_,_,_,_,_,S7,S8,S9]], 3, [S1, S2, S3, S4, S5, S6, S7, S8, S9] ).

% Draw the grid, neatly
draw([H|T]) :- drawrow(H), nl, draw(T).
draw([]).
drawrow([H|T]) :- drawcell(H), drawrow(T).
drawrow([]).
drawcell( C ) :- var(C), !, write( '. ' ).
drawcell( C ) :- nonvar(C), !, write(C), write(' ').

% Given the possibles set, returns sets that are exclusive subsets, ie, same
% row, same column or same box. In succeeds for each possibility.
findsets(K, Out) :- member( Pred, [inrow, incol, inbox] ),
                    member( R, [1,2,3,4,5,6,7,8,9] ), P =.. [Pred,R], sublist( P, K, Out ).

% Same, but not for boxes
%findlinesets(K, Out) :- member( Pred, [inrow, incol] ),
%                        member( R, [1,2,3,4,5,6,7,8,9] ), P =.. [Pred,R], sublist( P, K, Out ).

% Returns if the number of elements in List matches the number of distinct numbers appearing in List
matchcount( List ) :- matchcount2( List, [], List ).

matchcount2( L, S, [[_,_,V]|T] ) :- matchcount3( L, S, Lout, Sout, V ), matchcount2( Lout, Sout, T ).
matchcount2( [], _, [] ).  % Lists must run out simultaneously

matchcount3( Lin, Sin, Lout, Sout, [H|V] ) :- memberchk( H, Sin ), !, matchcount3( Lin, Sin, Lout, Sout, V ).  % If H is a member, no change
matchcount3( [_|Lin], Sin, Lout, Sout, [H|V] ) :- matchcount3( Lin, [H|Sin], Lout, Sout, V ).
matchcount3( Lout, S, Lout, S, [] ).

% mysubset, unlike the normal subset, returns all possible subsets
mysubset( [H|T1], [H|T2] ) :- mysubset( T1, T2 ).
mysubset( T1, [_|T2] ) :- mysubset( T1, T2 ).
mysubset( [], [] ).

inrow(R,[R,_,_]).
incol(C,[_,C,_]).
inbox(B,[R,C,_]) :- findbox(R,C,B).

% If two cell coordinates are related in someway
related( [R,_], [R,_] ).
related( [_,C], [_,C] ).
related( [R1, C1], [R2, C2] ) :- findbox( R1, C1, B ), findbox( R2, C2, B ).