ArcJSを使って、Webページ上にミニゲームを作る

これは、2014年Lispアドベントカレンダーの最後12/25に投稿されるはずだった記事です。
年末が特に忙しく、5日も遅れてしましいました。すみません。「遅れちゃったしもういいかなー」とも思ったのですが、
このような記事も見つけてしまいまして、ほかでやりたい人もいたのに、さすがに放置はまずいかなと思って書きました。(それにしても素晴らしい奥さんですね...)

以下記事 -----

ArcJS紹介

皆さんはArcというLisp方言をご存知でしょうか。著名なLisperであるPaul Grahamさんが2009年に発表した次世代のLisp方言でシンプルな特徴を持っています。チュートリアル

出た当時は第三のLispとして注目度もあったのですが、最近は、第三のLispの座はClojureに奪われ、めっきりと話を聞かなくなってしまいました。
とはいえ、私は好きで使っています。

前のエントリで紹介しましたが、ブラウザ上で動くArc処理系を作りました。

smihica/arc-js · GitHub

こだわったところは、

  1. VM型の処理系でJavaScriptでStackVMを作って動かしているところ。
  2. コンパイラのセルフホスティングを実現しているところ。
  3. Macro, Object, ファーストクラス継続など めぼしい機能は一通り実現されているところ。

などです。
schemeでは、有名なBiwaSchemeというのがありますが、それのArc版と思っていただけるとわかりやすいです。

今回はArcJSの「Webページ上で動かせる」という特徴をつかって、
Arcで簡単なゲームを作って遊んでみましょう。

題材は 『テトリス』 にしてみます。

ベース

<!doctype html>
<html lang="ja">
  <head>
    <style> #c1 {float:left;border:1px solid #ddd;background:#000;} #editor {float:left;width:850px;height:600px;} #holder { width:850px;height:550px;font-family:Consolas,Monaco,monospace;font-size:14px; } #run { float:left; font-size:20px; } </style>
    <script src="arc.min.js"></script>
  </head>
  <body>
    <canvas id="c1" width="300" height="600"></canvas>
    <div id="editor">
      <textarea id="holder"></textarea>
      <button id="run" onclick="run()">実行</button>
    </div>
  </body>
  <script>
    var arcjs = ArcJS.context();
    function run() {
      var code = document.getElementById("holder").value;
      arcjs.evaluate(code);
    }
  </script>
</html>

まずは、こんな HTMLを書いてみました。 0.html
ArcJSを使うには、このHTMLにあるように、arc.min.js をインクルードして、
ArcJS.context();でArc処理系を受け取り、context.eval(";; arc code ;;")でArcコードを実行します。
( arc.min.js は githubnpmでダウンロードできます )
では、左側のフォームにArcコードを打ち込んで試してみましょう。

