Prolog: Optimizing a puzzle solver after trying really hard

Question

I am trying to solve a 15 puzzle in Prolog, I need to find the minimal number of moves.

Here we have a sample puzzle with detailed answer. https://rosettacode.org/wiki/15_puzzle_solver

I am using A* search, using manhattan distance as the heuristic.

To start with, I made sure the program is deterministic. Rules either doesn't apply, or fail quickly, or run to completion without backtracking. To optimize for space, I used a single number to represent the state. The search queue is optimized using a binomial queue, the visited check is optimized using a hashtrie. However, the performance is still awful.

Here is my implementation for the binomial queue:

:- module(myheap, [myHeapInsert/4, myHeapDeleteMin/4]).

mergeOneTree(Tree, [], [Tree]) :-
  Tree = binomialQueueNode(_, _, _, _), !.

mergeOneTree(Tree, [Head|Tail], [Tree,Head|Tail]) :- 
  Tree = binomialQueueNode(Size, _, _, _),
  Head = binomialQueueNode(Head_Size, _, _, _),
  Size < Head_Size,
  !.

mergeOneTree(Tree, [Head|Tail], Result) :-
  Tree = binomialQueueNode(Size, Data, Priority, Subtree_Content-Subtree_Indeterminate),
  Head = binomialQueueNode(Size, _, Head_Priority, _),
  Priority < Head_Priority, 
  Concatenation = Subtree_Content-Concatenation_Indeterminate,
  Subtree_Indeterminate = [Head|Concatenation_Indeterminate],
  DoubleSize is Size *2,
  mergeOneTree(binomialQueueNode(DoubleSize, Data, Priority, Concatenation), Tail, Result),
  !.

mergeOneTree(Tree, [Head|Tail], Result) :-
  Tree = binomialQueueNode(Size, _, Priority, _),
  Head = binomialQueueNode(Size, Head_Data, Head_Priority, Head_Subtree_Content-Head_Subtree_Indeterminate),
  Priority >= Head_Priority, 
  Concatenation = Head_Subtree_Content-Concatenation_Indeterminate,
  Head_Subtree_Indeterminate = [Tree|Concatenation_Indeterminate],
  DoubleSize is Size *2,
  mergeOneTree(binomialQueueNode(DoubleSize, Head_Data, Head_Priority, Concatenation), Tail, Result),
  !.

mergeOneTree(Tree, [Head|Tail], [Head|TailResult]) :-
  Tree = binomialQueueNode(Size, _, _, _),
  Head = binomialQueueNode(Head_Size, _, _, _),
  Size > Head_Size,
  mergeOneTree(Tree, Tail, TailResult),
  !.

merge([], X, X) :- !.
merge([H|T], X, R) :- mergeOneTree(H, X, I), merge(T, I, R), !.

findMinTree([H|T], MinTree, Others) :-
  findMinTree(H, T, MinTree, Others), !.

findMinTree(CurrentMin, [], CurrentMin, []) :- !.

findMinTree(CurrentMin, [Candidate|Tail], ResultMinTree, [Candidate|ResultOthers]) :-
  CurrentMin = binomialQueueNode(_, _, CurrentMin_Priority, _),
  Candidate = binomialQueueNode(_, _, Candidate_Priority, _),
  Candidate_Priority > CurrentMin_Priority,
  findMinTree(CurrentMin, Tail, ResultMinTree, ResultOthers),
  !.

findMinTree(CurrentMin, [Candidate|Tail], ResultMinTree, [CurrentMin|ResultOthers]) :-
  CurrentMin = binomialQueueNode(_, _, CurrentMin_Priority, _),
  Candidate = binomialQueueNode(_, _, Candidate_Priority, _),
  Candidate_Priority =< CurrentMin_Priority,
  findMinTree(Candidate, Tail, ResultMinTree, ResultOthers),
  !.

myHeapInsert(BeforeTree, Data, Priority, AfterTree) :- 
  mergeOneTree(binomialQueueNode(1, Data, Priority, Dummy-Dummy), BeforeTree, AfterTree), !.

