patmatch.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
   2 ;;;; Code from Paradigms of AI Programming
   3 ;;;; Copyright (c) 1991 Peter Norvig
   4
   5 (in-package :cl-tuples)
   6
   7 ;;;; File pat-match.lisp: Pattern matcher from section 6.2
   8
   9 ;;; Two bug fixes By Richard Fateman, rjf@cs.berkeley.edu  October 92.
  10
  11 ;;; The basic are in auxfns.lisp; look for "PATTERN MATCHING FACILITY"
  12
  13 (defun variable-p (x)
  14   "Is x a variable (a symbol beginning with `?')?"
  15   (and (symbolp x) (equal (elt (symbol-name x) 0) #\?)))
  16
  17 (defun pat-match (pattern input &optional (bindings no-bindings))
  18   "Match pattern against input in the context of the bindings"
  19   (cond ((eq bindings fail) fail)
  20         ((variable-p pattern)
  21          (match-variable pattern input bindings))
  22         ((eql pattern input) bindings)
  23         ((segment-pattern-p pattern)
  24          (segment-matcher pattern input bindings))
  25         ((single-pattern-p pattern)                 ; ***
  26          (single-matcher pattern input bindings))   ; ***
  27         ((and (consp pattern) (consp input))
  28          (pat-match (rest pattern) (rest input)
  29                     (pat-match (first pattern) (first input)
  30                                bindings)))
  31         (t fail)))
  32
  33
  34 (setf (get '?is  'single-match) 'match-is)
  35 (setf (get '?or  'single-match) 'match-or)
  36 (setf (get '?and 'single-match) 'match-and)
  37 (setf (get '?not 'single-match) 'match-not)
  38
  39 (setf (get '?*  'segment-match) 'segment-match)
  40 (setf (get '?+  'segment-match) 'segment-match+)
  41 (setf (get '??  'segment-match) 'segment-match?)
  42 (setf (get '?if 'segment-match) 'match-if)
  43
  44 (defun segment-pattern-p (pattern)
  45   "Is this a segment-matching pattern like ((?* var) . pat)?"
  46   (and (consp pattern) (consp (first pattern))
  47        (symbolp (first (first pattern)))
  48        (segment-match-fn (first (first pattern)))))
  49
  50 (defun single-pattern-p (pattern)
  51   "Is this a single-matching pattern?
  52   E.g. (?is x predicate) (?and . patterns) (?or . patterns)."
  53   (and (consp pattern)
  54        (single-match-fn (first pattern))))
  55
  56 (defun segment-matcher (pattern input bindings)
  57   "Call the right function for this kind of segment pattern."
  58   (funcall (segment-match-fn (first (first pattern)))
  59            pattern input bindings))
  60
  61 (defun single-matcher (pattern input bindings)
  62   "Call the right function for this kind of single pattern."
  63   (funcall (single-match-fn (first pattern))
  64            (rest pattern) input bindings))
  65
  66 (defun segment-match-fn (x)
  67   "Get the segment-match function for x,
  68   if it is a symbol that has one."
  69   (when (symbolp x) (get x 'segment-match)))
  70
  71 (defun single-match-fn (x)
  72   "Get the single-match function for x,
  73   if it is a symbol that has one."
  74   (when (symbolp x) (get x 'single-match)))
  75
  76 (defun match-is (var-and-pred input bindings)
  77   "Succeed and bind var if the input satisfies pred,
  78   where var-and-pred is the list (var pred)."
  79   (let* ((var (first var-and-pred))
  80          (pred (second var-and-pred))
  81          (new-bindings (pat-match var input bindings)))
  82     (if (or (eq new-bindings fail)
  83             (not (funcall pred input)))
  84         fail
  85         new-bindings)))
  86
  87 (defun match-and (patterns input bindings)
  88   "Succeed if all the patterns match the input."
  89   (cond ((eq bindings fail) fail)
  90         ((null patterns) bindings)
  91         (t (match-and (rest patterns) input
  92                       (pat-match (first patterns) input
  93                                  bindings)))))
  94
  95 (defun match-or (patterns input bindings)
  96   "Succeed if any one of the patterns match the input."
  97   (if (null patterns)
  98       fail
  99       (let ((new-bindings (pat-match (first patterns)
 100                                      input bindings)))
 101         (if (eq new-bindings fail)
 102             (match-or (rest patterns) input bindings)
 103             new-bindings))))
 104
 105 (defun match-not (patterns input bindings)
 106   "Succeed if none of the patterns match the input.
 107   This will never bind any variables."
 108   (if (match-or patterns input bindings)
 109       fail
 110       bindings))
 111
 112 (defun segment-match (pattern input bindings &optional (start 0))
 113   "Match the segment pattern ((?* var) . pat) against input."
 114   (let ((var (second (first pattern)))
 115         (pat (rest pattern)))
 116     (if (null pat)
 117         (match-variable var input bindings)
 118         (let ((pos (first-match-pos (first pat) input start)))
 119           (if (null pos)
 120               fail
 121               (let ((b2 (pat-match
 122                           pat (subseq input pos)
 123                           (match-variable var (subseq input 0 pos)
 124                                           bindings))))
 125                 ;; If this match failed, try another longer one
 126                 (if (eq b2 fail)
 127                     (segment-match pattern input bindings (+ pos 1))
 128                     b2)))))))
 129
 130 (defun first-match-pos (pat1 input start)
 131   "Find the first position that pat1 could possibly match input,
 132   starting at position start.  If pat1 is non-constant, then just
 133   return start."
 134   (cond ((and (atom pat1) (not (variable-p pat1)))
 135          (position pat1 input :start start :test #'equal))
 136         ((<= start (length input)) start) ;*** fix, rjf 10/1/92 (was <)
 137         (t nil)))
 138
 139 (defun segment-match+ (pattern input bindings)
 140   "Match one or more elements of input."
 141   (segment-match pattern input bindings 1))
 142
 143 (defun segment-match? (pattern input bindings)
 144   "Match zero or one element of input."
 145   (let ((var (second (first pattern)))
 146         (pat (rest pattern)))
 147     (or (pat-match (cons var pat) input bindings)
 148         (pat-match pat input bindings))))
 149
 150 (defun match-if (pattern input bindings)
 151   "Test an arbitrary expression involving variables.
 152   The pattern looks like ((?if code) . rest)."
 153   ;; *** fix, rjf 10/1/92 (used to eval binding values)
 154   (and (progv (mapcar #'car bindings)
 155               (mapcar #'cdr bindings)
 156           (eval (second (first pattern))))
 157        (pat-match (rest pattern) input bindings)))
 158
 159 (defun pat-match-abbrev (symbol expansion)
 160   "Define symbol as a macro standing for a pat-match pattern."
 161   (setf (get symbol 'expand-pat-match-abbrev)
 162     (expand-pat-match-abbrev expansion)))
 163
 164 (defun expand-pat-match-abbrev (pat)
 165   "Expand out all pattern matching abbreviations in pat."
 166   (cond ((and (symbolp pat) (get pat 'expand-pat-match-abbrev)))
 167         ((atom pat) pat)
 168         (t (cons (expand-pat-match-abbrev (first pat))
 169                  (expand-pat-match-abbrev (rest pat))))))
 170
 171 (defun rule-based-translator
 172        (input rules &key (matcher 'pat-match)
 173         (rule-if #'first) (rule-then #'rest) (action #'sublis))
 174   "Find the first rule in rules that matches input,
 175   and apply the action to that rule."
 176   (some
 177     #'(lambda (rule)
 178         (let ((result (funcall matcher (funcall rule-if rule)
 179                                input)))
 180           (if (not (eq result fail))
 181               (funcall action result (funcall rule-then rule)))))
 182     rules))