(prn 'HelloWorld)

試しに、上のように打ち込んで実行すると、consoleに HelloWorld と書き出されることがわかります。
1.html

では、右側の黒い画面にゲーム画面が表示されるようにして、左側に打ち込んだArcコードが描画するようにします。このままでは画面に絵を出すことができないので、canvasタグへのJSブリッジを書いてみましょう。

var arcjs = ArcJS.context();
function run() {
  var code = document.getElementById("holder").value;
  arcjs.evaluate(code);
}
// -- 追加
var canvas = document.getElementById('c1');
var ctx = canvas.getContext('2d');
ArcJS.Primitives('user').define({
  'draw': [{dot: -1}, function(x, y, color) {
    ctx.fillStyle = color;
    ctx.fillRect(x*30, y*30, 30, 30);
    return ArcJS.nil;
  }],
  'clear': [{dot: -1}, function () {
    ctx.fillStyle = "#000";
    ctx.fillRect(0, 0, 300, 600);
    return ArcJS.nil;
  }],
  'alert': [{dot: -1}, function (x) {
    alert(x);
    return ArcJS.nil;
  }]
});
// --

これで、canvasにブロックを書き込む draw という関数と 全消去する clear という関数、alertを出す関数がArc内で使用できるようになります。

(draw 1 1 "#F00")

と打ち込んで実行すると、右上に赤い四角が出るのが見えると思います。3.html
ArcJSでは以下のようにプリミティブ関数を定義できます。

ArcJS.Primitives( /*ネームスペース名*/ ).define({
  '関数名': [{dot:-1}, /* リスト引数の開始位置(なければ-1) */
             function( ... ) { ... }],
});

テトロミノを作る

さて、画面にブロックを出すことができるようになったので、まずテトリスのブロック(テトロミノ)を作ってみます。

(def make-tetromino (typ)
  (withs ((base color)
          (case typ
            I '(((0 . 0) (1  . 0) (-1 . 0) (-2 . 0)) "#0FF")
            O '(((0 . 0) (1  . 0) (1  . 1) (0  . 1)) "#FF0")
            T '(((0 . 0) (0  . 1) (1  . 0) (-1 . 0)) "#F0F")
            J '(((0 . 0) (-2 . 0) (-1 . 0) (0  . 1)) "#00F")
            L '(((0 . 0) (0  . 1) (1  . 0) (2  . 0)) "#F70")
            S '(((0 . 0) (1  . 0) (0  . 1) (-1 . 1)) "#0F0")
            Z '(((0 . 0) (-1 . 0) (0  . 1) (1  . 1)) "#F00"))
          p           '(4 . 0)
          origin      (fn (p) (fn ((x . y)) (cons (+ car.p x) (+ cdr.p y))))
          get         (fn (p r) (map1 origin.p base)))
    (rfn tetromino (cmd (o arg nil))
      (case cmd
        color  color
        get    (get p r)
        draw   (each pn (get p r) (draw car.pn cdr.pn color))))))

ちょっとオブジェクト指向っぽくしてみました。
(make-tetromino type) をすると、関数が帰ってきます。
関数は color get draw などのコマンドを受け取ることができます。
それぞれ、colorは色を"#F00"のような形で返します。
getはブロックの位置を (x . y) のリストで返します。
drawはブロックをスクリーンに描きます。

以下のように書き加えて実行してみましょう。

(= t1 (make-tetromino 'Z nil))
(t1 'draw)

赤いZブロックが表示されたでしょうか。4.html

f:id:nagayoru:20141230151451p:plain

移動・回転させる

さて、ブロックはできたのですが、まだ動かす関数がありません。
ブロックは回転させたり移動させたりできなくてはいけません。
でも、移動・回転は、すでに溜まっているブロックにぶつからないようにしなければなりません。

なので、stageという関数を受け取って、移動や回転の前にその位置におけるかどうか確認しましょう。

(stage 'can-put? new-positions)

このような関数が作れると仮定して、移動と回転の処理も書き加えてみます。

まずは移動です。
引数にstageを受け取るようにして、

(def make-tetromino (typ stage) ;; stage 追加
  (withs ((base color)
          (case typ
            I '(((0 . 0) (1  . 0) (-1 . 0) (-2 . 0)) "#0FF")
            O '(((0 . 0) (1  . 0) (1  . 1) (0  . 1)) "#FF0")
            T '(((0 . 0) (0  . 1) (1  . 0) (-1 . 0)) "#F0F")
            J '(((0 . 0) (-2 . 0) (-1 . 0) (0  . 1)) "#00F")
            L '(((0 . 0) (0  . 1) (1  . 0) (2  . 0)) "#F70")
            S '(((0 . 0) (1  . 0) (0  . 1) (-1 . 1)) "#0F0")
            Z '(((0 . 0) (-1 . 0) (0  . 1) (1  . 1)) "#F00"))
          p           '(4 . 0)
          origin      (fn (p) (fn ((x . y)) (cons (+ car.p x) (+ cdr.p y))))
          get         (fn (p) (map1 origin.p base)))
    (rfn tetromino (cmd (o arg nil))
      (case cmd
        color  color
        get    (get p)
        ;; 追加
        move   (let np
                   (case arg
                     left  (cons (- car.p 1) cdr.p)
                     right (cons (+ car.p 1) cdr.p)
                     down  (cons car.p (+ cdr.p 1)))
                 (when (stage 'can-put? (get np)) (= p np) t))
        draw   (each pn (get p) (draw car.pn cdr.pn color))))))

(tetromino 'move 'down) で、もし下に動かせれば動かし、t が帰ってきます。
動かせなければ、nilが帰ってきます。

次に、回転の処理も書き加えてみましょう。

(def make-tetromino (typ stage)
  (withs ((base color)
          (case typ
            I '(((0 . 0) (1  . 0) (-1 . 0) (-2 . 0)) "#0FF")
            O '(((0 . 0) (1  . 0) (1  . 1) (0  . 1)) "#FF0")
            T '(((0 . 0) (0  . 1) (1  . 0) (-1 . 0)) "#F0F")
            J '(((0 . 0) (-2 . 0) (-1 . 0) (0  . 1)) "#00F")
            L '(((0 . 0) (0  . 1) (1  . 0) (2  . 0)) "#F70")
            S '(((0 . 0) (1  . 0) (0  . 1) (-1 . 1)) "#0F0")
            Z '(((0 . 0) (-1 . 0) (0  . 1) (1  . 1)) "#F00"))
          p           '(4 . 0)
          origin      (fn (p) (fn ((x . y)) (cons (+ car.p x) (+ cdr.p y))))
          ;; 追加
          r           idfn
          rotate      (fn (r) (compose (fn ((x . y)) (cons y (- x))) r))
          ;; 変更
          get         (fn (p r) (map1 (compose origin.p r) base)))
    (rfn tetromino (cmd (o arg nil))
      (case cmd
        color  color
        get    (get p r)
        move   (let np
                   (case arg
                     left  (cons (- car.p 1) cdr.p)
                     right (cons (+ car.p 1) cdr.p)
                     down  (cons car.p (+ cdr.p 1)))
                 (when (stage 'can-put? (get np r)) (= p np) t))
        ;; 追加
        rotate (let nr (rotate r)
                 (when (stage 'can-put? (get p nr))
                   (= r nr) t))
        draw   (each pn (get p r) (draw car.pn cdr.pn color))))))

現在の回転をrという関数で表しています。
(get)するときに、baseへ当てる関数にrもcomposeするようにしました。
rotate時にはrに x y -> y -x とする関数をcomposeしています。
(tetromino 'rotate) で回転できれば回転し、t が帰ってきます。

ステージを作る

さて、できましたが、肝心のstageがありません。

(stage 'can-put? new-positions)

このようなことができるstageを作ってみましょう。

(def make-stage ()
  (withs (field      {}
          positions  (mappend (fn (y) (map1 [cons _ y] (range 0 9))) (nrev (range 0 19)))
          target     (fn _)
          overflow?  (fn (x y) (no (and (<= 0 x 9) (<= 0 y 19)))))
    (rfn stage (cmd (o o1 nil) (o o2 nil))
      (case cmd
        can-put?
        (no (ccc (fn (cc) (each p o1 (when (or (overflow? car.p cdr.p) (field p)) (cc t))))))
        tick
        (unless (do1 (target 'move 'down) (stage 'draw))
          (let c (target 'color) (each p (target 'get) (= (field p) c)))
          (stage 'add (make-tetromino (rand-elt '(I O T J L S Z)) stage)))
        add
        (if (stage 'can-put? (o1 'get))
            (= target o1)
            (game-over 'over))
        draw
        (do (clear) (target 'draw)
            (each p positions (aif (field p) (draw car.p cdr.p it))))))))

できました。
それぞれ can-put? tick add draw をコマンドとして受け取る関数ができます。
フィールドはテーブルで表してみました。 { (x1 . y1) "color" ... } の形で入ります。

  • can-put? では、その位置に、重ならずにブロックをおけるか確かめます。
  • tick では、一つブロックが落ちていくようにして、一番下に行ったらブロックをフィールドに転写し、新しいブロックを追加します。これを一定時間ごとに呼び出して、動かそうと思います。
  • add では、新しいブロックを追加します。
  • draw では、現在のブロックと積み上がったフィールドを描写しています。

メインの関数も作ってみましょう。

(when
    (is 'over
        (ccc
          (fn (cc)
            (= game-over cc
               stage (make-stage))
            ((afn (stage)
               (stage 'tick)
               (stage 'draw)
               (arc.time::set-timer
                 self 800 nil
                 stage))
             stage))))
  (alert "GAME OVER"))

継続を作って、ゲームオーバー時に戻ってくる場所をグローバル環境に保存しています。
(stage 'tick) と (stage 'draw) が0.8秒ごとに呼ばれます。
ゲームオーバーになると、(stage 'add) 内部で継続が呼ばれて、処理が戻ってきます。
ご覧の通り、arcではcccで継続を作ります。
まだ入力を受け付けるようになっていませんが、これで、一度動かしてみましょう。

5.html

f:id:nagayoru:20141230151239p:plain

キーボードで動かせるようにする

さて、ブロックは落ちてくるようになったものの、今のままでは、ただブロックが落ちるだけで何もできません。キーボードイベントをとってブロックを操作できるようにしてみましょう。

HTMLに以下のコードを追記します。

<head> 内部に追記 (keyeventの為にjqueryを入れる)
<script src="//ajax.googleapis.com/ajax/libs/jquery/1.11.2/jquery.min.js"></script>

<script> 内部に追記
$(window).keydown(function(e){ arcjs.evaluate("(keydown " + e.which + ")"); });

これで

(def keydown (code) (prn code))

このような式実行すると、consoleに押したキーコードがプリントされるようになります。
6.html

ということで、stage関数をちょっと改造してキーコードを受け取れるようにします。

(def make-stage ()
  (withs (field      {}
          positions  (mappend (fn (y) (map1 [cons _ y] (range 0 9))) (nrev (range 0 19)))
          target     (fn _)
          overflow?  (fn (x y) (no (and (<= 0 x 9) (<= 0 y 19)))))
    (rfn stage (cmd (o o1 nil) (o o2 nil))
      (case cmd
        can-put?
        (no (ccc (fn (cc) (each p o1 (when (or (overflow? car.p cdr.p) (field p)) (cc t))))))
        tick
        (unless (do1 (target 'move 'down) (stage 'draw))
          (each p (target 'get) (= (field p) (target 'color)))
          (stage 'add (make-tetromino (rand-elt '(I O T J L S Z)) stage)))
        add
        (if (stage 'can-put? (o1 'get))
            (= target o1)
            (game-over 'over))
        draw
        (do (clear) (target 'draw)
            (each p positions (aif (field p) (draw car.p cdr.p it))))
        ;; 追加
        keydown
        (do (case o1
              37 (target 'move 'left)  ;left
              38 (target 'rotate)      ;up
              39 (target 'move 'right) ;right
              40 (target 'move 'down)) ;down
            (stage 'draw))))))

このようにしてみました。keydown関数は以下のようにします。

(def keydown (c) (stage 'keydown c))

これで、keyを使ってブロックが動かせるようになりました。もう一度動かしてみましょう。
7.html

f:id:nagayoru:20141230151247p:plain

これでブロックが自由に動かせるようになりました。

ブロックを消す処理

さて、最後に、ブロックを消す処理です。
先ほども書いたように、フィールドにブロックを転写した直後にフィールド内の各行をチェックして、全て埋まっている行があれば、削除していけばよいでしょう。

(def make-stage ()
  (withs (field      {}
          positions  (mappend (fn (y) (map1 [cons _ y] (range 0 9))) (nrev (range 0 19)))
          target     (fn _)
          overflow?  (fn (x y) (no (and (<= 0 x 9) (<= 0 y 19)))))
    (rfn stage (cmd (o o1 nil) (o o2 nil))
      (case cmd
        can-put?
        (no (ccc (fn (cc) (each p o1 (when (or (overflow? car.p cdr.p) (field p)) (cc t))))))
        tick
        (unless (do1 (target 'move 'down) (stage 'draw))
          (each p (target 'get) (= (field p) (target 'color)))
          ;; 追加
          (stage 'line-clear)
          (stage 'add (make-tetromino (rand-elt '(I O T J L S Z)) stage)))
        add
        (if (stage 'can-put? (o1 'get))
            (= target o1)
            (game-over 'over))
        draw
        (do (clear) (target 'draw)
            (each p positions (aif (field p) (draw car.p cdr.p it))))
        keydown
        (do (case o1
              37 (target 'move 'left)  ;left
              38 (target 'rotate)      ;up
              39 (target 'move 'right) ;right
              40 (target 'move 'down)) ;down
            (stage 'draw))
        ;; 追加
        line-clear
        ((afn (lines)
           (when lines
             (let line car.lines
               (if (no (pos [no (field _)] line)) ;; 埋まっている行である
                   (do (map (fn (l1 l2) (map (fn (p1 p2) (= (field p1) (field p2))) l1 l2)) lines cdr.lines) ;; 一つ上の行をくり下げていく。
                       (each p (car:last lines) (= (field p) nil))     ;; 一番上の行は空白にする
                       (self lines))
                   (self cdr.lines)))))
         (tuples positions 10))))))

できました!
これで基本的なゲームはできましたが、最後に速度とスコアも追加してみましょう。

(= score 0 span 800)

;; ... stage内

  (each p (car:last lines) (= (field p) nil))     ;; 一番上の行は空白にする
  ;; 追加
  (= score (+ score 100) span (int (* span 0.9)))

;; ... main関数

(when
    (is 'over
        (ccc
          (fn (cc)
            (= game-over cc)
            (= stage (make-stage))
            ((afn (stage)
               (stage 'tick)
               (stage 'draw)
               (arc.time::set-timer
                 self span nil
                 stage))
             stage))))
  (alert (+ "GAME OVER - SCORE " score)))

できました!
全体はこんな感じです。

(= score 0 span 800)

(def keydown (c) (stage 'keydown c))

(def make-tetromino (typ stage)
  (withs ((base color)
          (case typ
            I '(((0 . 0) (1  . 0) (-1 . 0) (-2 . 0)) "#0FF")
            O '(((0 . 0) (1  . 0) (1  . 1) (0  . 1)) "#FF0")
            T '(((0 . 0) (0  . 1) (1  . 0) (-1 . 0)) "#F0F")
            J '(((0 . 0) (-2 . 0) (-1 . 0) (0  . 1)) "#00F")
            L '(((0 . 0) (0  . 1) (1  . 0) (2  . 0)) "#F70")
            S '(((0 . 0) (1  . 0) (0  . 1) (-1 . 1)) "#0F0")
            Z '(((0 . 0) (-1 . 0) (0  . 1) (1  . 1)) "#F00"))
          p           '(4 . 0)
          origin      (fn (p) (fn ((x . y)) (cons (+ car.p x) (+ cdr.p y))))
          r           idfn
          rotate      (fn (r) (compose (fn ((x . y)) (cons y (- x))) r))
          get         (fn (p r) (map1 (compose origin.p r) base)))
    (rfn tetromino (cmd (o arg nil))
      (case cmd
        color  color
        get    (get p r)
        move   (let np
                   (case arg
                     left  (cons (- car.p 1) cdr.p)
                     right (cons (+ car.p 1) cdr.p)
                     down  (cons car.p (+ cdr.p 1)))
                 (when (stage 'can-put? (get np r)) (= p np) t))
        rotate (let nr (rotate r)
                 (when (stage 'can-put? (get p nr))
                   (= r nr) t))
        draw   (each pn (get p r) (draw car.pn cdr.pn color))))))

(def make-stage ()
  (withs (field      {}
          positions  (mappend (fn (y) (map1 [cons _ y] (range 0 9))) (nrev (range 0 19)))
          target     (fn _)
          overflow?  (fn (x y) (no (and (<= 0 x 9) (<= 0 y 19)))))
    (rfn stage (cmd (o o1 nil) (o o2 nil))
      (case cmd
        can-put?
        (no (ccc (fn (cc) (each p o1 (when (or (overflow? car.p cdr.p) (field p)) (cc t))))))
        tick
        (unless (do1 (target 'move 'down) (stage 'draw))
          (each p (target 'get) (= (field p) (target 'color)))
          (stage 'line-clear)
          (stage 'add (make-tetromino (rand-elt '(I O T J L S Z)) stage)))
        add
        (if (stage 'can-put? (o1 'get))
            (= target o1)
            (game-over 'over))
        draw
        (do (clear) (target 'draw)
            (each p positions (aif (field p) (draw car.p cdr.p it))))
        keydown
        (do (case o1
              37 (target 'move 'left)  ;left
              38 (target 'rotate)      ;up
              39 (target 'move 'right) ;right
              40 (target 'move 'down)) ;down
            (stage 'draw))
        line-clear
        ((afn (lines)
           (when lines
             (let line car.lines
               (if (no (pos [no (field _)] line))
                   (do (map (fn (l1 l2) (map (fn (p1 p2) (= (field p1) (field p2))) l1 l2)) lines cdr.lines)
                       (each p (car:last lines) (= (field p) nil))
                       (= score (+ score 100) span (int (* span 0.9)))
                       (self lines))
                   (self cdr.lines)))))
         (tuples positions 10))))))

(when
    (is 'over
        (ccc
          (fn (cc)
            (= game-over cc
               stage (make-stage))
            ((afn (stage)
               (stage 'tick)
               (stage 'draw)
               (arc.time::set-timer
                 self span nil
                 stage))
             stage))))
  (alert (+ "GAME OVER - SCORE " score)))

全体で80行程度で簡単なテトリスができました。

8.html

f:id:nagayoru:20141230152140p:plain

まとめ

いかがでしたでしょうか。今回はテトリスの作成を題材にArcJSを使って見ることをしました。

こんな感じに、ブラウザでちょっとLispを使いたい時のBiwaSchemeとは違うもう一つの選択肢になるかもしれません。

今回はわかりやすくするために、ゲームっぽいものを作りましたが、仕事では、弊社システム管理のためのDSLを作るために、ArcJSを使っていたりします。
DSLはS式の形であわらされ、リアルタイムにコードチェックされ、Fixすると実コードにコンパイルされ、弊社システムにコンフィギュレートされます。
実際、JavaScriptで書くよりLispで書いたほうがアドバンテージがあるのは、今回のゲームのような処理よりむしろ、DSL実装などの処理なのかなぁとテトリス作ってて思いました。

以上です。ではみなさま良いお年を。

JavaScriptでNode.JS/ブラウザ上で動くArc処理系を作った。

去年の夏ぐらいに、NodeJS/ブラウザ上で動くArc言語*1処理系「ArcJS」を作りました。
全体として2500行ぐらいでStackVMまで実装してあるので、処理系を作りたい人は参考になるかもしれません。

http://smihica.github.io/arc-js/

既に実際に仕事で部分的に使ってみていて、結構使えているので紹介します。
(仕事では、ArcJS上を使い、ブラウザ上でDSLを走らせ、DSL->Pythonコードを生成するのに使っています)

ArcJS特徴としては以下のようになっています。

  • 逐次実行方式ではなく、JavaScriptでStackVMを作って動かしているので高速。*2
  • コンパイラのセルフホスティングを実現している。(つまりArc言語自身でコンパイラが書いてある)
  • Macro, Object, FirstClass継続など めぼしい機能は一通り実現されている。
  • Arcに特徴的な機能 オブジェクトのデフォルト関数、ssyntax などももちろん実現されている。

本家のArcにないArcJS独自の機能として、

  • symbol-syntaxのユーザー定義
  • ネームスペース

などを使う事が出来ます。

以下にNodeJS動かしてみる際の簡単なチュートリアルを書きます。*3

インストール

npmからインストールできます。

$ npm install -g arc-js

これでarcjsとarcjscというコマンドが用意されます。

$ arcjs --version
0.1.2

では早速やってみましょう。

$ arcjs

と打つと以下のようにREPLが起動します

arc>

ちょっとREPLに色々打ち込んで試してみます。

ArcJSのprimitiveの値は、シンボル, 数値, コンス, 文字, 文字列, 正規表現, Hash, Tagged, 関数, 継続 などがあります。

;; シンボル
arc> t
t
arc> nil
nil
arc> 'a
a
arc> 'u-nk_~o#abc$$%%moemoe
u-nk_~o#abc$$%%moemoe
arc> '|a b c| ;; delimiterを含んだ文字列のsymbol
|a b c|

;; 数値
arc> 0
0
arc> 3.14
3.14
arc> -inf.0
-inf.0
arc> #x10 ;; 16進数
16

;; 文字
arc> #\a
#\a
arc> #\あ
#\あ

;; 文字列
arc> "abc"
"abc"
arc> "あいう"
"あいう"
arc> "a\nb"
"a\nb"
arc> "\u000A"
"\n"

;; コンス
arc> '(a b)
(a b)
arc> '(a . (b . c))
(a b . c)

;; 正規表現 (ArcJSによる拡張)
arc> #/a/
#<regex /a/>
arc> #/^\w+@[a-zA-Z_]+?\.[a-zA-Z]{2,3}$/
#<regex /^\w+@[a-zA-Z_]+?\.[a-zA-Z]{2,3}$/>

;; Hash
arc> (table)
#<table n=0>

;; Tagged
arc> (annotate 'my-type (table))
#<tagged my-type #<table n=0>>

Taggedはオブジェクト指向的な事をするのに使えます。

式 (S式を使います)

arc> (+ 1 2)
3
arc> (+ (/ 1 2) 3)
3.5

let / with

局所変数束縛には、let, withを使います。

;; (let var val body)
arc> (let a 10
       (+ a (* a 2)))
30
;; (with (var1 val1 var2 val2) body)
arc> (with (x 3 y 4)
       (sqrt (+ (expt x 2) (expt y 2))))
5

let, with ではリストのパターンマッチも使えます。

arc> (let (a . (b . (c . d))) '(1 2 3 . 4)
       (* a b c d))
24

=

変数定義、束縛には = を使います。

arc> (= s '(f o o))
(f o o)
arc> s
(f o o)

= は場所を指定して代入する事も出来ます

arc> (= (s 0) 'm)
m
arc> s
(m o o)

if

arcではnon-nilな値はすべてtrueと評価されます

arc> (if 0 'a 'b)
a
arc> (if nil 'a 'b)
b

論理反転は (no x) です。

arc> (if (no nil) 'a 'b)
a
arc> (if (no (odd 2)) 'a)
a

ここで、

(if a b c d e)

(if a
    b
    (if c
        d
        e))

と同じです

is / iso

is は同値であるかを見ます

arc> (is 'a 'a)
t
arc> (is "xxx" "xxx")
t
arc> (is (list 'x) (list 'x))
nil

iso は同一構造(isomorphic)であるかどうかを見ます

arc> (iso (list 'x) (list 'x))
t

def

defで現在のネームスペースにグローバル関数を定義します。

arc> (def translate (sym)
       (case sym
         apple 'mela
         onion 'cipolla
         'che?))
#<fn:translate>
arc> (translate 'apple)
mela
arc> (translate 'syzygy)
che?

for, each, while, repeat, map

様々なイテレート機能があります。

arc> (for i 1 10
          (pr i " "))
1 2 3 4 5 6 7 8 9 10 nil
arc> (each x '(a b c d e) 
       (pr x " "))
a b c d e nil
arc> (let x 10
       (while (> x 5)
         (= x (- x 1))
         (pr x)))
98765nil
arc> (repeat 5 (pr "la "))
la la la la la nil
arc> (map (fn (x) (+ x 10)) '(1 2 3))
(11 12 13)
arc> (map [+ _ 10] '(1 2 3))
(11 12 13)

ここで、[+ _ 10] という表記がありますが、これは (fn (_) (+ _ 10)) に展開されます。
Arcでは [... _ ...] は (fn (_) (... _ ...)) に展開されます。

mac

マクロはmacで定義出来ます。

arc> (mac when2 (tes . then) `(if ,tes (do ,@then)))
#<tagged mac #<fn:when2>>
arc> (when2 t 1 2 3)
3

レガシーマクロなので、暗黙の変数束縛も作れます

arc> (mac aif2 (tes then else)
       `(let it ,tes
          (if it ,then ,else)))
#<tagged mac #<fn:aif2>>
arc> (aif2 (car '(a b c)) it 'x)
a

w/uniqでワンタイムなシンボルに束縛できます。(ユニークなシンボルを返す関数は(uniq)です)
これによって一度しか評価されない式を作れます。( (++ i)は評価されるたびに i をインクリメントしてしまう)

arc> (mac prn-x-times (form times)
       (w/uniq v
         `(let ,v ,form
            (do ,@(map (fn (_) `(prn ,v)) (range 1 times))
                nil))))
#<tagged mac #<fn:prn-x-times>>
arc> (let i 5 (prn-x-times (++ i) 3))
6
6
6
nil

continuation

継続はcccで作れます。cccに渡される関数の第一引数に、継続が渡されます。
大域脱出の様なことが実現できます。

arc> (ccc
       (fn (c)
         (do (c 10)
             (err))))
10

yieldの様なことも実現できます。

arc> (ccc
       (fn (return)
         (let x 0
           (while t
             (ccc (fn (c)
                    (= next c)
                    (return x)))
             (++ x)))))
0
arc> (next nil)
1
arc> (next nil)
2

symbol-syntax

Arcの特徴的な機能として、シンボル名がある形だったときに展開されるマクロがあります。
これをsymbol-syntaxと言います。
例えば (car:cdr x) は (car (cdr x)) に展開されます。(コロン「:」がある場合に展開される)

;; 実際は (car (cdr '(1 2 3))) に展開されている。
arc> (car:cdr '(1 2 3))
2

ほかには、たとえば、 ~x は (complement x) に展開されます。

;; 実際は (~no 'a) は ((complement no) 'a) に展開されている。
arc> (if (~no 'a) 'b 'c)
c

ssexpand関数でsymbol-syntaxの展開を確認することができます。

arc> (ssexpand 'abc:def)
(compose abc def)
arc> (ssexpand '~no)
(complement no)

ArcJSの拡張で、symbol-syntaxをユーザーが定義できる機能 defss があります。

試しに、例として、 (caadaar x) や (cadadadadadar x) が car と cdr の連続の式、つまり (car (cdr ... x)) に展開できるようなsymbol-syntaxを定義してみましょう。
以下のようにします。

arc> (defss cxr-ss #/^c([ad]{3,})r$/ (xs)
       (let ac [case _ #\a 'car #\d 'cdr]
         `(fn (x)
            ,((afn (xs) (if xs `(,(ac (car xs)) ,(self (cdr xs))) 'x))
              (coerce (string xs) 'cons)))))
#<tagged special-syntax (#<regex /^c([ad]{3,})r$/> 12 #<fn:cxr-ss>)>

ssexpandで試してみましょう。

arc> (ssexpand 'caaar)
(fn (x) (car (car (car x))))
arc> (ssexpand 'cadadar)
(fn (x) (car (cdr (car (cdr (car x))))))

つまり、 caaar => (fn (x) (car (car (car x)))) になるという事です。
defssは以下のように使います。

(defss symbol-syntaxの名前 マッチする正規表現 正規表現でグルーピングした文字列のシンボルが渡される引数 body)

の順で、s式かシンボルを返すようにします。
では、実際に使ってみます。

arc> (cadddr '(1 2 3 4 5 6))
4

namespace

ArcJSの拡張で、Gaucheのモジュールシステム*4にちょっと似た独自のネームスペースが使えます。
ネームスペースを定義するには(defns)を使用します

arc> (defns A)
#<namespace A>

また、(ns namespace)というスペシャルフォームで、該当ネームスペースに入る事が出来ます。

arc> (ns 'A) ;; この他にもstringやnamespace-objectを取れる。 (ns "A") でもいいし、 (ns (defns A)) でもいい。
#<namespace A>
arc:A> 

見ると分かるように、プロンプトが、arc:A>になり、現在入っているネームスペースが表示されます。

現在のネームスペースを見るには、(***curr-ns***) 関数を使います。

arc:A> (***curr-ns***)
#<namespace A>

ちなみに、この ***...*** のような名前に束縛した場合、ネームスペース関係なく、すべてのネームスペースで同一の値にアクセスできるようになります。

名前をエクスポートするには、

arc> (defns A :export fn1 macro1 fn2)

の様に書きます。こうすると、このネームスペース「A」をインポートしたネームスペースの内部では、fn1 macro1 fn2 にアクセスする事が出来ます。
export節を書かなかった場合は、すべての名前がエクスポートされます。

また、他のネームスペースをインポートするには、

arc> (defns A :import B C)

の様に書きます。このとき、ネームスペースBやCは既に読み込まれていなければなりません。
このとき、BやCの内部でインポートされている名前にはAからはアクセスできません。
Aに明示的にインポートするか、BやCにエクスポートさせてブリッジする必要があります。

さらに、extendを使うと、既にあるネームスペースを拡張する事が出来ます。
extendした場合は、extendされたネームスペースのすべての名前にアクセスできます。

arc> (defns A :extend B)

では、ちょっと軽くやってみましょう。

;; 名前 a, b をエクスポートするネームスペース「A」(以下ns)を定義して入る。
arc> (ns (defns A :export a b))
#<namespace A>
;; 値定義 a = 10, b = 20, c = 30
arc:A> (= a 10 b 20 c 30)
30
;; A をインポートして c をエクスポートする ns「B」を定義して入る。
arc:A> (ns (defns B :import A :export c))
#<namespace B>
;; a, b は A がエクスポートしている a, b なので、それぞれ 10, 20
arc:B> a
10
arc:B> b
20
;; c は 定義もされていないし、Aからエクスポートもされていないので、unbound error
arc:B> c
Error: Unbound variable c
Stack Trace:
_______________________________________

;; ネームスペース指定の symbol-syntax「::」でアクセスできる。
arc:B> A::c
30
;; ns B にも 名前 c を定義。
arc:B> (= c 40)
40
arc:B> c
40
arc:B> B::c
40
;; ns A に戻ると、c は Aに束縛されている c なので 30
arc:B> (ns 'A)
#<namespace A>
arc:A> c
30
;; A と B をインポートした C を作る。
arc:A> (ns (defns C :import A B))
#<namespace C>
;; a, b は A がエクスポートしている a, b なので、それぞれ 10, 20
arc:C> a
10
arc:C> b
20
;; c は B がエクスポートしている c なので、40
arc:C> c
40

こんな感じです。extendは各自試してみてください。

Object System

この他、generic-functionを定義することで、オブジェクト指向っぽい事も出来ますが、
長くなりそうなので、また次の日記で書こうと思います。

*1:Arc自体については以下に作者のポールグレアム氏の記述があります。http://ycombinator.com/arc/tut.txt

*2:このページに行って、run>>を押すと、StackVMが(gcd 77 22)の命令列を実行する様子を見る事が出来る http://smihica.github.io/arc-js/stack_visualizer.html

*3:ブラウザで使う場合はこちらを参照してください http://smihica.github.io/arc-js/

*4:http://practical-scheme.net/gauche/man/gauche-refj_32.html

BoehmGCによる早すぎる解放

展示の為に、まとまった量のArcのコードを書いてglazeで実行したらsegvが頻発した。
調べてみるとまだ使用中のオブジェクトを解放してしまっていたようである。

glazeは環境フレームをstd::vectorにオブジェクトを格納する形で実装していたが、もしかして、
std::vector内は参照不可能と判断されてしまい、collectされてしまうのではないか思い、以下のような実験コードを書いて検証してみた。

#include <stdio.h>
#include <sys/types.h>
#include <vector>
#include <gc.h>
#include <gc_cpp.h>
#include <gc/gc_allocator.h>

class object : public gc_cleanup
{
public:
    object(size_t d) { data = d; };
    ~object() {
        // GCによって回収されるときにプリント
        fprintf(stdout, "destructor called id (%ld)\n", data);
        fflush(stdout);
    };

    size_t data;
};

int main() {
    GC_INIT();

    std::vector<object*> tes = std::vector<object*>();

    object* item;
    size_t i;

    for (i = 0; i < 10000; i++) {
        item = new object(i);
        tes.push_back(item);
    }

    sleep(2);

    return 0;
}
  • コンパイルして実行。
$ g++ gctest.cc -lgc -o gctest
$ ./gctest
...
... 省略
...
destructor called id (8778)
destructor called id (9417)
destructor called id (8910)
destructor called id (8779)
destructor called id (9416)
destructor called id (8909)
destructor called id (8776)
destructor called id (9419)
destructor called id (8908)
destructor called id (8777)
destructor called id (9418)
  • ものの見事に全部GCされてしまっている。

上記現象を調べてみるとBoehmGCはstd::vectorやstd::mapと併用する場合は、
それらの定義時にgc_allocator<>やtraceable_allocator<>などというものを指定する必要があるらしい。

参考:http://osdir.com/ml/programming.garbage-collection.boehmgc/2004-06/msg00014.html

まだあまりうまく理解できていないが、これは参照を知らせるためのものかなにかだろうか??
とりあえず、テストコードを以下のようにしてみた。

#include <stdio.h>
#include <sys/types.h>
#include <vector>
#include <gc.h>
#include <gc_cpp.h>
#include <gc/gc_allocator.h>

class object : public gc_cleanup
{
public:
    object(size_t d) { data = d; };
    ~object() {
        fprintf(stdout, "destructor called id (%ld)\n", data);
        fflush(stdout);
    };

    void print() {
        fprintf(stdout, " %ld", data);
        fflush(stdout);
    }

    size_t data;
};

int main() {
    GC_INIT();

    std::vector<object*, traceable_allocator<object*> > tes =
        std::vector<object*, traceable_allocator<object*> >();

    object* item;
    size_t i;

    for (i = 0; i < 5000; i++) {
        // まず5000個挿入
        item = new object(i);
        tes.push_back(item);
    }

    for (size_t j = 0; j < 2000; j++) {
        // 2000個削除(参照不能にする)
        tes.pop_back();
    }

    for (; i < 10000; i++) {
        // さらに5000個挿入
        item = new object(i);
        tes.push_back(item);
    }

    sleep(2);

    std::vector<object*, traceable_allocator<object*> >::iterator k;
    fprintf(stdout, "(");

    for (k = tes.begin(); k != tes.end(); k++)
    {
        (*k)->print();
    }
    fprintf(stdout, ")\n");

    sleep(2);

    return 0;
}
  • コンパイルして実行。
$ g++ gctest.cc -lgc -o gctest
$ ./gctest
...
... 省略
...
destructor called id (3906)
destructor called id (3907)
destructor called id (3908)
( 0 1 2 3 ...省略... 2997 2998 2999 5000 5001 5002 ...省略... 9997 9998 9999)
  • ちゃんと参照不能としたもの(3000-4999)のみがGCされている。

この結果をもとにglazeの実装も直したらうまく動いた。

問題4.14

  • はてなDiaryの一日の文字数制限なのか、途中できられていたので書き直す。
;;;
;;; util
;;;

(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      #f))

;;;
;;; environment
;;;

;basic-proc
(define the-empty-environment '())
(define enclosing-environment cdr)
(define first-frame car)

;frame-proc
(define (make-frame variables values)
  (cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
  (set-car! frame (cons var (car frame)))
  (set-cdr! frame (cons val (cdr frame))))

;env-proc
(define (extend-environment vars vals base-env)
  (if (= (length vars) (length vals))
      (cons (make-frame vars vals) base-env)
      (if (< (length vars) (length vals))
          (error "Too many arguments supplied -- EXTEND_ENVIRONMENT " vars vals)
          (error "Too few arguments supplied -- EXTEND_ENVIRONMENT " vars vals))))

(define (env-loop null-proc find-proc name var env)
  (define (scan vars vals)
    (cond ((null? vars) (null-proc env))
          ((eq? var (car vars)) (find-proc vals))
          (else (scan (cdr vars) (cdr vals)))))
  (if (eq? env the-empty-environment)
      (error "Unbound variable. -- " name " " var)
      (let ((frame (first-frame env)))
        (scan (frame-variables frame)
              (frame-values frame)))))

(define (lookup-variable-value var env)
  (define (null-proc env)
    (env-loop null-proc find-proc "LOOKUP_VARIABLE_VALUE" var (enclosing-environment env)))
  (define (find-proc vals) (car vals))
  (env-loop null-proc find-proc "LOOKUP_VARIABLE_VALUE" var env))

(define (set-variable-value! var val env)
  (define (null-proc env)
    (env-loop null-proc find-proc "SET_VARIABLE_VALUE!" var (enclosing-environment env)))
  (define (find-proc vals) (set-car! vals val))
  (env-loop null-proc find-proc "SET_VARIABLE_VALUE!" var env))

(define (define-variable! var val env)
  (define (null-proc env) (add-binding-to-frame! var val (first-frame env)))
  (define (find-proc vals) (set-car! vals val))
  (env-loop null-proc find-proc "DEFINE_VARIABLE!" var env))

(define (make-unbound-variable! var env)
  (define (env-loop env)
    (define (scan prev-vars vars prev-vals vals)
      (cond ((null? vars)
             (env-loop (enclosing-envrionment env)))
            ((eq? var (car vars))
             (set-cdr! prev-vars (cdr vars))
             (set-cdr! prev-vals (cdr vals)))
            (else (scan (cdr prev-vars) (cdr vars)
                        (cdr prev-vals) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable. -- MAKE_UNBOUND_VARIABLE! " var)
        (let ((frame (first-frame env)))
          (if (eq? var (car (frame-variables frame)))
              (begin
                (set-car! frame (cdr (frame-variables frame)))
                (set-cdr! frame (cdr (frame-values frame))))
              (scan (frame-variables frame) (cdr (frame-variables frame))
                    (frame-values frame) (cdr (frame-values frame)))))))
  (env-loop env))


;;;
;;; procedures
;;;

(define (make-procedure parameters body env) (list 'procedure parameters body env))
(define (compound-procedure? p) (tagged-list? p 'procedure))

(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))

(define (primitive-procedure? proc) (tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))

(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? (lambda (x) (if (null? x) 'true 'false)))))

(define (primitive-procedure-names)
  (map car primitive-procedures))

(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))

(define (apply-primitive-procedure proc args)
  (apply ;; in underlying scheme
   (primitive-implementation proc) args))


;;;
;;; table
;;;

(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (cdr record)
                  #f))
            #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key-2 value))

                            (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define the-table (make-table))
(define get (the-table 'lookup-proc))
(define put (the-table 'insert-proc!))

;;;
;;; eval
;;;

(define (self-evaluating? exp)
  (cond ((number? exp) #t)
        ((string? exp) #t)
        (else #f)))
(define variable? symbol?)
(define application? pair?)
(define operator car)
(define operands cdr)
(define first-operand car)
(define rest-operands cdr)
(define no-operands? null?)
(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (cons (aeval (first-operand exps) env)
            (list-of-values (rest-operands exps) env))))

(define (aeval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        (else
         (let ((proc (get 'eval (car exp))))
           (if proc
               (proc exp env)
               (if (application? exp)
                   (aapply (aeval (operator exp) env)
                           (list-of-values (operands exp) env))
                   (error "Unknown expression type -- EVAL " exp)))))))

(define (install-eval-package)
  ;; quote
  (define (text-of-quotation exp env) (cadr exp))

  ;; set!
  (define (assignment-variable exp) (cadr exp))
  (define (assignment-value exp) (caddr exp))
  (define (eval-assignment exp env)
    (set-variable-value! (assignment-variable exp)
                         (aeval (assignment-value exp) env)
                         env))

  ;; unbind!
  (define (unbind-variable exp) (cadr exp))
  (define (eval-unbind exp env)
    (make-unbound-variable! (unbind-variable exp) env))

  ;; define
  (define (make-lambda parameters body) (cons 'lambda (cons parameters body)))
  (define (definition-variable exp)
    (if (symbol? (cadr exp))
        (cadr exp)
        (caadr exp)))
  (define (definition-value exp)
    (if (symbol? (cadr exp))
        (caddr exp)
        (make-lambda (cdadr exp)
                     (cddr exp))))
  (define (eval-definition exp env)
    (define-variable! (definition-variable exp)
                      (aeval (definition-value exp) env)
                      env)
    'ok)

  ;; util
  (define (first-exp seq) (car seq))
  (define (rest-exps seq) (cdr seq))
  (define (last-exp? seq) (null? (cdr seq)))

  ;; eval-if
  (define (if-predicate exp) (cadr exp))
  (define (if-consequent exp) (caddr exp))
  (define (if-alternative exp)
    (if (not (null? (cdddr exp)))
        (cadddr exp)
        #f))
  (define (eval-if exp env)
    (if (true? (aeval (if-predicate exp) env))
        (begin
          (display "true pass\n")
          (aeval (if-consequent exp) env))
        (begin
          (display "false pass\n")
          (aeval (if-alternative exp) env))))

  ;; lambda
  (define (lambda-parameters exp) (cadr exp))
  (define (lambda-body exp) (cddr exp))
  (define (eval-lambda exp env)
    (make-procedure (lambda-parameters exp)
                    (lambda-body exp)
                    env))

  ;; begin
  (define (eval-sequence exps env)
    (cond ((last-exp? exps) (aeval (first-exp exps) env))
          (else (aeval (first-exp exps) env)
                (eval-sequence (rest-exps exps) env))))
  (define (begin-actions exp) (cdr exp))
  (define (eval-begin exp env)
    (eval-sequence (begin-actions exp) env))

  ;; cond
  (define (cond-clauses exp) (cdr exp))
  (define (cond-predicate clause) (car clause))
  (define (cond-actions clause) (cdr clause))
  (define (cond-else-clause? clause) (eq? (cond-predicate clause) 'else))

  (define (make-begin seq) (cons 'begin seq))
  (define (sequence->exp seq)
    (cond ((null? seq) seq)
          ((last-exp? seq) (first-exp seq))
          (else (make-begin seq))))

  (define (expand-clauses clauses)
    (if (null? clauses)
        'false
        (let ((first (car clauses))
              (rest (cdr clauses)))
          (if (cond-else-clause? first)
              (if (null? rest)
                  (sequence->exp (cond-actions first))
                  (error "ELSE clause isn't last -- COND->IF " clauses))
              (if (eq? (cadr first) '=>)
                  (let ((sym (gensym)))
                    (list 'let (list (list sym (cond-predicate first)))
                          (list 'if
                                sym
                                (list (caddr first) sym)
                                (expand-clauses rest))))
                  (make-if (cond-predicate first)
                           (sequence->exp action)
                           (expand-clauses rest)))))))

  (define (cond->if exp)
    (expand-clauses (cond-clauses exp)))

  (define (eval-cond exp env)
    (aeval (cond->if exp) env))

  ;; and
  (define (eval-and-sequence exps env)
    (if (null? exps)
        'true
        (if (true? (aeval (first-exp exps) env))
            (eval-and-sequence (rest-exps exps) env)
            'false)))
  (define (eval-and exp env)
    (eval-and-sequence (cdr exp) env))

  ;; or
  (define (eval-or-sequence exps env)
    (if (null? exps)
        'false
        (if (true? (aeval (first-exp exps) env))
            'true
            (eval-and-sequence (rest-exps exps) env))))
  (define (eval-or exp env)
    (eval-or-sequence (cdr exp) env))

  ;; let
  (define (let->combination exp)
    (let ((second (cadr exp)))
      (let ((named? (symbol? second)))
        (let ((bindings (if named? (caddr exp) second))
              (body (if named? (cdddr exp) (cddr exp))))
          (let ((vars (map car bindings))
                (exps (map cadr bindings)))
            (if named?
                (list 'let bindings
                      (append (list 'define (append (list second) vars))
                              body)
                      (append (list second) vars))
                (append (list (append (list 'lambda vars) (cddr exp))) exps)))))))

  (define (eval-let exp env)
    (aeval (let->combination exp) env))

  ;; let*
  (define (let*->nested-lets exp)
    (let ((bindings (cadr exp)))
      (let binds->lets ((binds bindings))
        (if (null? (cdr binds))
            (append (list 'let (list (car binds))) (cddr exp))
            (list 'let (list (car binds))
                  (binds->lets (cdr binds)))))))

  (define (eval-let* exp env) (aeval (let*->nested-lets exp) env))

  ;; do
  (define (do->named-let exp)
    (let ((binds (cadr exp))
          (predicate (caaddr exp))
          (value (car (cdaddr exp)))
          (body (cdddr exp)))
      (let ((var-inits (map (lambda (bind) (list (car bind) (cadr bind))) binds))
            (updates (map caddr binds))
            (iter-name (gensym)))
        `(let ,iter-name ,var-inits
              (if ,predicate
                  ,value
                  (begin
                    ,@body
                    (,iter-name ,@updates)))))))

  (define (eval-do exp env)
    (aeval (do->named-let exp) env))

  (put 'eval 'quote text-of-quotation)
  (put 'eval 'set! eval-assignment)
  (put 'eval 'unbind! eval-unbind)
  (put 'eval 'define eval-definition)
  (put 'eval 'if eval-if)
  (put 'eval 'lambda eval-lambda)
  (put 'eval 'begin eval-begin)
  (put 'eval 'and eval-and)
  (put 'eval 'or eval-or)

  ;; jast a macro
  (put 'eval 'cond eval-cond)
  (put 'eval 'let eval-let)
  (put 'eval 'let* eval-let*)
  (put 'eval 'do eval-do)
)
(install-eval-package)

;;;
;;; apply
;;;

(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (last-exp? seq) (null? (cdr seq)))
(define (eval-sequence exps env)
    (cond ((last-exp? exps) (aeval (first-exp exps) env))
          (else (aeval (first-exp exps) env)
                (eval-sequence (rest-exps exps) env))))

(define (aapply procedure arguments)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment
           (procedure-parameters procedure)
           arguments
           (procedure-environment procedure))))
        (else
         (error "Unknown procedure type -- APPLY " procedure))))

;;;
;;; true? false?
;;;


(define (true? x) (not (eq? x 'false)))
(define (false? x) (eq? x 'false))

;;;
;;; make
;;;

(define (setup-environment)
  (let ((initial-env
         (extend-environment (primitive-procedure-names)
                             (primitive-procedure-objects)
                             ;the-empty-environment
                             '())))
    (define-variable! 'true 'true initial-env)
    (define-variable! 'false 'false initial-env)
    initial-env))

;;;
;;; repl
;;;

(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (let ((output (aeval input the-global-environment)))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))

(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))

(define (announce-output string)
  (newline) (display string) (newline))

(define (user-print object)
  (if (compound-procedure? object)
      (display (list 'compound-procedure
                     (procedure-parameters object)
                     (procedure-body object)
                     '<procedure-env>))
      (display object)))



;;;
;;; running !!
;;;

(define the-global-environment (setup-environment))

(driver-loop)

(define (append x y) (if (null? x) y (cons (car x) (append (cdr x) y))))

(append (quote (a b c)) (quote (d e f)))


;;; 4.14
;; 定義版
(define (map fn lis)
  (if (null? lis)
      '()
      (cons (fn (car lis)) (map fn (cdr lis)))))

(map car (quote ((1 2) (3 4))))
;-> (1 3)

;; プリミティブ版
;; 一度Replを止める。

gosh> (define (map2 fn lis)
        (if (null? lis)
            '()
            (cons (fn (car lis)) (map2 fn (cdr lis)))))

gosh> (define primitive-procedures
        (list (list 'car car)
              (list 'cdr cdr)
              (list 'cons cons)
              (list 'null? (lambda (x) (if (null? x) 'true 'false)))
              (list 'map map2)))

gosh> (define the-global-environment (setup-environment))
gosh> (driver-loop)

;;; M-Eval input:
(map car (quote ((1 2) (3 4))))
*** ERROR: invalid application: ((primitive #<subr car>) (1 2))
Stack Trace:
_______________________________________
  0  fn

  1  (aeval input the-global-environment)
        At line 443 of "(stdin)"


;; mapに渡されてくるのはメタschemeのデータなので、内部でメタschemeのapplyをしてやらねばならない。

4章のメタschemeを参考に、C++でscheme処理系を作る。

  • 大体3000行程度のC++になった。
    • もっとも単純な機能のschemeとなっている。macroやcall/ccはない。GCはboehmGCを使用した。
    • C++で作るにあたって、一番違ったのはreaderとobjectだった。
    • そこらへんを見ると参考になるかも。
  • githubにおいた

問題4.13

(define (make-unbound-variable! var env)
  (define (env-loop env)
    (define (scan prev-vars vars prev-vals vals)
      (cond ((null? vars)
             (env-loop (enclosing-envrionment env)))
            ((eq? var (car vars))
             (set-cdr! prev-vars (cdr vars))
             (set-cdr! prev-vals (cdr vals)))
            (else (scan (cdr prev-vars) (cdr vars)
                        (cdr prev-vals) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable. -- MAKE_UNBOUND_VARIABLE! " var)
        (let ((frame (first-frame env)))
          (if (eq? var (car (frame-variables frame)))
              (begin
                (set-car! frame (cdr (frame-variables frame)))
                (set-cdr! frame (cdr (frame-values frame))))
              (scan (frame-variables frame) (cdr (frame-variables frame))
                    (frame-values frame) (cdr (frame-values frame)))))))
  (env-loop env))

;; unboundされる変数名のコンスペア連結を外して消す。
;; frame の先頭にあった場合のみ、frameのcar部とcdr部を変更するので違う処理が必要。
;; listの中にある場合は、そのコンスを飛ばして下のコンスと接続するようにする。
;; 直近の環境に無ければ、上方の環境をたどりながら探していく。

問題4.12

(define (env-loop null-proc find-proc name var env)
  (define (scan vars vals)
    (cond ((null? vars) (null-proc env))
          ((eq? var (car vars)) (find-proc vals))
          (else (scan (cdr vars) (cdr vals)))))
  (if (eq? env the-empty-environment)
      (error "Unbound variable -- " name " " var)
      (let ((frame (first-frame env)))
        (scan (frame-variables frame)
              (frame-values frame)))))

(define (lookup-variable-value var env)
  (define (null-proc env)
    (env-loop null-proc find-proc "LOOKUP_VARIABLE_VALUE" var (enclosing-environment env)))
  (define (find-proc vals) (car vals))
  (env-loop null-proc find-proc "LOOKUP_VARIABLE_VALUE" var env))

(define (set-variable-value! var val env)
  (define (null-proc env)
    (env-loop null-proc find-proc "SET_VARIABLE_VALUE!" var (enclosing-environment env)))
  (define (find-proc vals) (set-car! vals val))
  (env-loop null-proc find-proc "SET_VARIABLE_VALUE!" var env))

(define (define-variable! var val env)
  (define (null-proc env) (add-binding-to-frame! var val (first-frame env)))
  (define (find-proc vals) (set-car! vals val))
  (env-loop null-proc find-proc "DEFINE_VARIABLE!" var env))