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

Exercise 2.8

ええと、 Exercise 1.19 の解は何処、と言いつつ検索してみたんですが、どうも EoPL シリーズって最終的に解はこうなりました、な手続き引用をしていない。探してみるに free-vars は以下な模様?

(define (free-vars l)
  (let f ((rslt '()) (arg (cadr l)) (body (cddr l)))
    (define (free-symbol l s)
      (cond ((null? l) '())
	    ((eq? (car l) s) s)
	    (else
	     (free-symbol (cdr l) s)))
      )
    (if (null? body)
	rslt
	(if (pair? (car body))
	    (f (let ((l (car body)))
		 (if (eq? 'lambda (car l))
		     (f rslt (append arg (cadr l)) (cddr l))
		     (f rslt arg l)))
		 arg (cdr body))
	    (let ((ret (free-symbol arg (car body))))
	      (f (if (and (null? ret) (symbol? (car body)))
		     (append rslt (list (car body)))
		     rslt)
		 arg (cdr body)))))
    )
  )

よく分からんな、と言いつつ試験があることを思いだす。以下が試験なのかな?

(use gauche.test)

(add-load-path ".")
(load "free-vars")

(test-start "free-vars")
(test-section "free-vars")
(test* "(free-vars '(lambda (x) y)) should return (y)"
       '(y)
       (free-vars '(lambda (x) y)))
(test* "(free-vars '(lambda (x) (y))) should return (y)"
       '(y)
       (free-vars '(lambda (x) (y))))
(test* "(free-vars '(lambda (x y) (x 1 2) ((y) 3 z)) should return (z)"
       '(z)
       (free-vars '(lambda (x y) (x 1 2) ((y) 3 z))))
(test* "(free-vars '(lambda (x) (x))) should return ()"
       '()
       (free-vars '(lambda (x) (x))))
(test* "(free-vars '(lambda (x) (x 1 2 3))) should return ()"
       '()
       (free-vars '(lambda (x) (x 1 2 3))))
(test* "(free-vars '(lambda (x) ()) should return ()"
       '()
       (free-vars '(lambda (x) ())))
(test* "(free-vars '(lambda () (x)) should return (x)"
       '(x)
       (free-vars '(lambda () (x))))
(test* "(free-vars '(lambda () ((x) (y))) should return (x y)"
       '(x y)
       (free-vars '(lambda () ((x) (y)))))
(test* "(free-vars '(lambda (y) ((lambda (x) x) y)) should return ()"
       '()
       (free-vars '(lambda (y) ((lambda (x) x) y))))
(test* "(free-vars '(lambda (y) ((lambda (x) (+ z x)) y)) should return (+ z)"
       '(+ z)
       (free-vars '(lambda (y) ((lambda (x) (+ z x)) y))))
(test* "(free-vars '(lambda (x) ((lambda (y) (+ y x)) 3)) should return (+)"
       '(+)
       (free-vars '(lambda (x) ((lambda (y) (+ y x)) 3))))
(test-end)

なるほど。あるいは bound-vars は? って略して書いてやがる。こーゆーエントリで冗長なので略、はダウトですな。いかんいかん。

(define (bound-vars l)
  (let ((arg (cadr l)))
    (define (free-symbol s)
      (let f ((l arg))
	(cond ((null? l) '())
	      ((eq? (car l) s)  s)
	      (else
	       (f (cdr l))))
	)
      )
    (let f ((rslt '()) (l (cddr l)))
      (if (null? l)
	  rslt
	  (if (pair? (car l))
	      (f (f rslt (car l)) (cdr l))
	      (let ((ret (free-symbol arg (car body))))
	        (f (if (null? ret)
		       rslt
		       (append rslt (list (car body))))
  		   arg (cdr body)))))
      )
    )
  )

こうなのかな?
bound-vars の試験は以下なのか。

(use gauche.test)

(add-load-path ".")
(load "bound-vars")

(test-start "bound-vars")
(test-section "bound-vars")
(test* "(bound-vars '(lambda (x) y)) should return ()"
       '()
       (bound-vars '(lambda (x) y)))
(test* "(bound-vars '(lambda (x) (y))) should return ()"
       '()
       (bound-vars '(lambda (x) (y))))
(test* "(bound-vars '(lambda (x y) (x 1 2) ((y) 3 z)) should return (x y)"
       '(x y)
       (bound-vars '(lambda (x y) (x 1 2) ((y) 3 z))))
(test* "(bound-vars '(lambda (x) (x))) should return (x)"
       '(x)
       (bound-vars '(lambda (x) (x))))
(test* "(bound-vars '(lambda (x) (x 1 2 3))) should return (x)"
       '(x)
       (bound-vars '(lambda (x) (x 1 2 3))))
(test* "(bound-vars '(lambda (x) ()) should return ()"
       '()
       (bound-vars '(lambda (x) ())))
(test* "(bound-vars '(lambda () (x)) should return ()"
       '()
       (bound-vars '(lambda () (x))))
(test* "(bound-vars '(lambda () ((x) (y))) should return ()"
       '()
       (bound-vars '(lambda () ((x) (y)))))
(test-end)

ちょっとこれで試験をしてみます。

bound-vars

微妙。bound-vars は以下な実装にて上記の試験にパスな模様。

(define (bound-vars l)
  (let f ((rslt '()) (arg (cadr l)) (body (cddr l)))
    (define (free-symbol l s)
      (cond ((null? l) '())
	    ((eq? (car l) s) s)
	    (else
	     (free-symbol (cdr l) s)))
      )
    (if (null? body)
	rslt
	(if (pair? (car body))
	    (f (let ((l (car body)))
		 (if (eq? 'lambda (car l))
		     (f rslt (append arg (cadr l)) (cddr l))
		     (f rslt arg l)))
		 arg (cdr body))
	    (let ((ret (free-symbol arg (car body))))
	      (f (if (null? ret)
		     rslt
		     (append rslt (list (car body))))
		 arg (cdr body)))))
    )
  )

で、これを abstract syntax 使うってどうしたものやら。あ、違うな面白そうなんで明日の現実トウヒ用に取っとく方向。(こら
おそらくは cases 使ったら凄く可読性が上がると思います。今日は体調微妙なんでこれで終了。