- 6.2 A pattern-matching tool
- おお、pattern/actionペアをテーブルにいれて拡張性を担保するプログラミングスタイルを、data-driven programmingと言うのか。正直知らんかった。
- "In this case, the keys to the table will be symbols (like ?*), and it is fine if the representation of the table is distributed across memory. Thus, property lists are an appropriate choice." なるほど。こういう風に判断するのか。
- あとはソースを追う。例によって日本語のコメントは私、その他はNorvig。
;;; 6.2 A Pattern-Matching Tool
;;; これらはgeneralized single patの例
#+test
(pat-match '(x = (?is ?n numberp)) '(x = 34)) ; => ((?n . 34))
#+test
(pat-match '(x = (?is ?n numberp)) '(x = x)) ; => nil
#+test
(pat-match '(?x (?or < = >) ?y) '(3 < 4)) ; => ((?Y . 4) (?X . 3))
#+test
(pat-match '(x = (?and (?is ?n numberp) (?is ?n oddp)))
'(x = 3)) ; => ((?N . 3))
#+test
(pat-match '(?x /= (?not ?x)) '(3 /= 4)) ; => ((?X . 3))
#+test
(pat-match '(?x > ?y (?if (> ?x ?y))) '(4 > 3)) ; => ((?Y . 3) (?X . 4))
(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)) ; segment-match -> segment-matcher
((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)))
;; pat-match ver.6
;; *** の節を追加。
(defconstant fail nil "Indicates pat-match failure")
(defconstant no-bindings '((t . t))
"Indicates pat-match success, with no variables.")
(defun variable-p (x)
"Is x a variable (a symbol beginning with '?')?"
(and (symbolp x) (equal (char (symbol-name x) 0) #\?)))
(defun get-binding (var bindings)
"Find a (variable . value) pair in a binding list."
(assoc var bindings))
(defun binding-var (binding)
"Get the variable part of a single binding."
(car binding))
(defun binding-val (binding)
"Get the value part of a single binding."
(cdr binding))
(defun make-binding (var val) (cons var val))
(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)
;; Once we add a "real" binding,
;; we can get rid of the dummy no-bindings
(if (eq bindings no-bindings)
nil
bindings)))
(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))))
(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))) ; =1=
(if (or (eq new-bindings fail)
(not (funcall pred input))) ; =2=
fail
new-bindings)))
;; =1= : まず、varでpat-matchしちゃう。
;; =2= : =1=がfailするか、inputがpredでないならば、もともとのbindingsを返却。
;; ここで、なぜpredの対象がinputでいいんだろ？？？
;; =3= : =1=が成功したら、new-bindingsを返却。
(defun match-and (patterns input bindings)
"Succeed if all the patterns match the input."
(cond ((eq bindings fail) fail)
((null patterns) bindings) ; =1=
(t (match-and (rest patterns) input ; =2=
(pat-match (first patterns) input
bindings)))))
;; =1= : 再帰の終了条件。patternsがnilならbindingsを返して終了。
;; =2= : patternsのfirstでpat-matchしたbindingsでpatternsのrestをpatternsとして再帰。
(defun match-or (patterns input bindings)
"Succeed if any one of the patterns match the input."
(if (null patterns)
fail ; =1=
(let ((new-bindings (pat-match (first patterns) ; =2=
input bindings)))
(if (eq new-bindings fail)
(match-or (rest patterns) input bindings) ; =3=
new-bindings)))) ; =4=
;; =1= : 再帰の終了条件。pattensがnilならfail。
;; =2= : patternsのfirstがpat-matchするかをnew-bindingsへ。
;; =3= : =2=がfailしたらpatternsのrestで再帰。
;; =4= : =2=が成功なら、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)
;; We assume that pat starts with a constant
;; In other words, a pattern can't have 2 consecutive vars
(let ((pos (first-match-pos (first pat) input start))) ; =3.1=
(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)))))))
;; segment-match ver.3
;; 変更点のみ記載。
;; =3.1= position -> first-match-pos
(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))) ; =1=
(position pat1 input :start start :test #'equal))
((< start (length input)) start) ; =2=
(t nil))) ; =3=
;; =1= : 以前のsegment-matchと同じ処理
;; =2= : =1=の条件が合致しない場合は何らかの変数的なものなので、startがinputより長くなってなければstartをそのまま返す。
;; =3= : startがinputより長いのでこれはposは無い。よって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) ; =1=
(pat-match pat input bindings)))) ; =2=
;; =1= : 1つマッチする場合の処理。??を外したvarを、残余なpatにconsしたpatternにてマッチするか。
;; =2= : 0個マッチする場合の処理。残余なpatをpatternにしててマッチするか。
;; =1=, =2= いずれも失敗したらnil。
(defun match-if (pattern input bindings)
"Test an arbitrary expression involving variables.
The pattern looks like ((?if code) . rest)."
(and (progv (mapcar #'car bindings) ; =1=
(mapcar #'cdr bindings)
(eval (second (first pattern))))
(pat-match (rest pattern) input bindings))) ; =2=
;; =1= : おお! progvだ!
;; そうかprogvだとこういう形で変数と値の束縛構成もlisp formでできるんだ。そこがletとの大きな違いだったのか。
;; ここでprogvを使うのは、evalに束縛を効かせるためかな。
;; そしてそれがevalの結果、tかnilかと。
;; =2= : それがtなら(rest patterns)についてpat-matchする、と。
#+test
(pat-match '(?x ?op ?y is ?z (?if (eql (?op ?x ?y) ?z)))
'(3 + 4 is 7)) ; => error
;; これは間違いじゃないか？？？
#+test
(pat-match '(?x ?op ?y is ?z (?if (eql (funcall ?op ?x ?y) ?z)))
'(3 + 4 is 7))
;; 正しくはこうじゃないといけないのでは？
;; Norvigのerrataをみてみると、、、やはり！！
;; http://norvig.com/paip-errata.html
#+test
(pat-match '(?x ?op ?y (?if (funcall ?op ?x ?y)))
'(3 > 4))
(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))))))
#+test
(pat-match-abbrev '?x* '(?* ?x)) ; => (?* ?X)
#+test
(pat-match-abbrev '?y* '(?* ?y)) ; => (?* ?Y)
#+test
(setf axyd (expand-pat-match-abbrev '(a ?x* ?y* d))) ; => (A (?* ?X) (?* ?Y) D)
#+test
(pat-match axyd '(a b c d)) ; => ((?Y B C) (?X))
今回はここまで。おもしろかった！
やっぱり流し読みよりも、ちゃんとやった方がおもしろい。
こつこつ。
