Eight Puzzle in Common Lisp

epuzzle.lisp

;;; The 8 puzzle
;;; (defpackage :eightpuzzle
;;;  (:use :common-lisp)
;;;  (:export #:main #:run))

;;; (in-package :eightpuzzle)

;;; For using with Lispworks
;;; 
;;; (deliver `runeight "eight-puzzle" 0 :multiprocessing t)
;;;
;;; For compiling to binary use ECLS
;;; http://ecls.sourceforge.net/ecldev/Compiler-examples.html
;;; another alternative can be Steel Bank CL using these commands 
;;;
;;;	
;;;
;;; 	sbcl --eval "(progn 
;;;               (compile-file \"eightpuzzle.lisp\") 
;;;               (load \"eightpuzzle\") 
;;;               (save-lisp-and-die \"eightpuzzle.core\"))"
;;;
;;;	For running the compiled
;;;	
;;;		sbcl --core eightpuzzle.core --noinform\
;;;		     --eval "(progn (eightpuzzle:main) (quit))"
;;;
;;;
;;; For running with interpreter use Clozure Common Lisp Implementation
;;;
;;;	(save-application "~/eightpuzzle.execer" :toplevel-function #'eightpuzzle:main :prepend-kernel t)

;;; 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))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; 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))


(defun runeight ()
  "REPL"

  (format t "~C"  #\linefeed)
  (format t "Enter heuristic multiplier for search: ")
  (LET (heur-mult)
    (SETQ heur-mult (read heur-mult))      
      (format t "Entered Heuristic multiplier is ~a" heur-mult)
    )

  (format t "~C"  #\linefeed)
  (format t "Depth of search (number of states): ")
  (LET (dept)
    (SETQ dept (read dept))      
    (format t "Entered depth of search (number of states for depth) is ~a" dept)
    (best *start* dept)
    )

  ;; (runeight)
)

(defun main ()
  (within-main-loop
    (runeight)))

(defun run ()
  (main)
  (join-main-thread))