;
; ptl.l
;
; Don Hopkins
;

; Pattern matcher
(defun match (lst1 lst2 alist)
  (cond
    ; Have we succeeded?
    ((and (null lst1) (null lst2))
      (cond
	((null alist) t)
	(t alist)))
    ; Have we failed?
    ((null lst1) nil)
    ((and ; this is not elagant, but it works.
       (null lst2)
       (not (and
	      (eq (length lst1) 1)
	      (eq (atomcar (car lst1)) '*))))
      nil)
    ; Will any word match, or are they equal?
    ((or (eq (car lst1) '?)
         (eq (car lst2) (car lst1)))
      (match (cdr lst1) (cdr lst2) alist))
    ; Will zero or more words match?
    ((eq (car lst1) '*)
      (or
	(match (cdr lst1) lst2 alist)
	(match (cdr lst1) (cdr lst2) alist)
	(match lst1 (cdr lst2) alist)))
    ; Will one or more words match?
    ((eq (car lst1) '+)
      (or
	(match (cdr lst1) (cdr lst2) alist)
	(match lst1 (cdr lst2) alist)))
    ; If it's an atom, check the first character.
    ((atom (car lst1))
      (let ((prefix (atomcar (car lst1)))
	    (var (atomcdr (car lst1))))
	(cond
	  ; Bind one word?
	  ((eq prefix '>)
	    (match (cdr lst1) (cdr lst1)
	      (add-binding alist var (car lst2))))
	  ; Bind zero or more words?
	  ((eq prefix '*)
	    (or
	      (match (cdr lst1) lst2
		(add-binding alist var nil))
	      (match (cdr lst1) (cdr lst2)
		(add-binding alist var (ncons (car lst2))))
	      (match lst1 (cdr lst2)
		(add-binding alist var (ncons (car lst2))))))
	  ; Bind one or more words?
	  ((eq prefix '+)
	    (or
	      (match (cdr lst1) (cdr lst2)
		(add-binding alist var (ncons (car lst2))))
	      (match lst1 (cdr lst2)
		(add-binding alist var (ncons (car lst2)))))))))
    ; It's a list. Is it a restrict clause?
    ((eq (caar lst1) 'restrict)
      (cond
	; Match one word?
	((eq (cadar lst1) '?)
	  (and
	    (member (car lst2) (caddar lst1))
	    (match (cdr lst1) (cdr lst2) alist)))
	; Bind one word?
	((and
	   (atom (cadar lst1))
	   (eq (atomcar (cadar lst1)) '>)
	   (member (car lst2) (caddar lst1))
	   (match (cdr lst1) (cdr lst2)
	     (add-binding alist (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))

; Replace any atoms in l that are on alist with what they're associated 
; with on alist. 
(defun do-replacements (l alist)
  (apply 'append
    (mapcar #'(lambda (a)
		(cond
		  ((assoc a alist)
		    (cdr (assoc a alist)))
		  (t (list a))))
      l)))
  
; Read lines of input and print the result of thinking about them.
(defun preach ()
  (setq done-flag nil)
  (pprint '(Hi there! Welcome to the Jim and Tammy show!) 0)
  (do ()
    (done-flag nil)
    (pprint (think (get-sentence)) 0)))

; Take a sentence and return a reply.
(defun think (sentence)
  (setq sentence (do-replacements sentence replacement-alist))
  (do ( (thought brain (cdr thought))
	 (bindings nil) )
    ((or
       (setq bindings (match (caar thought) sentence nil))
       (null thought))
      (cond
	(bindings
	  (funcall (cadar thought) bindings))
	(t `(I can\'t think of anything to say about ,@sentence))))
    ))

; Print a list as human readable text.
(defun pprint (l x)
  (cond
    ((null l) (terpri))
    ((> (+ x (flatsize (car l))) 75)
      (terpri)
      (princ (car l))
      (pprint (cdr l) (+ (flatsize (car l)))))
    (t
      (or
	(eq x 0)
	(member (car l) punctuation)
	(princ '| |))
      (princ (car l))
      (pprint (cdr l) (+ x (flatsize (car l)) 1)))))


; Prompt for and read a sentence.
(defun get-sentence ()
  (princ '|> |)
  (read-sentence))

; Read a sentence ended by a period or an atom ending in a period. Return a list,
; without the period.
(defun read-sentence ()
  (let* ( (this-atom (read))
	  (exploded-atom (explode this-atom)))
    (cond
      ((member (car (last exploded-atom)) punctuation)
	(list
	  (implode (reverse (cdr (reverse
				   (do-replacements
				     (explode this-atom)
				     lowercase-alist)))))
	  (car (last exploded-atom))))
      (t
	(cons
	  (implode (do-replacements
		     (explode this-atom)
		     lowercase-alist))
	  (read-sentence))))))

; Given the name of a (circular) list, returns the first element and 
; rotates the list.
(defmacro do-first-and-rotate (list-name)
  `(prog1 (eval (car ,list-name))
    (setq ,list-name (cdr ,list-name))))

; A macro that makes a circular list. Returns what was the first cons cell 
; of that list.
(defmacro make-circular (l)
  `(cdr (rplacd (nthcdr (- (length ,l) 1) ,l) ,l)))

; 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))))

; Make <foo call the macro (val foo) ...
(setsyntax '|<| 'vsplicing-macro 'val)

; Words to replace
(setq replacement-alist
  '((i you) (you me) (me you) (my your) (your my) (my your)
     (mine yours) (yours mine) (myself yourself)))
    
; Upper to lower case replacements
(setq lowercase-alist
  '( (A a) (B b) (C c) (D d) (E e) (F f) (G g) (H h) (I i) (J j) (K k) (L l) (M m)
     (N n) (O o) (P p) (Q q) (R r) (S s) (T t) (U u) (V v) (W w) (X x) (Y y) (Z z) ))

; End if sentence delimiters
(setq punctuation '(|.| |?| |!|))

; The brain ...

(setq brain
  `(
     ((* praise the lord *)
       (lambda (bindings) (do-first-and-rotate ptl-replies)))
     ((* (restrict >badguy (satan devil lucifer)) *)
       (lambda (bindings) (do-first-and-rotate badguy-replies)))
     ((* (restrict ? (cry waa sad tear tears depressing depressed)) *)
       (lambda (bindings) (do-first-and-rotate sad-replies)))
     ((you love +it ?)
       (lambda (bindings) (do-first-and-rotate love-replies)))
     ((please >ahem (restrict ? (us me)) *)
       (lambda (bindings) (do-first-and-rotate ahem-replies)))
     ((* (restrict ? (done bye goodbye click quit exit)) *)
       (lambda (bindings) (setq done-flag t)
	 (do-first-and-rotate done-replies)))
     ((*all (restrict ? (|.| |?| |!|)))
       (lambda (bindings) (eval (random-element catch-all-replies))))))

(setq ptl-replies
  (make-circular '(
     '(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
  (make-circular '(
     `(,<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!)
		    )))
(setq sad-replies
  (make-circular '(
     '(Boo-hoo\, think of all those starving children in Africa we could be helping
       with your money!)
     '(Oh\, now Tammy\'s crying so much that big blobs of her makeup are oozing off
       and seeping down between the couch cushions!)
     '(Tammy\'s never going to be happy again if you don\'t send us all of your valium.)
		    )))
(setq love-replies
  (make-circular '(
     `(Why\, you know I love ,@<it too! But send me some money to prove it to God!)
     '(Not as much as Jesus loves me to have your money!)
     `(Well\, you can\'t take ,@<it to heaven\, but you can leave ,@<it to us when
       you\'re gone!)
		    )))

(setq ahem-replies
  (make-circular '(
     `(The only way I can ,<ahem you is if you become a full consenting faith partner.)
     `(You must give the appropriate love offering for me to ,<ahem you.)
     `(Oh\, go ,<ahem yourself!)
		    )))

(setq done-replies
  (make-circular '(
     '(So long! Be sure to tune in again!)
     '(No no! Please don\'t change the channel!)
		    )))

(setq catch-all-replies
  '(
     `(Why do you say ,@<all when you could just send money???)
     '(You can make it! That\'s right brother! Just make a donation.)
     '(I\'ll pray for you -- just make it worth my while!)
     ))