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

軽い環境でナニなのは良いのですが、emacs で skk 使えんのはイタ杉。とりあえず、'() を受け付けるようにして、parse を修正する方向で。
とりあえず expression が '() を取り扱う方向で修正盛り込み。

(define-datatype expression expression?
  (nul-exp
   (datum null?))
  (lit-exp
   (datum number?))
  (var-exp
   (id symbol?))
  (if-exp
   (test-exp expression?)
   (true-exp expression?)
   (false-exp expression?))
  (lambda-exp
   (ids (list-of symbol?))
   (body expression?))
  (app-exp
   (rands (list-of expression?))))

追加分含め、試験が以下。

(use gauche.test)

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

(test-start "expression")
(test-section "expression")
(test* "expression is ..."
       '((nul-exp lit-exp var-exp if-exp lambda-exp app-exp)
	 (nul-exp datum)
	 (lit-exp datum)
	 (var-exp id)
	 (if-exp test-exp true-exp false-exp)
	 (lambda-exp ids body)
	 (app-exp rands))
       expression)

(test-section "expression?")
(test* "(nul-exp) is expression"
       #t
       (expression? '(nul-exp)))

(test* "(lit-exp) is expression"
       #t
       (expression? '(lit-exp)))
(test* "(var-exp) is expression"
       #t
       (expression? '(var-exp)))
(test* "(if-exp) is expression"
       #t
       (expression? '(if-exp)))
(test* "(lambda-exp) is expression"
       #t
       (expression? '(lambda-exp)))
(test* "(app-exp) is expression"
       #t
       (expression? '(app-exp)))

(test-section "nul-exp")
(test* "(nul-exp ()) is (nul-exp ())"
       '(nul-exp ())
       (nul-exp '()))

(test-section "lit-exp")
(test* "(lit-exp 1) is (lit-exp 1)"
       '(lit-exp 1)
       (lit-exp 1))

(test-section "var-exp")
(test* "(var-exp 'x) is (var-exp x)"
       '(var-exp x)
       (var-exp 'x))

(test-section "if-exp")
(test* "(if-exp (var-exp x) (lit-exp 1) (lit-exp 2)) is ..."
       '(if-exp (var-exp x) (lit-exp 1) (lit-exp 2))
       (if-exp (var-exp 'x) (lit-exp 1) (lit-exp 2)))

(test-section "lambda-exp")
(test* "(lambda-exp (x) (lit-exp 1)) is ..."
       '(lambda-exp (x) (lit-exp 1))
       (lambda-exp '(x) (lit-exp 1)))

(test-section "app-exp")
(test* "(app-exp '((var-exp x) (lit-exp 1))) is ..."
       '(app-exp ((var-exp x) (lit-exp 1)))
       (app-exp '((var-exp x) (lit-exp 1))))

(test-end)

試験は無問題。次は parse 周辺をナニ。以下が実装。

(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
	   (nul-exp (datum) '())
	   (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) id)
	   (free-info (id) id))))

(define parse-expression
  (lambda (datum)
    (cond
     ((null? datum) (nul-exp datum))
     ((number? datum) (lit-exp datum))
     ((symbol? datum) (var-exp datum))
     ((pair? datum)
      (cond ((eqv? (car datum) 'lambda)
	     (lambda-exp (cadr datum)
			 (parse-expression (caddr datum))))
	    ((eqv? (car datum) 'if)
	     (if-exp (parse-expression (cadr datum))
		     (parse-expression (caddr datum))
		     (parse-expression (cadddr datum))))
	    (else
	     (let f ((rslt '()) (datum datum))
		(if (null? datum)
		    (cons 'app-exp (list rslt))
		    (f (append rslt (list (parse-expression (car datum))))
		       (cdr datum)))))))
     (else
      (eopl:error 'parse-expression
		  "Invalid concrete symtax ~s" datum)))))

以下が試験。一応パスしてますが、試験に不足がないかどうかは微妙。

(use gauche.test)

(add-load-path ".")
(load "define-datatype")
(load "expression")
(load "occurs-free")
(load "parse")

(test-start "parse")
(test-section "unparse-expression")
(test* "unparse 1"
       1
       (unparse-expression '(lit-exp 1)))

(test* "unparse 'a"
       'a
       (unparse-expression '(var-exp a)))

(test* "unparse (if x 1 2)"
       '(if x 1 2)
       (unparse-expression '(if-exp (var-exp x) (lit-exp 1) (lit-exp 2))))

(test* "unparse (lambda (x) x)"
       '(lambda (x) x)
       (unparse-expression '(lambda-exp (x) (var-exp x))))

(test* "unparse ((lambda (x) x) a)"
       '((lambda (x) x) a)
       (unparse-expression '(app-exp ((lambda-exp (x) (var-exp x)) (var-exp a)))))

(test* "unparse (lambda (x) (f x y))"
       '(lambda (x) (f x y))
       (unparse-expression '(lambda-exp (x) (app-exp ((var-exp f) (var-exp x) (var-exp y))))))

(test* "unparse (lambda (x) (x))"
       '(lambda (x) (x))
       (unparse-expression '(lambda-exp (x) (app-exp ((var-exp x))))))

(test* "unparse (lambda (x y z) x)"
       '(lambda (x y z) x)
       (unparse-expression '(lambda-exp (x y z) (var-exp x))))

(test* "unparse (lambda () x)"
       '(lambda () x)
       (unparse-expression '(lambda-exp () (var-exp x))))

(test* "unparse (if (null? l) x y)"
       '(if (null? l) x y)
       (unparse-expression '(if-exp (app-exp ((var-exp null?) (var-exp l)))
				    (var-exp x)
				    (var-exp y))))

(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))))))


(test-section "parse-expression")
(test* "parse '()"
       '(nul-exp ())
       (parse-expression '()))

(test* "parse 1"
       '(lit-exp 1)
       (parse-expression 1))

(test* "parse 'a"
       '(var-exp a)
       (parse-expression 'a))

(test* "parse (if x 1 2)"
       '(if-exp (var-exp x) (lit-exp 1) (lit-exp 2))
       (parse-expression '(if x 1 2)))

(test* "parse (lambda (x) x)"
       '(lambda-exp (x) (var-exp x))
       (parse-expression '(lambda (x) x)))

(test* "parse ((lambda (x) x) a)"
       '(app-exp ((lambda-exp (x) (var-exp x)) (var-exp a)))
       (parse-expression '((lambda (x) x) a)))

(test* "string is undefined"
       *test-error*
       (parse-expression "a"))

(test* "parse (a b c)"
       '(app-exp ((var-exp a) (var-exp b) (var-exp c)))
       (parse-expression '(a b c)))

(test* "parse ((lambda (x) (+ x x)) a)"
       '(app-exp ((lambda-exp (x) (app-exp ((var-exp +) (var-exp x) (var-exp x)))) (var-exp a)))
       (parse-expression '((lambda (x) (+ x x)) a)))

(test* "parse (lambda (x) (x))"
       '(lambda-exp (x) (app-exp ((var-exp x))))
       (parse-expression '(lambda (x) (x))))

(test* "parse (if (null? l) x y)"
       '(if-exp (app-exp ((var-exp null?) (var-exp l))) (var-exp x) (var-exp y))
       (parse-expression '(if (null? l) x y)))

(test-end)

パスしてます。これで

test (free-vars '(lambda (x) ()) should return (), expects ()

な試験にパス。残りは

test (free-vars '(lambda (x y) (x 1 2) ((y) 3 z)) should return (z): expects (z) => got ()

なんですが、これはダサいんですが、以下でナニ。

(define parse-expression
  (lambda (datum)
    (cond
     ((null? datum) (nul-exp datum))
     ((number? datum) (lit-exp datum))
     ((symbol? datum) (var-exp datum))
     ((pair? datum)
      (cond ((eqv? (car datum) 'lambda)
	     (lambda-exp (cadr datum)
			 (if (= 1 (length (cddr datum)))
			     (parse-expression (caddr datum))
			     (parse-expression (cddr datum)))))
	    ((eqv? (car datum) 'if)
	     (if-exp (parse-expression (cadr datum))
		     (parse-expression (caddr datum))
		     (parse-expression (cadddr datum))))
	    (else
	     (let f ((rslt '()) (datum datum))
		(if (null? datum)
		    (cons 'app-exp (list rslt))
		    (f (append rslt (list (parse-expression (car datum))))
		       (cdr datum)))))))
     (else
      (eopl:error 'parse-expression
		  "Invalid concrete symtax ~s" datum)))))

追加した試験のみ以下に。

(test* "parse (lambda (x) (x y) (z a))"
       '(lambda-exp (x) (app-exp ((app-exp ((var-exp x) (var-exp y)))
				  (app-exp ((var-exp z) (var-exp a))))))
       (parse-expression '(lambda (x) (x y) (z a))))

これで free-vars な試験は全部パス。次は bound-vars か、と言いつつ実装着手。作ってみてびっくり。実装は以下なんですが

(add-load-path ".")
(load "define-datatype")
(load "expression")
(load "parse")

(define (bound-vars l)
  (bound-vars-test (parse-expression l)))

(define (bound-vars-test l)
  (let f ((rslt '()) (arg '()) (l l))
    (cases expression l
	   (nul-exp (datum) rslt)
	   (lit-exp (num) rslt)
	   (var-exp (id)
		    (let free-symbol ((l arg) (s id))
		      (cond ((null? l) rslt)
			    ((eq? (car l) s)
			     (append rslt (list s)))
			    (else
			     (free-symbol (cdr l) s)))))
	   (lambda-exp (ids body)
		       (f rslt (append arg ids) body))
	   (app-exp (rands)
		    (let app-exp-inner ((rslt rslt) (rands rands))
		      (if (null? rands)
			  rslt
			  (app-exp-inner (f rslt arg (car rands))
					 (cdr rands)))))
	   (else
	    rslt)
	   ))
	    
  )

free-vars との差分が以下。って diff とったら出力微妙だな。。ちがうのは var-exp の分岐の中身だけです (勿論、手続きの名前とかは異なりますが)

	   (var-exp (id)
		    (let free-symbol ((l arg) (s id))
		      (cond ((null? l) rslt)
			    ((eq? (car l) s)
			     (append rslt (list s)))
			    (else
			     (free-symbol (cdr l) s)))))

ええと、ここだけ違うんだったら lambda なソレを渡せばなんとかなりますな。余裕があったら追記しますし、微妙だったら明日の現実トウヒなネタになります (を