Miracle Sudoku in Prolog

miracle.pl

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   Miracle Sudoku in Prolog
   Marcus Smith

   Base sudoku and PostScript animation code by Markus Triska:
   https://www.metalevel.at/sudoku/
   https://github.com/triska/clpfd

   Addtional miracle sudoku constraints:
   - Two cells separated by a knight's move or a king's move cannot contain the same digit.
   - Two cells orhtogonally adjacent cannot contain consecutive digits.

   See:
   The Miracle Sudoku <https://www.youtube.com/watch?v=yKf9aUIxdb4>
   A New Miracle Sudoku <https://www.youtube.com/watch?v=Tv-48b-KuxI>
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

:- encoding(utf8).
:- use_module(library(clpfd)).
:- use_module(library(lists)).

miracle(Rows) :-
	N = 9,
	length(Rows,N), maplist(same_length(Rows), Rows),
	append(Rows,Vs), Vs ins 1..N,
	maplist(all_distinct, Rows),
	transpose(Rows,Columns), maplist(all_distinct, Columns),
	Rows = [As,Bs,Cs,Ds,Es,Fs,Gs,Hs,Is],
	blocks(As,Bs,Cs), blocks(Ds,Es,Fs), blocks(Gs,Hs,Is),
	length(Vs,Vlength), numlist(1,Vlength,VIs),
	maplist(knight(N,Vs), VIs),
	maplist(king(N,Vs), VIs),
	maplist(orthogonal(N,Vs), VIs) .

blocks([],[],[]).
blocks([N1,N2,N3|Ns1], [N4,N5,N6|Ns2], [N7,N8,N9|Ns3]) :-
	all_distinct([N1,N2,N3,N4,N5,N6,N7,N8,N9]),
	blocks(Ns1,Ns2,Ns3) .