myHeapDeleteMin(BeforeTree, MinData, MinPriority, AfterTree) :- 
  findMinTree(BeforeTree, MinTree, Others), 
  MinTree = binomialQueueNode(_, MinData, MinPriority, MinTreeSubTree_Content-MinTreeSubTree_Indeterminate),
  MinTreeSubTree_Indeterminate = [],
  merge(Others, MinTreeSubTree_Content, AfterTree),
  !.

Here is my implementation for the hash trie:

:- module(myhash, [myHashEmpty/1, myHashGet/4, myHashPut/5]).

reverseBinary(0, 0, []).
reverseBinary(0, L, [0|R]) :- L > 0, D is L - 1, reverseBinary(0, D, R), !.
reverseBinary(1, L, [1|R]) :- L > 0, D is L - 1, reverseBinary(0, D, R), !.
reverseBinary(N, L, Result) :- N > 1, R is N mod 2, Q is (N - R) / 2, D is L - 1, reverseBinary(Q, D, QR), Result = [R|QR], !.

getValue([H|T], Key, Value) :- H = pair(Key, Value); getValue(T, Key, Value), !.

getHash(Key, [], hashTrieLeaf(Values), Value) :- getValue(Values, Key, Value), !.
getHash(Key, [0|T], hashTrieNode(Left,_), Value) :- getHash(Key, T, Left, Value), !.
getHash(Key, [1|T], hashTrieNode(_,Right), Value) :- getHash(Key, T, Right, Value), !.

putHash(Tuple, [], hashTrieNil, hashTrieLeaf([Tuple])) :- !.
putHash(Tuple, [], hashTrieLeaf(Tuples), hashTrieLeaf([Tuple|Tuples])) :- !.
putHash(Tuple, [0|T], hashTrieNil, hashTrieNode(LeftResult, hashTrieNil)) :-
  putHash(Tuple, T, hashTrieNil, LeftResult), !.
putHash(Tuple, [0|T], hashTrieNode(Left,Right), hashTrieNode(LeftResult, Right)) :-
  putHash(Tuple, T, Left, LeftResult), !.
putHash(Tuple, [1|T], hashTrieNil, hashTrieNode(hashTrieNil, RightResult)) :-
  putHash(Tuple, T, hashTrieNil, RightResult), !.
putHash(Tuple, [1|T], hashTrieNode(Left,Right), hashTrieNode(Left, RightResult)) :-
  putHash(Tuple, T, Right, RightResult), !.

myHashEmpty(hashTrieNil) :- !.
myHashGet(HashMap, Key, Hash, Value) :- reverseBinary(Hash, 30, HashBits), getHash(Key, HashBits, HashMap, Value), !.
myHashPut(BeforeHashMap, Key, Hash, Value, AfterHashMap) :- reverseBinary(Hash, 30, HashBits), putHash(pair(Key, Value), HashBits, BeforeHashMap, AfterHashMap), !.

And finally, the puzzle solving code:

:- set_prolog_stack(global, limit(100 000 000 000)).
:- set_prolog_stack(trail,  limit(20 000 000 000)).
:- set_prolog_stack(local,  limit(2 000 000 000)).

:- use_module(myheap).
:- use_module(myhash).

hash([], 0) :- !.
hash([H|T], Hash) :- hash(T, R), Hash is (H + 23 * R) mod 1073741824, !.

flatten([[A,B,C,D],[E,F,G,H],[I,J,K,L],[M,N,O,P]],[A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P]) :- !.

