【PAIP】6 Building Software Tools (その2)

引き続き、6.2 A pattern-matching tool。

• 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))
  

  
  

今回はここまで。おもしろかった！
やっぱり流し読みよりも、ちゃんとやった方がおもしろい。
こつこつ。