;; 8-puzzle assignment
;; Drexel University, CS510 Fall 2012
;; Ariel Stolerman
;; ----------
;; Structures
;; ----------
(defun make-node (state pred-node action)
"Given the state, immediate predecessor and action that maps from the predecessor
to the given state, creates the corresponding node as a list. This information is
necessary to backtrack the actions needed for the solution. The 'md' field is for
path-cumulative Manhattan-distance and necessary for A*."
(list state
(make-hash state)
pred-node action
(+ (get-md pred-node) (manhattan-dist state))
(+ (get-depth pred-node) 1)))
(defun get-state (node)
"Returns the state of the given node."
(car node))
(defun get-hash (node)
"Returns the hash of the state of the given node, a unique integer representation."
(car (cdr node)))
(defun get-pred-node (node)
"Returns the predecessor node of the given node."
(car (cdr (cdr node))))
(defun get-action (node)
"Returns the action that maps from the predecessor of the given node to it."
(car (cdr (cdr (cdr node)))))
(defun get-md (node)
"Returns the cumulative Manhattan-distance from the root to the given node (included)."
(car (cdr (cdr (cdr (cdr node))))))
(defun get-depth (node)
"Returns the depth of the node (root is in depth 0)."
(car (cdr (cdr (cdr (cdr (cdr node)))))))
(defun init-node (state)
"Returns an initial-state node generated from the given state, i.e. with NIL
predecessor node and action that led to it (as it is initial)."
(list state (make-hash state) nil nil 0 0))
;; -----------------
;; Search algorithms
;; -----------------
(defun graph-search-sol (puzzle add-func)
"Returns the solution (sequence of moves) for the given puzzle using graph search
with the given algorithm fringe-update function (add-bfs, add-dfs or add-a*)."
(car (graph-search puzzle add-func)))
(defun graph-search (puzzle add-func)
"The general graph-search algorithm."
(let ((closed ())
(fringe (list (init-node puzzle)))
(curr nil)
(curr-hash 0)
(max-fringe 0)
(max-depth 0))
(loop do (progn
(if (is-empty fringe) (return-from graph-search 'FAILURE))
;; remove first from fringe
(setf curr (car fringe))
(setf curr-hash (get-hash curr))
(setf fringe (cdr fringe))
;; continue only if not already seen
(if (not (member curr-hash closed)) (progn
;; update maximum depth seen thus far
(setf max-depth (max max-depth (get-depth curr)))
;; mark node's state as seen
(setf closed (cons curr-hash closed))
;; if reached goal state, return solution and statistics
(if (is-goal curr) (return-from graph-search
(list (solution curr) max-fringe max-depth)))
;; else expand and add to fringe
(setf fringe (funcall add-func fringe (expand curr)))
;; update maximum fringe size
(setf max-fringe (max max-fringe (length fringe)))))))))
;; Queue types - BFS, DFS, A*
(defun add-bfs (fringe to-add)
"Given the fringe and new nodes to add, adds them to the fringe as a BFS queue, i.e
to the end of the queue (FIFO)."
(nconc fringe to-add))
(defun add-dfs (fringe to-add)
"Given the fringe and new nodes to add, adds them to the fringe as a DFS queue, i.e
to the beginning of the queue (LIFO)."
(nconc to-add fringe))
(defun add-a* (fringe to-add)
"Given the fringe and new nodes to add, adds them to the fringe as an A* priority
queue with respect to Manhattan distance."
(progn
(dolist (node to-add)
(setf fringe (add-node-a* fringe node)))
fringe))
;; Search utility methods
(defun add-node-a* (fringe node)
"Given the fringe and a new node to add, adds it to the fringe as an A* priority
queue with respect to Manhattan distance."
(if (not fringe)
(list node)
(if (< (get-md node) (get-md (car fringe)))
(cons node fringe)
(cons (car fringe) (add-node-a* (cdr fringe) node)))))
(defun is-goal (node)
"Returns T if the given node's state is the goal-state and NIL otherwise."
(eql (get-hash node) 123456789))
(defun expand (node)
"Returns a list of successor nodes of the given node."
(let ((valid (valid-moves (get-state node)))
(res ()))
(dolist (direction valid)
(setf res (cons (make-node (move (get-state node) direction) node direction) res)))
res))
(defun solution (node &optional (sol ()))
"Returns the solution sequence of actions from the initial problem state to the
goal state."
(if (not (get-action node))
sol
(progn
(setf sol (cons (get-action node) sol))
(solution (get-pred-node node) sol))))
(defun manhattan-dist (state)
"Returns the cumulative Manhattan distance of the given node's state and the goal state."
(let ((v 0)
(res 0))
(do ((i 0 (+ i 1)))
((equal i 9) res)
(progn
(setf v (- (value state (div i 3) (mod i 3)) 1))
(setf res (+ res
(manhattan-diff (cons (div i 3) (mod i 3))
(cons (div v 3) (mod v 3)))))))))
(defun manhattan-diff (first second)
"Returns the Manhattan distance between the two given puzzle coordinates."
(+ (abs (- (car first) (car second)))
(abs (- (cdr first) (cdr second)))))
;; ---------
;; Utilities
;; ---------
(defun is-empty (lst)
"Returns T if the given list is empty and NIL otherwise."
(eql lst nil))
(defun make-hash (state)
"Simple hash of a node state to a unique integer representation."
(let ((factor 100000000)
(res 0))
(do ((i 0 (+ i 1)))
((equal i 9) res)
(progn
(setf res (+ res (* (value state (div i 3) (mod i 3)) factor)))
(setf factor (/ factor 10))))))
(defun div (a b)
"Simple integer division arithmetic operator."
(/ (- a (mod a b)) b))
;;(defun len (lst)
;; ""
;; (let ((res 0))
;; (dolist (elem lst)
;; (setf res (+ res 1)))
;; res))
;; -------
;; Testing
;; -------
(defun test (add-func &optional (max-moves 20) (num-runs 10))
"Test search function. Given the add-to-queue function (BFS / DFS / A*), optional
maximum number of moves for the generated puzzles (default: 20) and optional number
of experiments to run (default: 10), runs a series of search experiments on randomly
generated puzzles and returns statistics:
- average runtime (in milliseconds)
- minimum / maximum / average number of moves in the generated solutions
- minimum / maximum / average max. fringe size reached"
(let ((tmp ())
(sol-len 0)
(min-sol-len 0)
(max-sol-len 0)
(all-sol-len 0)
(max-fringe 0)
(min-max-fringe 0)
(max-max-fringe 0)
(all-max-fringe 0)
(runtime 0)
(all-runtimes 0)
(timebase (/ internal-time-units-per-second 1000))) ;; to get milliseconds
(do ((i 0 (+ i 1)))
((equal i num-runs)
(list (float (/ all-runtimes num-runs))
min-sol-len
max-sol-len
(float (/ all-sol-len num-runs))
min-max-fringe
max-max-fringe
(float (/ all-max-fringe num-runs))))
(progn
(setf runtime (/ (get-internal-real-time) timebase))
(setf tmp (graph-search (random-puzzle max-moves) add-func))
(setf runtime (- (/ (get-internal-real-time) timebase) runtime))
(setf sol-len (length (car tmp)))
(setf max-fringe (car (cdr tmp)))
(setf all-runtimes (+ all-runtimes runtime))
;; update max solution length statistics
(setf min-sol-len
(if (equal min-sol-len 0)
sol-len (min min-sol-len sol-len)))
(setf max-sol-len (max max-sol-len sol-len))
(setf all-sol-len (+ all-sol-len sol-len))
;; update max fringe statistics
(setf min-max-fringe
(if (equal min-max-fringe 0)
max-fringe (min min-max-fringe max-fringe)))
(setf max-max-fringe (max max-max-fringe max-fringe))
(setf all-max-fringe (+ all-max-fringe max-fringe))
(setf tmp nil)))))
(defun test-all (&optional (max-moves 20) (num-runs 10))
"Runs 'test' with all priority algorithms: BFS, DFS and A* and displays the statistics."
(let ((res nil)
(alg (list #'add-bfs #'add-dfs #'add-a*))
(alg-name (list "BFS" "DFS" "A*")))
(format t "Running ~A experiments per algorithm with ~A maximum~%" num-runs max-moves)
(format t "moves per randomly generated puzzle.~%")
(loop while (not (equal alg NIL)) do (progn
(format t "Running random searches with ~A...~%" (car alg-name))
(setf res (test (car alg) max-moves num-runs))
(format t "- Average runtime (ms): ~A~%" (car res))
(setf res (cdr res))
(format t "- Minimum solution length: ~A~%" (car res))
(setf res (cdr res))
(format t "- Maximum solution length: ~A~%" (car res))
(setf res (cdr res))
(format t "- Average solution length: ~A~%" (car res))
(setf res (cdr res))
(format t "- Minimum max fringe size reached: ~A~%" (car res))
(setf res (cdr res))
(format t "- Maximum max fringe size reached: ~A~%" (car res))
(setf res (cdr res))
(format t "- Average max fringe size reached: ~A~%~%" (car res))
(setf alg (cdr alg))
(setf alg-name (cdr alg-name))))))
(defun test-solution (puzzle solution)
"Tests the given solution on the given initial puzzle state. Returns T if the
solution is correct and NIL otherwise."
(dolist (direction solution)
(setf puzzle (move puzzle direction)))
(equal (make-hash puzzle) 123456789))
;; ============================================================================
;; 8-puzzle
;; Copyright 2006--2012, Evan A. Sultanik
;; http://www.sultanik.com/
(defun random-puzzle (&optional (max-moves 20))
"Returns a random puzzle that requires no more than `max-moves' moves to solve."
(let ((puzzle (make-array '(3 3) :initial-contents '((1 2 3)(4 5 6)(7 8 9)))) (next nil))
(loop for i from 1 to max-moves do
(let ((vm (valid-moves puzzle)))
(setf puzzle (move puzzle (nth (random (length vm)) vm)))))
puzzle))
(defun value (puzzle row col)
"Returns the value of the piece at position (`row',`col') in the `puzzle'
(a value of 9 represents the open space)"
(aref puzzle row col))
(defun print-puzzle (puzzle)
"Prints the puzzle on the screen."
(format t "-------------
")
(loop for row from 0 to 2 do
(loop for col from 0 to 2 do
(if (= 9 (value puzzle row col))
(format t "| ")
(format t "| ~d " (value puzzle row col))))
(format t "|
-------------
")))
(defun copy-array (array)
"Utility function for making a copy of an array."
(let ((dims (array-dimensions array)))
(adjust-array
(make-array dims :element-type (array-element-type array) :displaced-to array)
dims)))
(defun set-cell (puzzle row col new-value)
"Sets the cell (`row',`col') in `puzzle' to `new-value'."
(let ((newpuzzle (copy-array puzzle)))
(setf (aref newpuzzle row col) new-value)
newpuzzle))
(defun swap-cells (puzzle row1 col1 row2 col2)
"Swaps the values of two cells in a puzzle."
(let ((cell1 (value puzzle row1 col1)))
(set-cell (set-cell puzzle row1 col1 (value puzzle row2 col2)) row2 col2 cell1)))
(defun space-position (puzzle &optional (idx 0))
"Returns a list containing two elements: the row and column of the space in the puzzle."
(let ((r nil) (c nil))
(loop for row from 0 to 2 do
(loop for col from 0 to 2 do
(when (= (value puzzle row col) 9)
(setf r row)
(setf c col)
(return))))
(list r c)))
(defun move (puzzle direction)
"Returns the puzzle resulting from making the given move in the given puzzle
(note that the validity of the move is not checked)."
(let ((pos (space-position puzzle)))
(let ((row (car pos)) (col (car (cdr pos))))
(cond
((equal direction 'RIGHT)
(if (>= col 2)
nil
(swap-cells puzzle row col row (+ col 1))))
((equal direction 'LEFT)
(if (<= col 0)
nil
(swap-cells puzzle row col row (- col 1))))
((equal direction 'UP)
(if (<= row 0)
nil
(swap-cells puzzle row col (- row 1) col)))
((equal direction 'DOWN)
(if (>= row 2)
nil
(swap-cells puzzle row col (+ row 1) col)))
(t nil)))))
(defun valid-moves (puzzle)
"Returns a list containing the valid directions in which a move can be made in the
given puzzle."
(let ((moves nil) (pos (space-position puzzle)))
(let ((row (car pos)) (col (car (cdr pos))))
(if (< col 2) (push 'RIGHT moves))
(if (> col 0) (push 'LEFT moves))
(if (< row 2) (push 'DOWN moves))
(if (> row 0) (push 'UP moves)))
moves))