Scheme on JavaScript でオセロゲーム

javascript scheme

動機

先日、JavaScript 界にその名をとどろかす、かの id:amachang にお会いする機会に恵まれた。amachang は、評判どおり、やさしく礼儀正しい好青年であった。最近、私は Gauche を勉強していて、その流れで amachang が作った JavaScript で動く Scheme の話になった。いろいろ教えていただいたので、そのささやかなお礼に、amachang の作った Scheme 風処理系のうえで、私が Gauche のために書いた簡単なオセロゲームのプログラムを走らせてみた。

謝辞

まずは Scheme on JavaScript を作ってくれた amachang に感謝します。ソースコードはわかりやすかった。言語実装者の気分がちょっぴり味わえて楽しかった。

あとはオセロゲームのアルゴリズムを解説しているこのサイトにも大変お世話になっております。非常に整理されたアルゴリズムだと思う。

遊び方

このプログラムは Firefox 2.0 以上で動作する。IE や Safari では動かないようだ。

まずはここをクリック。

Scheme on JavaScript でオセロゲーム

コンピュータとの対戦ゲームである。人間は黒石である。オセロ盤をクリックすると石を置くことができる。Scheme on JavaScript は非常に遅くて、たぶん反応が返ってくるのに数秒はかかるので、忍耐強く待ってほしい。このプログラムは先読みもできるのだが、スピード優先のため、あえてその機能を封印している。そのため、たいしてコンピュータは賢くないけれども、どうかご容赦を。

Scheme on JavaScript の改造点

スコープがらみのバグの修正にずいぶん時間がとられた。オセロゲームのプログラム自体の移植にはそれほど時間はかからなかった。

  • Firefox 2.0 で動くようにした。（オリジナルは Firefox 3.0 以上のみ)
  • いくつかの機能の追加 (cond, not, 単項マイナス, vector 等)
  • バグフィックス(let でスコープの扱いが正しくなかった（ぽい）等々 数点)
  • ";" から始まる行をコメントとみなす
  • 小カッコ () のかわりに 中カッコ [] も同じように使えるようにした
  • eval() の回数をなるべく減らして、パフォーマンス向上に努めた。（それでも遅いけど)

amachang も言っているとおり、構文解析は厳密ではないし、エラー処理もほとんどないけれども、Gauche 用に作ったプログラムが、わずかな修正で動いたのには感動した。Scheme かわいいよ Scheme。（修正したのは、主に CGI => クライアント側プログラムにする部分と、car/cdr を使ったリスト操作を vector 操作に置き換えた部分)

ソースコード

Scheme 本体 (JavaScript 部分)
// Scheme on JavaScript
// The code below is based on amachang's work. Special thanks to him!
// http://d.hatena.ne.jp/amachang/20080120/1200850505
// http://amachang.art-code.org/scheme/

var tokenize = function(source) { return source.replace(/^\s*;.*$/gm, "").match(/\"(?:[^"])*\"|\|[^\|]*\||(\)|\(|\[|\]|\s+|[^\(\)\[\]\s]+)/gm).filter(/^[^\s]/); } 

var parse = function(tokens) {
    var list = [], token;
    while ((token = tokens.shift()) && token != ')' && token != ']')
        list.push((token == '(')         ? parse(tokens) :
        					(token == '[')         ? parse(tokens) :	
                  (token[0] == '"')      ? token.substring(1, token.length - 1) :
                  (token.match(/^-?\d/)) ? window.eval(token) :
                  new Symbol(token));
    return list;
};

var scope = function(proto) { 
	return { __proto__: proto };
};

var Symbol = function(name) { this.name = name.match(/^\|/) ? name.substring(1, name.length - 1) : name };
Symbol.prototype.toString = function() { return this.name; }

var SpecialForm = function(fn) { fn.special = true; return fn };

var ev = function(o, _) {
    if (o instanceof Array) {
        var fn = ev(o[0], _);
        var args = o.slice(1);
        return fn.apply(_, fn.special ? args : args.map(function(a) { return ev(a, _); }));
    }
    else if (o instanceof Symbol) return _[o];
    else return o;
};

