EoPL reading (72) 2.2 An Abstraction for Inductive Data Type

む。lexical-address って

(lambda-exp (x y z)
	    (app-exp ((lambda-exp 
		       (x y) 
		       (app-exp ((var-exp +) 
				 (var-exp x) 
				 (var-exp y) 
				 (var-exp z))))
		      (var-exp y) (var-exp x))))

を吸わせたら

(lambda-exp (x y z)
	    (app-exp ((lambda-exp 
		       (x y) 
		       (app-exp ((free-info +) 
				 (lex-info x 0 0) 
				 (lex-info y 0 1) 
				 (lex-info z 1 2))))
		      (lex-info y 0 1) (lex-info x 0 0))))))

が出てこないと微妙なの?
イージーに lexical-address を書いてしまいました、という事ッスか。とりあえず書き換えてみます。ええと、lexical-address 手続きが以下。

(add-load-path ".")
(load "define-datatype")
(load "expression")
(load "variable-reference")

(define (lexical-address exp)
  (define (lexical-address-inner rslt dict l)
    (cases expression l
	   (lit-exp (datum) l)
	   (var-exp (id)
		    (let f ((d 0) (p 0) (dict dict))
		      (cond ((null? dict) (free-info id))
			    ((memq id (car dict))
			     (let f-inner ((p p) (dict (car dict)))
			       (if (eq? id (car dict))
				   (lex-info id d p)
				   (f-inner (+ p 1) (cdr dict)))))
			    (else
			     (f (+ d 1) 0 (cdr dict))))))
	   (if-exp (test-exp true-exp false-exp)
		   (append rslt 
			   (list 'if-exp
				 (lexical-address-inner '() dict test-exp)
				 (lexical-address-inner '() dict true-exp)
				 (lexical-address-inner '() dict false-exp))))
	   (lambda-exp (ids body)
		       (append (append rslt `(lambda-exp ,ids))
			       (list (lexical-address-inner '()
							    (cons ids dict)
							    body))))
	   (app-exp (rands)
		    (let f ((l '()) (rands rands))
		      (cond ((null? rands) (append rslt (cons 'app-exp (list l))))
			    (else
			     (f (append l
					(list (lexical-address-inner '() dict (car rands))))
				(cdr rands))))))
	   ))
  (lexical-address-inner '() '() exp))

なんかネスト深すぎて微妙。試験が以下です。ここまでリストが複雑だと試験がダメなのか実装がダメなのかが分かり辛い。

(use gauche.test)

(add-load-path ".")
(load "lexical-address")

(test-start "lexical-address")
(test-section "lexical-address")
(test* "(lit-exp 1) "
       '(lit-exp 1)
       (lexical-address '(lit-exp 1)))

(test* "(var-exp a) "
       '(free-info a)
       (lexical-address '(var-exp a)))

(test* "(app-exp ((var-exp a) (var-eexp b)))"
       '(app-exp ((free-info a) (free-info b)))
       (lexical-address '(app-exp ((var-exp a) (var-exp b)))))

(test* "(lambda-exp (x y) (app-exp (((var-exp +) (var-exp x) (var-exp y)))))"
       '(lambda-exp (x y) (app-exp ((free-info +) (lex-info x 0 0) (lex-info y 0 1))))
       (lexical-address '(lambda-exp 
			  (x y) 
			  (app-exp ((var-exp +) (var-exp x) (var-exp y))))))

(test* "(app-exp ((lambda-exp 
                   (x y) 
                   (app-exp ((var-exp +) (var-exp x) (var-exp y)))) 
                  (var-exp a) (var-exp b)))"
       '(app-exp ((lambda-exp (x y) 
			      (app-exp ((free-info +) 
					(lex-info x 0 0) 
					(lex-info y 0 1)))) 
		  (free-info a) (free-info b)))
       (lexical-address '(app-exp 
			  ((lambda-exp 
			    (x y) 
			    (app-exp ((var-exp +) (var-exp x) (var-exp y))))
			   (var-exp a) 
			   (var-exp b)))))

(test* "(if-exp (app-exp ((var-ex =) (var-exp x) (var-exp y))) 
                (var-exp x) 
                (var-exp y))"
       '(if-exp (app-exp ((free-info =) (free-info x) (free-info y)))
		(free-info x) 
		(free-info y))
       (lexical-address '(if-exp 
			  (app-exp ((var-exp =) (var-exp x) (var-exp y))) 
			  (var-exp x) 
			  (var-exp y))))

(test* "(lambda-exp (x y) 
          (if-exp (app-exp ((var-exp =) (var-exp y) (lit-exp 0))) 
                  (var-exp x) 
                  (app-exp ((var-exp +) (var-exp x) (var-exp y)))))"
       '(lambda-exp (x y) (if-exp (app-exp ((free-info =) 
					    (lex-info y 0 1) 
					    (lit-exp 0)))
				  (lex-info x 0 0)
				  (app-exp ((free-info +) 
					    (lex-info x 0 0) 
					    (lex-info y 0 1)))))
       (lexical-address '(lambda-exp 
			  (x y) 
			  (if-exp (app-exp ((var-exp =) (var-exp y) (lit-exp 0))) 
				  (var-exp x) 
				  (app-exp ((var-exp +) (var-exp x) (var-exp y)))))))

(test* "(lambda-exp (x y z)
         (app-exp (lambda-exp (x y) (app-exp ((var-exp +) 
                                              (var-exp x) 
                                              (var-exp y) 
                                              (var-exp z))) 
                  (var-exp y) (var-exp x))))"
       '(lambda-exp (x y z)
	  (app-exp ((lambda-exp (x y) (app-exp ((free-info +)
						(lex-info x 0 0)
						(lex-info y 0 1)
						(lex-info z 1 2))))
		    (lex-info y 0 1) 
		    (lex-info x 0 0))))
       (lexical-address '(lambda-exp (x y z)
				     (app-exp ((lambda-exp 
						(x y) 
						(app-exp ((var-exp +) 
							  (var-exp x) 
							  (var-exp y) 
							  (var-exp z))))
					       (var-exp y) (var-exp x))))))

(test-end)

上記のソレ達は試験にパスしてます。次は unparse か。unparse な手続きに以下を追加。

	   (else
	    (cases variable-reference exp
		   (lex-info (id depth position) (val-exp id))
		   (free-info (id) (val-exp id))))

試験も追加。

(test* "unparse .."
       '(lambda-exp (x y z)
	  (app-exp ((lambda-exp (x y) (app-exp (val-exp +)
					       (val-exp x)
					       (val-exp y)
					       (val-exp z)))
		    (val-exp y)
		    (val-exp x))))
       (unparse-expression '(lambda-exp (x y z)
					(app-exp 
					 ((lambda-exp 
					   (x y) (app-exp ((free-info +)
							   (lex-info x 0 0)
							   (lex-info y 0 1)
							   (lex-info z 1 2))))
					  (lex-info y 0 1) 
					  (lex-info x 0 0))))))

でもこの実装では NG な模様。

test unparse ..: expects (lambda-exp (x y z) (app-exp ((lambda-exp (x y) (app-exp (val-exp +) (val-exp x) (val-exp y) (val-exp z))) (val-exp y) (val-exp x)))) => got #<error "cases \"~n  Not a ~a variant: ~s.\" expression (free-info +)">

うーん。isa を使うんか。しかも val-exp とかあるし。。
実装以下なカンジで。

(add-load-path ".")
(load "define-datatype")
(load "variable-reference")

(define unparse-expression
  (lambda (exp)
    (if ((isa expression) exp)
	(unparse-exp exp)
	(unparse-var exp))))

(define unparse-exp
  (lambda (exp)
    (cases expression exp
	   (lit-exp (num) num)
	   (var-exp (id) id)
	   (if-exp (test-exp true-exp false-exp)
		   (list 'if 
			 (unparse-expression test-exp) 
			 (unparse-expression true-exp) 
			 (unparse-expression false-exp)))
	   (lambda-exp (ids body)
		       (list 'lambda ids
			     (unparse-expression body)))
	   (app-exp (rands)
		    (let f ((rslt '()) (rands rands))
		      (if (null? rands)
			  rslt
			  (f (append rslt (list (unparse-expression (car rands)))) (cdr rands)))))
	   )))

(define unparse-var
  (lambda (exp)
    (cases variable-reference exp
	   (lex-info (id depth position) (var-exp id))
	   (free-info (id) (var-exp id)))))

以下な試験にパス。

(test* "unparse .."
       '(lambda (x y z)
	  ((lambda (x y) ((var-exp +)
			  (var-exp x)
			  (var-exp y)
			  (var-exp z)))
	   (var-exp y)
	   (var-exp x)))
       (unparse-expression '(lambda-exp (x y z)
					(app-exp 
					 ((lambda-exp 
					   (x y) (app-exp ((free-info +)
							   (lex-info x 0 0)
							   (lex-info y 0 1)
							   (lex-info z 1 2))))
					  (lex-info y 0 1) 
					  (lex-info x 0 0))))))

上記でサラしてる試験は色々な意味で大ダウトだったりしてます。(とほほ
ってか、よくみたら (var-exp +) ってダメじゃん。あー何してんの。試験はこれだな。

(test* "unparse .."
       '(lambda (x y z)
	  ((lambda (x y) (+ x y z)) y x))
       (unparse-expression '(lambda-exp (x y z)
					(app-exp 
					 ((lambda-exp 
					   (x y) (app-exp ((free-info +)
							   (lex-info x 0 0)
							   (lex-info y 0 1)
							   (lex-info z 1 2))))
					  (lex-info y 0 1) 
					  (lex-info x 0 0))))))

実装はこれ。

(define unparse-var
  (lambda (exp)
    (cases variable-reference exp
	   (lex-info (id depth position) id)
	   (free-info (id) id))))

最初こうしてたのに何故だ。とりあえず Exercise 2.7 はこれで終わり。