;; This file defines the MAZE search problem
;; To use this file use:

;; (setf *search-problem* (maze-search "filename"))
;;  ; Load the maze and create the seach problem.

;; (setf start (sp-start *search-problem*))
;;  ; start is the start position in the maze

;; (setf successors (sp-successors *search-problem*))
;;  ; successors is the successors function for the search.
;;  ; to call use:
;; (funcall successors position)

;; (setf goalp (sp-goalp *search-problem*))
;;  ; goalp is the goal predicate, returning T if at the end, and 
;;  ; NIL otherwise. Use with funcall as above.

;;  (setf h (sp-h *search-problem*))
;;  ; h is the mahattan heuristics for this problem. Use with funcall
;;  ; as above.

;; (funcall (sp-print *search-problem*))
;; ; Will print the maze to the screen.

;; (funcall (sp-print *search-problem*) solution)
;; ; Will print the given solution path on the screen.

(defstruct sp
  start
  successors
  goalp
  h
  print)

(defun read-maze (fn)
  (let
      ((maze ())
       (in (open fn))
       (start)
       (end))
    
    (do ((i 0 (1+ i))
	 (l (read-line in nil nil) (read-line in nil nil))
	 )
	((not l))
      (let*
	  (
	   (sym
	  (map 'list 
	    (lambda (x) 
	      (case x
		((#\.) t)
		((#\x) :start)
		((#\y) :end)
		)
	      ) l))
	 (st (position :start sym))
	 (en (position :end sym))
	 )
	(push sym maze)
	(when st (setf start (list st i)))
	(when en (setf end (list en i)))
	))
    
    (close in)
    
    (list 
     (make-array (list (length maze) (length (first maze))) 
		 :element-type 'symbol
		 :initial-contents (reverse maze))
     start end)
    )
  )

(defun maze-getpos (maze position)
  (let ((x (first position))
	(y (second position)))
	(when (array-in-bounds-p (first maze) y x)
	  (aref (first maze) y x))))

(defun maze-start (maze)
  (second maze))

(defun maze-goalp (maze position)
  (eql (maze-getpos maze position) :end))

(defun maze-successors (maze position)
  (let 
    ((x (first position))
     (y (second position)))
     (remove-if-not 
      (lambda (p) (maze-getpos maze p))
      (list (list x (1+ y))
	    (list x (1- y))
	    (list (1+ x) y)
	    (list (1- x) y)
	    )
      )
     )
  )

(defun maze-h (maze position)
  (let* ((end (third maze))
	 (xe (first end))
	 (ye (second end))
	 (x (first position))
	 (y (second position)))
    (+ (abs (- x xe)) (abs (- y ye)))))

(defun maze-doprint (maze)
  (dotimes (r (array-dimension maze 0))
    (dotimes (c (array-dimension maze 1))
      (princ (case (aref maze r c)
	       ((t) #\ )
	       ((nil) (let ((h (and (maze-getpos (list maze) (list (1+ c) r))
				    (maze-getpos (list maze) (list (1- c) r))))
			    (v (and (maze-getpos (list maze) (list c (1+ r)))
				    (maze-getpos (list maze) (list c (1- r))))))
			(cond ((and v h) #\#)
			      (v #\-)
			      (h #\|)
			      (t #\+))))
		
	       ((:start) #\x)
	       ((:end) #\y)
	       ((:path) #\*))))
    (format t "~%")))

(defun shallow-copy-array (array &key (undisplace-array nil))
  "Shallow copies the contents of any array into another array with
equivalent properties.  If array is displaced, then this function
will normally create another displaced array with similar properties,
unless UNDISPLACE-ARRAY is non-NIL, in which case the contents of the
array will be copied into a completely new, not displaced, array."
  (check-type array array)
  (multiple-value-bind (displaced-to displaced-index-offset)
      (array-displacement array)
    (let ((dimensions (array-dimensions array))
          (element-type (array-element-type array))
          (adjustable (adjustable-array-p array))
          (fill-pointer (when (array-has-fill-pointer-p array)
                          (fill-pointer array))))
      (when undisplace-array
        (setf displaced-to nil))
      (let ((new-array
             (apply #'make-array
                    (list* dimensions
                           :element-type element-type
                           :adjustable adjustable
                           :fill-pointer fill-pointer
                           :displaced-to displaced-to
                           (if displaced-to
                               (list :displaced-index-offset
                                     displaced-index-offset)
                               nil)))))
        (unless displaced-to
          (dotimes (i (array-total-size array))
            (setf (row-major-aref new-array i)
                  (row-major-aref array i))))
        new-array))))
    
(defun maze-print (maze &optional path)
  (let ((temp-maze (shallow-copy-array (first maze))))
    (dolist (p path) 
      (when (eql (aref temp-maze (second p) (first p)) :path)
	(maze-doprint temp-maze) (format t "~%") (setf temp-maze (shallow-copy-array (first maze))))
      (setf (aref temp-maze (second p) (first p)) :path))
    (maze-doprint temp-maze)
    ))

(defun maze-search (fn) 
  (let 
      ((maze (read-maze fn)))
    (make-sp :start (maze-start maze)
	     :successors (lambda (p) (maze-successors maze p))
	     :goalp (lambda (p) (maze-goalp maze p))
	     :h (lambda (p) (maze-h maze p))
	     :print (lambda (&optional p) (maze-print maze p)))))