開発環境
- 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.77を解いてみる。
その他参考書籍
問題 4.77
修正前のコードでの質問と出力を確認。
コード(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 operands frame-stream)
(simple-stream-flatmap
(lambda (frame)
(if (stream-null? (qeval (negated-query operands)
(singleton-stream frame)))
(singleton-stream frame)
the-empty-stream))
frame-stream))
(put 'not 'qeval negate)
(define (lisp-value call frame-stream)
(simple-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 (unique-query exps) (car exps))
(define (uniquely-asserted contents frame-stream)
(stream-flatmap
(lambda (frame)
(let ((expand-stream (qeval (unique-query contents)
(singleton-stream frame))))
(if (or (stream-null? expand-stream)
(not (stream-null? (stream-cdr expand-stream))))
the-empty-stream
expand-stream)))
frame-stream))
(put 'unique 'qeval uniquely-asserted)
(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)
(simple-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))))
((depends-on? val var frame)
'failed)
(else (extend var val frame)))))
(define (depends-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 (simple-stream-flatmap proc s)
(simple-flatten (stream-map proc s)))
(define (simple-flatten stream)
(stream-map stream-car
(stream-filter (lambda (s)
(not (stream-null? s)))
stream)))
(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! (job (Bitdiddle Ben) (computer wizard)))
(assert! (job (Hacker Alyssa P) (computer programmer)))
(assert! (supervisor (Hacker Allysa P) (Bitdiddle Ben)))
(assert! (job (Fect Cy D) (computer programmer)))
(assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
(assert! (job (Tweakit Lem E) (computer technician)))
(assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
(assert! (job (Reasoner Louis) (computer programmer trainee)))
(assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
(assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
(assert! (job (Warbucks Oliver) (administration big wheel)))
(assert! (job (Scrooge Eben) (accounting chief accountant)))
(assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
(assert! (job (Cratchet Robert) (accounting scrivener)))
(assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
(assert! (job (Aull DeWitt) (administration secretary)))
(assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
(and (supervisor ?x ?y)
(not (job ?x (computer programmer))))
;;; Query results:
(and (supervisor (aull dewitt) (warbucks oliver)) (not (job (aull dewitt) (computer programmer))))
(and (supervisor (cratchet robert) (scrooge eben)) (not (job (cratchet robert) (computer programmer))))
(and (supervisor (scrooge eben) (warbucks oliver)) (not (job (scrooge eben) (computer programmer))))
(and (supervisor (bitdiddle ben) (warbucks oliver)) (not (job (bitdiddle ben) (computer programmer))))
(and (supervisor (reasoner louis) (hacker alyssa p)) (not (job (reasoner louis) (computer programmer))))
(and (supervisor (tweakit lem e) (bitdiddle ben)) (not (job (tweakit lem e) (computer programmer))))
(and (supervisor (hacker allysa p) (bitdiddle ben)) (not (job (hacker allysa p) (computer programmer))))
;;; Query input:
(and (not (job ?x (computer programmer)))
(supervisor ?x ?y))
;;; Query results:
;;; Query input:
End of input stream reached.
Moriturus te saluto.
$
notの順番を入れ替えると出力結果が変わってしまうことを確認できた。
フィルタ演算(andのnot)を遅延。
修正、追加箇所。
コード(BBEdit)
qeval.scm
(define (conjoin conjuncts frame-stream)
(let ((ordered-conjuncts (delay-or-conjuncts conjuncts)))
(if (empty-conjunction? ordered-conjuncts)
frame-stream
(conjoin (rest-conjuncts ordered-conjuncts)
(qeval (first-conjunct ordered-conjuncts)
frame-stream)))))
;; conjunctsの順番を入れ替える。
(define (delay-or-conjuncts conjuncts)
;; notを含むものと含まないものにconjunctsを分ける。
(define (iter conjuncts not-conjuncts rest)
(if (empty-conjunction? conjuncts)
(cons not-conjuncts rest)
(let ((first (first-conjunct conjuncts))
(rest1 (rest-conjuncts conjuncts)))
(if (eq? (type first) 'not)
(iter rest1
(cons first not-conjuncts)
rest)
(iter rest1
not-conjuncts
(cons first rest))))))
;; notを含まないもの1つ1つ対して順に、全てのnotをフィルタリングしていく
(define (iter2 rest not-conjuncts)
(cond ((empty-conjunction? not-conjuncts) rest)
((empty-conjunction? rest) not-conjuncts)
(else
(let ((first (first-conjunct rest))
(rest2 (rest-conjuncts rest)))
(append (cons first not-conjuncts)
(iter2 rest2 not-conjuncts))))))
(let ((not-rest (iter conjuncts '() '())))
(let ((not-conjuncts (car not-rest))
(rest (cdr not-rest)))
;; (append rest not-conjuncts)だと全てのnotを最後に移動
;; 効率化の為に出来るだけフィルタリングを早く実行
(iter2 rest not-conjuncts))))
入出力結果(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! (job (Bitdiddle Ben) (computer wizard)))
(assert! (job (Hacker Alyssa P) (computer programmer)))
(assert! (supervisor (Hacker Allysa P) (Bitdiddle Ben)))
(assert! (job (Fect Cy D) (computer programmer)))
(assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
(assert! (job (Tweakit Lem E) (computer technician)))
(assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
(assert! (job (Reasoner Louis) (computer programmer trainee)))
(assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
(assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
(assert! (job (Warbucks Oliver) (administration big wheel)))
(assert! (job (Scrooge Eben) (accounting chief accountant)))
(assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
(assert! (job (Cratchet Robert) (accounting scrivener)))
(assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
(assert! (job (Aull DeWitt) (administration secretary)))
(assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
Assertion added to data base.
;;; Query input:
(and (supervisor ?x ?y)
(not (job ?x (computer programmer))))
;;; Query results:
(and (supervisor (aull dewitt) (warbucks oliver)) (not (job (aull dewitt) (computer programmer))))
(and (supervisor (cratchet robert) (scrooge eben)) (not (job (cratchet robert) (computer programmer))))
(and (supervisor (scrooge eben) (warbucks oliver)) (not (job (scrooge eben) (computer programmer))))
(and (supervisor (bitdiddle ben) (warbucks oliver)) (not (job (bitdiddle ben) (computer programmer))))
(and (supervisor (reasoner louis) (hacker alyssa p)) (not (job (reasoner louis) (computer programmer))))
(and (supervisor (tweakit lem e) (bitdiddle ben)) (not (job (tweakit lem e) (computer programmer))))
(and (supervisor (hacker allysa p) (bitdiddle ben)) (not (job (hacker allysa p) (computer programmer))))
;;; Query input:
(and (not (job ?x (computer programmer)))
(supervisor ?x ?y))
;;; Query results:
(and (not (job (aull dewitt) (computer programmer))) (supervisor (aull dewitt) (warbucks oliver)))
(and (not (job (cratchet robert) (computer programmer))) (supervisor (cratchet robert) (scrooge eben)))
(and (not (job (scrooge eben) (computer programmer))) (supervisor (scrooge eben) (warbucks oliver)))
(and (not (job (bitdiddle ben) (computer programmer))) (supervisor (bitdiddle ben) (warbucks oliver)))
(and (not (job (reasoner louis) (computer programmer))) (supervisor (reasoner louis) (hacker alyssa p)))
(and (not (job (tweakit lem e) (computer programmer))) (supervisor (tweakit lem e) (bitdiddle ben)))
(and (not (job (hacker allysa p) (computer programmer))) (supervisor (hacker allysa p) (bitdiddle ben)))
;;; Query input:
End of input stream reached.
Moriturus te saluto.
$
andのnotを含む2つの質問の順番を入れ替えても同じ出力結果を生じるように出来た。
0 コメント:
コメントを投稿