var define = SpecialForm(function() {
    var islambda = arguments[0] instanceof Array;
    var symbol = islambda ? arguments[0][0] : arguments[0];
    var value = islambda ?
        lambda.apply(this, [arguments[0].slice(1)].concat(Array.slice(arguments, 1))) : arguments[1];
    return this[symbol] = ev(value, this);
});

var jsspform = function(___source) {
		var func = window.eval(___source);
		return SpecialForm(function() {
    		return func.apply(this, arguments);
    });
};

var jslambda = function(___source) {
		var func = window.eval(___source);
		return function() {
    		return func.apply(this, arguments);
    };
};

window.evalLisp = function(source) {
    var list = parse(tokenize(source));
    for (var i = 0; i < list.length; i ++) ev(list[i], window);
}

function init() {
    window.parse = parse;
    window.tokenize = tokenize;
    window.scope = scope;
    window.define = define;
    window.jsspform = jsspform;
    window.ev = ev;
    var library = document.getElementById('library').firstChild.nodeValue;
    evalLisp(library);
}

window.onload = function() {
	init();
	evalLisp(document.getElementById('code').firstChild.nodeValue);
};

var printBuffer = "";
Scheme ライブラリ部
(define #t 1)
(define #f 0)

(define -> (jsspform "function(self, prop) {
    var self = ev(self, this), prop = self[prop];
    return (typeof prop == 'function') ?
        function() { return prop.apply(self, arguments) } :
        prop
}"))

(define if (jsspform "function(cond, t, f) { return ev(cond, this) ? ev(t, this) : ev(f, this); }"))

(define cond (jsspform "function() {
	var i;
	for(i = 0; i < arguments.length; i++) {
		var cond = arguments[i][0];
		var expr = arguments[i][1];
		if(cond instanceof Symbol && cond.name == 'else') {	
			return ev(expr, this);
		} else if(ev(cond, this)) {
			return ev(expr, this);
		}
	}}"))

(define set! (jsspform "function(symbol, value) {
    var scp = this;

    do {
        if (scp.hasOwnProperty(symbol.name)) {
            scp[symbol] = ev(value, this);
            return 0;
        }
    } while (scp = scp.__proto__);
}"))

(define lambda (jsspform "function() {
    var args = Array.shift(arguments);
    var exprs = arguments;
    var pscope = this;
    return function() {
            var _ = scope(pscope);
            for (var i = 0; i < args.length; i ++) _[args[i]] = arguments[i];
            for (var i = 0; i < exprs.length; i++) var r = ev(exprs[i], _);
            return r;
    };
}"))

(define let (jsspform "function() {
    var pairs = Array.shift(arguments), ps = [], vs = [];
    pairs.forEach(function([p, v]) { ps.push(p); vs.push(v) });
    Array.unshift(arguments, ps);
    var list = [lambda.apply(this, arguments)].concat(vs);
    return ev(list, this);
}"))

(define begin (jslambda "function() {  
	return arguments[arguments.length - 1];
}"))

(define + (jslambda "function() {
    var result = arguments[0];
    for (var i = 1; i < arguments.length; i ++) result += arguments[i];
    return result
}"))

(define - (jslambda "function() {
		if (arguments.length == 1) return -arguments[0];
    var result = arguments[0];
    for (var i = 1; i < arguments.length; i ++) result -= arguments[i];
    return result
}"))

(define / (jslambda "function() {
    var result = arguments[0];
    for (var i = 1; i < arguments.length; i ++) result /= arguments[i];
    return result
}"))

(define * (jslambda "function() {
    var result = arguments[0];
    for (var i = 1; i < arguments.length; i ++) result *= arguments[i];
    return result
}"))

(define =       (jslambda "function(a, b) { return a == b ? 1 : 0; }"))
(define <       (jslambda "function(a, b) { return a < b ? 1 : 0 }"))
(define >       (jslambda "function(a, b) { return a > b ? 1 : 0 }"))
(define <=       (jslambda "function(a, b) { return a <= b ? 1 : 0 }"))
(define >=       (jslambda "function(a, b) { return a >= b ? 1 : 0 }"))
(define expt    (jslambda "function(a, b) { return Math.pow(a, b) }"))
(define or      (jslambda "function(a, b) { return a || b ? 1 : 0 }"))
(define and     (jslambda "function(a, b) { return a && b ? 1 : 0 }"))
(define not     (jslambda "function(a) { return !a }"))

(define display (jslambda "function(a) {
    document.getElementById('log').appendChild(document.createTextNode(a + '\n'));
    return a;
}"))

(define message (jslambda "function(a) {
    document.getElementById('message').innerHTML = a;
}"))

(define print (jslambda "function(a) {
	printBuffer += a;
}"))

(define flush (jslambda "function() {
    document.getElementById('monitor').innerHTML = printBuffer;
    printBuffer = '';
}"))

(define make-vector (jslambda "function() {
	return new Array();
}"))

(define vector-ref (jsspform "function(a, n) {
	return this[a][ev(n, this)];
}"))

(define vector-set! (jsspform "function(a, n, v) {
	return this[a][ev(n, this)] = ev(v, this);
}"))

(define vector-push! (jsspform "function(a, v) {
	return this[a].push(ev(v, this));
}"))

(define vector-pop! (jsspform "function(a) {
	return this[a].pop();
}"))

(define string-append (jslambda "function() {
	var res = [];
	for(var i = 0; i < arguments.length; i++) {
		res.push(arguments[i]);
	}
	return res.join('');
}"))

(define x->string (jslambda "function(a) {
	return new String(a);
}"))
オセロゲーム・プログラム
;;; Othello
;;; Written by Eiji Sakai in April 2008
;;; Algorithm is based on http://hp.vector.co.jp/authors/VA015468/platina/algo/

(define BLANK 0)
(define BLACK 1)
(define WHITE 2)
(define WALL 3)
(define A1 (+ 1 (* 1 9)))
(define H1 (+ 8 (* 1 9)))
(define D4 (+ 4 (* 4 9)))
(define E4 (+ 5 (* 4 9)))
(define D5 (+ 4 (* 5 9)))
(define E5 (+ 5 (* 5 9)))
(define A8 (+ 1 (* 8 9)))
(define H8 (+ 8 (* 8 9)))
(define N 10000)

(define (repeat from to proc)
  (cond [(>= from to) #f]
	[else (begin
		(proc from)
		(repeat (+ 1 from) to proc))]))

(define (while-do pred proc)
  (if (pred) (begin
	       (proc)
	       (while-do pred proc))))

; declare the othello board
(define ban (make-vector 91))

(define stack (make-vector))

(define (stack-push! elt)
  (vector-push! stack elt))

(define (stack-pop!)
  (vector-pop! stack))

(define (ban-init)
  (repeat 0 91 (lambda (i)
		 (vector-set! ban i WALL)))
  (repeat 1 9 
	  (lambda (i)
	    (repeat 1 9 
		    (lambda (j)
			      (vector-set! ban (+ (* i 9) j) BLANK)))))
  
  (vector-set! ban D4 BLACK)
  (vector-set! ban E4 WHITE)
  (vector-set! ban D5 WHITE)
  (vector-set! ban E5 BLACK)
)

(define (ban-display-cell value pos)
  (let ((f (cond [(= value WHITE) "white.jpg"]
     [(= value BLACK) "black.jpg"]
     [else "blank.jpg"])))
    (string-append "<A HREF='javascript:evalLisp(%22(on-board-click " (x->string pos) ")%22)'><IMG SRC='" f "' BORDER='0'/></A>")))

(define (ban-display)
  (let ((pos 0))
  (print "<TABLE BORDER='1'>")
  (repeat 1 9 
    (lambda (y)
      (print "<TR>")
      (repeat 1 9
        (lambda (x)
          (print "<TD>")
          (set! pos (+ (* y 9) x))
          (print (ban-display-cell (vector-ref ban pos) pos))
          (print "</TD>")))
      (print "</TR>")))
  (print "</TABLE>")
  (flush)))

(define (adverse-color color)
  (cond [(= color WHITE) BLACK]
  [(= color BLACK) WHITE]
  [else color]))

(define (ban-eval color)
  (let ((ev 0)
  (adv-color (adverse-color color))
  (m 0)
  (v 0))
    (repeat 1 9 
      (lambda (y) 
        (repeat 1 9 
          (lambda (x)
      (set! m (+ (* y 9) x))
      (set! v 
            (cond [(= m A1) 4]
            [(= m A8) 4]
            [(= m H1) 4]
            [(= m H8) 4]
            [else 1]))
      (set! ev (cond [(= (vector-ref ban m) color) (+ ev v)]
            [(= (vector-ref ban m) adv-color) (- ev v)]
            [else ev]))))))
    ev))
    
 (define (flip-line color m dir)
  (let ((i 0)
        (n (+ m dir))
        (adv-color (adverse-color color)))
    (while-do [lambda () (= (vector-ref ban n) adv-color)]
        (lambda () (set! n (+ n dir))))
    (cond [(= (vector-ref ban n) color)
     (begin
       (set! n (- n dir))
       (while-do [lambda () (not (= n m))]
           (lambda () 
       (vector-set! ban n color)
       (stack-push! n)
       (set! n (- n dir))
       (set! i (+ i 1))))
       i)]
    [else 0])))

(define (undo color)
  (let ((n (stack-pop!)))
    (vector-set! ban (stack-pop!) BLANK)
    (repeat 0 n
      (lambda (_) 
        (vector-set! ban (stack-pop!) (adverse-color color))))))

(define (flip color m)
  (let ((n 0))
  (cond [(= (vector-ref ban m) BLANK)
   (begin 
     (set! n (+ n (flip-line color m -10)))
     (set! n (+ n (flip-line color m -9)))
     (set! n (+ n (flip-line color m -8)))
     (set! n (+ n (flip-line color m -1)))
     (set! n (+ n (flip-line color m 1)))
     (set! n (+ n (flip-line color m 8)))
     (set! n (+ n (flip-line color m 9)))
     (set! n (+ n (flip-line color m 10)))
     (if (> n 0)
         (begin
     (vector-set! ban m color)
     (stack-push! m)
     (stack-push! n)))
     n)]
  [else 0])))

(define (mm-max t)
  (let ((max (- N))
  (m 0)
  (n 0)
  (v 0))
    (cond [(= t 0) (ban-eval WHITE)]
    [else 
     (repeat 1 9
       (lambda (y)
         (repeat 1 9
           (lambda (x)
             (set! m (+ (* y 9) x))
             (set! n (flip WHITE m))
             (if (> n 0)
           (begin
             (set! v (mm-min (- t 1)))
             (undo WHITE)
             (if (> v max) (set! max v))))))))])
    max)) 

(define (mm-min t)
  (let ((min N)
  (m 0)
  (n 0)
  (v 0))
    (cond [(= t 0) (ban-eval WHITE)]
    [else 
     (repeat 1 9
       (lambda (y)
         (repeat 1 9
           (lambda (x)
             (set! m (+ (* y 9) x))
             (set! n (flip BLACK m))
             (if (> n 0)
           (begin
             (set! v (mm-max (- t 1)))
             (undo BLACK)
             (if (> v min) (set! min v))))))))])
    min))    

(define (choose-cell)
  (let ((max (- N))
  (m 0)
  (n 0)
  (v 0)
  (m-at-max 0))
    (repeat 1 9
      (lambda (y)
        (repeat 1 9
          (lambda (x)
      (set! m (+ (* y 9) x))
      (set! n (flip WHITE m))
      (if (> n 0)
        (begin
          (set! v (mm-min 0))
          (undo WHITE)
          (if (> v max) 
            (begin
               (set! max v)
               (set! m-at-max m)))))))))
    m-at-max))

(define MSG "Your turn.")

(define (on-board-click m)
  (message "Please wait... The computer is thinking of the next move.")
 	((-> window setTimeout) 
 		(lambda ()
  		(let ((n 0))
  	   (set! n (flip BLACK m))
  	   (if (> n 0)
  	 			(begin
  	 			  (set! m (choose-cell))
  	   			(set! n (flip WHITE m))
  	        (ban-display)))
  	   (message MSG))) 
  	100))

(define (start-game)
	(message MSG)
	(ban-init)
	(ban-display))
	
(start-game)