1:- module(npuzzle,[]).    2% N-puzzle program    K. Mukai SFC Keio
    3% 1995.6.26 20:22  
    4% 
    5%   unsolvable case   
    6% | ?- npuzzle([[15,14,13,12],[11,10,9,8],[7,6,5,4],[3,2,1,0]],X).
    7%
    8%   solvable case
    9% | ?- npuzzle([[14,15,13,12],[11,10,9,8],[7,6,5,4],[3,2,1,0]],X).
   10% | ?- npuzzle([[24,23,22,21,20],[19,18,17,16,15],[14,13,12,11,10],
   11%      [9,8,7,6,5],[4,3,2,1,0]],P).
   12% :- use_module(library(lists)).
   13
   14non_member(X,Y):- member(X,Y),!,fail.
   15non_member(_,_).
   16
   17% for generating benchmark tests
   18makepuzzle(N,X):-J is N*N-1, matrix(N,N,X),setnpuzzle(J,X).
   19
   20matrix(1,N,[X]):-!,length(X,N).
   21matrix(K,N,[T|R]):- J is K-1, length(T,N), matrix(J,N,R).
   22
   23setnpuzzle(_,[]):-!.
   24setnpuzzle(X,[[]|Y]):-!,setnpuzzle(X,Y).
   25setnpuzzle(X,[[X|Y]|Z]):-!,U is X-1, setnpuzzle(U,[Y|Z]).
   26
   27test(N,X,L):- 
   28	makepuzzle(N,A),
   29        npuzzle(A,P),
   30	flatten(P,Pf),
   31	length(Pf,L),
   32        reverse2(A,[],Ar),
   33        opposite(P,Po),
   34        apply(Po,Ar,B),
   35        reverse2(B,[],X).
   36
   37% | ?- test(5,X,_).
   38%
   39% X = [[ 1, 2, 3, 4, 5],
   40%      [ 6, 7, 8, 9,10],
   41%      [11,12,13,14,15],
   42%      [16,17,18,19,20],
   43%      [21,22,23,24, 0]] 
   44%
   45
   46% main predicate
   47
   48npuzzle_web(X, 'Result' = Y) :- npuzzle(X,Y).
   49
   50npuzzle(X,Y):-
   51	reverse2(X,[],Xr),     % reverse rows and columns
   52	makelinear(Xr,[_|Z]),  % see as a list of integers
   53	bubblesort(Z,_,G),     % lists of switches (i,j)
   54	length(G,N),
   55	0 =:= N mod 2,         % even permutation means being solvable.
   56	!,
   57	switch2cycle(G,L),     % even permutaions to 3-cyclic permutaions.
   58	cycle2path(L,Xr,_,Y1),
   59	opposite(Y1,Y2),
   60	flatten(Y2,Y).			% left-right, up-down  reverse
   61npuzzle(_,'unsolvable: odd permutation').
   62
   63cycle2path([],X,X,[]).
   64cycle2path([X|Y],Z,U,[P,Q]):-
   65	cycle(X,Z,Z1,P),
   66	cycle2path(Y,Z1,U,Q).
   67
   68makelinear([],[]).
   69makelinear([X|Y],Z):-
   70	makelinear(Y,Z1),
   71	append(X,Z1,Z).
   72
   73bubblesort([],[],[]).
   74bubblesort([X|Y],Z,U):-
   75	bubblesort(Y,V,W),
   76	insert(X,V,Z,P),
   77	append(W,P,U).
   78
   79insert(X,[],[X],[]):-!.
   80insert(X,[Y|Z],[X,Y|Z],[]):-X>Y,!.
   81insert(X,[Y|Z],[Y|U],[[Y,X]|V]):-insert(X,Z,U,V).
   82
   83% product of two 2-cyclic permutations is a product of 
   84% 3-cyclic permutations.
   85makecyclic([X,Y],[Z,U],[]):-member(X,[Z,U]),member(Y,[Z,U]),!.
   86makecyclic([X,Y],[X,U],[[X,Y,U]]):-!.
   87makecyclic([X,Y],[U,X],[[X,Y,U]]):-!.
   88makecyclic([Y,X],[U,X],[[X,Y,U]]):-!.
   89makecyclic([Y,X],[X,U],[[X,Y,U]]):-!.
   90makecyclic([X,U],[Y,Z],[[X,Y,Z],[X,Y,U]]).
   91
   92switch2cycle([],[]).
   93switch2cycle([X,Y|Z],U):-
   94	makecyclic(X,Y,C),
   95	switch2cycle(Z,U1),
   96	append(C,U1,U).
   97
   98cycle(A,[X,Y|Z],[X1,Y1|Z],P):-
   99	contain(A,[X,Y]),!,
  100        cycle2n(A,[X,Y],[X1,Y1],P).
  101cycle(A,X,Y,P):-
  102	X=[[_,_]|_],!,  % two columns matrix
  103	zip(X,X1), % for reducing to two rows matrix.
  104	cycle(A,X1,Y1,P1),
  105	zip(Y1,Y),
  106	zip_path(P1,P).
  107cycle(A,[[0|X],Y|Z],[R1,R2|Z2],[P,d,Q,u,Pi]):-
  108	cleartop(A,[[0|X],Y],[[0|X1],[U|Y1]],P),
  109	inverse(P,Pi),
  110	cycle(A,[[0|Y1]|Z],[[0|Y2]|Z2],Q),
  111	apply([u,Pi],[[U|X1],[0|Y2]],[R1,R2]).
  112
  113cleartop(A,[[0,X|R],[Z,U|S]|W],[R1,R2|W],[P,Q]):-
  114	cleartop1(A,[[0,X],[Z,U]],[[0,X1],[Z1,U1]],P),
  115	cleartop2(A,[[0,X1|R],[Z1,U1|S]],[R1,R2],Q).
  116
  117cleartop1(A,[[0,X],[Z,U]],[[0,X],[Z,U]],[]):-non_member(Z,A),!.
  118cleartop1(A,[[0,X],[Z,U]],V,P):-non_member(X,A),!,
  119	triple2path([Z,X,U],[[0,X],[Z,U]],V,P).
  120cleartop1(_,[[0,X],[Z,U]],V,P):-
  121	triple2path([Z,U,X],[[0,X],[Z,U]],V,P).
  122
  123cleartop2(A,[[0,X|R],[Y,Z|S]],D,[P,Q]):-
  124	member(U,A),
  125	member(U,[X|R]),!,
  126	cleartop3(U,A,[[0,X|R],[Y,Z|S]],T,P),
  127	cleartop2(A,T,D,Q).
  128cleartop2(_,X,X,[]).
  129
  130cleartop3(N,A,[X,[Y,Z,U|S]],T,P):-member(Z,A),!,
  131	cycle2n([Z,N,U],[X,[Y,Z,U|S]],T,P).
  132cleartop3(N,_,[X,[Y,Z,U|S]],T,P):-
  133	cycle2n([N,Z,U],[X,[Y,Z,U|S]],T,P).
  134
  135% | ?- cycle2n([1,2,3],[[0,1,4],[2,5,3]],X,P).
  136% P = [r,[[l,d,r,u],[[r,d,l,u],[[l,d,r,u],[]]]],[r,d,l,u],
  137%         [[[[],[d,l,u,r]],[d,r,u,l]],[d,l,u,r]],l]
  138% X = [[0,2,4],[3,5,1]] ? 
  139cycle2n([A,B,C],[[0,X|R],[Y,Z|S]],[[0,X1|R],[Y1,Z1|S]],Q):-
  140	member(X,[A,B,C]),
  141	member(Y,[A,B,C]),
  142	member(Z,[A,B,C]),!,
  143	triple2path([A,B,C],[[0,X],[Y,Z]],[[0,X1],[Y1,Z1]],Q).
  144cycle2n(P,[[0,X,U|R],[Y,Z,V|S]],
  145       [[0,X3,U3|R2],[Y3,Z3,V3|S2]],
  146	 [r,H,G,Hi,l]):-
  147 clearleft(P,[[X,0,U],[Y,Z,V]],[[X1,0,U1],[Y1,Z1,V1]],H),
  148 inverse(H,Hi),
  149 cycle2n(P,[[0,U1|R],[Z1,V1|S]],[[0,U2|R2],[Z2,V2|S2]],G),
  150 apply(Hi,[[X1,0,U2],[Y1,Z2,V2]],[[X3,0,U3],[Y3,Z3,V3]]).
  151
  152equalcycperm([A,B,C],[A,B,C]).
  153equalcycperm([B,C,A],[A,B,C]).
  154equalcycperm([C,A,B],[A,B,C]).
  155
  156move1(r,[[0,X],Y],[[X,0],Y]).  
  157move1(d,[[X,0],[Y,Z]],[[X,Z],[Y,0]]).
  158move1(l,[X,[Z,0]],[X,[0,Z]]).
  159move1(u,[[X,Y],[0,Z]],[[0,Y],[X,Z]]).
  160move1(r,[Y,[0,X]],[Y,[X,0]]).
  161move1(u,[[X,Y],[Z,0]],[[X,0],[Z,Y]]).
  162move1(l,[[X,0],Y],[[0,X],Y]).
  163move1(d,[[0,X],[Y,Z]],[[Y,X],[0,Z]]).
  164
  165turn(Z,[[A,B|X1],[C,D|X2]|X],[[E,F|X1],[G,H|X2]|X]):-
  166	turn1(Z,[[A,B],[C,D]],[[E,F],[G,H]]).
  167
  168turn1([d,r,u,l],[[0,A],[B,C]],[[0,B],[C,A]]).
  169turn1([r,d,l,u],[[0,A],[B,C]],[[0,C],[A,B]]).
  170turn1([l,d,r,u],[[A,0],[B,C]],[[B,0],[C,A]]).
  171turn1([d,l,u,r],[[A,0],[B,C]],[[C,0],[A,B]]).
  172turn1([l,u,r,d],[[A,B],[C,0]],[[B,C],[A,0]]).
  173turn1([u,l,d,r],[[A,B],[C,0]],[[C,A],[B,0]]).
  174turn1([r,u,l,d],[[A,B],[0,C]],[[C,A],[0,B]]).
  175turn1([u,r,d,l],[[A,B],[0,C]],[[B,C],[0,A]]).
  176         
  177% | ?- apply([r,d,r,u],[[0,1,2],[3,4,5]],X).
  178% X = [[1,4,0],[3,5,2]] ? 
  179
  180apply(X,Y,Z):-apply(X,[],[],Y,M,N,U),restore(M,N,U,Z).
  181
  182apply([],M,N,X,M,N,X).
  183apply([A,B,C,D|W],M,N,X,M1,N1,X1):-
  184	turn([A,B,C,D],X,X2),!,
  185	apply(W,M,N,X2,M1,N1,X1).
  186apply([A|W],M,N,X,M1,N1,X1):-!,
  187	apply(A,M,N,X,M2,N2,X2),
  188	apply(W,M2,N2,X2,M1,N1,X1).
  189apply(A,M,N,[[X,Y|R],[U,V|S]|T],M,N,[[X1,Y1|R],[U1,V1|S]|T]):-
  190	move1(A,[[X,Y],[U,V]],[[X1,Y1],[U1,V1]]),!.
  191apply(u,M,[R|Rs],X,M1,N1,X1):-apply(u,M,Rs,[R|X],M1,N1,X1).
  192apply(d,M,N,[X|Y],M1,N1,X1):-apply(d,M,[X|N],Y,M1,N1,X1).
  193apply(l,[C|M],N,X,M1,N1,X1):-!,
  194	revmulticons(C,N,N2,C2),
  195	multicons(C2,X,X3),
  196	apply(l,M,N2,X3,M1,N1,X1).
  197apply(r,M,N,X,M1,N1,X1):-
  198	firstcolumn(N,Cn,N2),
  199	firstcolumn(X,Cx,X2),
  200	reverse(Cn,Cx,C),
  201	apply(r,[C|M],N2,X2,M1,N1,X1).
  202
  203triple2path(T,[[0,X],[Z,Y]],[[0,Y],[X,Z]],[r,d,l,u]):-
  204	equalcycperm(T,[X,Y,Z]),!.
  205triple2path(T,[[Z,0],[Y,X]],[[X,0],[Z,Y]],[d,l,u,r]):-
  206	equalcycperm(T,[X,Y,Z]),!.
  207triple2path(T,[[Y,Z],[X,0]],[[Z,X],[Y,0]],[l,u,r,d]):-
  208	equalcycperm(T,[X,Y,Z]),!.
  209triple2path(T,[[X,Y],[0,Z]],[[Y,Z],[0,X]],[u,r,d,l]):-
  210	equalcycperm(T,[X,Y,Z]),!.
  211triple2path(_,[[0,X],[Z,Y]],[[0,Z],[Y,X]],[d,r,u,l]):-!.
  212triple2path(_,[[Z,0],[Y,X]],[[Y,0],[X,Z]],[l,d,r,u]):-!.
  213triple2path(_,[[Y,Z],[X,0]],[[X,Y],[Z,0]],[u,l,d,r]):-!.
  214triple2path(_,[[X,Y],[0,Z]],[[Z,X],[0,Y]],[r,u,l,d]).
  215
  216% | ?- clearleft([1,2,3],[[1,0,4],[2,5,3]],R,P).
  217% P = [[l,d,r,u],[[r,d,l,u],[[l,d,r,u],[]]]],
  218% R = [[5,0,3],[4,2,1]] ? 
  219clearleft(C,[[X,0,Y],[Z,U,V]],[[X,0,Y],[Z,U,V]],[]):-
  220	non_member(X,C),
  221	non_member(Z,C),!.
  222clearleft(C,[[X,0,Y],[Z,U,V]],R,[P,Q]):-
  223	member(U,C),!,
  224	out(A,[Y,V],C),
  225	remove(A,[Y,V],[B]),
  226	triple2path([U,A,B],[[0,Y],[U,V]],[M,N],P),
  227	clearleft(C,[[X|M],[Z|N]],R,Q).
  228clearleft(C,[[X,0,Y],[Z,U,V]],R,[P,Q]):-
  229	member(X,C),!,
  230	triple2path([U,X,Z],[[X,0],[Z,U]],[[X1,0],[Z1,U1]],P),
  231	clearleft(C,[[X1,0,Y],[Z1,U1,V]],R,Q).
  232clearleft(C,[[X,0,Y],[Z,U,V]],R,[P,Q]):-
  233	triple2path([U,Z,X],[[X,0],[Z,U]],[[X1,0],[Z1,U1]],P),
  234	clearleft(C,[[X1,0,Y],[Z1,U1,V]],R,Q).
  235
  236%
  237% member(X,[X|_]).
  238% member(X,[_|Y]):-member(X,Y).
  239
  240%flatten(X,Y):-flatten(X,Y,[]).
  241%flatten([],X,X):-!.
  242%flatten(X,[X|Z],Z):-atomic(X),!.
  243%flatten([X|Y],Z,U):-flatten(X,Z,V),flatten(Y,V,U).
  244
  245remove(_,[],[]).
  246remove(X,[X|Y],Y).
  247remove(X,[U|Y],[U|Z]):-X\==U,remove(X,Y,Z).
  248
  249out(A,X,Y):-member(A,X),non_member(A,Y).
  250
  251reverse([],X,X).
  252reverse([X|Y],Z,U):-reverse(Y,[X|Z],U).
  253
  254reverse2([],X,X).
  255reverse2([X|Y],Z,U):-reverse(X,[],Xr), reverse2(Y,[Xr|Z],U).
  256
  257restore(X,Y,Z,U):-reverse(Y,Z,Z1),restorecol(X,Z1,U).
  258
  259restorecol([],X,X).
  260restorecol([X|Y],Z,U):-multicons(X,Z,Z1),restorecol(Y,Z1,U).
  261
  262multicons([],[],[]).
  263multicons([X|Y],[Z|U],[[X|Z]|V]):-multicons(Y,U,V).
  264
  265revmulticons(A,[],[],A).
  266revmulticons(A,[X|Y],[[D|X]|Y1],B):-revmulticons(A,Y,Y1,[D|B]).
  267
  268contain([],_).
  269contain([X|Y],Z):-contain1(X,Z),contain(Y,Z).
  270
  271contain1(X,[Y|_]):-member(X,Y),!.
  272contain1(X,[_|R]):-contain1(X,R).
  273
  274firstcolumn([],[],[]).
  275firstcolumn([[X|X1]|R],[X|Y],[X1|S]):-firstcolumn(R,Y,S).
  276
  277zip_path([],[]).
  278zip_path([X|Y],[Xt|Yt]):-
  279	zip_path(X,Xt),
  280	zip_path(Y,Yt).
  281zip_path(X,Y):-zip_path1(X,Y).
  282
  283zip_path1(d,r).
  284zip_path1(r,d).
  285zip_path1(u,l).
  286zip_path1(l,u).
  287
  288opposite(u,d).
  289opposite(d,u).
  290opposite(l,r).
  291opposite(r,l).
  292
  293opposite([],[]).
  294opposite([X|Y],[Xo|Yo]):-opposite(X,Xo), opposite(Y,Yo).
  295
  296inverse([],[]).
  297inverse(r,l).
  298inverse(l,r).
  299inverse(d,u).
  300inverse(u,d).
  301inverse([X|Y],Z):-inverse([X|Y],[],Z).
  302
  303inverse([],X,X).
  304inverse([X|Y],Z,U):-inverse(X,Xi), inverse(Y,[Xi|Z],U)