We represent each state in the eight puzzle by the numbers 1 through 8 for the tiles and 0 for the space. A state is just a list of 9 numbers.
A move in this world is just the transposition of a tile and the space (the 0 tile), if and only if those two tiles are adjacent horizontally or vertically.
To make the code more general, we use a table of adjacencies to define the board, instead of hard coding everything.
;;; The 8 puzzle
(in-package "USER")
;;; State is a list
;;;
;;; ( 1 2 3 4 5 6 7 8 0 )
;;;
(defvar *start* '(1 2 3
4 5 6
7 8 0))
(defvar *goal* '(1 8 7
2 0 6
3 4 5))
;;; Define adjacencies
(defvar *adj*
'((0 1 3)
(1 0 4 2)
(2 1 5)
(3 0 4 6)
(4 1 3 5 7)
(5 2 4 8)
(6 3 7)
(7 4 6 8)
(8 5 7)))
(defun goalp (state)
(equal state *goal*))
(defun transpose (state i j)
(transpose1 state j i (nth i state) (nth j state)))
(defun transpose1 (state i j ival jval)
(cond
((null state) nil)
((zerop i)
(cons ival
(transpose1 (cdr state) (- i 1) (- j 1) ival jval)))
((zerop j)
(cons jval
(transpose1 (cdr state) (- i 1) (- j 1) ival jval)))
(t
(cons (car state)
(transpose1 (cdr state) (- i 1) (- j 1) ival jval)))))
(defun loc-of (num state)
(cond
((null state) 0)
((eq (car state) num) 0)
((+ 1 (loc-of num (cdr state))))))
(defun space-at (state)
(loc-of 0 state))
(defun new-states (state)
(let ((zloc (space-at state)))
(mapcar #'(lambda (toloc)
(transpose state zloc toloc))
(cdr (assoc zloc *adj*)))))
;;; The value of a state is 3/4 based in how similar that state
;;; is to the goal state, and 1/4 based on whether tiles adjacent
;;; in the goal state are also adjacent in the current state.
(defun heur-value (state)
(+
(* 3 (similarity state *goal*))
(adj-value state *goal*)))
;;; similarity is the number of tiles in the same position in two states
(defun similarity (s1 s2)
(cond
((or (null s1) (null s2)) 0)
((equal (car s1) (car s2))
(+ 1 (similarity (cdr s1) (cdr s2))))
((similarity (cdr s1) (cdr s2)))))
(defun adj-num (num state)
(mapcar
#'(lambda (n) (nth n state))
(cdr (assoc (loc-of num state) *adj*))))
(defun number-common (l1 l2)
(cond
((null l1) 0)
((null l2) 0)
((memq (car l1) l2)
(+ 1 (number-common (cdr l1) l2)))
((number-common (cdr l1) l2))))
;;; adj-value is the number of tile adjacencies common between thw
;;; two states
(defun adj-value (s1 s2)
(apply #'+
(mapcar
#'(lambda (num)
(number-common (adj-num num s1) (adj-num num s2)))
'(1 2 3 4 5 6 7 8))))
(in-package "USER")
;;; Breadth first search with state limit
;;; A node is a list of (hval state parent gradparent ...)
(defun hval-of (node) (car node))
(defun state-of (node) (cadr node))
(defun path-of (node) (cdr node))
(defun depth-of (node) (length (cddr node)))
(defvar *visited* nil)
(defvar *heur-mult* 2)
(defun best (state limit)
(let ((nodes 0)
(expanded 0)
(branches 0)
(limit limit)
(open (list (list (heur-value state) state))))
(setf *visited* nil)
(loop
(cond ((null open)
(print (list 'nodes nodes expanded branches))
(return (list 'no 'solution 'found))))
(incf nodes)
(cond ((goalp (state-of (car open)))
(print (list 'nodes nodes expanded branches))
(print (list 'length 'of 'soln (depth-of (car open))))
(return (path-of (car open)))))
(cond ((> nodes limit)
(print (list 'nodes nodes expanded branches))
(return (list 'closest 'was (car open)))))
(let ((children (new-states (state-of (car open)))))
(incf expanded)
(setf branches (+ (length children) branches))
(setf open (combine-queue children (car open) (cdr open)))))))
;;; This function takes the new children of the current node, the
;;; current node, and the rest of the queue and builds new nodes for
;;; those child states that have not been visited.
;;; Note that the SORT is overkill, since we only need the best
;;; state in front, but the program is shorter if we use sort
;;; Note: we use (*HEUR-MULT* X HEUR - DEPTH) as the value of a node...
;;; this makes for for shorter (but not necessarily optimal) paths.
(defun combine-queue (new-states node queue)
(push (state-of node) *visited*)
(dolist (state new-states)
(if (not (member state *visited* :test #'equal))
(push (cons (- (* *heur-mult* (heur-value state)) (depth-of node))
(cons state (cdr node)))
queue)))
(sort queue #'> :key #'car))
;;; Sun Common Lisp, Development Environment 4.0.0 , 6 July 1990 ;;; Sun-4 Version for SunOS 4.0.x and sunOS 4.1 > (compile-file "best") > (compile-file "eight") > (load "best") > (load "eight") > (setf *heur-mult* 1) (setf *heur-mult* 1) 1 > (best *start* 1000000) (best *start* 1000000) ;;; Expanding Dynamic Memory ;;; GC: 209336 words [837344 bytes] of dynamic storage in use. ;;; 446022 words [1784088 bytes] of free storage available before a GC. ;;; 1101380 words [4405520 bytes] of free storage available if GC is disabled. (NODES 7429 7428 20722) ; Branching factor 2.79 (LENGTH OF SOLN 26) ((1 8 7 2 0 6 3 4 5) (1 0 7 2 8 6 3 4 5) (1 7 0 2 8 6 3 4 5) (1 7 6 2 8 0 3 4 5) (1 7 6 2 0 8 3 4 5) (1 0 6 2 7 8 3 4 5) (0 1 6 2 7 8 3 4 5) (2 1 6 0 7 8 3 4 5) (2 1 6 3 7 8 0 4 5) (2 1 6 3 7 8 4 0 5) (2 1 6 3 0 8 4 7 5) (2 0 6 3 1 8 4 7 5) (0 2 6 3 1 8 4 7 5) (3 2 6 0 1 8 4 7 5) (3 2 6 1 0 8 4 7 5) (3 0 6 1 2 8 4 7 5) (0 3 6 1 2 8 4 7 5) (1 3 6 0 2 8 4 7 5) (1 3 6 4 2 8 0 7 5) (1 3 6 4 2 8 7 0 5) (1 3 6 4 2 8 7 5 0) (1 3 6 4 2 0 7 5 8) (1 3 0 4 2 6 7 5 8) (1 0 3 4 2 6 7 5 8) (1 2 3 4 0 6 7 5 8) (1 2 3 4 5 6 7 0 8) (1 2 3 4 5 6 7 8 0))