EoPL reading (111) 2.3 Representation Strategies for Data Types

Exercise 2.20

用件済んだので次の問題に着手。2.17 ではメッセージパッシングで云々してます。これがいっちゃん楽、っていう固定概念をステないと駄目な気がしますが、とりあえず実装してみます。
てか、先に試験を書く。

(use gauche.test)

(add-load-path ".")
(load "Fig2.3")

(test-start "has-association?")
(test* "(has-association? 'a (empty-env))"
       #f
       (has-association? (empty-env)))
(test* "(has-association? 'a (((a b) (1 2))))"
       #t
       (has-association? 'a (extended-env-record
			     '(a b)
			     '(1 2)
			     (empty-env))))
(test* "(has-association? 'z (((a b) (1 2))))"
       #f
       (has-association? 'z (extended-env-record
			     '(a b)
			     '(1 2)
			     (empty-env))))

(test-end)

で、実装が以下。

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

(define scheme-value? (lambda (v) #t))

(define list-of
  (lambda (pred)
    (lambda (val)
      (or (null? val)
          (and (pair? val)
               (pred (car val))
               ((list-of pred) (cdr val)))))))

(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record
   (syms (list-of symbol?))
   (vals (list-of scheme-value?))
   (env environment?)))

(define empty-env
  (lambda ()
    (empty-env-record)))

(define extend-env
  (lambda (syms vals env)
    (extended-env-record syms vals env)))

(define apply-env-inner
  (lambda (cmd env sym)
    (cases environment env
	   (empty-env-record 
	    ()
	    (if (eqv? cmd 'pred)
		#f
		(eopl:error 'apply-env
			    "No binding for" sym)))
	   (extended-env-record 
	    (syms vals env)
	    (let ((pos (list-find-position sym syms)))
	      (if (number? pos)
		  (list-ref vals pos)
		  (apply-env-inner cmd env sym)))))))

(define apply-env
  (lambda (env sym)
    (apply-env-inner 'apply env sym)))
(define has-association?
  (lambda (env sym)
    (apply-env-inner 'pred env sym)))

(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

(define list-index
  (lambda (pred ls)
    (cond ((null? ls) #f)
          ((pred (car ls)) 0)
          (else
           (let ((list-index-r (list-index pred (cdr ls))))
             (if (number? list-index-r)
                 (+ list-index-r 1)
                 #f))))))

ええと、has-association? の試験は以下でした。#t は戻ってこないんだよな、と。

(use gauche.test)

(add-load-path ".")
(load "Fig2.3")

(test-start "has-association?")
(test* "(has-association? (empty-env) 'a)"
       #f
       (has-association? (empty-env) 'a))
(test* "(has-association? (((a b) (1 2))) 'a)"
       #f
       (not (has-association? (extended-env-record
			       '(a b)
			       '(1 2)
			       (empty-env)) 'a)))
(test* "(has-association? (((a b) (1 2)) 'z))"
       #f
       (has-association? (extended-env-record
			  '(a b)
			  '(1 2)
			  (empty-env)) 'z ))

(test-end)

なんか微妙だなぁ。とりあえず 2.3.4 に進みます。