EOPL 第2章の Exercise 2.1 から 2.10 答案

EOPL 第2章はデータ抽象について。また、著者らが用意したマクロ（Scheme でヴァリアント型定義やそれに対するパターンマッチを可能にする）が導入されて AST を定義/操作したり、AST から情報を抽出したりする練習問題も出てくる。こうした練習が後の章への準備になるのかと思われる。

ところで本筋と離れたところでこの章の Exercise 2.5 が非常に苦労した問題だった。難易度は星2つなので特に難しい問題として用意されたわけではないと思うのだけど…

問題は

<bintree> ::= <number> | <symbol> <bintree> <bintree>

という定義の二分木が与えられたときに葉の合計がもっとも大きくなるような（葉ではない）ノードのシンボルを返す関数 max-interior を書けというもの。葉の数字は負の数でもよいのでルートが最も大きいとは限らない。

なお、Scheme + EOPL のマクロではこの2分木は

(define-datatype bintree bintree?
  (leaf-node
    (datum number?))
  (interior-node
    (key symbol?)
    (left bintree?)
    (right bintree?)))

と定義することが出来て、たとえば全ての葉ノードの合計は

(define leaf-sum
  (lambda (tree)
    (cases bintree tree
      (leaf-node (datum) datum)
      (interior-node (key left right)
        (+ (leaf-sum left) (leaf-sum right))))))

というようにパターンマッチを使って書ける。パターンのネストはできない（と思う）。

この問題をできれば「副作用なし」「効率」「コードがわかりやすい」を満たすように書きたかったのだけど、コードをあれこれいじり倒したあげく結局効率は捨てた回答にしました。

以下は練習問題2.1から2.10の私の答案です。2.5への回答は真ん中辺です。

; Exercise 2.1 from p.42
; bignum を実装する

; plus function from p.41
(define plus
  (lambda (x y)
    (if (iszero? x)
      y
      (succ (plus (pred x) y)))))

(define *base-n* 10)

