;; The 5 puzzle with depth-first, breadth-first and best-first 
;; (with heuristic function counting number of tiles in their 
;; proper places) searches.

;; Written by Neli Zlatareva, 2003.

(setf finish '(1 2 3 4 5 0))

;; Given two states, s1 and s2, HEURISTIC returns a number of 
;; tiles in the same place.

(defun heuristic (s1 s2)
   (count-equals s1 s2))

(defun count-equals (s1 s2)
   (cond ((endp s1) 0)
         ((and (= (first s1) (first s2)) (not (= 0 (first s1))))
            (+ 1 (count-equals (rest s1) (rest s2))))
         (t (count-equals (rest s1) (rest s2)))))

(defun closerp (path1 path2 target-node)
	(> (heuristic (first path1) target-node)
           (heuristic (first path2) target-node)))

(defun best-first (start finish &optional
                       (queue (list (list start))))
     (cond ((endp queue) nil)
	   ((equal finish (first (first queue)))
	       (print (length (first queue))) (reverse (first queue)))
	   (t (best-first start finish
                      (sort (append (extend (first queue)) (rest queue))
                             #'(lambda (p1 p2) (closerp p1 p2 finish)))))))

(defun breadth-first (start finish &optional
                       (queue (list (list start))))
     (cond ((endp queue) nil)
           ((equal finish (first (first queue)))
	       (print (length (first queue))) (reverse (first queue)))
           (t (breadth-first start finish
                  (append (rest queue) (extend (first queue)))))))

(defun depth-first (start finish &optional
                       (queue (list (list start))))
     (cond ((endp queue) nil)
	   ((equal finish (first (first queue)))
	       (print (length (first queue))) (reverse (first queue)))
	   (t (depth-first start finish
                  (append (extend (first queue)) (rest queue))))))

;; The maximum path length is set to 60 -- change this
;; number as needed. When a path length becomes 60, EXTEND
;; returns NIL preventing this path from further extension. 
;; Modify this arbitrary limit as needed. Note that this 
;; limit is only to preserve computer memory, and may help 
;; with depth-first or best-first searches. 

(defun extend (path)
	(if (< (length path) 60) (print (reverse path))
                 (return-from extend NIL))
	(mapcar #'(lambda (new-node) (cons new-node path))
             (remove-if #'(lambda (neighbor) 
                             (member neighbor path :test #'equalp))
                        (get-new-states (first path)))))

(defun get-new-states (state)
   (setf new-states '())
   (locate-zero state))

(defun locate-zero (state)
   (cond ((= 0 (first state)) (move-1 state))
         ((= 0 (second state)) (move-2 state))
         ((= 0 (third state)) (move-3 state))
         ((= 0 (fourth state)) (move-4 state))
         ((= 0 (fifth state)) (move-5 state))
         ((= 0 (sixth state)) (move-6 state))))

(defun move-1 (state)
   (setf new-states (cons (append (list (second state)) 
        (list (first state)) (nthcdr 2 state)) new-states))
   (setf new-states (cons (append (list (fourth state)) 
        (list (second state)) (list (third state))   
        (list (first state)) (nthcdr 4 state)) new-states)))

(defun move-2 (state)
   (setf new-states (cons (append (list (second state)) 
        (list (first state)) (nthcdr 2 state)) new-states))    
   (setf new-states (cons (append (list (first state))
        (list (third state)) (list (second state)) (nthcdr 3 state)) 
           new-states))
   (setf new-states (cons (append (list (first state))
        (list (fifth state)) (list (third state)) (list (fourth state))
        (list (second state)) (last state)) new-states)))

(defun move-3 (state)
   (setf new-states (cons (append (list (first state))
        (list (third state)) (list (second state)) (nthcdr 3 state)) 
            new-states))
   (setf new-states (cons (append (butlast state 4) (last state)
        (list (fourth state)) (list (fifth state)) (list (third state)))
            new-states)))

(defun move-4 (state)
   (setf new-states (cons (append (list (fourth state))
        (list (second state)) (list (third state)) (list (first state))
              (nthcdr 4 state)) new-states))
   (setf new-states (cons (append (butlast state 3) 
        (list (fifth state)) (list (fourth state)) (last state)) 
            new-states)))

(defun move-5 (state)
   (setf new-states (cons (append (list (first state))
        (list (fifth state)) (list (third state)) (list (fourth state))
        (list (second state)) (last state)) new-states))
   (setf new-states (cons (append (butlast state 3) 
        (list (fifth state)) (list (fourth state)) (last state)) 
            new-states))
   (setf new-states (cons (append (butlast state 2)
        (last state) (list (fifth state))) new-states)))

(defun move-6 (state)
   (setf new-states (cons (append (butlast state 2)
        (last state) (list (fifth state))) new-states))
   (setf new-states (cons (append (butlast state 4) (last state)
        (list (fourth state)) (list (fifth state)) (list (third state)))
            new-states)))