「4.4」の検索結果
「naga:4-55/4-79」
から
次の単語がハイライトされています :
;;; Query input: (a) (supervisor ?name (Bitdiddle Ben)) ;;; Query outputs: (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (supervisor (Fect Cy D) (Bitdiddle Ben)) (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) ;;; Query input: (b) (job ?name (accounting . ?job)) ;;; Query outputs: (job (Cratchet Robert) (accounting scrivener)) (job (Scrooge Eben) (accounting chief accountant)) ;;; Query input: (c) (address ?name (Slumerville . ?address)) ;;; Query outputs: (address (Aull DeWitt) (Slumerville (Onion Square) 5)) (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)) (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
;;; Query input: (a) (and (supervisor ?name (Bitdiddle Ben)) (address ?name ?address)) ;;; Query outputs: (and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (address (Tweakit Lem E) (Boston (Bay State Road) 22))) (and (supervisor (Fect Cy D) (Bitdiddle Ben)) (address (Fect Cy D) (Cambridge (Ames Street) 3))) (and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))) ;;; Query input: (b) (and (salary (Bitdiddle Ben) ?Ben) (salary ?name ?amount) (lisp-value > ?Ben ?amount)) ;;; Query outputs: (and (salary (Bitdiddle Ben) 60000) (salary (Aull DeWitt) 25000) (lisp-value > 60000 25000)) (and (salary (Bitdiddle Ben) 60000) (salary (Cratchet Robert) 18000) (lisp-value > 60000 18000)) (and (salary (Bitdiddle Ben) 60000) (salary (Reasoner Louis) 30000) (lisp-value > 60000 30000)) (and (salary (Bitdiddle Ben) 60000) (salary (Tweakit Lem E) 25000) (lisp-value > 60000 25000)) (and (salary (Bitdiddle Ben) 60000) (salary (Fect Cy D) 35000) (lisp-value > 60000 35000)) (and (salary (Bitdiddle Ben) 60000) (salary (Hacker Alyssa P) 40000) (lisp-value > 60000 40000)) ;;; Query input: (c) (and (supervisor ?name ?supervisor) (not (job ?supervisor (computer . ?job)))) ;;; Query outputs: (and (supervisor (Aull DeWitt) (Warbucks Oliver)) (not (job (Warbucks Oliver) (computer . ?job)))) (and (supervisor (Cratchet Robert) (Scrooge Eben)) (not (job (Scrooge Eben) (computer . ?job)))) (and (supervisor (Scrooge Eben) (Warbucks Oliver)) (not (job (Warbucks Oliver) (computer . ?job)))) (and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (not (job (Warbucks Oliver) (computer . ?job))))
(assert!
(rule (can-replace ?person-1 ?person-2)
(and (job ?person-1 ?job-1)
(job ?person-2 ?job-2)
(not (same ?person-1 ?person-2))
(or (same ?job-1 ?job-2)
(can-do-job-r ?job-1 ?job-2)))))
(assert! ; Ben が Louis の代わりができるように
(rule (can-do-job-r ?job-1 ?job-2)
(or (can-do-job ?job-1 ?job-2)
(and (can-do-job ?job-1 ?job-x)
(can-do-job-r ?job-x ?job-2)))))
;;;;; a
;;;;; Query input:
;;(can-replace ?person (Fect Cy D))
;;;;; Query outputs:
;;(can-replace (Hacker Alyssa P) (Fect Cy D))
;;(can-replace (Bitdiddle Ben) (Fect Cy D))
;;;;; b
;;;;; Query input:
;;(and (can-replace ?person-1 ?person-2)
;; (salary ?person-1 ?salary-1)
;; (salary ?person-2 ?salary-2)
;; (lisp-value < ?salary-1 ?salary-2))
;;;;; Query outputs:
;;(and (can-replace (Fect Cy D) (Hacker Alyssa P)) (salary (Fect Cy D) 35000) (salary (Hacker Alyssa P) 40000) (lisp-value < 35000 40000))
;;(and (can-replace (Aull DeWitt) (Warbucks Oliver)) (salary (Aull DeWitt) 25000) (salary (Warbucks Oliver) 150000) (lisp-value < 25000 150000))
;;;;; Query input:
(assert!
(rule (big-shot ?person)
(and (job ?person (?division . ?rest-1))
(or (and (supervisor ?person ?supervisor)
(not (job ?supervisor (?division . ?rest-2))))
(not (supervisor ?person ?supervisor))))))
;;;;; Query input:
;;(big-shot ?who)
;;;;; Query outputs:
;;(big-shot (Scrooge Eben))
;;(big-shot (Warbucks Oliver))
;;(big-shot (Bitdiddle Ben))
;;;;; Query input::
;; a
;;;;; Query input:
;;(meeting ?division (Friday . ?time))
;;;;; Query outputs:
;;(meeting administration (Friday 1pm))
;; b
(assert!
(rule (meeting-time ?person ?day-and-time)
(or (meeting whole-company ?day-and-time)
(and (job ?person (?division . ?rest))
(meeting ?division ?day-and-time)))))
;;;;; Query input:
;;(meeting-time (Hacker Alyssa P) ?dat)
;;;;; Query outputs:
;;(meeting-time (Hacker Alyssa P) (Wednesday 4pm))
;;(meeting-time (Hacker Alyssa P) (Wednesday 3pm))
;; c
;;;;; Query input:
;;(meeting-time (Hacker Alyssa P) (Wednesday . ?time))
;;;;; Query outputs:
;;(meeting-time (Hacker Alyssa P) (Wednesday 4pm))
;;(meeting-time (Hacker Alyssa P) (Wednesday 3pm))
;;; ?person-1 と ?person-2 を文字列比較して ?person-1 のほうが小さければ
;;; 出力する
(assert!
(rule (lives-near-all ?person-1 ?person-2)
(and (address ?person-1 (?town . ?rest-1))
(address ?person-2 (?town . ?rest-2))
(not (same ?person-1 ?person-2))
(lisp-value (lambda (p1 p2)
(define (name-in-string l)
(if (null? l)
""
(string-append (symbol->string (car l))
(name-in-string (cdr l)))))
(string<?
(name-in-string p1)
(name-in-string p2)))
?person-1
?person-2))))
;;;;; Query input:
;;(lives-near-all ?a ?b)
;;;;; Query outputs:
;;(lives-near-all (Aull DeWitt) (Reasoner Louis))
;;(lives-near-all (Aull DeWitt) (Bitdiddle Ben))
;;(lives-near-all (Fect Cy D) (Hacker Alyssa P))
;;(lives-near-all (Bitdiddle Ben) (Reasoner Louis))
(assert!
(rule (?x next-to ?y in (?x ?y . ?u))))
(assert!
(rule (?x next-to ?y in (?v . ?z))
(?x next-to ?y in ?z)))
;;;;; Query input:
;;(?x next-to ?y in (1 (2 3) 4))
;;;;; Query outputs:
;;((2 3) next-to 4 in (1 (2 3) 4))
;;(1 next-to (2 3) in (1 (2 3) 4))
;;;;; Query input:
;;(?x next-to 1 in (2 1 3 1))
;;;;; Query outputs:
;;(3 next-to 1 in (2 1 3 1))
;;(2 next-to 1 in (2 1 3 1))
;; rule の assert 順を変えると (last-pair ?x (3)) は何も表示せずに loop する。
;; loop の表示を見ると rule にマッチした pattern を一生懸命(?)作っているのが
;; 良く分かる。
;; rule は後から登録した物が優先的に使われる。
;; ルールの本体がないルールは、その unifyで得られた frame を結果として返す。
;; 従って、問い合わせに対し、
;; 下のルールが 空frame と unify の結果の表示
;; 上のルールが 空frame と unify の結果を frame-1 として新しい問い合わせをする
;; 下のルールが frame-1 と unify の結果の表示
;; 上のルールが frame-1 と unify の結果を frame-2 として新しい問い合わせをする
;; ：
;; となる。
(assert! (rule (last-pair (?x . ?y) (?z))
(last-pair ?y (?z))))
(assert! (rule (last-pair (?x) (?x))))
;;;;; Query input:
;;(last-pair (3) ?a)
;;;;; Query outputs:
;;(last-pair (3) (3))
;;;;; Query input:
;;(last-pair (1 2 3) ?a)
;;;;; Query outputs:
;;(last-pair (1 2 3) (3))
;;;;; Query input:
;;(last-pair (2 ?a) (3))
;;;;; Query outputs:
;;(last-pair (2 3) (3))
;;;;; Query input:
;;(last-pair ?a (3))
;;;;; Query outputs:
;;(last-pair (3) (3))
;;(last-pair (?x-20 3) (3))
;;(last-pair (?x-20 ?x-22 3) (3))
;; ... loop ....
;; 一方、この登録順だと、
;; 下のルールが 空frame と unify の結果を frame-1 として新しい問い合わせをする
;; 下のルールが frame-1 と unify の結果を frame-2 として新しい問い合わせをする
;; ：
;; となる。したがって上のような表示がされない。
(assert! (rule (last-pair (?x) (?x))))
(assert! (rule (last-pair (?x . ?y) (?z))
(last-pair ?y (?z))))
;; ループの原因は
;; 問い合わせの変数 ?a が
;; ２つに分割され (?x . ?y)
;; その1つがまた問い合わせの変数として使われる ?y
;; ところにあり、ループの終了条件がない。最初の問い合わせが変数でなければ、終了する。
;;; rule 名を son にしたけど、それなりに動作する。 (assert! (son Adam Cain)) (assert! (son Cain Enoch)) (assert! (son Enoch Irad)) (assert! (son Irad Mehujael)) (assert! (son Mehujael Methushael)) (assert! (son Methushael Lamech)) (assert! (wife Lamech Ada)) (assert! (son Ada Jabal)) (assert! (son Ada Jubal)) ; (assert! (rule (grandson ?G ?S) (and (son ?F ?S) (son ?G ?F)))) (assert! (rule (son ?M ?S) (and (wife ?M ?W) (son ?W ?S)))) ;;;;; Query input: ;;(grandson Cain ?grandson) ;;;;; Query outputs: ;;(grandson Cain Irad) ;;;;; Query input: ;;(son Lamech ?son) ;;;;; Query outputs: ;;;;; Query input: ;;(son Lamech ?son) ;;;;; Query outputs: ;;(son Lamech Jubal) ;;(son Lamech Jabal) ;;;;; Query input: ;;(grandson Methushael ?grandson) ;;;;; Query outputs: ;;(grandson Methushael Jubal) ;;(grandson Methushael Jabal)
;; (Warbucks Oliver) が (wheel ?who) に該当するのは ;; 1 (Cratchet Robert) (Scrooge Eben) (Warbucks Oliver) ;; 2 (Tweakit Lem E) (Bitdiddle Ben) (Warbucks Oliver) ;; 3 (Fect Cy D) (Bitdiddle Ben) (Warbucks Oliver) ;; 4 (Hacker Alyssa P) (Bitdiddle Ben) (Warbucks Oliver) ;; の 4 通りあるため。 ;;;;; Query input: ;;(supervisor ?a ?b) ;;;;; Query outputs: ;;(supervisor (Aull DeWitt) (Warbucks Oliver)) ;;(supervisor (Cratchet Robert) (Scrooge Eben)) ;;(supervisor (Scrooge Eben) (Warbucks Oliver)) ;;(supervisor (Bitdiddle Ben) (Warbucks Oliver)) ;;(supervisor (Reasoner Louis) (Hacker Alyssa P)) ;;(supervisor (Tweakit Lem E) (Bitdiddle Ben)) ;;(supervisor (Fect Cy D) (Bitdiddle Ben)) ;;(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
;; (accumlation-function <variable> <query pattern>)
(define (acc-var acc-func)
(car acc-func))
(define (acc-q-pattern acc-func)
(cadr acc-func)
(define (acc-sum acc-func frame-stream)
(let ((sum 0)
(var (acc-var acc-func)))
(stream-for-each
(lambda (frame)
(let ((val (instantiate var frame #f)))
(if (and val (number? val))
(set! sum (+ sum val)))))
(qeval (acc-q-pattern acc-func) frame-stream))
(singleton-stream (Extend var sum '()))))
(put 'sum 'qeval acc-sum)
;; (make-unique <variable> <query pattern>)
(define (mkunique-var fil-def)
(car fil-def))
(define (mkunique-pattern fil-def)
(cadr fil-def))
(define (make-unique fil-def frame-stream)
(let ((val-list '())
(var (mkunique-var fil-def)))
(stream-flatmap
(lambda (frame)
(let ((val (instantiate var frame #f)))
(if (and val (not (member val val-list)))
(begin (set! val-list (cons val val-list))
(singleton-stream (Extend var val '())))
the-empty-stream)))
(qeval (mkunique-pattern fil-def) frame-stream))))
(put 'make-unique 'qeval make-unique)
;;;;; Query input:
;;(sum ?amount
;; (and (job ?x (computer programmer))
;; (salary ?x ?amount)))
;;;;; Query outputs:
;;(sum 75000 (and (job ?x (computer programmer)) (salary ?x 75000)))
;;;;; Query input:
;;(sum ?amount
;; (and (wheel ?who)
;; (salary ?who ?amount)))
;;;;; Query outputs:
;;(sum 660000 (and (wheel ?who) (salary ?who 660000)))
;;;;; Query input:
;;(make-unique ?who (wheel ?who))
;;;;; Query outputs:
;;(make-unique (Warbucks Oliver) (wheel (Warbucks Oliver)))
;;(make-unique (Bitdiddle Ben) (wheel (Bitdiddle Ben)))
;;;;; Query input:
;;(sum ?amount
;; (and (make-unique ?who (wheel ?who))
;; (salary ?who ?amount)))
;;;;; Query outputs:
;;(sum 210000 (and (make-unique ?who (wheel ?who)) (salary ?who 210000)))
;;;;; Query input:
(assert!
(rule (reverse (?x) (?x))))
(assert!
(rule (reverse (?x . ?y) ?z)
(and (reverse ?y ?w)
(append-to-form ?w (?x) ?z))))
;(assert!
; (rule (reverse (?x) (?x))))
;;;;; Query input:
;;(reverse (1 2 3) ?x)
;;;;; Query outputs:
;;(reverse (1 2 3) (3 2 1))
;;;;; Query input:
;;(reverse ?x (1 2 3))
;;;;; Query outputs:
;; ... loop ...
;;; ?relationship の出力に難あり。でも修正方法が？？？
;;(assert! (son Adam Cain))
;;(assert! (son Cain Enoch))
;;(assert! (son Enoch Irad))
;;(assert! (son Irad Mehujael))
;;(assert! (son Mehujael Methushael))
;;(assert! (son Methushael Lamech))
;;(assert! (wife Lamech Ada))
;;(assert! (son Ada Jabal))
;;(assert! (son Ada Jubal))
;;;
;;(assert! (rule (grandson ?G ?S) (and (son ?F ?S) (son ?G ?F))))
;;(assert! (rule (son ?M ?S) (and (wife ?M ?W) (son ?W ?S))))
(assert! (rule ((great . ?rel) ?x ?y)
(and (son ?x ?w)
(?rel ?w ?y))))
(assert! (rule ((grandson) ?x ?y)
(grandson ?x ?y)))
;;;;; Query input:
;;((great grandson) ?g ?ggs)
;;;;; Query outputs:
;;((great grandson) Mehujael Jubal)
;;((great grandson) Irad Lamech)
;;((great grandson) Mehujael Jabal)
;;((great grandson) Enoch Methushael)
;;((great grandson) Cain Mehujael)
;;((great grandson) Adam Irad)
;;;;; Query input:
;;(?relationship Adam Irad)
;;;;; Query outputs:
;;((great grandson) Adam Irad)
;;((great great . son) Adam Irad)
;;((great . grandson) Adam Irad)
;;((great great great . same) Adam Irad)
;;;;; Query input:
;;(?relationship Adam Jubal)
;;;;; Query outputs:
;;((great great great great great grandson) Adam Jubal)
;;((great great great great great great great . same) Adam Jubal)
;;((great great great great great . grandson) Adam Jubal)
;;((great great great great great great . son) Adam Jubal)
;;;;; Query input:
(define THE-ASSERTION '())
(define (add1 assertion)
(let ((old-assertion THE-ASSERTION))
(set! THE-ASSERTION (cons-stream assertion old-assertion))))
(define (add2 assertion)
(set! THE-ASSERTION (cons-stream assertion THE-ASSERTION)))
(define add #f)
;;;
(define (ex4_70)
(set! THE-ASSERTION '())
(set! add add1)
(add1 'assertion1)
(add1 'assertion2)
(display "add1:")
(dsp-stream THE-ASSERTION)
(newline)
(set! THE-ASSERTION '())
(set! add add2)
(add 'assertion1)
(add 'assertion2)
(display "add2:")
(dsp-stream THE-ASSERTION)
)
;;gosh> (ex4_70)
;;add1:assertion2 assertion1
;;add2:assertion2 assertion2 assertion2 assertion2 assertion2 assertion2 assertion2 assertion2 assertion2 assertion2 done
;;; cons-stream は １番目の引数と、２番目の引数を評価せず promise とした
;;; 物の pair を返す。
;;; 従って add2 では
;;; THE-ASSERTION → ('assertion2 . THE-ASSERTIONを返す手続き)
;;; となり stream は asserion2 が無限に続く。
;;; 一方 add1では
;;; THE-ASSERTION → ('assertion2 . old-assertion1を返す手続き)
;;; old-assertion1→ ('assertion1 . old-assertionを返す手続き)
;;; old-assertion → '()
;;; となり assertion の stream が得られる。
(assert! (loop 1 2))
(assert! (loop 1 3))
(assert! (rule (loop ?x ?y) (loop-rule ?x ?y)))
(assert! (rule (loop-rule ?x ?y) (loop-rule ?x ?y)))
;;; 4.4.4.6 Stream Operations に
;;; "Stream-append-delayed and interleave-delayed are just like stream-append
;;; and interleave (section 3.5.3), except that they take a delayed argument
;;; (like the integral procedure in section 3.5.4).
;;; This postpones looping in some cases (see exercise 4.71)."
;;; とあるので・・・
;;; 出力がバッファリングされているようで meadow だと実行中に差はわかりませんが。
;;gosh> (use SICP4)
;;gosh> (Query)
;;;;; Query input:
;;(load "ex4_71")
;;;;; Query input:
;;(loop ?a ?b)
;;;;; Query outputs:
;;(loop 1 3) ←
;;
;;Process scheme exited abnormally with code 1
;;gosh> (use SICP4)
;;ex4_71-procedures are installed
;;gosh> (Query)
;;;;; Query input:
;;(load "ex4_71")
;;;;; Query input:
;;(loop ?a ?b)
;;
;;Process scheme exited abnormally with code 1
;;; a
(define (simple-stream-flatmap proc s)
(simple-flatten (stream-map proc s)))
(define (simple-flatten stream)
(stream-map stream-car
(stream-filter
(lambda (stream) (if (eq? stream the-empty-stream) #f #t))
stream)))
;;; b
;; stream-flatmap と simple-stream-flatmap の差は stream 中の各 stream の
;; interleave を行わないことだが、各 stream が singleton-stream なので、
;; 生成される stream に差がでない。
(define (uniquely-asserted operands frame-stream)
(stream-flatmap
(lambda (frame)
(let ((ustream (qeval (unique-query operands) (singleton-stream frame))))
(if (and (not (eq? ustream the-empty-stream))
(not (eq? (stream-car ustream) the-empty-stream))
(eq? (stream-cdr ustream) the-empty-stream))
ustream
the-empty-stream)))
frame-stream))
(define (unique-query operands) (car operands))
;;;;; Query input:
;;(unique (job ?x (computer wizard)))
;;;;; Query outputs:
;;(unique (job (Bitdiddle Ben) (computer wizard)))
;;;;; Query input:
;;(unique (job ?x (computer programmer)))
;;;;; Query outputs:
;;;;; Query input:
;;(and (job ?x ?j) (unique (job ?anyone ?j)))
;;;;; Query outputs:
;;(and (job (Aull DeWitt) (administration secretary)) (unique (job (Aull DeWitt) (administration secretary))))
;;(and (job (Cratchet Robert) (accounting scrivener)) (unique (job (Cratchet Robert) (accounting scrivener))))
;;(and (job (Scrooge Eben) (accounting chief accountant)) (unique (job (Scrooge Eben) (accounting chief accountant))))
;;(and (job (Warbucks Oliver) (administration big wheel)) (unique (job (Warbucks Oliver) (administration big wheel))))
;;(and (job (Reasoner Louis) (computer programmer trainee)) (unique (job (Reasoner Louis) (computer programmer trainee))))
;;(and (job (Tweakit Lem E) (computer technician)) (unique (job (Tweakit Lem E) (computer technician))))
;;(and (job (Bitdiddle Ben) (computer wizard)) (unique (job (Bitdiddle Ben) (computer wizard))))
;;;;; Query input:
;;(and (job ?supervisor ?x) (unique (supervisor ?y ?supervisor)))
;;;;; Query outputs:
;;(and (job (Scrooge Eben) (accounting chief accountant)) (unique (supervisor (Cratchet Robert) (Scrooge Eben))))
;;(and (job (Hacker Alyssa P) (computer programmer)) (unique (supervisor (Reasoner Louis) (Hacker Alyssa P))))
;;;;; Query input:
