15 puzzle solver: Difference between revisions
Content added Content deleted
m (→Iterative Depth A*: Fixed formatting) |
(My solution in Common Lisp) |
||
Line 36: | Line 36: | ||
* [[A* search algorithm]] |
* [[A* search algorithm]] |
||
<br><br> |
<br><br> |
||
=={{Common Lisp}}== |
|||
{{trans|Racket}} |
|||
Using an A* search algorithm which is good enough for the first task. I increased SBCL's dynamic memory to 2GB for the code to run smoothly. |
|||
<lang lisp>;;; Using a priority queue for the A* search |
|||
(eval-when (:load-toplevel :compile-toplevel :execute) |
|||
(ql:quickload "pileup")) |
|||
;; * The package definition |
|||
(defpackage :15-solver |
|||
(:use :common-lisp :pileup) |
|||
(:export "15-puzzle-solver" "*initial-state*" "*goal-state*")) |
|||
(in-package :15-solver) |
|||
;; * Data types |
|||
(defstruct (posn (:constructor posn)) |
|||
"A posn is a pair struct containing two integer for the row/col indices." |
|||
(row 0 :type fixnum) |
|||
(col 0 :type fixnum)) |
|||
(defstruct (state (:constructor state)) |
|||
"A state contains a vector and a posn describing the position of the empty slot." |
|||
(matrix '#(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 0) :type simple-vector) |
|||
(empty-slot (posn :row 3 :col 3) :type posn)) |
|||
(defparameter directions '(up down left right) |
|||
"The possible directions shifting the empty slot.") |
|||
(defstruct (node (:constructor node)) |
|||
"A node contains a state, a reference to the previous node, a g value (actual |
|||
costs until this node, and a f value (g value + heuristics)." |
|||
(state (state) :type state) |
|||
(prev nil) |
|||
(cost 0 :type fixnum) |
|||
(f-value 0 :type fixnum)) |
|||
;; * Some constants |
|||
(defparameter *side-size* 4 "The size of the puzzle.") |
|||
(defvar *initial-state* |
|||
(state :matrix #(15 14 1 6 |
|||
9 11 4 12 |
|||
0 10 7 3 |
|||
13 8 5 2) |
|||
:empty-slot (posn :row 2 :col 0))) |
|||
(defvar *initial-state-2* |
|||
(state :matrix #( 0 12 9 13 |
|||
15 11 10 14 |
|||
3 7 2 5 |
|||
4 8 6 1) |
|||
:empty-slot (posn :row 0 :col 0))) |
|||
(defvar *goal-state* |
|||
(state :matrix #( 1 2 3 4 |
|||
5 6 7 8 |
|||
9 10 11 12 |
|||
13 14 15 0) |
|||
:empty-slot (posn :row 3 :col 3))) |
|||
;; * The functions |
|||
;; ** Accessing the elements of the puzzle |
|||
(defun matrix-ref (matrix row col) |
|||
"Matrices are simple vectors, abstracted by following functions." |
|||
(svref matrix (+ (* row *side-size*) col))) |
|||
(defun (setf matrix-ref) (val matrix row col) |
|||
(setf (svref matrix (+ (* row *side-size*) col)) val)) |
|||
;; ** The final predicate |
|||
(defun target-state-p (state goal-state) |
|||
"Returns T if STATE is the goal state." |
|||
(equalp state goal-state)) |
|||
(defun valid-movement-p (direction empty-slot) |
|||
"Returns T if direction is allowed for the current empty slot position." |
|||
(case direction |
|||
(up (< (posn-row empty-slot) (1- *side-size*))) |
|||
(down (> (posn-row empty-slot) 0)) |
|||
(left (< (posn-col empty-slot) (1- *side-size*))) |
|||
(right (> (posn-col empty-slot) 0)))) |
|||
;; ** Pretty print the state |
|||
(defun print-state (state) |
|||
"Helper function to pretty-print a state." |
|||
(format t " ====================~%") |
|||
(loop |
|||
with matrix = (state-matrix state) |
|||
for i from 0 below *side-size* |
|||
do |
|||
(loop |
|||
for j from 0 below *side-size* |
|||
do (format t "| ~2,D " (matrix-ref matrix i j))) |
|||
(format t " |~%")) |
|||
(format t " ====================~%")) |
|||
;; ** Move the empty slot |
|||
(defun move (state direction) |
|||
"Returns a new state after moving STATE's empty-slot in DIRECTION assuming a |
|||
valid direction." |
|||
(let* ((matrix (copy-seq (state-matrix state))) |
|||
(empty-slot (state-empty-slot state)) |
|||
(r (posn-row empty-slot)) |
|||
(c (posn-col empty-slot)) |
|||
(new-empty-slot |
|||
(ccase direction |
|||
(up (setf (matrix-ref matrix r c) (matrix-ref matrix (1+ r) c) |
|||
(matrix-ref matrix (1+ r) c) 0) |
|||
(posn :row (1+ r) :col c)) |
|||
(down (setf (matrix-ref matrix r c) (matrix-ref matrix (1- r) c) |
|||
(matrix-ref matrix (1- r) c) 0) |
|||
(posn :row (1- r) :col c)) |
|||
(left (setf (matrix-ref matrix r c) (matrix-ref matrix r (1+ c)) |
|||
(matrix-ref matrix r (1+ c)) 0) |
|||
(posn :row r :col (1+ c))) |
|||
(right (setf (matrix-ref matrix r c) (matrix-ref matrix r (1- c)) |
|||
(matrix-ref matrix r (1- c)) 0) |
|||
(posn :row r :col (1- c)))))) |
|||
(state :matrix matrix :empty-slot new-empty-slot))) |
|||
;; ** The heuristics |
|||
(defun l1-distance (posn0 posn1) |
|||
"Returns the L1 distance between two positions." |
|||
(+ (abs (- (posn-row posn0) (posn-row posn1))) |
|||
(abs (- (posn-col posn0) (posn-col posn1))))) |
|||
(defun element-cost (val current-posn) |
|||
"Returns the L1 distance between the current position and the goal-position |
|||
for VAL." |
|||
(if (zerop val) |
|||
(l1-distance current-posn (posn :row 3 :col 3)) |
|||
(multiple-value-bind (target-row target-col) |
|||
(floor (1- val) *side-size*) |
|||
(l1-distance current-posn (posn :row target-row :col target-col))))) |
|||
(defun distance-to-goal (state) |
|||
"Returns the L1 distance from STATE to the goal state." |
|||
(loop |
|||
with matrix = (state-matrix state) |
|||
with sum = 0 |
|||
for i below *side-size* |
|||
do (loop |
|||
for j below *side-size* |
|||
for val = (matrix-ref matrix i j) |
|||
for cost = (element-cost val (posn :row i :col j)) |
|||
unless (zerop val) |
|||
do (incf sum cost)) |
|||
finally (return sum))) |
|||
(defun out-of-order-values (list) |
|||
"Returns the number of values out of order." |
|||
(flet ((count-values (list) |
|||
(loop |
|||
with a = (first list) |
|||
with rest = (rest list) |
|||
for b in rest |
|||
when (> b a) |
|||
count b))) |
|||
(loop |
|||
for candidates = list then (rest candidates) |
|||
while candidates |
|||
summing (count-values candidates) into result |
|||
finally (return (* 2 result))))) |
|||
(defun row-conflicts (row state0 state1) |
|||
"Returns the number of conflicts in the given row, i.e. value in the right row |
|||
but in the wrong order. For each conflicted pair add 2 to the value, but a |
|||
maximum of 6 to avoid over-estimation." |
|||
(let* ((goal-row (loop |
|||
with matrix1 = (state-matrix state1) |
|||
for j below *side-size* |
|||
collect (matrix-ref matrix1 row j))) |
|||
(in-goal-row (loop |
|||
with matrix0 = (state-matrix state0) |
|||
for j below *side-size* |
|||
for val = (matrix-ref matrix0 row j) |
|||
when (member val goal-row) |
|||
collect val))) |
|||
(min 6 (out-of-order-values |
|||
;; 0 does not lead to a linear conflict |
|||
(remove 0 (nreverse in-goal-row)))))) |
|||
(defun col-conflicts (col state0 state1) |
|||
"Returns the number of conflicts in the given column, i.e. value in the right |
|||
row but in the wrong order. For each conflicted pair add 2 to the value, but a |
|||
maximum of 6 to avoid over-estimation." |
|||
(let* ((goal-col (loop |
|||
with matrix1 = (state-matrix state1) |
|||
for i below *side-size* |
|||
collect (matrix-ref matrix1 i col))) |
|||
(in-goal-col (loop |
|||
with matrix0 = (state-matrix state0) |
|||
for i below *side-size* |
|||
for val = (matrix-ref matrix0 i col) |
|||
when (member val goal-col) |
|||
collect val))) |
|||
(min 6 (out-of-order-values |
|||
;; 0 does not lead to a linear conflict |
|||
(remove 0 (nreverse in-goal-col)))))) |
|||
(defun linear-conflicts (state0 state1) |
|||
"Returns the linear conflicts for state1 with respect to state0." |
|||
(loop |
|||
for i below *side-size* |
|||
for row-conflicts = (row-conflicts i state0 state1) |
|||
for col-conflicts = (col-conflicts i state0 state1) |
|||
summing row-conflicts into all-row-conflicts |
|||
summing col-conflicts into all-col-conflicts |
|||
finally (return (+ all-row-conflicts all-col-conflicts)))) |
|||
(defun state-heuristics (state) |
|||
"Using the L1 distance and the number of linear conflicts as heuristics." |
|||
(+ (distance-to-goal state) |
|||
(linear-conflicts state *goal-state*))) |
|||
;; ** Generate the next possible states. |
|||
(defun next-state-dir-pairs (current-node) |
|||
"Returns a list of pairs containing the next states and the direction for the |
|||
movement of the empty slot." |
|||
(let* ((state (node-state current-node)) |
|||
(empty-slot (state-empty-slot state)) |
|||
(valid-movements (remove-if-not (lambda (dir) (valid-movement-p dir empty-slot)) |
|||
directions))) |
|||
(map 'list (lambda (dir) (cons (move state dir) dir)) valid-movements))) |
|||
;; ** Searching the shortest paths and reconstructing the movements |
|||
(defun reconstruct-movements (leaf-node) |
|||
"Traverse all nodes until the initial state and return a list of symbols |
|||
describing the path." |
|||
(labels ((posn-diff (p0 p1) |
|||
;; Compute a pair describing the last move |
|||
(posn :row (- (posn-row p1) (posn-row p0)) |
|||
:col (- (posn-col p1) (posn-col p0)))) |
|||
(find-movement (prev-state state) |
|||
;; Describe the last movement of the empty slot with R, L, U or D. |
|||
(let* ((prev-empty-slot (state-empty-slot prev-state)) |
|||
(this-empty-slot (state-empty-slot state)) |
|||
(delta (posn-diff prev-empty-slot this-empty-slot))) |
|||
(cond ((equalp delta (posn :row 1 :col 0)) 'u) |
|||
((equalp delta (posn :row -1 :col 0)) 'd) |
|||
((equalp delta (posn :row 0 :col 1)) 'l) |
|||
((equalp delta (posn :row 0 :col -1)) 'r)))) |
|||
(iter (node path) |
|||
(if (or (not node) (not (node-prev node))) |
|||
path |
|||
(iter (node-prev node) |
|||
(cons (find-movement (node-state node) |
|||
(node-state (node-prev node))) |
|||
path))))) |
|||
(iter leaf-node '()))) |
|||
(defun A* (initial-state |
|||
&key (goal-state *goal-state*) (heuristics #'state-heuristics) |
|||
(information 0)) |
|||
"An A* search for the shortest path to *GOAL-STATE*" |
|||
(let ((visited (make-hash-table :test #'equalp))) ; All states visited so far |
|||
;; Some internal helper functions |
|||
(flet ((pick-next-node (queue) |
|||
;; Get the next node from the queue |
|||
(heap-pop queue)) |
|||
(expand-node (node queue) |
|||
;; Expand the next possible nodes from node and add them to the |
|||
;; queue if not already visited. |
|||
(loop |
|||
with costs = (node-cost node) |
|||
with successors = (next-state-dir-pairs node) |
|||
for (state . dir) in successors |
|||
for succ-cost = (1+ costs) |
|||
for f-value = (+ succ-cost (funcall heuristics state)) |
|||
;; Check if this state was already looked at |
|||
unless (gethash state visited) |
|||
do |
|||
;; Insert the next node into the queue |
|||
(heap-insert |
|||
(node :state state :prev node :cost succ-cost |
|||
:f-value f-value) |
|||
queue)))) |
|||
;; The actual A* search |
|||
(loop |
|||
;; The priority queue |
|||
with queue = (make-heap #'<= :name "queue" :size 1000 :key #'node-f-value) |
|||
with initial-state-cost = (funcall heuristics initial-state) |
|||
initially (heap-insert (node :state initial-state :prev nil :cost 0 |
|||
:f-value initial-state-cost) |
|||
queue) |
|||
for counter from 1 |
|||
for current-node = (pick-next-node queue) |
|||
for current-state = (node-state current-node) |
|||
;; Output some information each counter or nothing if information |
|||
;; equals 0. |
|||
when (and (not (zerop information)) |
|||
(zerop (mod counter information))) |
|||
do (format t "~Dth State, heap size: ~D, current costs: ~D~%" |
|||
counter (heap-count queue) |
|||
(node-cost current-node)) |
|||
;; If the target is not reached continue |
|||
until (target-state-p current-state goal-state) |
|||
do |
|||
;; Add the current state to the hash of visited states |
|||
(setf (gethash current-state visited) t) |
|||
;; Expand the current node and continue |
|||
(expand-node current-node queue) |
|||
finally (return (values (reconstruct-movements current-node) counter)))))) |
|||
;; ** Pretty print the path |
|||
(defun print-path (path) |
|||
"Prints the directions of PATH and its length." |
|||
(format t "~{~A~} ~D moves~%" path (length path))) |
|||
;; ** Get some timing information |
|||
(defmacro timing (&body forms) |
|||
"Return both how much real time was spend in body and its result" |
|||
(let ((start (gensym)) |
|||
(end (gensym)) |
|||
(result (gensym))) |
|||
`(let* ((,start (get-internal-real-time)) |
|||
(,result (progn ,@forms)) |
|||
(,end (get-internal-real-time))) |
|||
(values ,result (/ (- ,end ,start) internal-time-units-per-second))))) |
|||
;; ** The main function |
|||
(defun 15-puzzle-solver (initial-state &key (goal-state *goal-state*)) |
|||
"Solves a given and valid 15 puzzle and returns the shortest path to reach the |
|||
goal state." |
|||
(print-state initial-state) |
|||
(multiple-value-bind (result time) |
|||
(timing (multiple-value-bind (path steps) |
|||
(a* initial-state :goal-state goal-state) |
|||
(print-path path) |
|||
steps)) |
|||
(format t "Found the shortest path in ~D steps and ~3,2F seconds~%" result time)) |
|||
(print-state goal-state)) |
|||
</lang> |
|||
{{out}} |
|||
<pre>15-SOLVER> (15-puzzle-solver *initial-state*) |
|||
==================== |
|||
| 15 | 14 | 1 | 6 | |
|||
| 9 | 11 | 4 | 12 | |
|||
| 0 | 10 | 7 | 3 | |
|||
| 13 | 8 | 5 | 2 | |
|||
==================== |
|||
RRRULDDLUUULDRURDDDRULLULURRRDDLDLUURDDLULURRULDRDRD 52 moves |
|||
Found the shortest path in 1130063 steps and 17.61 seconds |
|||
==================== |
|||
| 1 | 2 | 3 | 4 | |
|||
| 5 | 6 | 7 | 8 | |
|||
| 9 | 10 | 11 | 12 | |
|||
| 13 | 14 | 15 | 0 | |
|||
====================</pre> |
|||
=={{header|C++}}== |
=={{header|C++}}== |