moves([0,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],[move([X10,X01,X02,X03,0,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X10),move([X01,0,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X01)]) :- !.
moves([X00,0,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],[move([0,X00,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X00),move([X00,X11,X02,X03,X10,0,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X11),move([X00,X02,0,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X02)]) :- !.
moves([X00,X01,0,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],[move([X00,0,X01,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X01),move([X00,X01,X12,X03,X10,X11,0,X13,X20,X21,X22,X23,X30,X31,X32,X33],X12),move([X00,X01,X03,0,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X03)]):- !.
moves([X00,X01,X02,0,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],[move([X00,X01,0,X02,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X02),move([X00,X01,X02,X13,X10,X11,X12,0,X20,X21,X22,X23,X30,X31,X32,X33],X13)]):- !.
moves([X00,X01,X02,X03,0,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],[move([0,X01,X02,X03,X00,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X00),move([X00,X01,X02,X03,X20,X11,X12,X13,0,X21,X22,X23,X30,X31,X32,X33],X20),move([X00,X01,X02,X03,X11,0,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X11)]):- !.
moves([X00,X01,X02,X03,X10,0,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],[move([X00,0,X02,X03,X10,X01,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X01),move([X00,X01,X02,X03,0,X10,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33],X10),move([X00,X01,X02,X03,X10,X21,X12,X13,X20,0,X22,X23,X30,X31,X32,X33],X21),move([X00,X01,X02,X03,X10,X12,0,X13,X20,X21,X22,X23,X30,X31,X32,X33],X12)]):- !.
moves([X00,X01,X02,X03,X10,X11,0,X13,X20,X21,X22,X23,X30,X31,X32,X33],[move([X00,X01,0,X03,X10,X11,X02,X13,X20,X21,X22,X23,X30,X31,X32,X33],X02),move([X00,X01,X02,X03,X10,0,X11,X13,X20,X21,X22,X23,X30,X31,X32,X33],X11),move([X00,X01,X02,X03,X10,X11,X22,X13,X20,X21,0,X23,X30,X31,X32,X33],X22),move([X00,X01,X02,X03,X10,X11,X13,0,X20,X21,X22,X23,X30,X31,X32,X33],X13)]):- !.
moves([X00,X01,X02,X03,X10,X11,X12,0,X20,X21,X22,X23,X30,X31,X32,X33],[move([X00,X01,X02,0,X10,X11,X12,X03,X20,X21,X22,X23,X30,X31,X32,X33],X03),move([X00,X01,X02,X03,X10,X11,0,X12,X20,X21,X22,X23,X30,X31,X32,X33],X12),move([X00,X01,X02,X03,X10,X11,X12,X23,X20,X21,X22,0,X30,X31,X32,X33],X23)]):- !.
moves([X00,X01,X02,X03,X10,X11,X12,X13,0,X21,X22,X23,X30,X31,X32,X33],[move([X00,X01,X02,X03,0,X11,X12,X13,X10,X21,X22,X23,X30,X31,X32,X33],X10),move([X00,X01,X02,X03,X10,X11,X12,X13,X30,X21,X22,X23,0,X31,X32,X33],X30),move([X00,X01,X02,X03,X10,X11,X12,X13,X21,0,X22,X23,X30,X31,X32,X33],X21)]):- !.
moves([X00,X01,X02,X03,X10,X11,X12,X13,X20,0,X22,X23,X30,X31,X32,X33],[move([X00,X01,X02,X03,X10,0,X12,X13,X20,X11,X22,X23,X30,X31,X32,X33],X11),move([X00,X01,X02,X03,X10,X11,X12,X13,0,X20,X22,X23,X30,X31,X32,X33],X20),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X31,X22,X23,X30,0,X32,X33],X31),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X22,0,X23,X30,X31,X32,X33],X22)]):- !.
moves([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,0,X23,X30,X31,X32,X33],[move([X00,X01,X02,X03,X10,X11,0,X13,X20,X21,X12,X23,X30,X31,X32,X33],X12),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,0,X21,X23,X30,X31,X32,X33],X21),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X32,X23,X30,X31,0,X33],X32),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X23,0,X30,X31,X32,X33],X23)]):- !.
moves([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,0,X30,X31,X32,X33],[move([X00,X01,X02,X03,X10,X11,X12,0,X20,X21,X22,X13,X30,X31,X32,X33],X13),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,0,X22,X30,X31,X32,X33],X22),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X33,X30,X31,X32,0],X33)]):- !.
moves([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,0,X31,X32,X33],[move([X00,X01,X02,X03,X10,X11,X12,X13,0,X21,X22,X23,X20,X31,X32,X33],X20),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X31,0,X32,X33],X31)]):- !.
moves([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,0,X32,X33],[move([X00,X01,X02,X03,X10,X11,X12,X13,X20,0,X22,X23,X30,X21,X32,X33],X21),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,0,X30,X32,X33],X30),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X32,0,X33],X32)]):- !.
moves([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,0,X33],[move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,0,X23,X30,X31,X22,X33],X22),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,0,X31,X33],X31),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X33,0],X33)]):- !.
moves([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,0],[move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,0,X30,X31,X32,X23],X23),move([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,0,X32],X32)]):- !.
debug([X00,X01,X02,X03,X10,X11,X12,X13,X20,X21,X22,X23,X30,X31,X32,X33]) :- true,write(X00),write('\t'),write(X01),write('\t'),write(X02),write('\t'),write(X03),write('\t'),write('\n'),write(X10),write('\t'),write(X11),write('\t'),write(X12),write('\t'),write(X13),write('\t'),write('\n'),write(X20),write('\t'),write(X21),write('\t'),write(X22),write('\t'),write(X23),write('\t'),write('\n'),write(X30),write('\t'),write(X31),write('\t'),write(X32),write('\t'),write(X33),write('\t'),write('\n'),write('\n').

