Rainy Day Codings

引き続き Essentials of Programming Languages の練習問題。

2.12 と 2.22 は問題の文意がよく読み取れなかったのでひとまず保留した。どちらも星1つなので簡単なことを言っているはずなんだけど…。2.12 はα変換とかβ変換とかη変換とか重要そうなことを言っているので後で立ち戻ってくるかもしれない。この本の Exercise はこういう新奇な概念も説明少なめにさらっと問題に出してくる感があるので基本的には教師がついて授業で使う的な想定であまり独習向けな感じではないのかもという気もしてきた。

ともかく第2章が終わったのでようやく第3章に入れる。ここでついにインタプリタの実装が出てくるはずである。

以下は Exercise 2.11 から 2.26 までの私の答案です。長いので注意。

; Exercise 2.11 from p.53
(define-datatype expression expression?
  (var-exp
    (id symbol?))
  (lambda-exp
    (id symbol?)
    (body expression?))
  (app-exp
    (rator expression?)
    (rand expression?))
  (lit-exp
    (datum number?))
  (primapp-exp
    (prim symbol?)
    (rand1 expression?)
    (rand2 expression?)))

(define unparse-expression
  (lambda (exp)
    (cases expression exp
           (var-exp (id) id)
           (lambda-exp (id body)
                       (list
                         'lambda
                         (list id)
                         (unparse-expression body)))
           (app-exp (rator rand)
                    (list
                      (unparse-expression rator)
                      (unparse-expression rand)))
           (lit-exp (datum) datum)
           (primapp-exp (prim rand1 rand2)
                        (list
                          prim
                          (unparse-expression rand1)
                          (unparse-expression rand2))))))

(define parse-expression
  (lambda (datum)
    (cond
      ((number? datum) (lit-exp datum))
      ((symbol? datum) (var-exp datum))
      ((pair? datum)
       (cond
         ((eqv? (car datum) 'lambda)
          (lambda-exp
            (caadr datum)
            (parse-expression (caddr datum))))
         ((= 2 (length datum))
          (app-exp
            (parse-expression (car datum))
            (parse-expression (cdr datum))))
         ((= 3 (length datum))
          (primapp-exp
            (car datum)
            (parse-expression (cadr datum))
            (parse-expression (caddr datum)))))))))

(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)))
           (lit-exp (datum) '())
           (primapp-exp (prim rand1 rand2)
                        (uniqappend
                          (fv vars rand1)
                          (fv vars rand2))))))

(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)))
           (lit-exp (datum) '())
           (primapp-exp (prim rand1 rand2)
                        (uniqappend
                          (all-ids rand1)
                          (all-ids rand2))))))

(define lambda-calculus-subst
  (lambda (exp subst-exp subst-id)
    (letrec
      ((fvs (free-vars subst-exp))
       (subst
         (lambda (exp bs)
           (cases expression exp
             (var-exp (id)
               (if (assv id bs)
                 (cdr (assv id bs))
                 exp))
             (lambda-exp (id body)
               (cond
                 ((eqv? id subst-id) exp)
                 ((memv id fvs)
                  (let
                    ((fresh (fresh-id body "p")))
                    (lambda-exp
                      fresh
                      (subst body (cons (cons id (var-exp fresh)) bs)))))
                 (else
                   (lambda-exp id (subst body bs)))))
             (app-exp (rator rand)
               (app-exp (subst rator bs) (subst rand bs)))
             (lit-exp (datum)
               (lit-exp datum))
             (primapp-exp (prim rand1 rand2)
               (primapp-exp prim (subst rand1 bs) (subst rand2 bs)))))))
      (subst exp (list (cons subst-id subst-exp))))))

; Exercise 2.12 from p.54
; skipped...

; Exercise 2.13 from p.54
(define-datatype term term?
  (var-term
    (id symbol?))
  (constant-term
    (datum constant?))
  (app-term
    (terms (list-of term?))))

(define constant?
  (lambda (datum)
    (or
      (string? datum)
      (number? datum)
      (boolean? datum)
      (null? datum))))

(define unparse-term
  (lambda (exp)
    (cases term exp
      (var-term (id) id)
      (constant-term (datum) datum)
      (app-term (terms) (map (lambda (x) (unparse-term x)) terms)))))

(define parse-term
  (lambda (datum)
    (cond ((symbol? datum)
           (var-term datum))
          ((constant? datum)
           (constant-term datum))
          ((list? datum)
           (app-term (map (lambda (x) (parse-term x)) datum))))))

(define all-ids
  (lambda (exp)
    (cases term exp
      (var-term (id) (list id))
      (constant-term (datum) '())
      (app-term (terms) (uniq-concat (map (lambda (x) (all-ids x)) terms))))))

(define uniq-concat
  (lambda (lst)
    (if (null? lst)
      '()
      (uniqappend (car lst) (uniq-concat (cdr lst))))))

; Exercise 2.15 from p.58
(define empty-stack
  (lambda ()
    (vector
      (lambda () (eopl:error 'top "empty-stack"))
      (lambda () (eopl:error 'pop "empty-stack"))
      (lambda () #t)))) ; empty-stack?

(define push
  (lambda (datum stack)
    (vector
      (lambda () datum) ; top
      (lambda () stack) ; pop
      (lambda () #f)))) ; empty-stack?

(define top
  (lambda (stack)
    ((vector-ref stack 0))))

(define pop
  (lambda (stack)
    ((vector-ref stack 1))))

(define empty-stack?
  (lambda (stack)
    ((vector-ref stack 2))))

; Exercise 2.16 from p.58
(define list-find-last-position
  (lambda (sym los)
    (list-find-last-position-helper 0 #f sym los)))

(define list-find-last-position-helper
  (lambda (pos last sym los)
    (cond
      ((null? los) last)
      ((eqv? sym (car los))
       (list-find-last-position-helper (+ 1 pos) pos sym (cdr los)))
      (else
        (list-find-last-position-helper (+ 1 pos) last sym (cdr los))))))

; Exercise 2.17 from p.59
(load "2-3-2.scm")
(define empty-env
  (lambda ()
    (vector
      (lambda (sym) (eopl:error 'apply-env "No binding for ~s" sym))
      (lambda (sym) #f))))

(define extend-env
  (lambda (syms vals env)
    (vector
      (lambda (sym)
        (let ((pos (list-find-position sym syms)))
          (if (number? pos)
            (list-ref vals pos)
            (apply-env env sym))))
      (lambda (sym)
        (let ((pos (list-find-position sym syms)))
          (if (number? pos)
            #t
            (has-association? env sym)))))))

(define apply-env
  (lambda (env sym)
    ((vector-ref env 0) sym)))

(define has-association?
  (lambda (env sym)
    ((vector-ref env 1) sym)))

; Exercise 2.18 from p.60
(load "2-3-3.scm")
(define environment-to-list
  (lambda (env)
    (cases environment env
      (empty-env-record ()
        '(empty-env-record))
      (extended-env-record (syms vals env)
        (list
          'extended-env-record
          syms
          vals
          (environment-to-list env))))))

; Exercise 2.19 from p.61
(define-datatype stack stack?
  (empty-stack-record)
  (extended-stack-record
    (top scheme-value?)
    (s stack?)))

(define empty-stack
  (lambda ()
    (empty-stack-record)))

(define push
  (lambda (datum s)
    (extended-stack-record datum s)))

(define top
  (lambda (s)
    (cases stack s
      (empty-stack-record () (eopl:error 'top "empty-stack"))
      (extended-stack-record (datum s) datum))))

(define pop
  (lambda (s)
    (cases stack s
      (empty-stack-record () (eopl:error 'pop "empty-stack"))
      (extended-stack-record (datum s) s))))

(define empty-stack?
  (lambda (s)
    (cases stack s
      (empty-stack-record () #t)
      (else #f))))

; Exercise 2.20 from p.61
(define has-association?
  (lambda (env sym)
    (cases environment env
      (empty-env-record () #f)
      (extended-env-record (syms vals env)
        (if (memv sym syms)
          #t
          (has-association? env sym))))))

; Exercise 2.22 from p.63
; skipped...

; Exercise 2.23 from p.63
(define empty-env
  (lambda ()
    '(() ())))

(define extend-env
  (lambda (syms vals env)
    (list
      (append syms (car env))
      (append vals (cadr env)))))

(define apply-env
  (lambda (env sym)
    (let ((syms (car env))
          (vals (cadr env)))
      (let ((pos (list-find-position sym syms)))
        (if (number? pos)
          (list-ref vals pos)
          (eopl:error 'apply-env "No binding for ~s" sym))))))

; Exercise 2.24 from p.64
(define empty-subst
  (lambda ()
    (lambda (sym)
      (var-term sym))))

(define extend-subst
  (lambda (i t s)
    (lambda (sym)
      (if (eqv? sym i)
        t
        (s sym)))))

(define apply-subst
  (lambda (s i)
    (s i)))

(define subst-in-term
  (lambda (t s)
    (cases term t
      (var-term (id)
        (apply-subst s id))
      (constant-term (datum)
        t)
      (app-term (terms)
        (app-term (map (lambda (x) (subst-in-term x s)) terms))))))

(define subst-in-terms
  (lambda (ts s)
    (map (lambda (x) (subst-in-term x s)) ts)))

; Exercise 2.25
(define unify-term
  (lambda (t u)
    (cases term t
      (var-term (tid)
        (if (or (var-term? u) (not (memv tid (all-ids u))))
          (unit-subst tid u)
          #f))
      (else
        (cases term u
          (var-term (uid) (unify-term u t))
          (constant-term (udatum)
            (cases term t
              (constant-term (tdatum)
                (if (equal? tdatum udatum) (empty-subst) #f))
              (else #f)))
          (app-term (us)
            (cases term t
              (app-term (ts) (unify-terms ts us))
              (else #f))))))))

(define unify-terms
  (lambda (ts us)
    (cond
      ((and (null? ts) (null? us)) (empty-subst))
      ((or (null? ts) (null? us)) #f)
      (else
        (let ((subst-car (unify-term (car ts) (car us))))
          (if (not subst-car)
            #f
            (let ((new-ts (subst-in-terms (cdr ts) subst-car))
                  (new-us (subst-in-terms (cdr us) subst-car)))
              (let ((subst-cdr (unify-terms new-ts new-us)))
                (if (not subst-cdr)
                  #f
                  (compose-substs subst-car subst-cdr))))))))))

(define var-term?
  (lambda (t)
    (cases term t
      (var-term (id) #t)
      (else #f))))

(define unit-subst
  (lambda (i t)
    (extend-subst i t (empty-subst))))

(define compose-substs
  (lambda (t u)
    (lambda (sym)
      (let ((subst-t (apply-subst t sym)))
        (cases term subst-t
          (var-term (id) (apply-subst u id))
          (else subst-t))))))

; Exercise 2.26 from p.68
(define-datatype reference reference?
  (a-ref
    (position integer?)
    (vec vector?)))

(define cell
  (lambda (pos datum)
    (let ((ref (a-ref pos (vector datum))))
      (letrec
        ((cell? (lambda () #t))
         (contents (lambda ()
                     (cases reference ref
                       (a-ref (pos v) (vector-ref v 0)))))
         (setcell (lambda (datum)
                    (cases reference ref
                      (a-ref (pos v) (vector-set! v 0 datum))))))
        (vector cell? contents setcell)))))

(define reference-get-cell?-operation
  (lambda (c) (vector-ref c 0)))
(define reference-get-contents-operation
  (lambda (c) (vector-ref c 1)))
(define reference-get-setcell-operation
  (lambda (c) (vector-ref c 2)))