% Knight's move constraint:
knight(N,Vs,Cell) :-
	[DX,DY] ins -2 \/ -1 \/ 1 \/ 2,
	abs(DX) + abs(DY) #= 3,
	get_deltas(N,Vs,Cell,VCell,[DX,DY],VKnights),
	maplist(#\=(VCell), VKnights) .

% King's move constraint:
king(N,Vs,Cell) :-
	[DX,DY] ins 0 \/ -1 \/ 1,
	abs(DX) + abs(DY) #= 2, % Strictly #> 0 for a King's move, but orthogonal constraints are already covered by standard sudoku rules so we need only add diagonal constraints.
	get_deltas(N,Vs,Cell,VCell,[DX,DY],VKings),
	maplist(#\=(VCell), VKings) .

% Orthogonally adjacent non-consecutive constraint:
orthogonal(N,Vs,Cell) :-
	[DX,DY] ins 0 \/ -1 \/ 1,
	abs(DX) + abs(DY) #= 1,
	get_deltas(N,Vs,Cell,VCell,[DX,DY],VOrths),
	maplist(not_consec(VCell), VOrths) .

% Get cells we can "see" for the contstraint:
get_deltas(N,Vs,Cell,VCell,Ds,VMoves) :-
	n_x_y_k(N,X0,Y0,Cell),
	setof(Ds,label(Ds), Deltas),
	element(Cell,Vs,VCell),
	deltas_to_moves(N,Vs,X0,Y0,Deltas,[],VMoves) .

% For an N×N grid, convert between x/y coordinates and list index:
n_x_y_k(N,X,Y,K) :-
	[X,Y] ins 1..N,
	K #= N*(Y-1) + X .

% Apply a list of vectors to a coordinate, returning a list of new cells:
deltas_to_moves(_,_,_,_,[],L,L).
deltas_to_moves(N,Vs,X0,Y0,[Delta|Deltas],L2,VMoves) :-
	translate(N,Vs,X0,Y0,Delta,VMove),
	deltas_to_moves(N,Vs,X0,Y0,Deltas,[VMove|L2],VMoves).
% Exclude coordinates that end up outside the grid (ie for which the goals of n_x_y_k/4 are incompatible):
deltas_to_moves(N,Vs,X0,Y0,[_|Deltas],L2,VMoves) :-
	deltas_to_moves(N,Vs,X0,Y0,Deltas,L2,VMoves) .

% Apply a vector to a coordinate, returning a new cell:
translate(N,Vs,X0,Y0,Delta,VMove) :-
	Delta = [DX,DY],
	[X,Y] ins 1..N,
	X #= X0 + DX,
	Y #= Y0 + DY,
	n_x_y_k(N,X,Y,Move),
	element(Move,Vs,VMove) .

% Non-consecutive constraint for maplist/2:
not_consec(VCell,VOrth) :- abs(VCell - VOrth) #\= 1 .


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   Sample problems.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

% Miracle Sudoku by Mitchell Lee
% https://www.youtube.com/watch?v=yKf9aUIxdb4
problem('Miracle',P) :-
	P = [[_,_,_,_,_,_,_,_,_],
	     [_,_,_,_,_,_,_,_,_],
	     [_,_,_,_,_,_,_,_,_],
	     [_,_,_,_,_,_,_,_,_],
	     [_,_,1,_,_,_,_,_,_],
	     [_,_,_,_,_,_,2,_,_],
	     [_,_,_,_,_,_,_,_,_],
	     [_,_,_,_,_,_,_,_,_],
	     [_,_,_,_,_,_,_,_,_]].

% The New Miracle Sudoku by Aad van de Wetering
% https://www.youtube.com/watch?v=Tv-48b-KuxI
problem('New Miracle',P) :-
	P = [[_,_,_,_,_,_,_,_,_],
	     [_,_,_,_,_,_,_,_,_],
	     [_,_,_,_,4,_,_,_,_],
	     [_,_,3,_,_,_,_,_,_],
	     [_,_,_,_,_,_,_,_,_],
	     [_,_,_,_,_,_,_,_,_],
	     [_,_,_,_,_,_,_,_,_],
	     [_,_,_,_,_,_,_,_,_],
	     [_,_,_,_,_,_,_,_,_]].

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   Example queries:
   ?- problem('Miracle',Rows), miracle(Rows), maplist(labeling([ff]),Rows), maplist(writeln, Rows),! .

   However, operating on a single list is *much* faster:
   ?- problem('Miracle',Rows), miracle(Rows), append(Rows,Vs), labeling([ff],Vs), maplist(writeln, Rows),!, false .

   Generate squares:
   ?- miracle(Rows), append(Rows,Vs), labeling([ff],Vs), maplist(writeln, Rows),! .
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   Animation.

   A frozen goal for each variable emits PostScript instructions to
   draw a number. On backtracking, the field is cleared.

   Example:
   ?- problem('Miracle',Rows), show([ff],Rows) .
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

animate(Rows) :- animate(Rows,1).

animate([],_).
animate([Row|Rows],N) :-
	animate(Row,1,N),
	N1 #= N + 1,
	animate(Rows,N1).

animate([],_,_).
animate([C|Cs],Col,Row) :-
	freeze(C,label(Col,Row,C)),
	Col1 #= Col + 1,
	animate(Cs,Col1,Row).

label(Col,Row,N) :- format("(~w) ~w ~w num\n", [N,Col,Row]).
label(Col,Row,_) :- format("~w ~w clear\n", [Col,Row]), false.

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   PostScript definitions. Place a number N and clear a cell with:

   (N) Col Row num
   Col Row clear
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

postscript -->
	"/Palatino-Bold findfont 5 scalefont setfont \c
	320 9 div dup scale 0 setlinewidth -0.9 -0.9 translate \c
	/num { gsave 10 exch sub translate 0.5 0.25 translate 0.16 dup scale \c
		dup stringwidth pop -2 div 0 moveto show grestore } bind def \c
	/clear { gsave 10 exch sub translate 1 setgray 0.1 dup 0.8 \c
		dup rectfill grestore } bind def \c
	1 1 10 { gsave dup 1 moveto 10 lineto stroke grestore } for \c
	1 1 10 { gsave dup 1 exch moveto 10 exch lineto stroke grestore } for \c
	1 3 9 { 1 3 9 { 1 index gsave translate 0.05 setlinewidth
		0 0 3 3 rectstroke grestore } for pop } for\n".

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   Set up communication with gs.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

show(Options,Rows) :-
	miracle(Rows),
	open(pipe('gs -dNOPROMPT -g680x680 -dGraphicsAlphaBits=2 -r150 -q'),
		 write, Out, [buffer(false)]),
	tell(Out),
	phrase(postscript,Ps),
	format(Ps),
	append(Rows,Vs),
	call_cleanup((animate(Rows),labeling(Options,Vs)), close(Out)).