EOPL 第1章の Exercise 答案

Essentials of Programming Languages [1] の練習問題をかなり地道に一つ一つやっていた（なんか修行してるみたいな気分）。

そして第1章の練習問題のうちプログラムを書かせる問題は全部できたので（EOPL の Exercise を普通に Scheme でやって公開している人とかは世界中にたくさんいそうなので特に新奇性というか見る価値はないと思いますが）、一応この記事の最後に付けます。おそらく errorf 関数を使っている部分のみ Gauche 依存です。

しかし私が cond と let の開き括弧の数に確信を持てる日はくるのだろうか。

[1] http://www.cs.indiana.edu/eopl/

; Exercise 1.5 from p.14
; 数値のリストかどうかを判定する関数を、リスト以外が与えられた場合に対応する
(define list-of-numbers?-robust
  (lambda (lst)
    (cond
      ((not (list? lst)) #f)
      ((null? lst) #t)
      (else
        (and
          (number? (car lst))
          (list-of-numbers?-robust (cdr lst)))))))

; Exercise 1.6 from p.16
; n 番目の要素を返す関数を、リスト以外が与えられた場合に対応する
(define nth-elt-robust
  (lambda (lst n)
    (cond
      ((not (list? lst)) (errorf "~s is not a list" lst))
      ((null? lst)
        (errorf "List too short by ~s elements.~%" (+ n 1)))
      ((zero? n) (car lst))
      (else (nth-elt-robust (cdr lst) (- n 1))))))

; リスト長を返す関数を、リスト以外が与えられた場合に対応する
(define list-length-robust
  (lambda (lst)
    (cond
      ((not (list? lst)) (errorf "~s is not a list" lst))
      ((null? lst) 0)
      (else (+ 1 (list-length-robust (cdr lst)))))))

; Exercise 1.7 from p.16
; n 番目の要素を返す関数のエラーメッセージを親切にする
(define nth-elt-informative
  (lambda (l m)
    (letrec
      ((nth-elt-helper (lambda (lst n)
        (if (null? lst)
          (errorf "~s does not have an element ~s.~%" l m)
          (if (zero? n)
            (car lst)
            (nth-elt-helper (cdr lst) (- n 1)))))))
      (nth-elt-helper l m))))

;Exercise 1.11 from p.21
; 要素を置き換える subst 関数で slist の文法定義の production 毎に関数を書いていたのをインライン化する
(define subst-inlined
  (lambda (new old slist)
    (if (null? slist)
      '()
      (cons
        (if (symbol? (car slist))
          (if (eqv? (car slist) old) new (car slist))
          (subst-inlined new old (car slist)))
        (subst-inlined new old (cdr slist))))))

;Exercise 1.12 from p.21
; Kleene star を使った文法定義に基づいて subst 関数を書き換える
(define subst-map
  (lambda (new old slist)
    (map (lambda (se)
           (if (symbol? se)
             (if (eqv? se old) new se)
             (subst-map new old se)))
         slist)))

; Exercise 1.13 from p.22
; Kleene star を使った文法定義に基づいて notate-depth 関数を書き換える
(define notate-depth-map
  (lambda (slist)
    (notate-depth-in-s-list-map slist 0)))

(define notate-depth-in-s-list-map
  (lambda (slist d)
    (map
      (lambda (se)
        (if (symbol? se)
          (list se d)
          (notate-depth-in-s-list-map se (+ d 1))))
      slist)))

; Exercise 1.15 from p.24,25
; 要素を指定回数繰り返したリストを返す関数
(define duple
  (lambda (n x)
    (if (zero? n)
      '()
      (cons x (duple (- n 1) x)))))

; 2要素リストのリスト '((a b) (c d)) などについて各2要素を逆にする
(define invert
  (lambda (lst)
    (if (null? lst)
      '()
      (cons (list (cadar lst) (caar lst)) (invert (cdr lst))))))

; 与えられた述語でリストをフィルタリングする
(define filter-in
  (lambda (pred lst)
    (if (null? lst)
      '()
      (if (pred (car lst))
        (cons (car lst) (filter-in pred (cdr lst)))
        (filter-in pred (cdr lst))))))

; すべての要素が与えられた述語を満たすか
(define every?
  (lambda (pred lst)
    (if (null? lst)
      #t
      (and
        (pred (car lst))
        (every? pred (cdr lst))))))

; 与えられた述語を満たす要素が存在するか
(define exists?
  (lambda (pred lst)
    (if (null? lst)
      #f
      (or
        (pred (car lst))
        (exists? pred (cdr lst))))))

; 与えられた述語を満たす配列内の要素の位置
(define vector-index
  (lambda (pred v)
    (letrec ((vi (lambda (i)
                   (if (pred (vector-ref v i))
                     i
                     (vi (+ i 1))))))
      (vi 0))))

; リストの n 番目を x にしたリストを返す
(define list-set
  (lambda (lst n x)
    (if (null? lst)
      '()
      (if (zero? n)
        (cons x (cdr lst))
        (cons (car lst) (list-set (cdr lst) (- n 1) x))))))

; 2つリストを与えられたときにそのデカルト積を返す
(define product
  (lambda (los1 los2)
    (if (null? los1)
      '()
      (letrec
        ((h (lambda (los2)
              (if (null? los2)
                '()
                (cons (list (car los1) (car los2)) (h (cdr los2)))))))
        (append (h los2) (product (cdr los1) los2))))))

; リストの各要素を括弧で囲む（レベルを1下げる）
(define down
  (lambda (lst)
    (if (null? lst)
      '()
      (cons (list (car lst)) (down (cdr lst))))))

; 配列とリストが与えられたときに2つを連結した配列を返す
(define vector-append-list
  (lambda (v lst)
    (letrec ((vl (vector-length v))
             (ll (length lst))
             (v2 (make-vector (+ vl ll)))
             (blit (lambda (k)
                     (cond ((< k vl)
                            (vector-set! v2 k (vector-ref v k))
                            (blit (+ k 1))))))
             (conc (lambda (lst k)
                     (cond ((not (null? lst))
                            (vector-set! v2 k (car lst))
                            (conc (cdr lst) (+ k 1)))))))
      (blit 0)
      (conc lst vl)
      v2)))

; Exercise 1.16 from p.26
; リストの各トップレベル要素の括弧を取り除く（レベルを1あげる）
(define up
  (lambda (lst)
    (cond ((null? lst) ())
          ((list? (car lst)) (append (car lst) (up (cdr lst))))
          (else (cons (car lst) (up (cdr lst)))))))

; slist 中の s1 と s2 を交換する
(define swapper
  (lambda (s1 s2 slist)
    (if (null? slist)
      '()
      (cons
        (swapper-in-symbol-expression s1 s2 (car slist))
        (swapper s1 s2 (cdr slist))))))

(define swapper-in-symbol-expression
  (lambda (s1 s2 se)
    (if (symbol? se)
      (cond ((eqv? se s1) s2)
            ((eqv? se s2) s1)
            (else se))
      (swapper s1 s2 se))))

; slist 中の s が現れる回数を返す
(define count-occurrences
  (lambda (s slist)
    (if (null? slist)
      0
      (+
        (count-occurrences-in-symbol-expression s (car slist))
        (count-occurrences s (cdr slist))))))

(define count-occurrences-in-symbol-expression
  (lambda (s se)
    (if (symbol? se)
      (if (eqv? se s) 1 0)
      (count-occurrences s se))))

; slist の全括弧を取り払う
(define flatten
  (lambda (slist)
    (cond
      ((null? slist) ())
      ((symbol? (car slist)) (cons (car slist) (flatten (cdr slist))))
      (else (append (flatten (car slist)) (flatten (cdr slist)))))))

; 整列された2リストをマージする
(define merge
  (lambda (lon1 lon2)
    (cond
      ((null? lon1) lon2)
      ((null? lon2) lon1)
      ((< (car lon1) (car lon2)) (cons (car lon1) (merge (cdr lon1) lon2)))
      (else (cons (car lon2) (merge lon1 (cdr lon2)))))))

; Exercise 1.17 from p.27
; 2分木内の指定要素に辿り着くまでの道順を返す
(define path
  (lambda (n bst)
    (cond
      ((null? bst) '(fail))
      ((= n (car bst)) '())
      ((< n (car bst)) (cons 'left (path n (cadr bst))))
      (else (cons 'right (path n (caddr bst)))))))

; ソート
(define sort
  (lambda (lon)
    (cond
      ((<= (length lon) 1) lon)
      (else
        (append
          (sort (filter-in (lambda (x) (< x (car lon))) lon))
          (filter-in (lambda (x) (= x (car lon))) lon)
          (sort (filter-in (lambda (x) (> x (car lon))) lon)))))))

; 与えられた述語によるソート
(define sort-by
  (lambda (pred lon)
    (if (null? lon)
      '()
      (insert-by pred (car lon) (sort-by pred (cdr lon))))))

(define insert-by
  (lambda (pred n lon)
    (cond
      ((null? lon) (list n))
      ((pred n (car lon))
       (cons n lon))
      (else
        (cons (car lon) (insert-by pred n (cdr lon)))))))

; Exercise 1.18 from p.27
; 関数合成
(define compose
  (lambda (p1 p2)
    (lambda (x)
      (p1 (p2 x)))))

; slist 中から s を取り出すための関数を出力する（無ければ errvalue を返す）
(define car&cdr
  (lambda (s slist errvalue)
    (if (null? slist)
      errvalue
      (if (symbol? (car slist))
        (if (eqv? (car slist) s)
          'car
          (let ((result (car&cdr s (cdr slist) errvalue)))
            (if (eqv? result errvalue)
              errvalue
              (list 'compose result 'cdr))))
        (let ((result (car&cdr s (car slist) errvalue)))
          (if (eqv? result errvalue)
            (let ((result (car&cdr s (cdr slist) errvalue) ))
              (if (eqv? result errvalue)
                errvalue
                (list 'compose result 'cdr)))
            (list 'compose result 'car)))))))

; 同じことを compose なしでやる
(define car&cdr2
  (lambda (s slist errvalue)
    (if (null? slist)
      errvalue
      (if (symbol? (car slist))
        (if (eqv? (car slist) s)
          'car
          (let ((result (car&cdr2 s (cdr slist) errvalue)))
            (if (eqv? result errvalue)
              errvalue
              `(lambda (x) (,result (cdr x))))))
        (let ((result (car&cdr2 s (car slist) errvalue)))
          (if (eqv? result errvalue)
            (let ((result (car&cdr2 s (cdr slist) errvalue) ))
              (if (eqv? result errvalue)
                errvalue
                `(lambda (x) (,result (cdr x)))))
            `(lambda (x) (,result (car x)))))))))

; Exercise 1.19 from p.31
; ラムダ式中の自由変数のリストを返す
(define free-vars
  (lambda (exp)
    (fv '() exp)))

(define fv
  (lambda (vars exp)
    (cond
      ((symbol? exp)
       (if (memv exp vars) '() (list exp)))
      ((eqv? (car exp) 'lambda)
       (fv (uniqcons (caadr exp) vars) (caddr exp)))
      (else
        (uniqappend (fv vars (car exp)) (fv vars (cadr exp)))))))

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

; ラムダ式中の束縛変数のリストを返す
(define bound-vars
  (lambda (exp)
    (bv '() exp)))

(define bv
  (lambda (vars exp)
    (cond
      ((symbol? exp)
       (if (memv exp vars) (list exp) '()))
      ((eqv? (car exp) 'lambda)
       (bv (uniqcons (caadr exp) vars) (caddr exp)))
      (else
        (uniqappend (bv vars (car exp)) (bv vars (cadr exp)))))))

; Exercise 1.22 from p.32
; ある変数が free か bound かを判定する関数を複数引数に対応するように書き換える
(define occurs-free?-2
  (lambda (var exp)
    (cond
      ((symbol? exp) (eqv? var exp))
      ((eqv? (car exp) 'lambda)
       (and (not (exists? (lambda (x) (eqv? x var)) (cadr exp)))
            (exists? (lambda (x) (occurs-free?-2 var x)) (cddr exp))))
      (else (exists? (lambda (x) (occurs-free?-2 var x)) exp)))))

(define occurs-bound?-2
  (lambda (var exp)
    (cond
      ((symbol? exp) #f)
      ((eqv? (car exp) 'lambda)
       (or (exists? (lambda (x) (occurs-bound?-2 var x)) (cddr exp))
           (and (exists? (lambda (x) (eqv? x var)) (cadr exp))
                (exists? (lambda (x) (occurs-free?-2 var x)) (cddr exp)))))
      (else (exists? (lambda (x) (occurs-bound?-2 var x)) exp)))))

; Exercise 1.31 from p.37
; Scheme のサブセットに基づく式を与えられたときに変数の reference を lexical address で置き換える
(define lexical-address
  (lambda (exp)
    (la exp '())))

(define la
  (lambda (exp bs)
    (cond
      ((symbol? exp) (get-address exp bs 0))
      ((eqv? (car exp) 'if)
       (list 'if (la (cadr exp) bs) (la (caddr exp) bs) (la (cadddr exp) bs)))
      ((eqv? (car exp) 'lambda)
       (list 'lambda
             (cadr exp)
             (la (caddr exp) (cons (cadr exp) bs))))
      (else
        (map (lambda (x) (la x bs)) exp)))))

(define get-address
  (lambda (var bs d)
    (cond
      ((null? bs) (list var 'free))
      ((memv var (car bs))
       (list var ': d (get-pos var (car bs))))
      (else
        (get-address var (cdr bs) (+ d 1))))))

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

; Exercise 1.32 from p.37
; lexical address から変数名を復元する
(define un-lexical-address
  (lambda (exp)
    (ula exp '())))

(define ula
  (lambda (exp bs)
    (cond
      ((eqv? (car exp) ':)
       (if (> (length bs) (cadr exp))
         (let ((b (list-ref bs (cadr exp))))
           (if (> (length b) (caddr exp))
             (list-ref b (caddr exp))
             #f))
         #f))
      ((eqv? (car exp) 'lambda)
       (let ((body (ula (caddr exp) (cons (cadr exp) bs))))
         (if (eqv? body #f)
           #f
           (list 'lambda (cadr exp) body))))
      (else
        (let ((body (map (lambda (x) (ula x bs)) exp)))
          (if (exists? (lambda (x) (eqv? x #f)) body)
            #f
            body))))))

; Exercise 1.33 from p.37
; ラムダ式中に宣言済みの変数を shadowing するような宣言があるかを判断する
(define check-redeclaration
  (lambda (exp)
    (cr exp '())))

(define cr
  (lambda (exp bs)
    (cond
      ((symbol? exp) #f)
      ((eqv? (car exp) 'lambda)
       (or
         (contain? (caadr exp) bs)
         (cr (caddr exp) (cons (caadr exp) bs))))
      (else
        (or
          (cr (car exp) bs)
          (cr (cadr exp) bs))))))

(define contain?
  (lambda (s lst)
    (cond
      ((null? lst) #f)
      ((eqv? (car lst) s) #t)
      (else
        (contain? s (cdr lst))))))