1 ;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
2 ;;;; Code from Paradigms of AI Programming
3 ;;;; Copyright (c) 1991 Peter Norvig
5 (in-package :cl-tuples
)
7 ;;;; File pat-match.lisp: Pattern matcher from section 6.2
9 ;;; Two bug fixes By Richard Fateman, rjf@cs.berkeley.edu October 92.
11 ;;; The basic are in auxfns.lisp; look for "PATTERN MATCHING FACILITY"
14 "Is x a variable (a symbol beginning with `?')?"
15 (and (symbolp x
) (equal (elt (symbol-name x
) 0) #\?)))
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
)
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
)
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
)
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
)
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
)))))
50 (defun single-pattern-p (pattern)
51 "Is this a single-matching pattern?
52 E.g. (?is x predicate) (?and . patterns) (?or . patterns)."
54 (single-match-fn (first pattern
))))
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
))
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
))
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
)))
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
)))
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
)))
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
95 (defun match-or (patterns input bindings
)
96 "Succeed if any one of the patterns match the input."
99 (let ((new-bindings (pat-match (first patterns
)
101 (if (eq new-bindings fail
)
102 (match-or (rest patterns
) input bindings
)
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
)
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
)))
117 (match-variable var input bindings
)
118 (let ((pos (first-match-pos (first pat
) input start
)))
122 pat
(subseq input pos
)
123 (match-variable var
(subseq input
0 pos
)
125 ;; If this match failed, try another longer one
127 (segment-match pattern input bindings
(+ pos
1))
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
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 <)
139 (defun segment-match+ (pattern input bindings
)
140 "Match one or more elements of input."
141 (segment-match pattern input bindings
1))
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
))))
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
)))
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
)))
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
)))
168 (t (cons (expand-pat-match-abbrev (first pat
))
169 (expand-pat-match-abbrev (rest pat
))))))
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."
178 (let ((result (funcall matcher
(funcall rule-if rule
)
180 (if (not (eq result fail
))
181 (funcall action result
(funcall rule-then rule
)))))