|
|
@@ -0,0 +1,182 @@
|
|
|
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
|
|
|
+;;;; Code from Paradigms of AI Programming
|
|
|
+;;;; Copyright (c) 1991 Peter Norvig
|
|
|
+
|
|
|
+;;;; File pat-match.lisp: Pattern matcher from section 6.2
|
|
|
+
|
|
|
+;;; Two bug fixes By Richard Fateman, rjf@cs.berkeley.edu October 92.
|
|
|
+
|
|
|
+;;; The basic are in auxfns.lisp; look for "PATTERN MATCHING FACILITY"
|
|
|
+
|
|
|
+(in-package #:chatikbot)
|
|
|
+
|
|
|
+(defun variable-p (x)
|
|
|
+ "Is x a variable (a symbol beginning with `?')?"
|
|
|
+ (and (symbolp x) (equal (elt (symbol-name x) 0) #\?)))
|
|
|
+
|
|
|
+(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))
|
|
|
+ ((eql pattern input) bindings)
|
|
|
+ ((segment-pattern-p pattern)
|
|
|
+ (segment-matcher pattern input bindings))
|
|
|
+ ((single-pattern-p pattern) ; ***
|
|
|
+ (single-matcher pattern input bindings)) ; ***
|
|
|
+ ((and (consp pattern) (consp input))
|
|
|
+ (pat-match (rest pattern) (rest input)
|
|
|
+ (pat-match (first pattern) (first input)
|
|
|
+ bindings)))
|
|
|
+ (t fail)))
|
|
|
+
|
|
|
+
|
|
|
+(setf (get '?is 'single-match) 'match-is)
|
|
|
+(setf (get '?or 'single-match) 'match-or)
|
|
|
+(setf (get '?and 'single-match) 'match-and)
|
|
|
+(setf (get '?not 'single-match) 'match-not)
|
|
|
+
|
|
|
+(setf (get '?* 'segment-match) 'segment-match)
|
|
|
+(setf (get '?+ 'segment-match) 'segment-match+)
|
|
|
+(setf (get '?? 'segment-match) 'segment-match?)
|
|
|
+(setf (get '?if 'segment-match) 'match-if)
|
|
|
+
|
|
|
+(defun segment-pattern-p (pattern)
|
|
|
+ "Is this a segment-matching pattern like ((?* var) . pat)?"
|
|
|
+ (and (consp pattern) (consp (first pattern))
|
|
|
+ (symbolp (first (first pattern)))
|
|
|
+ (segment-match-fn (first (first pattern)))))
|
|
|
+
|
|
|
+(defun single-pattern-p (pattern)
|
|
|
+ "Is this a single-matching pattern?
|
|
|
+ E.g. (?is x predicate) (?and . patterns) (?or . patterns)."
|
|
|
+ (and (consp pattern)
|
|
|
+ (single-match-fn (first pattern))))
|
|
|
+
|
|
|
+(defun segment-matcher (pattern input bindings)
|
|
|
+ "Call the right function for this kind of segment pattern."
|
|
|
+ (funcall (segment-match-fn (first (first pattern)))
|
|
|
+ pattern input bindings))
|
|
|
+
|
|
|
+(defun single-matcher (pattern input bindings)
|
|
|
+ "Call the right function for this kind of single pattern."
|
|
|
+ (funcall (single-match-fn (first pattern))
|
|
|
+ (rest pattern) input bindings))
|
|
|
+
|
|
|
+(defun segment-match-fn (x)
|
|
|
+ "Get the segment-match function for x,
|
|
|
+ if it is a symbol that has one."
|
|
|
+ (when (symbolp x) (get x 'segment-match)))
|
|
|
+
|
|
|
+(defun single-match-fn (x)
|
|
|
+ "Get the single-match function for x,
|
|
|
+ if it is a symbol that has one."
|
|
|
+ (when (symbolp x) (get x 'single-match)))
|
|
|
+
|
|
|
+(defun match-is (var-and-pred input bindings)
|
|
|
+ "Succeed and bind var if the input satisfies pred,
|
|
|
+ where var-and-pred is the list (var pred)."
|
|
|
+ (let* ((var (first var-and-pred))
|
|
|
+ (pred (second var-and-pred))
|
|
|
+ (new-bindings (pat-match var input bindings)))
|
|
|
+ (if (or (eq new-bindings fail)
|
|
|
+ (not (funcall pred input)))
|
|
|
+ fail
|
|
|
+ new-bindings)))
|
|
|
+
|
|
|
+(defun match-and (patterns input bindings)
|
|
|
+ "Succeed if all the patterns match the input."
|
|
|
+ (cond ((eq bindings fail) fail)
|
|
|
+ ((null patterns) bindings)
|
|
|
+ (t (match-and (rest patterns) input
|
|
|
+ (pat-match (first patterns) input
|
|
|
+ bindings)))))
|
|
|
+
|
|
|
+(defun match-or (patterns input bindings)
|
|
|
+ "Succeed if any one of the patterns match the input."
|
|
|
+ (if (null patterns)
|
|
|
+ fail
|
|
|
+ (let ((new-bindings (pat-match (first patterns)
|
|
|
+ input bindings)))
|
|
|
+ (if (eq new-bindings fail)
|
|
|
+ (match-or (rest patterns) input bindings)
|
|
|
+ new-bindings))))
|
|
|
+
|
|
|
+(defun match-not (patterns input bindings)
|
|
|
+ "Succeed if none of the patterns match the input.
|
|
|
+ This will never bind any variables."
|
|
|
+ (if (match-or patterns input bindings)
|
|
|
+ fail
|
|
|
+ bindings))
|
|
|
+
|
|
|
+(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 (first-match-pos (first pat) input start)))
|
|
|
+ (if (null pos)
|
|
|
+ fail
|
|
|
+ (let ((b2 (pat-match
|
|
|
+ pat (subseq input pos)
|
|
|
+ (match-variable var (subseq input 0 pos)
|
|
|
+ bindings))))
|
|
|
+ ;; If this match failed, try another longer one
|
|
|
+ (if (eq b2 fail)
|
|
|
+ (segment-match pattern input bindings (+ pos 1))
|
|
|
+ b2)))))))
|
|
|
+
|
|
|
+(defun first-match-pos (pat1 input start)
|
|
|
+ "Find the first position that pat1 could possibly match input,
|
|
|
+ starting at position start. If pat1 is non-constant, then just
|
|
|
+ return start."
|
|
|
+ (cond ((and (atom pat1) (not (variable-p pat1)))
|
|
|
+ (position pat1 input :start start :test #'equal))
|
|
|
+ ((<= start (length input)) start) ;*** fix, rjf 10/1/92 (was <)
|
|
|
+ (t nil)))
|
|
|
+
|
|
|
+(defun segment-match+ (pattern input bindings)
|
|
|
+ "Match one or more elements of input."
|
|
|
+ (segment-match pattern input bindings 1))
|
|
|
+
|
|
|
+(defun segment-match? (pattern input bindings)
|
|
|
+ "Match zero or one element of input."
|
|
|
+ (let ((var (second (first pattern)))
|
|
|
+ (pat (rest pattern)))
|
|
|
+ (or (pat-match (cons var pat) input bindings)
|
|
|
+ (pat-match pat input bindings))))
|
|
|
+
|
|
|
+(defun match-if (pattern input bindings)
|
|
|
+ "Test an arbitrary expression involving variables.
|
|
|
+ The pattern looks like ((?if code) . rest)."
|
|
|
+ ;; *** fix, rjf 10/1/92 (used to eval binding values)
|
|
|
+ (and (progv (mapcar #'car bindings)
|
|
|
+ (mapcar #'cdr bindings)
|
|
|
+ (eval (second (first pattern))))
|
|
|
+ (pat-match (rest pattern) input bindings)))
|
|
|
+
|
|
|
+(defun pat-match-abbrev (symbol expansion)
|
|
|
+ "Define symbol as a macro standing for a pat-match pattern."
|
|
|
+ (setf (get symbol 'expand-pat-match-abbrev)
|
|
|
+ (expand-pat-match-abbrev expansion)))
|
|
|
+
|
|
|
+(defun expand-pat-match-abbrev (pat)
|
|
|
+ "Expand out all pattern matching abbreviations in pat."
|
|
|
+ (cond ((and (symbolp pat) (get pat 'expand-pat-match-abbrev)))
|
|
|
+ ((atom pat) pat)
|
|
|
+ (t (cons (expand-pat-match-abbrev (first pat))
|
|
|
+ (expand-pat-match-abbrev (rest pat))))))
|
|
|
+
|
|
|
+(defun rule-based-translator
|
|
|
+ (input rules &key (matcher 'pat-match)
|
|
|
+ (rule-if #'first) (rule-then #'rest) (action #'sublis))
|
|
|
+ "Find the first rule in rules that matches input,
|
|
|
+ and apply the action to that rule."
|
|
|
+ (some
|
|
|
+ #'(lambda (rule)
|
|
|
+ (let ((result (funcall matcher (funcall rule-if rule)
|
|
|
+ input)))
|
|
|
+ (if (not (eq result fail))
|
|
|
+ (funcall action result (funcall rule-then rule)))))
|
|
|
+ rules))
|
