;
; ptl.l
;
; Don Hopkins		Sat Sep 12 15:09:48 EDT 1987
;

; Pattern matcher
(defun match (lst1 lst2 bindings)
  (cond
    ; Have we succeeded?
    ((and (null lst1) (null lst2))
      (cond
	((null bindings) t)
	(t bindings)))
    ; Have we failed?
    ((or (null lst1) (null lst2)) nil)
    ; Will any word match, or are they equal?
    ((or (eq (car lst1) '?)
         (eq (car lst2) (car lst1)))
      (match (cdr lst1) (cdr lst2) bindings))
    ; Will zero or more words match?
    ((eq (car lst1) '*)
      (or
	(match (cdr lst1) lst2 bindings)
	(match (cdr lst1) (cdr lst2) bindings)
	(match lst1 (cdr lst2) bindings)))
    ; Will one or more words match?
    ((eq (car lst1) '+)
      (or
	(match (cdr lst1) (cdr lst2) bindings)
	(match lst1 (cdr lst2) bindings)))
    ; If it's an atom, check the first character.
    ((atom (car lst1))
      (let ((prefix (atomcar (car lst1)))
	    (var (atomcdr (car lst1))))
	(cond
	  ((eq prefix '>)
	    (match (cdr lst1) (cdr lst1)
	      (add-binding bindings var (car lst2))))
	  ((eq prefix '*)
	    (or
	      (match (cdr lst1) lst2
		(add-binding bindings var nil))
	      (match (cdr lst1) (cdr lst2)
		(add-binding bindings var (ncons (car lst2))))
	      (match lst1 (cdr lst2)
		(add-binding bindings var (ncons (car lst2))))))
	  ((eq prefix '+)
	    (or
	      (match (cdr lst1) (cdr lst2)
		(add-binding bindings var (ncons (car lst2))))
	      (match lst1 (cdr lst2)
		(add-binding bindings var (ncons (car lst2)))))))))
    ; It's a list. Is it a restrict clause?
    ((eq (caar lst1) 'restrict)
      (cond
	((eq (cadar lst1) '?)
	  (and
	    (member (car lst2) (caddar lst1))
	    (match (cdr lst1) (cdr lst2) bindings)))
	((and
	   (atom (cadar lst1))
	   (eq (atomcar (cadar lst1)) '>)
	   (member (car lst2) (caddar lst1))
	   (match (cdr lst1) (cdr lst2)
	     (add-binding bindings (atomcdr (cadar lst1)) (car lst2)))))))))

; Add a variable definition to a binding list. If the variable
; is already in the binding list, then append to its value.
(defun add-binding (bindings var val)
  (cond
    ; If we're at the end, then append the binding.
    ((null bindings)
      (ncons (list var val)))
    ; If we've found a variable with the same name, and this val and
    ; the variable's value both lists, then append the variable's value
    ; and this val.
    ((and (listp val)
          (listp (cadar bindings))
          (equal var (caar bindings)))
      (cons (list var (append (cadar bindings) val))
	    (cdr bindings)))
    (t (cons (car bindings)
	     (add-binding (cdr bindings) var val)))))

; Strip '>' or '*' from variable
(defun atomcar (x)
  (car (explode x)))

; Return remainder of a variable
(defun atomcdr (x)
  (implode (cdr (explode x))))

; Random element of a list
(defun random-element (lst)
  (nth (random (length lst)) lst))

; Generate a reply given a set of bindings and a reply list.
(defun make-reply (bindings reply)
  (eval reply))

; Take a sentence and return a reply.
(defun think (sentence)
  (do* ( (db brain (cdr db))
	 (bindings
	   (match (caar db) sentence nil)
	   (match (caar db) sentence nil)) )
    ((or bindings (null db))
      (cond
	(bindings
	  (make-reply bindings (cadar db)))
	(t `(I can't think of anything to say about ,@sentence))))
    ))

; Return the last cons of a non-nil list.
(defun last (l)
  (cond
    ((null l) nil)
    ((null (cdr l)) l)
    (t (last (cdr l)))))

; Given the name of a list, returns the first element and rotates the list.

(defun return-one-of (list-name)
  (let* ( (head (eval list-name))
	  (first (car head))
	  (rest (cdr head)))
    (set list-name rest)
    (rplacd (last head) head)
    (rplacd head nil)
    first
))

; Define <foo to expand to (cadr (assoc 'foo bindings)), which
; retrieves the value of the variable foo in the bindings.

(defun val ()
  (list `(cadr ,`(assoc ',(read) bindings))))

(setsyntax '|<| 'vsplicing-macro 'val)

; The brain.

(setq brain
  '(
     ((* praise the lord *)
       (return-one-of 'ptl-replies))
     ((* (restrict >badguy (satan devil lucifer)) *)
       (return-one-of 'badguy-replies))
     ((*all)
       '`(Why do you say ,@<all ???))
     ))

(setq ptl-replies
  '(
     '(Hallaluaja brother! Your praise is tax deductable!)
     '(Well show the lord you mean it\, and send in some cash!)
     '(What the Lord needs is praise\, but what we need is money!)
     '(Enough praising the lord\, already! Pass The Loot!)))

(setq badguy-replies
  '(
     `(,<badguy will have your soul if you don\'t give enough!)
     `(Help fight the battle against ,<badguy with your
	love offerings!)
     `(Show God you hate ,<badguy more than anyone in your
	neighborhood\, by sending all you can possibly spare!)
     `(,<badguy is the root of all evil\, and your donation will
	help us to take over his job!)))