開発環境
- OS X Mavericks - Apple(OS)
- Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
- Scheme (プログラミング言語)
- MIT/GNU Scheme (処理系)
計算機プログラムの構造と解釈(Gerald Jay Sussman(原著)、Julie Sussman(原著)、Harold Abelson(原著)、和田 英一(翻訳)、ピアソンエデュケーション、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の4(超言語的抽象)、4.4(論理型プログラミング)、4.4.4(質問システムの実装)、4.4.4.6(ストリーム演算)、4.4.4.7(質問の構文手続き)、4.4.4.8(フレームと束縛)、問題 4.72を解いてみる。
その他参考書籍
問題 4.72
最初のストリームが無限ストリームの場合でも、いつかは混ぜ合わされたストリームへ行く道を見つけることが出来るようにするため。
単に連接して、ストリームを差し込みにしなかった場合、1つ目のストリームが無限のために、どれだけ繰り返し辿っていっても2つ目のストリームに辿り着くことはない。
差し込みが上手く働くのが分かる例。
表明、規則の定義、
(assert! (married a b))
(assert! (wife c d))
(assert! (rule (married ?x ?y)
(or (married ?y ?x)
(wife ?x ?y))))
に(married ?x ?y)という質問をした場合、ストリームを差し込みにした場合は、(married a b)、(married c d、(married b a)、(married d c)の全てが出力されるのに対し、単に連接してストリームを差し込みにしなかった場合は(married a b)、(married b a)しか出力されない。(ただし、どちらの場合も無限ループになることには変わらない。)
確認。
以前の未完成のコードを修正して規則も定義できるようになり、やっと質問シッステムの実装完了。(まだそんなに使ってないので修正必要箇所が出てくるかも…)
とりあえず、今まで質問システムでの確認を先延ばしにしてきた問題で、少しずつ質問システムを 使ってみることに。
ストリームを差し込みにした場合。(通常の質問システムを使った場合。)
コード(BBEdit)
qeval.scm
(define input-prompt ";;; Query input:")
(define out-prompt ";;; Query results:")
(define (query-driver-loop)
(prompt-for-input input-prompt)
(let ((q (query-syntax-process (read))))
(cond ((assertion-to-be-added? q)
(add-rule-or-assertion! (add-assertion-body q))
(newline)
(display "Assertion added to data base.")
(query-driver-loop))
(else
(newline)
(display out-prompt)
(display-stream
(stream-map
(lambda (frame)
(instantiate q
frame
(lambda (v f)
(contract-question-mark v))))
(qeval q (singleton-stream '()))))
(query-driver-loop)))))
(define (stream-ref s n)
(if (= n 0)
(stream-car s)
(stream-ref (stream-cdr s) (- n 1))))
(define (stream-map proc s)
(if (stream-null? s)
the-empty-stream
(cons-stream (proc (stream-car s))
(stream-map proc (stream-cdr s)))))
(define (stream-for-each proc s)
(if (stream-null? s)
'done
(begin (proc (stream-car s))
(stream-for-each proc (stream-cdr s)))))
(define (display-stream s)
(stream-for-each display-line s))
(define (display-line x)
(newline)
(display x))
(define (prompt-for-input string)
(newline) (newline) (display string) (newline))
(define (instantiate exp frame unbound-var-handler)
(define (copy exp)
(cond ((var? exp)
(let ((binding (binding-in-frame exp frame)))
(if binding
(copy (binding-value binding))
(unbound-var-handler exp frame))))
((pair? exp)
(cons (copy (car exp)) (copy (cdr exp))))
(else exp)))
(copy exp))
(define (qeval query frame-stream)
(let ((qproc (get (type query) 'qeval)))
(if qproc
(qproc (contents query) frame-stream)
(simple-query query frame-stream))))
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define (simple-query query-pattern frame-stream)
(stream-flatmap
(lambda (frame)
(stream-append-delayed
(find-assertions query-pattern frame)
(delay (apply-rules query-pattern frame))))
frame-stream))
(define (conjoin conjuncts frame-stream)
(if (empty-conjunction? conjuncts)
frame-stream
(conjoin (rest-conjuncts conjuncts)
(qeval (first-conjunct conjuncts)
frame-stream))))
(put 'and 'qeval conjoin)
(define (disjoin disjuncts frame-stream)
(if (empty-disjunction? disjuncts)
the-empty-stream
(interleave-delayed
(qeval (first-disjunct disjuncts) frame-stream)
(delay (disjoin (rest-disjuncts disjuncts)
frame-stream)))))
(put 'or 'qeval disjoin)
(define (negate opernds frame-stream)
(stream-flatmap
(lambda (frame)
(if (stream-null? (qeval (negated-query operands)
(singleton-stream frame)))
(singleton-stream frame)
the-empty-stream))
frame-stream))
(define (lisp-value call frame-stream)
(stream-flatmap
(lambda (frame)
(if (execute
(instantiate
call
frame
(lambda (v f)
(error "Unknown pat var -- LISP-VALUE" v))))
(singleton-stream frame)
the-empty-stream))
frame-stream))
(put 'lisp-value 'qeval lisp-value)
(define (execute exp)
(apply (eval (predicate exp) user-initial-environment)
(args exp)))
(define (always-true ignore frame-stream) frame-stream)
(put 'always-true 'qeval always-true)
(define (find-assertions pattern frame)
(stream-flatmap (lambda (datum)
(check-an-assertion datum pattern frame))
(fetch-assertions pattern frame)))
(define (check-an-assertion assertion query-pat query-frame)
(let ((match-result
(pattern-match query-pat assertion query-frame)))
(if (eq? match-result 'failed)
the-empty-stream
(singleton-stream match-result))))
(define (pattern-match pat dat frame)
(cond ((eq? frame 'failed) 'failed)
((equal? pat dat) frame)
((var? pat) (extend-if-consistent pat dat frame))
((and (pair? pat) (pair? dat))
(pattern-match (cdr pat)
(cdr dat)
(pattern-match (car pat)
(car dat)
frame)))
(else 'failed)))
(define (extend-if-consistent var dat frame)
(let ((binding (binding-in-frame var frame)))
(if binding
(pattern-match (binding-value binding) dat frame)
(extend var dat frame))))
(define (apply-rules pattern frame)
(stream-flatmap (lambda (rule)
(apply-a-rule rule pattern frame))
(fetch-rules pattern frame)))
(define (apply-a-rule rule query-pattern query-frame)
(let ((clean-rule (rename-variables-in rule)))
(let ((unify-result
(unify-match query-pattern
(conclusion clean-rule)
query-frame)))
(if (eq? unify-result 'failed)
the-empty-stream
(qeval (rule-body clean-rule)
(singleton-stream unify-result))))))
(define (rename-variables-in rule)
(let ((rule-application-id (new-rule-application-id)))
(define (tree-walk exp)
(cond ((var? exp)
(make-new-variable exp rule-application-id))
((pair? exp)
(cons (tree-walk (car exp))
(tree-walk (cdr exp))))
(else exp)))
(tree-walk rule)))
(define (unify-match p1 p2 frame)
(cond ((eq? frame 'failed) 'failed)
((equal? p1 p2) frame)
((var? p1) (extend-if-possible p1 p2 frame))
((var? p2) (extend-if-possible p2 p1 frame))
((and (pair? p1) (pair? p2))
(unify-match (cdr p1)
(cdr p2)
(unify-match (car p1)
(car p2)
frame)))
(else 'failed)))
(define (extend-if-possible var val frame)
(let ((binding (binding-in-frame var frame)))
(cond (binding
(unify-match
(binding-value binding) val frame))
((var? val)
(let ((binding (binding-in-frame val frame)))
(if binding
(unify-match
var (binding-value binding) frame)
(extend var val frame))))
((depeds-on? val var frame)
'failed)
(else (extend var val frame)))))
(define (depnds-on? exp var frame)
(define (tree-walk e)
(cond ((var? e)
(if (equal? var e)
true
(let ((b (binding-in-frame e frame)))
(if b
(tree-walk (binding-value b))
false))))
((pair? e)
(or (tree-walk (car e))
(tree-walk (cdr e))))
(else false)))
(tree-walk exp))
(define THE-ASSERTIONS the-empty-stream)
(define (fetch-assertions pattern frame)
(if (use-index? pattern)
(get-indexed-assertions pattern)
(get-all-assertions)))
(define (get-all-assertions) THE-ASSERTIONS)
(define (get-indexed-assertions pattern)
(get-stream (index-key-of pattern) 'assertion-stream))
(define (get-stream key1 key2)
(let ((s (get key1 key2)))
(if s s the-empty-stream)))
(define THE-RULES the-empty-stream)
(define (fetch-rules pattern frame)
(if (use-index? pattern)
(get-indexed-rules pattern)
(get-all-rules)))
(define (get-all-rules) THE-RULES)
(define (get-indexed-rules pattern)
(stream-append
(get-stream (index-key-of pattern) 'rule-stream)
(get-stream '? 'rule-stream)))
(define (add-rule-or-assertion! assertion)
(if (rule? assertion)
(add-rule! assertion)
(add-assertion! assertion)))
(define (add-assertion! assertion)
(store-assertion-in-index assertion)
(let ((old-assertions THE-ASSERTIONS))
(set! THE-ASSERTIONS
(cons-stream assertion old-assertions))
'ok))
(define (add-rule! rule)
(store-rule-in-index rule)
(let ((old-rules THE-RULES))
(set! THE-RULES (cons-stream rule old-rules))
'ok))
(define (store-assertion-in-index assertion)
(if (indexable? assertion)
(let ((key (index-key-of assertion)))
(let ((current-assertion-stream
(get-stream key 'assertion-stream)))
(put key
'assertion-stream
(cons-stream assertion
current-assertion-stream))))))
(define (store-rule-in-index rule)
(let ((pattern (conclusion rule)))
(if (indexable? pattern)
(let ((key (index-key-of pattern)))
(let ((current-rule-stream
(get-stream key 'rule-stream)))
(put key
'rule-stream
(cons-stream rule
current-rule-stream)))))))
(define (indexable? pat)
(or (constant-symbol? (car pat))
(var? (car pat))))
(define (index-key-of pat)
(let ((key (car pat)))
(if (var? key) '? key)))
(define (use-index? pat)
(constant-symbol? (car pat)))
(define (stream-append-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(stream-append-delayed (stream-cdr s1) delayed-s2))))
(define (interleave-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(interleave-delayed (force delayed-s2)
(delay (stream-cdr s1))))))
(define (stream-flatmap proc s)
(flatten-stream (stream-map proc s)))
(define (flatten-stream stream)
(if (stream-null? stream)
the-empty-stream
(interleave-delayed
(stream-car stream)
(delay (flatten-stream (stream-cdr stream))))))
(define (singleton-stream x)
(cons-stream x the-empty-stream))
(define (type exp)
(if (pair? exp)
(car exp)
(error "Unknown expression TYPE" exp)))
(define (contents exp)
(if (pair? exp)
(cdr exp)
(error "Unknown expression CONTENTS" exp)))
(define (assertion-to-be-added? exp)
(eq? (type exp) 'assert!))
(define (add-assertion-body exp)
(car (contents exp)))
(define (empty-conjunction? exps) (null? exps))
(define (first-conjunct exps) (car exps))
(define (rest-conjuncts exps) (cdr exps))
(define (empty-disjunction? exps) (null? exps))
(define (first-disjunct exps) (car exps))
(define (rest-disjuncts exps) (cdr exps))
(define (negated-query exps) (car exps))
(define (predicate exps) (car exps))
(define (args exps) (cdr exps))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
(define (rule? statement)
(tagged-list? statement 'rule))
(define (conclusion rule) (cadr rule))
(define (rule-body rule)
(if (null? (cddr rule))
'(always-true)
(caddr rule)))
(define (query-syntax-process exp)
(map-over-symbols expand-quesion-mark exp))
(define (map-over-symbols proc exp)
(cond ((pair? exp)
(cons (map-over-symbols proc (car exp))
(map-over-symbols proc (cdr exp))))
((symbol? exp) (proc exp))
(else exp)))
(define (expand-quesion-mark symbol)
(let ((chars (symbol->string symbol)))
(if (string=? (substring chars 0 1) "?")
(list '?
(string->symbol
(substring chars 1 (string-length chars))))
symbol)))
(define (var? exp)
(tagged-list? exp '?))
(define (constant-symbol? exp) (symbol? exp))
(define rule-counter 0)
(define (new-rule-application-id)
(set! rule-counter (+ 1 rule-counter))
rule-counter)
(define (make-new-variable var rule-application-id)
(cons '? (cons rule-application-id (cdr var))))
(define (contract-question-mark variable)
(string->symbol
(string-append "?"
(if (number? (cadr variable))
(string-append (symbol->string (caddr variable))
"-"
(number->string (cadr variable)))
(symbol->string (cadr variable))))))
(define (make-binding variable value)
(cons variable value))
(define (binding-variable binding)
(car binding))
(define (binding-value binding)
(cdr binding))
(define (binding-in-frame variable frame)
(assoc variable frame))
(define (extend variable value frame)
(cons (make-binding variable value) frame))
(query-driver-loop)
入出力結果(Terminal, REPL(Read, Eval, Print, Loop))
$ scheme
MIT/GNU Scheme running under MacOSX
Type `^C' (control-C) followed by `H' to obtain information about interrupts.
Copyright (C) 2011 Massachusetts Institute of Technology
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Image saved on Saturday October 26, 2013 at 11:02:50 PM
Release 9.1.1 || Microcode 15.3 || Runtime 15.7 || SF 4.41 || LIAR/C 4.118
Edwin 3.116
1 ]=> (load "./qeval.scm")
;Loading "./qeval.scm"...
;;; Query input:
(assert! (married a b))
Assertion added to data base.
;;; Query input:
(assert! (wife c d))
Assertion added to data base.
;;; Query input:
(assert! (rule (married ?x ?y)
(or (married ?y ?x)
(wife ?x ?y))))
Assertion added to data base.
;;; Query input:
(married ?x ?y)
;;; Query results:
(married a b)
(married b a)
(married c d)
(married a b)
(married d c)
(married b a)
(married c d)
(married a b)
(married d c)
(married b a)
(married c d)
(married a b)
(married d c)
(married b a)
(married c d)
(married a b)
;; 無限に続くので中断
(married a b)^C
Interrupt option (? for help):
;... aborted
;Quit!
1 ]=>
確かに(married a b)、(married c d、(married b a)、(married d c)の全てののパターンが探索され、出力されることを確認できた。
disjoinとstream-flatmapが、単に連接で、ストリームを差し込みにしなかった場合。
上記のコードのinterleave-delayedをstream-append-delayedに変更。
コード(BBEdit)
qeval_infinite.scm
;; 省略
(define (disjoin disjuncts frame-stream)
(if (empty-disjunction? disjuncts)
the-empty-stream
(stream-append-delayed
(qeval (first-disjunct disjuncts) frame-stream)
(delay (disjoin (rest-disjuncts disjuncts)
frame-stream)))))
;; 省略
(define (interleave-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(stream-append-delayed (force delayed-s2)
(delay (stream-cdr s1))))))
;; 省略
(define (flatten-stream stream)
(if (stream-null? stream)
the-empty-stream
(stream-append-delayed
(stream-car stream)
(delay (flatten-stream (stream-cdr stream))))))
;; 省略
入出力結果(Terminal, REPL(Read, Eval, Print, Loop))
$ scheme
MIT/GNU Scheme running under MacOSX
Type `^C' (control-C) followed by `H' to obtain information about interrupts.
Copyright (C) 2011 Massachusetts Institute of Technology
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Image saved on Saturday October 26, 2013 at 11:02:50 PM
Release 9.1.1 || Microcode 15.3 || Runtime 15.7 || SF 4.41 || LIAR/C 4.118
Edwin 3.116
1 ]=> (load "./qeval_infinite.scm")
;Loading "./qeval_infinite.scm"...
;;; Query input:
(assert! (married a b))
Assertion added to data base.
;;; Query input:
(assert! (wife c d))
Assertion added to data base.
;;; Query input:
(assert! (rule (married ?x ?y)
(or (married ?y ?x)
(wife ?x ?y))))
Assertion added to data base.
;;; Query input:
(married ?x ?y)
;;; Query results:
(married a b)
(married b a)
(married a b)
(married b a)
(married a b)
(married b a)
(married a b)
(married b a)
(married a b)
(married b a)
(married a b)
(married b a)
(married a b)
(married b a)
(married a b)
(married b a)
(married a b)
(married b a)
(married a b)
(married b a)
;; 無限に続くので中断
(married a b)^C
Interrupt option (? for help):
;... aborted
;Quit!
1 ]=>
(married a b)、(married b a)しか出力されていない。
0 コメント:
コメントを投稿