easy([[1, 2, 3, 4],[5, 6, 0, 8],[9, 10, 7,  11],[13, 14, 15, 12]]).
hard([[15, 14,  1,  6],[ 9, 11,  4, 12],[ 0, 10,  7,  3],[13,  8,  5,  2]]).

dist(A, B, C) :- C is A - B, C >= 0, !.
dist(A, B, C) :- C is B - A, C >= 0, !.

manhattan(L, D) :- manhattan(L, 0, D), !.
manhattan([], _, 0) :- !.
manhattan([0|T], L, D) :- 
  NextL is L + 1, 
  manhattan(T, NextL, D),
  !.
manhattan([H|T], L, D) :- 
  H > 0, 
  CellCol is L mod 4, 
  CellRow is (L - CellCol) / 4, 
  DataCol is (H - 1) mod 4, 
  DataRow is (H - 1- DataCol) / 4, 
  dist(CellCol, DataCol, CD), 
  dist(CellRow, DataRow, RD), 
  NextL is L + 1, 
  manhattan(T, NextL, TD), 
  D is CD + RD + TD,
  !.

compress([], 0) :- !.
compress([H|T], L) :- compress(T, I), L is I * 16 + H, !.

uncompress(L, R) :- uncompress(L, 16, R), !.
uncompress(_, 0, []) :- !.
uncompress(L, C, [H|T]) :- C > 0, D is C - 1, H is L mod 16, R is (L - H) / 16, uncompress(R, D, T), !.

search(CurrentBoard) :-
  myHashEmpty(EmptyHash),
  hash(CurrentBoard, CurrentBoardHash),  
  manhattan(CurrentBoard, CurrentBoardPriority),
  compress(CurrentBoard, CurrentBoardCompressed),
  myHashPut(EmptyHash, CurrentBoardCompressed, CurrentBoardHash, _, Enqueued),  
  search(CurrentBoard, CurrentBoardPriority, 0, Enqueued, []), !.

search(CurrentBoard, _, _, _, _) :-
  manhattan(CurrentBoard, 0),
  !.

search(CurrentBoard, CurrentBoardPriority, CurrentStep, Enqueued, Queue) :-
  CurrentBoardPriority > 0,
  moves(CurrentBoard, NextMoves),
  update_enqueued_queue_all(Enqueued, Queue, NextMoves, CurrentStep, NextEnqueued, ImmediateQueue),
  myHeapDeleteMin(ImmediateQueue, NextState, NextBoardPriority, NextQueue),
  state(NextBoardCompressed, _, NextStep) = NextState,
  uncompress(NextBoardCompressed, NextBoard),
  search(NextBoard, NextBoardPriority, NextStep, NextEnqueued, NextQueue),
  !.

