modify 08(named-let implementation)

4/08.scm

@@ -1,59 +1,53 @@
-;; ex 4.8
-;; the form of named-let expressions
-(let name ((var1 exp1) (var2 exp2) ...) body)
-->
-((lambda (var1 var2 ...)
-   (let ((name (lambda (var1 var2 ...) body)))
-     body))
- exp1 exp2 ...)
-->
-((lambda (var1 var2 ...)
-   ((lambda (name) body) (lambda (var1 var2 ...) body))
-   body)
- exp1 exp2 ...)
+;; (let name ((var1 exp1) (var2 exp2) ...) body)
+;; ->
+;; ((lambda (var1 var2 ...)
+;;    (define name (lambda (var1 var2 ...) body))
+;;     (name var1 var2 ...))
+;;  exp1 exp2 ...)
+;; ->
+;; ((lambda (var1 var2 ...)
+;;    ((lambda (name) body) (lambda (var1 var2 ...) body))
+;;    body)
+;;  exp1 exp2 ...)
 
 
-;; answer
-;; extend ex4.6 answer for named-let
-;; named-let: (let name bindings body)
 
-;; lambda
 (define (make-lambda parameters body)
-  ;;(list 'lambda parameters body)  ;;not correct
   (cons 'lambda (cons parameters body)))
 
-
-
 (define (named-let? exp)
   (symbol? (cadr exp)))
-(define (let-binds exp)
+(define (let-bindings exp)
   (if (named-let? exp)
       (caddr exp)
       (cadr exp)))
+(define (let-name exp)
+  (cadr exp))
 (define (let-body exp)
   (if (named-let? exp)
-      (cadddr exp)
-      (caddr exp)))
+      (cdddr exp)
+      (cddr exp)))
 (define (let-vars exp)
-  (if (null? (let-binds exp))
+  (if (null? exp)
       '()
-      (cons (caar (let-binds binds))
-	    (let-vars (cdr (let-binds exp))))))
-  (define (let-exps exp env)
-  (if (null? (let-binds exp))
-      '()
-      (cons (eval (cadar (let-binds exp)) env)
-	    (let-exps (cdr (let-binds exp))))))
+      (map car (let-bindings exp))))
 
+(define (let-exps exp env)
+  (if (null? exp)
+      '()
+      (map (lambda (x) (eval (cadr x) env))
+	   (let-bindings exp))))
 
+;; let式からlambda式への変換
 (define (let->combination exp env)
   (if (named-let? exp)
-      (list (make-lambda (let-vars exp)
-			 (list (make-lambda (let-name exp)
-					    (let-body exp))
-			       (make-lambda (let-vars exp)
-					    (let-body exp))))
+      (cons (make-lambda (let-vars exp)
+			 (list
+			  (list 'define (let-name exp)
+				(make-lambda (let-vars exp)
+					     #?=(let-body exp)))
+			  (cons (let-name exp) (let-vars exp))))
 	    (let-exps exp env))
-      (list (make-lambda (let-vars (let-binds exp))
+      (cons (make-lambda (let-vars exp)
 			 (let-body exp))
-	    (let-exps (let-binds exp) env))))
+	    (let-exps exp env))))

4/4-4.scm

@@ -0,0 +1,144 @@
+;; Implementation the Query System
+
+;; 4.4.4.1 The Driver Loop and Instantiation
+;;(use util.stream)
+(define input-prompt ";;; Query input:")
+(define output-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 output-prompt)
+	   ;;(display-stream
+	   (write-stream ;;or stream->string (?)
+	    (stream-map
+	     (lambda (frame)
+	       (instantiate q
+			    frame
+			    (lambda (v f)
+			      (contract-question-mark v))))
+	     (qeval q (singleton-stream '()))))
+	   (query-driver-loop)))))
+
+;; 具現化
+(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))
+
+;; 4.4.4.2 The Evaluator
+(define (qeval query frame-stream)
+  (let ((qproc (get (type query) 'qeval)))
+    (if qproc
+	(qproc (contents query) frame-stream)
+	(simple-query query frame-stream))))
+
+;; qproc: もしクエリが特殊形式なら，ストリームとクエリを引数に評価する．
+;; そうでないなら，単純質問と考え処理する
+
+
+
+;; simple query
+(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))
+
+;; and
+(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)
+
+;; or
+(define (disjoin disjuncts frame-stream)
+  (if (empty-disjunction? disjuncts)
+      the-empty-stream
+      (interleave-delayed ;;merge
+       (qeval (first-disjunct disjuncts) frame-stream)
+       (delay (disjoin (rest-disjuncts disjuncts)
+		       frame-stream)))))
+
+;; (put 'or 'qeval disjoin)
+
+
+;; Filters
+
+;; not
+(define (negate operands frame-stream)
+  (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)
+
+
+;; lisp-value
+(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)))
+
+
+;; 4.4.4.3
+;; Finding Assertions by Pattern Matching
+(define (find-assertions pattern frame)
+  (stream-flatmap (lambda (datum)
+		    (check-an-assertion datum pattern frame))
+		  (fetch-assertions pattern frame)))
+
+(define (pattern-match pat dat frame)
+  (cond ((eq? frame 'failed) 'faild)
+	((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))))

4/68.scm

@@ -0,0 +1,14 @@
+;; not checked
+
+;; 1 atomをどう表現する?
+;; (rule (revert ?x ?x))だと(revert (1 2) (1 2))にマッチする
+;; =>append-to-formを使えば表現できる
+
+
+(rule (revert (?x) (?x))
+      (append-to-form ?x () (?x))) ;;ok?
+
+(rule (revert (?x . (?a)) (?a . ?y))
+      (revert ?x ?y))
+
+両方答えられる．

4/69.scm

@@ -0,0 +1,24 @@
+;; not checked
+
+((great grandson) ?g ?ggs)
+
+;; ?relが(great great grandson)のような関係を表すかチェックする規則
+(rule (relationship ?rel)
+      (or (relationship grandson)
+	  (and (relationship (great . ?rel-2))
+	       (relationship ?rel-2))))
+
+;; (son a b)のような場合
+(rule (?rel ?x ?y)
+      (son ?x ?y)
+      (wife ?x ?y)
+      (grandson ?x ?y))
+
+;; ((great grondson) a b)のような場合
+(rule ((great ?rel) ?x ?y)
+      (and (relationship ?rel)
+	   (son ?x ?s)
+	   (?rel ?s ?y)))
+
+
+

4/ChangeLog

@@ -0,0 +1,19 @@
+2008-11-06  Hiroshige Umino  <[email protected]>
+
+	* 4-4.scm: varのいみ
+
+2008-11-01  Hiroshige Umino  <[email protected]>
+
+	* 4-4.scm
+	(qeval):
+	■ここで言う特殊形式というのは何?
+	andやor，notなど．(put 'and 'qeval conjoin)などとしておく．
+
+	(simple-query):
+	□(stream-append-delayed ...)の引数部分
+	*(find-assertion ...)は全表明に対してパターンをマッチ&拡張フレームのストリームを作る
+	*(apply-rules ...)可能な規則を全て作用させて拡張されたフレームのもう1つ(?)のストリームを作る
+	*後者はユニフィケーション?
+
+	(lisp-value):
+	□(instantinate ...)が何をしているか．

4/evaluators/query-system.scm

@@ -0,0 +1,5 @@
+
+;; to use the stream module
+(use util.stream)
+(define input-prompt ";;; Query input:")
+(define output-prompt "	;;; Query results:")

README

@@ -1,3 +1,5 @@
-there is sicp codes from the 4th Chapter
+there is sicp codes from Chapter 4
 
-# sicp-codes/4/01.scm is my answer of exercise 4.1
+# sicp-codes/4/01.scm is my answer of exercise 4.1
+
+# use Gauche implementation