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