update_enqueued_queue_all(Enqueued, Queue, [], _, Enqueued, Queue) :- !.
update_enqueued_queue_all(Enqueued, Queue, [Head|Tail], CurrentStep, NextEnqueued, NextQueue) :-
  move(HeadBoard, HeadMove) = Head,
  hash(HeadBoard, HeadHash),
  compress(HeadBoard, HeadBoardCompressed),
  update_enqueued_queue(Enqueued, Queue, HeadBoard, HeadBoardCompressed, HeadHash, HeadMove, CurrentStep, ImmediateEnqueued, ImmediateQueue),
  update_enqueued_queue_all(ImmediateEnqueued, ImmediateQueue, Tail, CurrentStep, NextEnqueued, NextQueue),
  !.

update_enqueued_queue(Enqueued, Queue, Board, BoardCompressed, BoardHash, Move, CurrentStep, NextEnqueued, NextQueue) :-
  myHashGet(Enqueued, BoardCompressed, BoardHash, _), NextEnqueued = Enqueued, NextQueue = Queue, !;  
  NextStep is CurrentStep + 1, manhattan(Board, BoardHeuristic), BoardPriority is NextStep + BoardHeuristic, myHashPut(Enqueued, BoardCompressed, BoardHash, _, NextEnqueued), myHeapInsert(Queue, state(BoardCompressed, Move, NextStep), BoardPriority, NextQueue), !.

solve(X) :- flatten(X, Y), search(Y).

run :- hard(X), solve(X).

The code, as is, does not run to completion in a few minutes on my computer. I did a profile(run) with a reduced goal (e.g. stopping when the manhattan distance is 10), majority of the time is spent on garbage collection.

I have read about another thread on StackOverflow talking about the same thing, the 'solution' was to use the constraint library, that's something I cannot use.

I run out of my bag of tricks, frankly I am not a frequent Prolog programmer. Any idea how can I do better in term of speed?

Prolog is not exactly known for speed; can you use another language? — Scott Hunter, Dec 23 '17 at 10:38
It would be interesting to see if I implement exactly the same algorithm with C or something similar, what sort of speed will I get, that establish some sort of baseline of what I should expect. I guess I can live with 10x slower, but 100x slower probably mean something is really wrong. For the sake of this post, however, can we stay with Prolog? — Andrew Au, Dec 23 '17 at 10:42
Assuming the time is dominated by backtracking, maybe a better heuristic is in order (not that I have one). — Scott Hunter, Dec 23 '17 at 21:27
What makes you think the performance is "awful", though? It seems pretty good to me, and finding a shortest path to a solution *is* [NP-hard](https://en.wikipedia.org/wiki/15_puzzle). On my PC, your code solves a puzzle requiring 25 moves in less than a second, which seems quite acceptable - getting much faster than that would probably require either calling into C or C++, or cleverer Prolog tricks than I know how to do. A C++ solver of mine takes about 20 seconds to solve a puzzle requiring 33 moves, and probably wouldn't run to completion on the "hard" instance in a few minutes, either. — phlummox, Jan 17 '18 at 03:34
Thanks @phlummox for the nice words. I wasn't aware that the program was fast for the 25 moves puzzle. I was trying out the puzzle given in this link: https://rosettacode.org/wiki/15_puzzle_solver, it is definitely a hard puzzle because it requires 53 steps, on my computer, the program just never stops. Wonder how it performs on your C++ solver? — Andrew Au, Jan 18 '18 at 02:49
Heh, well, my solver starts to take minutes once you get to about 35 moves or so, so I haven't run it on the full 53-step puzzle :) IIRC, the solvers on rosettacode.org use more heuristics than mine (there's a list of heuristics at https://heuristicswiki.wikispaces.com/N+-+Puzzle - I just used "number of mismatches"), and probably other clever tricks too. — phlummox, Jan 18 '18 at 04:35
p.s. @andrew-au, I uploaded my [c++ solver](https://github.com/phlummox/fifteen-puzzle/tree/master) if you want to try it/compare - a pretty basic implementation, but seems to work fine. — phlummox, Jan 18 '18 at 07:12

Prolog: Optimizing a puzzle solver after trying really hard

0 Answers0