(defun simple-equal (x y)
  "Are x and y equal?"
  (if (or (atom x) (atom y))
      (eql x y)
      (and (simple-equal (first x) (first y))
	   (simple-equal (rest x) (rest y)))))

(defun pat-match (pattern input)
  "Does pattern match input? Any variable can match anything."
  (if (variable-p pattern)
      t
      (if (or (atom pattern) (atom input))
	  (eql pattern input)
	  (and (pat-match (first pattern) (first input))
	       (pat-match (rest pattern) (rest input))))))

(defun variable-p (x)
  "Is x a variable (a symbol beginning with '?')?"
  (and (symbolp x) (equal (char (symbol-name x) 0) #\?)))

(defun pat-match (pattern input)
  "Does pattern match input? WARNING: buggy version."
  (if (variable-p pattern)
      (list (cons pattern input))
      (if (or (atom pattern) (atom input))
	  (eql pattern input)
	  (append (pat-match (first pattern) (first input))
		  (pat-match (rest pattern) (rest input))))))

(defconstant fail nil "Indicates pat-match failure.")
(defconstant no-bindings '((t . t)) "Indicates pat-match success, with no variables.")

(defun get-binding (var bindings)
  "Find (variable . value) pair in binding list."
  (assoc var bindings))

(defun binding-val (binding)
  "Get the value part of single binding."
  (cdr binding))

(defun lookup (var bindings)
  "Get the value part (for var) from a binding list."
  (binding-val (get-binding var bindings)))

(defun extend-bindings (var val bindings)
  "Add a (var . value) pair to a binding list."
  (cons (cons var val) bindings))

(defun pat-match (pattern input &optional (bindings no-bindings))
  "Match pattern against input in the context of the bindings."
  (pprint (list pattern input bindings))
  (cond ((eq bindings fail) 
	 fail)
	((variable-p pattern)
	 (match-variable pattern input bindings))
	((eql pattern input)
	 bindings)
	((and (consp pattern) (consp input))
	 (pat-match (rest pattern) (rest input)
		    (pat-match (first pattern) (first input)
			       bindings)))
	(t fail)))

(defun match-variable (var input bindings)
  "Does VAR match input? Uses (or updates) and returns bindings."
  (let ((binding (get-binding var bindings)))
    (cond ((not binding) (extend-bindings var input bindings))
	  ((equal input (binding-val binding)) bindings)
	  (t fail))))

(defun extend-bindings (var val bindings)
  "Add a (var . value) pair to a binding list."
  (cons (cons var val) 
	;; Once we add a "real" binding, we get rid of the "dummy" no-bindings
	(if (and (eq bindings no-bindings))
	    nil
	    bindings)))

(defun pat-match (pattern input &optional (bindings no-bindings))
  "Match pattern against input in the context of the bindings."
  (cond ((eq bindings fail) 
	 fail)
	((variable-p pattern)
	 (match-variable pattern input bindings))
	((segment-pattern-p pattern)
	 (segment-match pattern input bindings))
	((eql pattern input)
	 bindings)
	((and (consp pattern) (consp input))
	 (pat-match (rest pattern) (rest input)
		    (pat-match (first pattern) (first input)
			       bindings)))
	(t fail)))



(defun starts-with (list x)
  "Is this a list whose first element is x?"
  (and (consp list)
       (eql (first list) x)))

(defun segment-match (pattern input bindings &optional (start 0))
  "Match the segment pattern ((?* var) ? pat) against input."
  (let ((var (second (first pattern)))
	(pat (rest pattern)))
    (if (null pat)
	(match-variable var input bindings)
	;; We assume that pat starts with a constant.
	;; In other words, a pattern can't have 2 consecutive vars
	(let ((pos (position (first pat) input
			     :start start :test #'equal)))
	  (if (null pos)
	      fail
	      (let ((b2 (pat-match pat (subseq input pos) bindings)))
		(if (eq b2 fail)
		    ;; If this match failed, try another longer one
		    (segment-match pattern input bindings (+ pos 1))
		    (match-variable var (subseq input 0 pos) b2))))))))

(defun segment-match (pattern input bindings &optional (start 0))
  "Match the segment pattern ((?* var) ? pat) against input."
  (let ((var (second (first pattern)))
	(pat (rest pattern)))
    (if (null pat)
	(match-variable var input bindings)
	;; We assume that pat starts with a constant.
	;; In other words, a pattern can't have 2 consecutive vars
	(let ((pos (position (first pat) input
			     :start start :test #'equal)))
	  (if (null pos)
	      fail
	      (let ((b2 (pat-match pat (subseq input pos) 
				   (match-variable var (subseq input 0 pos) ;; changed
						   bindings))))             ;; changed
		(if (eq b2 fail)
		    ;; If this match failed, try another longer one
		    (segment-match pattern input bindings (+ pos 1))
		    b2))))))) ;; changed

(defun rule-pattern (rule) (first rule))
(defun rule-responses (rule) (rest rule))

(defparameter *eliza-rules*
 '((((?* ?x) hello (?* ?y))      
    (How do you do.  Please state your problem.))
   (((?* ?x) I want (?* ?y))     
    (What would it mean if you got ?y)
    (Why do you want ?y) (Suppose you got ?y soon))
   (((?* ?x) if (?* ?y)) 
    (Do you really think its likely that ?y) (Do you wish that ?y)
    (What do you think about ?y) (Really-- if ?y))
   (((?* ?x) no (?* ?y))
    (Why not?) (You are being a bit negative)
    (Are you saying "NO" just to be negative?))
   (((?* ?x) I was (?* ?y))       
    (Were you really?) (Perhaps I already knew you were ?y)
    (Why do you tell me you were ?y now?))
   (((?* ?x) I feel (?* ?y))     
    (Do you often feel ?y ?))
   (((?* ?x) I felt (?* ?y))     
    (What other feelings do you have?))))

(defun eliza ()
  "Respond to user input using pattern matching rules."
  (loop 
     (print 'eliza>)
     (write (flatten (use-eliza-rules (read))) :pretty t)))

(defun use-eliza-rules (input)
  "Find some rule with which to transform the input."
  (some #'(lambda (rule)
	    (let ((result (pat-match (rule-pattern rule) input)))
	      (if (not (eq result fail))
		  (sublis (switch-viewpoint result)
			  (random-elt (rule-responses rule))))))
	*eliza-rules*))

(defun switch-viewpoint (words)
  "Change I to you and vice versa, and so on."
  (sublis '((I . you) (you . I) (me . you) (am .are))
	  words))

(defun flatten (the-list)
  "Append together elements (or lists) in the list."
  (mappend #'mklist the-list))

(defun mklist (x)
  "Return x if it is a list, otherwise (x)."
  (if (listp x)
      x
      (list x)))

(defun mappend (fn the-list)
  "Apply fn to each element of list and append the results."
  (apply #'append (mapcar fn the-list)))

(defun random-elt (choices)
  "Choose an element from a list at random."
  (elt choices (random (length choices))))