(define zero '())

(define iszero? null?)

(define succ
  (lambda (n)
    (cond
      ((iszero? n) '(1))
      ((< (+ (car n) 1) *base-n*)
       (cons (+ (car n) 1) (cdr n)))
      (else
        (cons 0 (succ (cdr n)))))))

(define pred
  (lambda (n)
    (cond
      ((and
        (= (- (car n) 1) 0)
        (null? (cdr n)))
       '())
      ((>= (- (car n) 1) 0)
       (cons (- (car n) 1) (cdr n)))
      (else
        (cons (- *base-n* 1) (pred (cdr n)))))))

(define mult
  (lambda (x y)
    (if (iszero? x)
      '()
      (plus y (mult (pred x) y)))))

(define fact
  (lambda (x y)
    (if (iszero? y)
      (succ zero)
      (mult x (fact x (pred y))))))

; Exercise 2.3 from p.46
; 述語を与えられると「値がその述語を満たす配列かどうかを判断する関数」を返す関数
(define vector-of
  (lambda (pred)
    (lambda (val)
      (partial-vector-of pred val (vector-length val)))))

(define partial-vector-of
  (lambda (pred val n)
    (if (zero? n)
      #t
      (and
        (pred (vector-ref val (- n 1)))
        (partial-vector-of pred val (- n 1))))))

; Exercise 2.4 from p.47
; 2分木をリスト表現に変換する関数
(load "r5rs.scm")
(load "define-datatype.scm")
(load "2-2-1.scm")

(define bintree-to-list
  (lambda (tree)
    (cases bintree tree
           (leaf-node (datum) (list 'leaf-node datum))
           (interior-node (key left right)
                          (list 'interior-node
                                key
                                (bintree-to-list left)
                                (bintree-to-list right))))))

; Exercise 2.5 from p.47
(define max-interior
  (lambda (tree)
    (let ((flattened (flatten-tree tree)))
      (car (max-sum (car flattened) flattened)))))

(define flatten-tree
  (lambda (tree)
    (cases bintree tree
           (leaf-node (_) '())
           (interior-node (key left right)
                          (append
                            (list (list key (leaf-sum tree)))
                            (flatten-tree left)
                            (flatten-tree right))))))

(define max-sum
  (lambda (max lst)
    (cond
      ((null? lst) max)
      ((> (cadr max) (cadar lst))
       (max-sum max (cdr lst)))
      (else
        (max-sum (car lst) (cdr lst))))))

(define tree-a (interior-node 'a (leaf-node 2) (leaf-node 3)))
(define tree-b (interior-node 'b (leaf-node -1) tree-a))
(define tree-c (interior-node 'c tree-b (leaf-node 1)))
; (max-interior tree-b)
; (max-interior tree-c)

; Exercise 2.7 from p.52
; Scheme サブセット的な式のデータ型を定義し、parse/unparse 関数と lexical-address 関数を書く
(define-datatype expression expression?
  (lit-exp
    (datum number?))
  (var-exp
    (id symbol?))
  (lex-info
    (id symbol?)
    (depth number?)
    (position number?))
  (free-info
    (id symbol?))
  (if-exp
    (test-exp expression?)
    (true-exp expression?)
    (false-exp expression?))
  (lambda-exp
    (ids (list-of symbol?))
    (body expression?))
  (app-exp
    (rator expression?)
    (rands (list-of expression?))))

(define unparse-expression
  (lambda (exp)
    (cases expression exp
           (lit-exp (datum) datum)
           (var-exp (id) id)
           (lex-info (id depth position)
                     (list id ': depth position))
           (free-info (id) (list id ': 'free))
           (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 (rator rands)
                    (cons
                      (unparse-expression rator)
                      (map unparse-expression rands))))))

(define parse-expression
  (lambda (datum)
    (cond
      ((number? datum) (lit-exp datum))
      ((symbol? datum) (var-exp datum))
      ((pair? datum)
       (cond
         ((eqv? (car datum) 'if)
          (if-exp
            (parse-expression (cadr datum))
            (parse-expression (caddr datum))
            (parse-expression (cadddr datum))))
         ((eqv? (car datum) 'lambda)
          (lambda-exp
            (cadr datum)
            (parse-expression (caddr datum))))
         (else
           (app-exp
             (parse-expression (car datum))
             (map parse-expression (cdr datum)))))))))

(define lexical-address
  (lambda (exp)
    (la exp '())))

(define la
  (lambda (exp bs)
    (cases expression exp
           (lit-exp (datum) exp)
           (var-exp (id) (get-address id bs 0))
           (lex-info (id depth position) exp)
           (free-info (id) exp)
           (if-exp (test-exp true-exp false-exp)
                   (if-exp (la test-exp bs)
                           (la true-exp bs)
                           (la false-exp bs)))
           (lambda-exp (ids body)
                       (lambda-exp ids (la body (cons ids bs))))
           (app-exp (rator rands)
                    (app-exp
                      (la rator bs)
                      (map (lambda (x) (la x bs)) rands))))))

(define get-address
  (lambda (id bs d)
    (cond
      ((null? bs) (free-info id))
      ((memv id (car bs))
       (lex-info id d (get-pos id (car bs))))
      (else
        (get-address id (cdr bs) (+ d 1))))))

(define get-pos
  (lambda (s lst)
    (if (eqv? s (car lst))
      0
      (+ 1 (get-pos s (cdr lst))))))


; Exercise 2.8 from p.52
; ヴァリアント型を使って Exercise 1.19 の free-vars を再定義する
(load "2-2-2.scm") ; load the original expression datatype

(define free-vars
  (lambda (exp)
    (fv '() exp)))

(define fv
  (lambda (vars exp)
    (cases expression exp
           (var-exp (id)
                    (if (memv id vars) '() (list id)))
           (lambda-exp (id body)
                       (fv (uniqcons id vars) body))
           (app-exp (rator rand)
                    (uniqappend
                      (fv vars rator)
                      (fv vars rand))))))

(define uniqcons
  (lambda (hd tl)
    (if (memv hd tl) tl (cons hd tl))))

(define uniqappend
  (lambda (l1 l2)
    (if (null? l1)
      l2
      (uniqcons (car l1) (uniqappend (cdr l1) l2)))))

; Exercise 2.9 from p.52
; ラムダ式の parse-expression 関数を robust にする
(define parse-expression-robust
  (lambda (datum)
    (cond
      ((symbol? datum) (var-exp datum))
      ((pair? datum)
       (if (eqv? (car datum) 'lambda)
         (if (or
               (not (list? (cdr datum)))
               (not (= 3 (length datum)))
               (not (list? (cadr datum)))
               (not (= 1 (length (cadr datum)))))
           (eopl:error 'parse-expression-robust
                       "form (lambda (id) exp) required, but got ~s" datum)
           (lambda-exp (caadr datum)
                       (parse-expression-robust (caddr datum))))
         (if (or
               (not (list? (cdr datum)))
               (not (= 2 (length datum))))
           (eopl:error 'parse-expression-robust
                       "form (operator operand) required, but got ~s" datum)
           (app-exp
             (parse-expression-robust (car datum))
             (parse-expression-robust (cadr datum))))))
      (else (eopl:error 'parse-expression-robust
              "Invalid concrete syntax ~s" datum)))))

; Exercise 2.10 from p.53
; ラムダ式に含まれない新しいシンボルを作成する
(define fresh-id
  (lambda (exp s)
    (let ((syms (all-ids exp)))
      (letrec
        ((loop (lambda (n)
                 (let ((sym (string->symbol
                              (string-append s
                                             (number->string n)))))
                   (if (memv sym syms) (loop (+ n 1)) sym)))))
        (loop 0)))))

(define all-ids
  (lambda (exp)
    (cases expression exp
           (var-exp (id) (list id))
           (lambda-exp (id body)
                       (uniqcons id (all-ids body)))
           (app-exp (rator rand)
                    (uniqappend
                      (all-ids rator)
                      (all-ids rand))))))

; (fresh-id
;   (app-exp
;     (lambda-exp 'w2
;                 (app-exp (var-exp 'w1) (var-exp 'w0)))
;     (var-exp 'w3))
;   "w")
;=> w4

コメント 1

can you add procedural data representation for 2.24
by NO NAME (2007-09-21 09:06)