Tociyuki::Diary RSSフィード

tociyuki による Perl・Ruby・C++・C で書き散らしたコードを中心に、日常雑記も混在 : B  F  twitter  GitHub  CPAN  本館  公開鍵
 | 

2017年12月29日

[]遅延評価の解釈系

SICP 4.2.2 遅延評価の解釈系」をいじって遊んでみます。 まず、 apply に手を入れて、 手続きに primitive-lazy を追加します。 これはアプリケーションと同じで、 実引数の評価を必要が生じるまで遅延します。 なお、 ホスト処理系の eval と apply との名前衝突を避けて、 遅延評価インタプリタの eval を lazy-eval へ、 同 apply を lazy-apply に名称変更しています。

(use util.match)

 (define (lazy-apply fn args env)
  (match fn
   (('primitive p)
    (apply p (actual-list args env)))
   (('primitive-lazy p)
    (apply p (delay-list args env)))
   (('procedure vars body proc-env)
    (lazy-eval-seq body (extend-env vars (delay-list args env) proc-env)))
   (else (error "LAZY APPLY -- UNKNOWN PROCEDURE TYPE" fn))))

 (define (actual-list args env)
  (if (null? args)
   '()
   (cons (actual-value (car args) env) (actual-list (cdr args) env))))

 (define (delay-list vals env)
  (if (null? vals)
   '()
   (cons (delay-it (car vals) env) (delay-list (cdr vals) env))))

そして、 大域値の cons や list といった、 データ・コンストラクタを primitive-lazy にします。 それ以外は primitive としておき、 apply のタイミングで評価待ちの実引数の評価をおこなわせます。

 (define primitive-procedures
  `((car . (primitive ,car))
    (cdr . (primitive ,cdr))
    (cons . (primitive-lazy ,cons))
    (list . (primitive-lazy ,list))
    (eq? . (primitive ,eq?))
    (null? . (primitive ,null?))
    (apply . (primitive ,force-apply))
    ; 途中略
    (display . (primitive ,terse-display))
    (newline . (primitive ,newline)) ))

上の大域値の中に、 アプリケーションで利用するための apply 手続きも定義してあります。 可変長引数を扱いたいとき等に利用します。 上の lazy-apply は args は入力した式に束縛しますが、 下の force-apply の vals は評価結果の値に束縛します。 引数の型が異なっているため別の手続きに分けています。 評価結果は thunk のままになっていることもあるため、 primitive にはリストのトップレベルのペアの car と cdr の両方を force-it してから渡します。 primitive-lazy とアプリケーションには、 トップレベルの cdr だけを force-it してリストにします。 そのとき、 ペアの car が参照している値の Thunk には手をつけずに、 そのまま Thunk とします。

 (define (force-apply fn vals)
  (match fn
   (('primitive p)
    (apply p (force-list vals)))
   (('primitive-lazy p)
    (apply p (force-cdr-list vals)))
   (('procedure vars body proc-env)
    (lazy-eval-seq body (extend-env vars (force-cdr-list vals) proc-env)))
   (else (error "LAZY APPLY -- UNKNOWN PROCEDURE TYPE" fn))))

 (define (force-list vals)
  (if (null? vals)
   '()
   (cons (force-it (car vals)) (force-list (force-it (cdr vals))))))

 (define (force-cdr-list vals)
  (if (null? vals)
   '()
   (cons (car vals) (force-cdr-list (force-it (cdr vals))))))

手続き定義の引数部に dotted-list を許すようにして、 可変引数を受け取れるようにします。 lookup-variable 等を可変引数対応へ書き直します。 今回の実装では、 ラムダ形式の仮引数リストをそのまま手続きオブジェクトと環境フレームにつないで利用し、 値も実引数リストをそのままつないでいます。 SICP では length 手続きを使って仮引数と実引数の長さ比較をしていますけど、 SRFI-1 の length 手続きは真性リスト以外へエラーを生じるので、 length-frame/k を内部定義しています。 dotted-list の長さは末尾の cdr を空リストに置き換えた真性リストの長さと同じ値とし、 dotted か真性かのフラグを添えます。

 (define (extend-env vars vals env)
  ; ((lambda x body))                 は (kont 0 1  0)
  ; ((lambda (x y) body) 0 1)         は (kont 2 #f 2)
  ; ((lambda (x y . z) body) 0 1)     は (kont 2 1  2)
  ; ((lambda (x y . z) body) 0 1 2 3) は (kont 2 1  4)
  (define (length-frame/k vars vals kont)
   (let loop ((vars vars) (count 0))
    (cond
     ((null? vars) (kont count #f (length vals)))
     ((symbol? vars) (kont count 1 (length vals)))
     ((not (pair? vars)) (error "LAZY APPLY -- INVALID SYNTAX PARAMETER" vars))
     (else (loop (cdr vars) (+ count 1))))))

  (length-frame/k vars vals (lambda (nvars var.rest nvals)
   (cond
    ((> nvars nvals) (error "LAZY APPLY -- TOO FEW ARGUMETNS" vars))
    ((or var.rest (= nvars nvals)) (cons (cons vars vals) env))
    (else (error "LAZY APPLY -- TOO MANY ARGUMETNS" vars))))))

この場合の変数参照はドット対の右辺のシンボルに対して値リストの残りを返します。 可変長変数は cdr から、 そうでないときは car から値を得ます。

 (define (lookup-variable env var)
  (let loop-rib ((env env))
   (if (pair? env)
    (member-variable-value env var
     car   ; (lambda (x y . z) body) の x と y
     cdr   ; (lambda e body) か (lambda (x y . z) の e と z
     (lambda () (loop-rib (cdr env))))
    (error "LAZY EVAL -- UNBOUND VARIABLE" var))))

変数代入の assign-variable では可変長変数は set-cdr! し、 そうでないときは set-car! します。

 (define (assign-variable env var val)
  (let loop-rib ((env env))
   (if (pair? env)
    (member-variable-value env var
     (lambda (vals) (set-car! vals val))
     (lambda (vals) (set-cdr! vals val))
     (lambda () (loop-rib (cdr env))))
    (error "LAZY EVAL -- UNBOUND VARIABLE" var))))

変数定義の define-variable は環境の先頭フレームに変数を見つけたときは変数代入と同じやりかたで代入し、 見つからなかったときは、 先頭フレームに変数と値をそれぞれ追加します。

 (define (define-variable env var val)
  (member-variable-value env var
   (lambda (vals) (set-car! vals val))
   (lambda (vals) (set-cdr! vals val))
   (lambda () (set-car! env (cons (cons var (caar env)) (cons val (cdar env)))))))

member-variable-value は、 env の car にあるフレーム中から変数を探して、 見つかったときは通常の変数か可変長変数の継続に値リストを適用します。 見つからなかったときは fail を呼びます。

 ; env は ((var . val) ...) か (((var ...) . (val ...)) ...)
 (define (member-variable-value env var kont-var kont-rest fail)
  (if (symbol? (caar env))
   (if (eq? (caar env) var)
    (kont-rest (car env))                   ; (lambda x body) の x
    (fail))
   (let loop ((vars (caar env)) (vals (cdar env)))
    (cond
     ((null? vars) (fail))
     ((eq? (car vars) var) (kont-var vals)) ; (lambda (x) body) の x
     ((symbol? (cdr vars))
      (if (eq? (cdr vars) var)
       (kont-rest vals)                     ; (lambda (x . y) body) の y
       (fail)))
     (else (loop (cdr vars) (cdr vals)))))))

Procedure や Thunk があると、 環境ごと表示して見難いので、 リストを作り直して表示するようにしています。

 (define (terse e)
  (if (not (pair? e))
   e
   (match e
    (('procedure _ _ _) '<procedure>)
    (('thunk _ _) '<thunk>)
    (('evaluated-thunk x) (terse x))
    (else (cons (terse (car e)) (terse (cdr e)))))))

 (define (terse-print . e) (apply print (map terse e)))
 (define (terse-display . e) (apply display (map terse e)))

遅延評価のインタプリタを動かしてみます。 リストの先頭から n の位置をとりだす list-ref、 リストの先頭から n 個を取り出す take、 リストの各要素を関数で変換したリストを作る map、 リストの各要素への繰り返し for-each 等の定番の関数を定義します。 any は map で使うために定義したものです。 続いて、 フィボナッチ数列の無限リストを定義し、 それの 49 の位置の値、 先頭 50 個の値を表示させています。 先頭 50 個のリストは作ったばかりでは、 サンクのペアだったものを、 for-each で null? を繰り返して 50 個の数値のリストにしています。

gosh> (lazy-repl)
call by needs evaluation based on SICP. type (exit) to terminate.
lazy> 
(define (list-ref e n)
 (if (= n 0)
  (car e)
  (list-ref (cdr e) (- n 1))))
lazy>
(define (take e n)
 (if (= n 0)
  '()
  (cons (car e) (take (cdr e) (- n 1)))))
lazy>
(define (any f e)
 (if (null? e)
  #f
  (let ((x (f (car e))))
   (if x x (any f (cdr e))))))
lazy>
(define (map f . e)
 (define (map1 f e)
  (if (null? e)
   '()
   (cons (f (car e)) (map1 f (cdr e)))))
 (define (vmap f e)
  (cond
   ((null? e) '())
   ((any null? e) '())
   (else (cons (apply f (map1 car e)) (vmap f (map1 cdr e))) )))
 (vmap f e))
lazy>
(define (for-each f e)
 (if (null? e)
  'done
  (begin
   (f (car e))
   (for-each f (cdr e)))))
lazy> (define fibonacci (cons 0 (cons 1 (map + (cdr fibonacci) fibonacci))))
lazy> (list-ref fibonacci 49)
7778742049
lazy> (define fib50 (take fibonacci 50))
lazy> fib50
(<thunk> . <thunk>)
lazy> (for-each null? fib50)
done
lazy> fib50
(0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946
17711 28657 46368 75025 121393 196418 317811 514229 832040 1346269 2178309
3524578 5702887 9227465 14930352 24157817 39088169 63245986 102334155 165580141
267914296 433494437 701408733 1134903170 1836311903 2971215073 4807526976
7778742049)
lazy> (exit)
gosh>

スパム対策のためのダミーです。もし見えても何も入力しないでください
ゲスト


画像認証

トラックバック - http://d.hatena.ne.jp/tociyuki/20171229/1514552417
 |