newLISP で On Lisp する．．．第１９章（その３）

（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）

　今回は、第１９章のタイトルでもある クエリコンパイラ です。とはいえ、コンパイラのない newLISP では、インタプリタのままになります。したがって、クエリインタプリタ に対して、速度の点で有利にはなりません。しかし、“On Lisp”本書の 事実の例 を評価してある状態で、

> (setq my-favorite-year 1723)
1723
>[cmd]
(with-answer (dates ?x my-favorite-year ?d)
   (print (format "%s was born in my favorite year.\n" (string ?x))))
[/cmd]
reynolds was born in my favorite year.
nil
> 

　ということが出来るようになります。前回見たように、クエリインタプリタ では、うまく動作しません。
　実装の前に、db-query 他、データベースの基本となる関数 は、第１９章（その１）で定義したものを使うのは、前回同様です。その上で、データベースを

(make-db '*default-db*)
(fact painter hogarth william english)
(fact painter canale antonio venetian)
(fact painter reynolds joshua english)
(fact dates hogarth 1697 1772)
(fact dates canale 1697 1768)
(fact dates reynolds 1723 1792)

　と定義しておきます。そして、matchex.lsp も実行しておきます。これで準備完了。
　さて、実装例です。（gensym、defun、car、cdr、cadr、t、mappend は newlisp-utility.lsp に定義してあります）

(define-macro (with-answer)
; (with-answer query &body body)
  (letex (_query (interpret-query (args 0))
          _body (cons 'begin (1 (args)))
          _bind (gensym))
    (dolist (_bind '_query)
      (lety _bind _body))
    nil))

(define-macro (lety var)
  (letex (_vars  (eval var)
          _body (args 0))
    (let _vars _body)))

(defun interpret-query (expr (binds '()))
  (case (car expr)
    (and  (interpret-and  (reverse (cdr expr)) binds))
    (or   (interpret-or   (cdr expr)  binds))
    (not  (interpret-not  (cadr expr) binds))
    (lisp (interpret-lisp (cadr expr) binds))
    (t    (lookupy (car expr) (cdr expr) binds))))

(defun interpret-and (clauses binds)
  (if (null clauses)
        (list binds)
        (mappend (fn (b) (interpret-query (car clauses) b))
                 (interpret-and (cdr clauses) binds))))

(defun interpret-or (clauses binds)
  (mappend (fn (c) (interpret-query c binds))
           clauses))

(defun interpret-not (clause binds)
  (if (interpret-query clause binds)
        '()
        (list binds)))

(defun interpret-lisp (clause binds)
  (letex (_clause clause)
    ;(mappend (fn (x) (lety x (if _clause (list x) '()))) binds)))
    (lety binds (if _clause (list binds) '()))))

(defun lookupy (pred arg (binds '()))
  (letex (_arg arg
          _binds binds)
    (mappend (fn (x) (aif (pat-match _arg x _binds) (list it) '()))
             (db-query pred))))

(define-macro (pat-match pat seq (binds '()))
; (if-match pat seq & binds)
  (let (_res   (match1 (append (explode (destruc pat (eval seq)) 2) binds)))
    (letex (_expr (if _res true nil)
            _vars _res)
      (if _expr
          '_vars '()))))

　マクロwith- answer は、前回と違って、展開式部のマクロletx を新規マクロlety に変えてあります。そして補助関数interpret-query では、新たに lisp項が加わり、補助関数interpret-lisp を呼び出します。また、補助関数lookupx は、新規補助関数lookupy になります。interpret-and、interpret-or、interpret-not は前回定義したものそのままです。
　補助関数lookupy とそこで使用しているマクロpat-match が今回のスクリプトの肝です。マクロpat-match は、“On Lisp”本書第１８章にある pat-match とは、実装も動作も全く別物です。第１８章（その５）で定義したマクロif-match の束縛部分のみを取り出したようなものです。中で使っている match1 は第１８章（その５）に、destruc は第１８章（その１）に定義してありますが、matchex.lsp に入れてあります(笑)。
　さて、動作を見てみましょう。クエリコンパイラ といっても、実装は、インタプリタベースです。
　まずは、お約束から、

> (setq my-favorite-year 1723)
1723
> (interpret-query '(dates ?x my-favorite-year ?d))
(((?x 'reynolds) (?d '1792)))
> 

　そして、クエリコンパイラ の用例 から二つ、

> (with-answer (painter 'hogarth ?x ?y) (println (list ?x ?y)))
(william english)
nil
> [cmd]
(with-answer (and (painter ?x _ 'english)
                  (dates ?x ?b _)
                  (not (and (painter ?x2 _ 'venetian)
                            (dates ?x2 ?b _))))
    (println ?x))
[/cmd]
reynolds
nil
> 

　もちろん、“On Lisp”本書の 事実の例 を評価してある状態です。前述のように実装がコンパイラになっていませんが、自己評価形式でない任意のリテラル引数 にクォートをつける必要があるのは、“On Lisp”本書の例と同様です。
　さらに、

> [cmd]
(with-answer (and (painter ?x _ _)
                    (dates ?x _ ?d)
                    (lisp ( [cmd]
(with-answer (and (dates ?x ?b ?d)
                    (lisp (> (- ?d ?b) 70)))
  (print (format "%s lived over 70 years.\n" (string ?x))))
[/cmd]
canale lived over 70 years.
hogarth lived over 70 years.
nil
> 

　と、lisp節も動作します。

　さて、第１９章 クエリコンパイラ のまとめです。

• newLISP でも、クエリコンパイラの動作を実現できます。（インタプリタ動作ですが）

　以上、如何でしょうか？

newLISP で On Lisp する．．．第１９章（その２）

（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）

　今回から 第１９章 クエリコンパイラ の本命の パターンマッチングクエリ に入ります。

　先ずは、クエリインタプリタ の実装です。db-query 他、データベースの基本となる関数 は、第１９章（その１）で定義したものを使います。（gensym、defun、null、car、cdr、cadr、t と mappend は newlisp-utility.lsp に定義してあります）

(define-macro (with-answer)
; (with-answer query &body body)
  (letex (_query (interpret-query (args 0))
          _body (cons 'begin (1 (args)))
          _bind (gensym))
    (dolist (_bind '_query)
       (letx _bind _body))
    nil))

 (define-macro (letx var)
  (letex (_vars (labels ((add/c (x) (letex (_x x) ''_x)))
                  (map (fn (x) (list (x 0) (add/c (x 1)))) (eval var)))
          _body (args 0))
    (let _vars _body)))

(defun interpret-query (expr (binds '()))
  (case (car expr)
       (and (interpret-and (reverse (cdr expr)) binds))
       (or  (interpret-or  (cdr expr)  binds))
       (not (interpret-not (cadr expr) binds))
       (t   (lookupEx (car expr) (cdr expr) binds))))

(defun interpret-and (clauses binds)
  (if (null clauses)
        (list binds)
        (mappend (fn (b) (interpret-query (car clauses) b))
                 (interpret-and (cdr clauses) binds))))

(defun interpret-or (clauses binds)
  (mappend (fn (c) (interpret-query c binds))
           clauses))

(defun interpret-not (clause binds)
  (if (interpret-query clause binds)
        '()
        (list binds)))

(defun lookupEx (pred arg (binds '()))
  (mappend (fn (x)
               (aif2 (matchEx x arg binds) (list it) '()))
           (db-query pred)))

　newLISP組込関数に lookup があるので、関数lookupEx に改名してあります。そして、関数lookupEx に使われている関数matchEx は、第１８章(その４)で定義したものです。また、アナフォリックマクロaif2 は、第１４章（その２）に定義したものです。あわせて matchex.lsp に定義しておきましたので、お使い下さい。マクロwith-answer 以外の関数は、mapcan の代わりに mappend を使っていることを除けば、“On Lisp” 本書のコードとほとんど一緒です。マクロwith-answer は、本書のコードと違って見えますが、内容的には、ほぼ同様の式の展開を行います。それを実現するために、マクロletx を用意しています。最後の nil は、本書コードの戻り値に合わせたものです。newLISP の dolist には、CommonLisp の dolist のように戻り値を指定する引数がないので。
　説明が長くなりましたが、動作させて見ましょう。本書の 事実の例 を評価した後の結果です。

> (lookupEx 'painter '(?x ?y english))
(((?y joshua) (?x reynolds)) ((?y william) (?x hogarth)))
> (interpret-query '(and (painter ?x ?y ?z) (dates ?x 1697 ?w)))
(((?w 1768) (?z venetian) (?y antonio) (?x canale)) ((?w 1772) (?z english) (?y william) 
  (?x hogarth)))
> 

　ざっとこんな感じです。
　クエリインタプリタの用例 を試してみると、

> (with-answer (painter hogarth ?x ?y) (println (list ?x ?y)))
(william english)
nil
> (with-answer (and (painter ?x _ _) (dates ?x 1697 _)) (println (list ?x)))
(canale)
(hogarth)
nil
> (with-answer (or (dates ?x ?y 1772) (dates ?x ?y 1792)) (println (list ?x ?y)))
(hogarth 1697)
(reynolds 1723)
nil
> [cmd]
(with-answer (and (painter ?x _ english)
                  (dates ?x ?b _)
                  (not (and (painter ?x2 _ venetian)
                            (dates ?x2 ?b _))))
    (println ?x))
[/cmd]
reynolds
nil
> 

　といった具合に、うまく動いているようです。

　束縛に関する制限 は、本書の制限がそのまま当てはまります。

> (interpret-query '(not (painter ?x ?y ?z)))
()
> 

　関数interpret-not は、定義通り、束縛があれば、空リストを返します。

> (interpret-query '(and (painter ?x ?y ?z) (not (dates ?x 1772 ?d))))
(((?z english) (?y joshua) (?x reynolds)) ((?z venetian) (?y antonio) (?x canale)) 
 ((?z english) (?y william) (?x hogarth)))
> (interpret-query '(and (not (dates ?x 1772 ?d)) (painter ?x ?y ?z))) 
(((?z english) (?y joshua) (?x reynolds)) ((?z venetian) (?y antonio) (?x canale)) 
 ((?z english) (?y william) (?x hogarth)))
> 

　正しい順序でも、誤った順序で指定しても一見同じに見えます。
　しかし、誤った順序では、

> (interpret-query '(and (not (dates ?x 1723 ?d)) (painter ?x ?y ?z)))
()
> 

　となります。クエリインタプリタの and は、左から順に束縛を作ります。最初の誤った例では、1772年生まれの束縛がなかったので関数interpret-not は、dates の全ての束縛を返します。直前の例では、1723年生まれの束縛があったので空リストを返します。正しい順序では、painter の束縛が最初に作られますので

> (interpret-query '(and (painter ?x ?y ?z) (not (dates ?x 1723 ?d))))
(((?z venetian) (?y antonio) (?x canale)) ((?z english) (?y william) (?x hogarth)))
> 

　となり、所望の結果が得られます。

> (interpret-query '(or (painter ?x ?y ?z) (dates ?x ?b ?d))) 
(((?z english) (?y joshua) (?x reynolds)) ((?z venetian) (?y antonio) (?x canale)) 
 ((?z english) (?y william) (?x hogarth)) 
 ((?d 1792) (?b 1723) (?x reynolds)) 
 ((?d 1768) (?b 1697) (?x canale)) 
 ((?d 1772) (?b 1697) (?x hogarth)))
> 

　この束縛では、painter と dates の束縛が独立して返ります。この束縛がお望みなら問題はないのですが（笑）。

　そして、次回のための前振りです。

> (setq my-favorite-year 1723)
1723
> (interpret-query '(dates ?x my-favorite-year ?d))
()
> 

　今回の クエリインタプリタ では、空リストが返りますが、期待しているのは、

(((?x 'reynolds) (?d '1792)))

　これを返せるようにするために、クエリコンパイラ が登場します、次回に（笑）。

　以上如何でしょうか？