;;;; gwking.lisp

(defpackage #:gwking
  (:use #:cl))

(in-package #:gwking)

(defparameter *example-expression*
  '(or (and "space" "mission")
    (and (or "moon" "lunar") "landing")))

(defparameter *test-strings*
  '("The NASA lunar program was a smashing success."
    "The moon landing was a triumph of technology and elbow grease."
    "Unmanned space missions have also been very successful."
    "The shuttle program is a joke, though."))

(defun find-word-in-string (word string)
  (search word string :test #'char-equal))

;;;
;;; Gary's version
;;;

(defun expression->logical-form (expression)
  (let ((mappings nil)
        (count 0))
    (labels ((do-it (expr)
               (cond ((atom expr)
                      (case expr
                        ((or and) expr)
                        ((nil) nil)
                        (t
                         (let ((sym (cdr (find expr mappings :key #'car))))
                           (unless sym
                             (setf sym (intern (format nil "word-~d" count)))
                             (incf count)
                             (push (cons expr sym) mappings))
                           sym))))
                     ((consp expr)
                      (cons (do-it (car expr)) (do-it (cdr expr)))))))   
      (values (do-it expression)
              mappings))))

(defun expression-in-string-p (expr string)
  (multiple-value-bind (logical-form mappings)
      (expression->logical-form expr)
    (let (variables values)
      (loop for (word . symbol) in mappings do
            (push symbol variables)
            (push (not (null (find-word-in-string word string))) values))
      (progv variables values (eval logical-form)))))

;;;
;;; Peter's version
;;;

(defun translate (tree &optional (stringvar (gensym)))
  (typecase tree
    (cons
     (cons (translate (car tree) stringvar) (translate (cdr tree) stringvar)))
    (symbol tree)
    (string `(find-word-in-string ,tree ,stringvar))))

(defun make-lambda-expression (expr)
  (let ((string (gensym)))
    `(lambda (,string) ,(translate expr string))))

(defun compile-expression (expr)
  (compile nil (make-lambda-expression expr)))


;;;
;;; Zach's version
;;;

(defun make-or-matcher (forms success failure)
  (if (null forms)
      failure
      (make-matcher-aux (first forms)
                        success
                        (make-or-matcher (rest forms) success failure))))

(defun make-and-matcher (forms success failure)
  (if (null forms)
      success
      (make-matcher-aux (first forms)
                        (make-and-matcher (rest forms) success failure)
                        failure)))

(defun make-string-matcher (string success failure)
  (lambda (target-string)
    (if (find-word-in-string string target-string)
        (funcall success target-string)
        (funcall failure target-string))))

(defun make-matcher-aux (form success failure)
  (etypecase form
    (cons
     (ecase (first form)
       (or (make-or-matcher (rest form) success failure))
       (and (make-and-matcher (rest form) success failure))))
    (string
     (make-string-matcher form success failure))))

(defun make-matcher (form)
  (make-matcher-aux form (constantly t) (constantly nil)))


;;;
;;; adeht
;;;

(defclass or-clause ()
  ((choices :initarg :choices :reader choices)))

(defclass and-clause ()
  ((choices :initarg :choices :reader choices)))

(defgeneric build-match-clause (expression))

(defmethod build-match-clause ((expression string))
  expression)

(defmethod build-match-clause ((expression cons))
  (let ((choices (mapcar #'build-match-clause (cdr expression))))
    (ecase (car expression)
      (or (make-instance 'or-clause :choices choices))
      (and (make-instance 'and-clause :choices choices)))))

(defgeneric build-match-function (clause))

(defmethod build-match-function ((clause string))
  (lambda (string)
    (find-word-in-string clause string)))

(defmethod build-match-function ((clause or-clause))
  (let ((choices (mapcar #'build-match-function (choices clause))))
    (lambda (string)
      (some (lambda (choice)
              (funcall choice string))
            choices))))

(defmethod build-match-function ((clause and-clause))
  (let ((choices (mapcar #'build-match-function (choices clause))))
    (lambda (string)
      (every (lambda (choice)
               (funcall choice string))
             choices))))



;;;
;;; Timing and testing
;;;

(defun test-matching (count fun)
  (dotimes (i count)
    (dolist (string *test-strings*)
      (funcall fun string))))

(defun test-match.gwking (count)
  (let ((fun (lambda (string)
               (expression-in-string-p *example-expression* string))))
    (test-matching count fun)))

(defun test-match.peter (count)
  (let ((fun (compile-expression *example-expression*)))
    (test-matching count fun)))

(defun test-match.xach (count)
  (let ((fun (make-matcher *example-expression*)))
    (test-matching count fun)))

(defun test-match.adeht (count)
  (let ((fun (build-match-function (build-match-clause *example-expression*))))
    (test-matching count fun)))


(defun test-compiling (count fun)
  (loop repeat count do (funcall fun)))


(defun test-compiling.peter (count)
  (test-compiling count
                  (lambda ()
                    (compile-expression *example-expression*))))

(defun test-compiling.xach (count)
  (test-compiling count
                  (lambda ()
                    (make-matcher *example-expression*))))

(defun test-compiling.adeht (count)
  (test-compiling count
                  (lambda ()
                    (build-match-function (build-match-clause *example-expression*)))))