PAIP: Eliza, Dialog with a Machine - W.I.P.

eliza.lisp

(defconstant +fail+ nil
  "Indicates PAT-MATCH failure.")

(defconstant +no-bindings+ '((t . t))
  "Indicates PAT-MATCH success, but with no variables.")

;;; Utilities

(defun starts-with (lst x)
  "Is X the first element of LST?"
  (and (consp lst)
       (eql (first lst)
            x)))

;;; Abstractions away from ASSOC to make working with variable bindings easier.

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

(defun binding-val (binding)
  "The value part of a 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)
        (if (eq bindings +no-bindings+)
            nil
            bindings)))

;;; Pattern matching.

(defun simple-equal (x y)
  "Are X and Y equal (do not check inside strings)?"
  (if (or (atom x)
          (atom y))
      (eql x y)
      (and (simple-equal (first x)
                         (first y))
           (simple-equal (rest x)
                         (rest y)))))

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

(defun segment-pattern-p (x)
  "Is X a segment-matching pattern (something of the form '((?* var) . pat)')?"
  (and (consp x)
       (starts-with (first x)
                    '?*)))

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

(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)
        (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)
                                                   bindings))))
                (if (eq b2 +fail+)
                    (segment-match pattern
                                   input
                                   bindings
                                   (1+ pos))
                    b2)))))))

(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+))))

Working through PAIP, this is Eliza, up to page 162.