EoPL reading (38) 1.3.1 Free and Bound Variables

Exercise.1-31

今日、海に遊びに行く道すがら、データ構造が微妙なんだろな、と思ってる中、単純に

((c) (a b c))

みたいなリスト持ってりゃ良いんじゃね? という事に気づく。lambda 式が出てきたらリスト更新で、symbol だったら上記の辞書みたいなのを探索すりゃ良い。とりあえず順に試験を書きつつ作ってみる事にします。
最初に書いた試験は以下。

(use gauche.test)

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

(test-start "lexical-address")
(test-section "lexical-address")
(test* "(lexical-address '()) should return '()"
       '()
       (lexical-address '()))

(test-end)

実装は以下なカンジ。

(define (lexical-address exp)
  (define (lexical-address-inner rslt dict l)
    (cond ((null? l) rslt)
	  )
    )
  (lexical-address-inner '() '() exp)
  )

ここから順次追記していきます。次は simbol だった時に処理か。これは例示されているナニを見るにリストを戻せば良い模様。若干 quasiquote でアレでしたが以下の試験にはパスしています。

(test* "(lexical-address 'a) should return '(a free)"
       '(a free)
       (lexical-address 'a))

実装はこんなカンジになっています。

(define (lexical-address exp)
  (define (lexical-address-inner rslt dict l)
    (cond ((null? l) rslt)
	  ((symbol? l)
	   (let f ((d 0) (p 0) (dict dict))
	     (cond ((null? dict) `(,l free))
		   ((memq? l (car dict))
		    (let f-inner ((p p) (dict (car dict)))
		      (if (eq? l (car dict))
			  `(,l : ,d ,p)
			  (f-inner (+ p 1) (cdr dict)))
		      ))
		   (else
		    (f (+ d 1) 0 (cdr dict))))
	     )
	   )
	  )
    )
  (lexical-address-inner '() '() exp)
  )

まだ試験は足りてませんが、現時点では試験不能。次は lambda の実装。どうやら辞書は cons で繋げていけば良い模様。
なんか先に手続きができちゃったみたいなので一応以下に。

	  ((eqv? l 'lambda)
	   (lexical-address-inner rslt (cons (cadr l) dict) (cddr l)))

これが正しのかどうかは不明。(を
試験を考えてみましょう。ちょっと symbol の処理 (というか値の戻し方) が微妙な気がしたんですが、気のせいという事にするかどうするか。
で、手を入れてみたのが以下です。まだ不安あり。

(define (lexical-address exp)
  (define (lexical-address-inner rslt dict l)
    (cond ((null? l) rslt)
	  ((symbol? l)
	   (let f ((d 0) (p 0) (dict dict))
	     (cond ((null? dict) (append rslt (list `(,l free))))
		   ((memq l (car dict))
		    (let f-inner ((p p) (dict (car dict)))
		      (if (eq? l (car dict))
			  (append rslt (list `(,l : ,d ,p)))
			  (f-inner (+ p 1) (cdr dict)))
		      ))
		   (else
		    (f (+ d 1) 0 (cdr dict))))))
	  ((eqv? (car l) 'lambda)
	   (lexical-address-inner (append rslt `(lambda ,(cadr l)))
				  (cons (cadr l) dict) (cddr l)))
	  (else
	   (lexical-address-inner
	    (lexical-address-inner rslt dict (car l))
	    dict
	    (cdr l))
	   )
	  )
    )
  (lexical-address-inner '() '() exp)
  )

試験は以下の三点。

(use gauche.test)

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

(test-start "lexical-address")
(test-section "lexical-address")
(test* "(lexical-address '()) should return '()"
       '()
       (lexical-address '()))

(test* "(lexical-address 'a) should return '((a free))"
       '((a free))
       (lexical-address 'a))

(test* "(lexical-address '(lambda (a b c) a)) should return '(lambda (a b c) (a : 0 0))"
       '(lambda (a b c) (a : 0 0))
       (lexical-address '(lambda (a b c) a)))
(test-end)

一応全部パスしてますが、いくつか追加で試験してみます。
まず以下を追加。

(test* "(lexical-address '(lambda (a b c) (a b c))) should return '(lambda (a b c) ((a : 0 0) (b : 0 1) (c : 0 2)))"
       '(lambda (a b c) ((a : 0 0) (b : 0 1) (c : 0 2)))
       (lexical-address '(lambda (a b c) (a b c))))

予想してましたが試験に通らず。

got (lambda (a b c) (a : 0 0) (b : 0 1) (c : 0 2))

との事。そうなんですよねぇ。この問題で ({}*) なブロックの処理対象になってるのは

• lambda body
• if の条件式
• if の then block
• if の else block

限定なのか。てーコトは else なナニの処理の仕方を変えてあげれば OK なのかなぁ。そーゆー意味では symbol? な部分では単発で戻してあげるようにして OK か。
と言いつつ実装を以下にしたら試験にパスしなくなってしまいました。

(define (lexical-address exp)
  (define (lexical-address-inner rslt dict l)
    (cond ((null? l) rslt)
	  ((symbol? l)
	   (let f ((d 0) (p 0) (dict dict))
	     (cond ((null? dict) (list `(,l free)))
		   ((memq l (car dict))
		    (let f-inner ((p p) (dict (car dict)))
		      (if (eq? l (car dict))
			  (list `(,l : ,d ,p))
			  (f-inner (+ p 1) (cdr dict)))
		      ))
		   (else
		    (f (+ d 1) 0 (cdr dict))))))
	  ((eqv? (car l) 'lambda)
	   (lexical-address-inner (append rslt `(lambda ,(cadr l)))
				  (cons (cadr l) dict) (cddr l)))
	  (else
	   (let g ((rslt rslt) (l l))
	     (cond ((null? l) rslt)
		   (else
		    (append rslt (list (lexical-address-inner '() dict (car l))))
		    (g rslt (cdr l)))))
	   )
	  )
    )
  (lexical-address-inner '() '() exp)
  )

else の部分が微妙なのは分かってるんですが ...
ちなみに試験な出力が以下です。

$ make
Testing lexical-address ...                                      failed.
discrepancies found.  Errors are:
test (lexical-address '(a)) should return '((a free)): expects ((a free)) => got ()
test (lexical-address '(a b)) should return '((a free) (b free)): expects ((a free) (b free)) => got ()
test (lexical-address '(lambda (a b c) a)) should return '(lambda (a b c) (a : 0 0)): expects (lambda (a b c) (a : 0 0)) => got (lambda (a b c))
test (lexical-address '(lambda (a b c) (a b c))) should return '(lambda (a b c) ((a : 0 0) (b : 0 1) (c : 0 2))): expects (lambda (a b c) ((a : 0 0) (b : 0 1) (c : 0 2))) => got (lambda (a b c))
$

で、else 部分を以下に修正してみたら

	  (else
	   (lexical-address-inner
	    (lexical-address-inner rslt dict (car l))
	    dict
	    (cdr l))
	   )

今度はこんなカンジに。

$ make
Testing lexical-address ...                                      failed.
discrepancies found.  Errors are:
test (lexical-address '(a b)) should return '((a free) (b free)): expects ((a free) (b free)) => got ((b free))
test (lexical-address '(lambda (a b c) a)) should return '(lambda (a b c) (a : 0 0)): expects (lambda (a b c) (a : 0 0)) => got ((a : 0 0))
test (lexical-address '(lambda (a b c) (a b c))) should return '(lambda (a b c) ((a : 0 0) (b : 0 1) (c : 0 2))): expects (lambda (a b c) ((a : 0 0) (b : 0 1) (c : 0 2))) => got ((c : 0 2))

あ、これは symbol なナニが rslt を引き継いでいないからか。

とほほ

と言いつつ手続き定義をニラんでいたら大変な事に気がついた。ような気がしたんですが違うのかなぁ。このあたりがカギでしょうか。

test (lexical-address '(a)) should return '((a free)), expects ((a free)) ==> ok
test (lexical-address '(a b)) should return '((a free) (b free)), expects ((a free) (b free)) ==> ERROR: GOT ((b free))

で、色々いぢくった挙句に試験にパスした。経過を記録してません (とほほ
実装が以下。

(define (lexical-address exp)
  (define (lexical-address-inner rslt dict l)
    (cond ((null? l) rslt)
	  ((symbol? l)
	   (let f ((d 0) (p 0) (dict dict))
	     (cond ((null? dict) `(,l free))
		   ((memq l (car dict))
		    (let f-inner ((p p) (dict (car dict)))
		      (if (eq? l (car dict))
			  `(,l : ,d ,p)
			  (f-inner (+ p 1) (cdr dict)))
		      ))
		   (else
		    (f (+ d 1) 0 (cdr dict))))))
	  ((eqv? (car l) 'lambda)
	   (lexical-address-inner (append rslt `(lambda ,(cadr l)))
				  (cons (cadr l) dict) (cddr l)))
	  (else
	   (let g ((rslt rslt) (l l))
	     (cond ((null? l) rslt)
		   (else
		    (g (append rslt (list (lexical-address-inner '() dict (car l))))
		       (cdr l)))))
	   )
	  )
    )
  (lexical-address-inner '() '() exp)
  )

このエントリ、動作したバージョンと動作しないバージョンが書いてあるはずなので、別途差分を確認してみたいと考えています。引き続き if を盛り込んでみます。
全体を以下に。まずは実装。

(define (lexical-address exp)
  (define (lexical-address-inner rslt dict l)
    (cond ((null? l) rslt)
	  ((symbol? l)
	   (let f ((d 0) (p 0) (dict dict))
	     (cond ((null? dict) `(,l free))
		   ((memq l (car dict))
		    (let f-inner ((p p) (dict (car dict)))
		      (if (eq? l (car dict))
			  `(,l : ,d ,p)
			  (f-inner (+ p 1) (cdr dict)))
		      ))
		   (else
		    (f (+ d 1) 0 (cdr dict))))))
	  ((eqv? (car l) 'lambda)
	   (lexical-address-inner (append rslt `(lambda ,(cadr l)))
				  (cons (cadr l) dict) (cddr l)))
	  ((eqv? (car l) 'if)
	   (lexical-address-inner (append rslt '(if)) dict (cdr l)))
	  (else
	   (let g ((rslt rslt) (l l))
	     (cond ((null? l) rslt)
		   (else
		    (g (append rslt (list (lexical-address-inner '() dict (car l))))
		       (cdr l)))))
	   )
	  )
    )
  (lexical-address-inner '() '() exp)
  )

試験が以下。

(use gauche.test)

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

(test-start "lexical-address")
(test-section "lexical-address")
(test* "(lexical-address '()) should return '()"
       '()
       (lexical-address '()))

(test* "(lexical-address 'a) should return '(a free)"
       '(a free)
       (lexical-address 'a))

(test* "(lexical-address '(a)) should return '((a free))"
       '((a free))
       (lexical-address '(a)))

(test* "(lexical-address '(a b)) should return '((a free) (b free))"
       '((a free) (b free))
       (lexical-address '(a b)))

(test* "(lexical-address '(lambda (a b c) a)) should return '(lambda (a b c) (a : 0 0))"
       '(lambda (a b c) (a : 0 0))
       (lexical-address '(lambda (a b c) a)))

(test* "(lexical-address '(lambda (a b c) (a b c))) should return '(lambda (a b c) ((a : 0 0) (b : 0 1) (c : 0 2)))"
       '(lambda (a b c) ((a : 0 0) (b : 0 1) (c : 0 2)))
       (lexical-address '(lambda (a b c) (a b c))))

(test* "(lexical-address '(lambda (a b c)
                            (if (eqv? b c)
                              ((lambda (c)
                                 (cons a c))
                               a)
                              b)))
         should return
         (lambda (a b c)
           (if ((eqv? free) (b : 0 1) (c : 0 2))
             ((lambda (c)
                ((cons free) (a : 1 0) (c : 0 0)))
              (a : 0 0))
             (b : 0 1)))"
       '(lambda (a b c)
	  (if ((eqv? free) (b : 0 1) (c : 0 2))
	      ((lambda (c)
		 ((cons free) (a : 1 0) (c : 0 0)))
	       (a : 0 0))
	      (b : 0 1)))
       (lexical-address '(lambda (a b c)
			   (if (eqv? b c)
			       ((lambda (c)
				  (cons a c))
				a)
			       b))))

(test-end)

もう少しアタマを冷やして再度確認してみます。
投入時間は夜ですが、海水浴から戻った昼過ぎからハマり続けてたりして。