;;; -*- Mode: LISP; Syntax: Common-lisp; Package: User; Base: 10 -*-
(in-package :user)

;;;=====================================================================================
;;; Word Ladders
;;;=====================================================================================

;;;=====================================================================================
;;; Node structure.

(defstruct (node
  (:print-function (lambda (structure stream depth) (print-word structure :stream stream))))
  (state  "")
  (parent ())
  (g-value 0)     ; The cost to reach this path (# of steps)
  (h-value 0)     ; The cost to reach the goal from this state
  (f-value 0)     ; Harlequin dies on (+ g-value h-value)
)

;;;=====================================================================================
(defun List-Of-Dictionary-Words (dictionary)
  (let ((word-list (with-open-file (stream dictionary :direction :input)
		     (loop with word
			   while (setq word (read stream))
			   collect word))))
    (loop for word in word-list
	  as string = (if (symbolp word) (string word))
	  when (= (length string) 4)
	  collect string)
))

(defvar *dictionary* (if (probe-file "dict")
			         (List-Of-Dictionary-Words "dict")
				 (mapcar #'string '(hate have hope hive cope cave cake cove came
						    lone love lake lane fate dove dive))))

(defvar *start-node* (make-node :state "HATE"))
(defvar *goal-node* (make-node :state "LOVE"))

;;;=====================================================================================
;;; A* search based on node structure defined above.  Cost-Fn is a heuristic cost estimator.
;;; Child-Fn is a function that generates new children.  And Equality-Fn specifies how
;;; to compare two nodes.

(defvar *closed* (make-hash-table :test #'equalp))

(defun a* (start-node goal-node &key (equality-fn #'equalp) (cost-fn #'Word-Diff)
		                     (child-fn #'Generate-Children) (debug nil))
  (let ((*open* (list start-node))
	(node start-node))
    (clrhash *closed*)
    (setf (node-h-value start-node) (funcall cost-fn (node-state start-node)
					             (node-state goal-node)))
    (setf (node-f-value start-node) (node-h-value node))
    (loop while (and *open* (not (funcall equality-fn node goal-node)))
	  when debug
	  do (print "OPEN:")
	  and
	  do (print *open*)
	  and
	  do (print "CLOSED:")
	  and
	  do (maphash #'(lambda (k v) (format t "~S" v)) *closed*)

	  ;; Back to the normal dos
	  do (setf node (pop *open*))
	  do (setf (gethash (node-state node) *closed*) node)
          do (setf *open*
               (remove-duplicates
                (sort (append (mapcar #'(lambda (n)
                                          (setf (node-h-value n)
                                            (funcall cost-fn (node-state n) (node-state goal-node)))
                                            ;; Have to set f after setting h.
                                            (setf (node-f-value n) (+ (node-g-value n) (node-h-value n)))
                                            n)
                                      (funcall child-fn node))
                              *open*)
                      #'< :key 'node-f-value)
                :test equality-fn :from-end t)
               ))

    (cond ((funcall equality-fn node goal-node)
	                       (format t "~%An optimal solution was found in ~D moves" (node-g-value node))
	                       (return-success node))  ;recursive print of solution
	  (t (return-failure start-node goal-node)) )
))

;;;=====================================================================================
;;; Special Word-Diff that only works for strings of length 4 in the same case.
;;; This is used since mismatch is so expensive.

(defun Word-Diff (s1 s2)
  (loop for i from 0 to 3
	unless (char= (elt s1 i) (elt s2 i))
	count i)
)  
	 
;;;=====================================================================================
(defun Node-Equal (x y)
  "Equality Predicate for two nodes."
  ;; Changed to string= to speed up.
  (string= (node-state x) (node-state y))
)

;;;=====================================================================================
;;; Generate Children of a node.

(defun Generate-Children (node)
  (loop for word in *dictionary*
	when (and (= (Word-Diff word (node-state node)) 1)
		  (not (gethash word *closed*)))  ; A new word
	collect (make-node :state word :parent node :g-value (1+ (node-g-value node))))
)

;;;=====================================================================================
(defun Return-Success (node)
  "If search is successful, print out nodes (in reverse order) up til root."
  (Print-Word node)
  (when (node-parent node)
    (Return-Success (node-parent node)) )
)

;;;=====================================================================================
(defun Return-Failure (start goal)
  "If search is unsuccessful, inform user."
  (format t "~%There is no solution from state: ~%~S" start)
  (format t "~%To state:~%~S" goal)
)

;;;=====================================================================================
(defun Print-Word (node &key (stream t))
  (format stream "<Node: '~a'  G:~D  H:~D  F:~D> "
	  (node-state node) (node-g-value node) (node-h-value node) (node-f-value node))
)

;;;=====================================================================================
(defun Test-A* (start goal &key (debug nil))
  (a* (make-node :state (string start))
      (make-node :state (string goal))
      :equality-fn #'node-equal
      :debug debug)
  )