; -------------------------------------------------------------------
;
; global variables
;
; -------------------------------------------------------------------
 
(setf tpflag t)                ; controls printing, see the function tp.

(setf remember-successors nil) ; if T, the successors of a node are 
                               ;  computed only once and remembered.
(setf nodesInGraph 0)          ; number of nodes in graph so far, used
			       ; for debugging purposes
(setf nodeExpanded 0)          ; number of nodes expanded

; -------------------------------------------------------------------
;
; Utility functions
;
; -------------------------------------------------------------------

; the next two functions are printing utilities.

(defun tp (&rest arguments)
  ;prints its args only if the variable tp is non-nil
  (cond (tpflag
	 (mapcar (function (lambda (x) (princ x))) arguments)
	 (terpri)))
  t)


(defun p (&rest arguments) 
  (mapcar (function (lambda (x) (princ x)))
	  arguments)
  (terpri)
  t)

; -------------------------------------------------------------------
;
; GRAPHSEARCH
;
; -------------------------------------------------------------------
;
; graph-search takes five problem-dependant arguments:
;
;     initial-node - a node from which to start the search.
;     goal-test -  a predicate true for goal nodes and false for non-Goal nodes.
;     successors -  a function to compute successor nodes (and associated
;                         arc costs) for a given node.  It should return a
;                         list of (node arc-cost) tuples.
;     estimate-to-goal - a functions which takes a node and returns an 
;                        estimate of the distance to a goal node.
;     estimate-path-cost - takes two arguments - the short-path cost for 
;                          a node and the estimate-to-goal and returns an 
;                          overall metric used in choosing which node to 
;                          expand next
;
; Nodes will be represented by atoms having the following properties:
;
;  children - A list of (node arcCost) tuples for immediate successors.
;  parent - The predecessor of the node on a minimal cost path to Start.
;  value-of-short-path - The cost of the shortest known path from Start 
;                        to the node.
;  value-of-estimate-to-goal - estimate of cost to a goal node.
;  value-of-estimate-path-cost - the overall estimate (e.g., in assignment
;                                = value-of-short-path +
;                                  value-of-estimate-to-goal)

 
(defun graph-search 
  (initial-node goal-test successors estimate-to-goal estimate-path-cost)

  (prog (open closed expl)

        ; initialize global variables for counting nodes
	(setf nodesInGraph 1)
	(setf nodesExpanded 0)

        ; add the initial-node to the graph and then call search
	(add-node initial-node nil 0 estimate-to-goal estimate-path-cost)
    
	(setf open (list initial-node))

     loop

        (cond ((null open) (return nil)))

	(setf expl (select-node open))
	(tp "Expl = " expl)

	(cond ((funcall goal-test expl)
	       (terpri)
	       (p "Goal node chosen for expansion: "
		  expl
		  " with cost = "
		  (get expl 'value-of-short-path))
	       (p "there are "
		  nodesInGraph
		  " nodes in the graph and "
		  nodesExpanded
		  " nodes were expanded")
	       (return (path expl))))


	(setf nodesExpanded (1+ nodesExpanded))
	(setf closed (cons expl closed))
	(setf open (update-graph-&-open (getchildren expl successors) 
					expl
					(delete expl open)
					closed
					successors
					estimate-to-goal
					estimate-path-cost))
	(go loop)))
  
  
  
 (defun update-graph-&-open 
   (succs parent open closed succ-fn est-goal est-path)
	;; adds the list of successors of parent -- represented as 
	;; (node arc-cost) tuples -- to the graph and open list -- must
	;; make sure node has not already been seen and check for updating
	;; shortest path

   (cond ((null succs) open)
	 (t (let* ((n (caar succs))
		   (arccost (cadar succs))
		   (cost (+ (get parent 'value-of-short-path)
			    arccost)))
	      (cond ((and (not (member n closed)) 
			  (not (member n open)))
		     (setf nodesInGraph (1+ nodesInGraph))
		     (add-node n parent cost est-goal est-path)
		     (update-graph-&-open (cdr succs)
					  parent
					  (cons n open)
					  closed
					  succ-fn
					  est-goal
					  est-path))
		    ((< cost (get n 'value-of-short-path))
		     (update-node n 
				  parent 
				  succ-fn 
				  cost 
				  est-path
				  open 
				  closed)
		     (update-graph-&-open (cdr succs)
					  parent
					  open
					  closed
					  succ-fn
					  est-goal
					  est-path))
		    ((update-graph-&-open (cdr succs)
					  parent
					  open 
					  closed
					  succ-fn
					  est-goal
					  est-path)))))))

       

(defun add-node 
  (node parent value-of-short-path estimate-to-goal estimate-path-cost)
  ; adds node NODE to the graph.
  
  (tp "  Adding node " 
      node 
      " with parent = " 
      parent 
      " and shortest path cost =  " 
      value-of-short-path)
  (or remember-successors (remprop node 'children))
  (setf (get node  'parent) parent)
  (setf (get  node 'value-of-short-path) value-of-short-path)
  (setf (get node 'value-of-estimate-to-goal) (funcall estimate-to-goal node)) 
  (setf (get  node `value-of-estimate-path-cost)
	(funcall estimate-path-cost 
		 value-of-short-path 
		 (get node 'value-of-estimate-to-goal))))



(defun update-node 
  (n parent successor-fn value-of-short-path estimate-path-cost open closed)

  ; a new shortest path from START to node N has been found with
  ;  length VALUE-OF-SHORT-PATH which goes through PARENT.  
  ;  ESTIMATE-PATH-COST function determines the new VALUE-OF-ESTIMATE-PATH-COST

  (tp "  Changing node "  
      n 
      " to have parent " 
      parent 
      " and cost " 
      value-of-short-path)
  (setf (get n 'parent) parent)
  (setf (get  n 'value-of-short-path) value-of-short-path)
  (setf (get n 'value-of-estimate-path-cost)
	(funcall estimate-path-cost
		 value-of-short-path
		 (get n 'value-of-estimate-to-goal)))


  ; Some of n's successors may have had shortest paths which did not
  ; go thru n, so Check each to see if a path thru n is now shorter.
  (check-short-path-&-update (ret-installed-succs (getchildren n successor-fn)
						  (append open closed))
			     n 
			     successor-fn
			     estimate-path-cost
			     open
			     closed))


(defun ret-installed-succs (succs installed)
  ;; takes a successors list and a list of nodes which have already
  ;; been installed in the graph -- returns those elements of succs which
  ;; contain nodes in installed
  (cond ((null succs) nil)
	((member (caar succs) installed)
	 (cons (car succs) (ret-installed-succs (cdr succs) installed)))
	((ret-installed-succs (cdr succs) installed))))


(defun check-short-path-&-update 
  (succs parent succ-fn estimate-path-cost-fn open closed)
  ;; checks to see if a path through parent to each element of succs
  ;; would be shorter than that elements current shortest path --
  ;; if so, then update that element -- 
  ;; succs elements are (name arccost) tuples
  (cond ((null succs) nil)
	(t (let ((node (caar succs))
		 (arccost (cadar succs)))
	     (cond ((< (+ (get parent 'value-of-short-path) arccost)
		       (get node 'value-of-short-path))
		    (update-node node
				 parent
				 succ-fn
				 (+ (get parent 'value-of-short-path)
				    arccost)
				 estimate-path-cost-fn
				 open
				 closed)))
	     (check-short-path-&-update (cdr succs)
					parent
					succ-fn
					estimate-path-cost-fn
					open 
					closed)))))

 

(defun select-node (open)
  ; returns the node on the open list with smallest value-of-estimate-path-cost.
  (select-node-with-shortest-est-path (get (car open) 
					   'value-of-estimate-path-cost)
				      (car open)
				      (cdr open)))


(defun select-node-with-shortest-est-path (smallest node-so-far open)
  ;; returns either node-so-far or member of open with estimated path
  ;; cost smaller than smaller
  (cond ((null open) node-so-far)
	((< (get (car open) 'value-of-estimate-path-cost)
	    smallest)
	 (select-node-with-shortest-est-path
	  (get (car open) 'value-of-estimate-path-cost)
	  (car open)
	  (cdr open)))
	((select-node-with-shortest-est-path smallest
					     node-so-far
					     (cdr open)))))


(defun getchildren (node successors)
    ;recall or compute successors of node
    (cond ((null (get node 'children))
           (setf  (get node 'children) (funcall successors node))))
    (get node 'children))

(defun path (node)
   ; returns a list of the nodes on the best known path from Start to node.
   (reverse (reversePath node)))
 
(defun reversePath (node)
   ; returns a list of the nodes on the best known path from node to Start.
   (cond ((null (get node 'parent))
	  (list node))
	 ((cons node (reversePath (get node 'parent))))))
 
; -------------------------------------------------------------------
;
; Dictionary Management
;
; -------------------------------------------------------------------

(defun legalword (w)   ; returns T if W is a legal word otherwise NIL
  (get w 'legalword))
 
(defun addword (w)  ; add word W to the dictionary
  (setf dictionary (cons w dictionary))
  (setf (get w 'legalword) t))
 
(defun deleteword (w)   ; remove word w from dictionary
  (setf dictionary (delete w dictionary))
  (setf (get w 'legalword) nil))
 
(setf dictionary  '(
   ask asp ass ads apt art arm ail aim age ate ale ade ark
   bat ban bit big bog bag bum  bud
   can  cab cat cog cot cub cut 
   dog don dot dab din dub 
   eat ear eel eak elm elk ebb eve ewe eye
   fat fan fun far fir few fly fob for fop 
   gas gym gag god gut gnu gin gig goo guy gym
   hit hot hat him ham hid hop 
   ill ilk ire ivy irk ink inn ion
   job jog jug jut jag jib jam jar
   kid kib keg ken
   lip lap lid lop lye lam lad 
   man men mop map mad mat mid
   nut nor not nit nab nob 
   oat oil oar our own ort
   pup pop pin pad pat 
   quo qua
   rot rut ran rid rye rat ray rap rip 
   sot sod sin sad sat sip sap sag 
   tot tad tip ten thy toy top 
   use urn ugh use ups 
   van vim vat vet vex vow
   was wip wad web wow wok why who way won wan 
   
   yes yen yet yip you 
   zoo zen zip zap))
 
(mapcar (function (lambda (x) (setf (get x  'legalword) t)))
	dictionary)

;--------------------------------------------------------------
; general lisp functions
;-------------------------------------------------------------
(defun implode (list)
    ;;; takes a list of single character atoms and combines them into a
    ;;; single atom. Common lisp has no built-in implode function.
    (cond ((null list) nil)
	  ((read-from-string
	    (concatenate 'string
			 (mapcar #'(lambda (x)
				     (cond ((numberp x)(digit-char x))
					   ((character x))))
				 list))))))

(defun explode (atom)
   ;;; takes an atom and splits it into a list of single character
   ;;; atoms. Common lisp has no built-in explode function.
    (cond ((listp atom) atom)
	  (t
	   (let ((s (string atom)))
	     (explodes s 0 (length s))))))

(defun explodes (str position len)
   ;;; recursive helping function for explode
   (cond ((eq position len) nil)
	 ((cons (read-from-string (string (schar str position)))
		(explodes str (1+ position) len)))))