X-ceter-Oの解析

scheme

サークルの後輩の話を聞くと、あるボードゲームの必勝法を探索するという課題が出たらしい。調べてみるとボードゲームはX-Ceter-Oという名前で、非常に単純な拡張をTic-Tac-Toeに施したものとなっている。遊び方は以下の動画。

1〜6の数字が書かれた6つのコマを使い、奇数が○、偶数が×となっている。
制約として、

  • これ以上のコマは無い。×も○も同時に3個までしか盤面上に存在できない
  • 一列にそろえると勝利
  • 消去する順番は限られている。何もコマが無い状態から始め、1から順番にコマを移動させていく(よって手番は交互になる)。

簡単に言えば、常に2手先を読んで相手がリーチを作るのを阻害しつつ、"最も新しいコマとリーチを作る"ように動かす必要が有る。
このゲームが興味深いのは、とりうる局面は十分に小さいという点。つまり、

mosh>(* 9 8 7 6 5 4)
60480
mosh>(* 6 60480)
362880

６種類のコマを9個のマスに置く方法ということから、盤面の状態は60480通りしかなく、"どのコマを動かすことが出来るか"という状態の6種類をあわせて、362880通りしか無い。ゲーム開始からコマが6つ置かれるまで　はとりあえず考えない。実は先手はコマが5個の状態で勝利する可能性が有るが、後手が人間的に指せばこのようなことはおきない。
もっとクレバーな方法も考えられるが、とりあえず簡単なプログラムをschemeで書いて、必勝局面を探索してみると両者ともにある程度存在するように思える。

50 :: [x 14021] [y 14469] / [m 10858] [u 21024]
50 :: [x 15946] [y 14512] / [m 9867] [u 20056]
50 :: [x 16312] [y 15399] / [m 10246] [u 18420]
50 :: [x 17196] [y 14596] / [m 11134] [u 17460]
50 :: [x 16014] [y 16503] / [m 11353] [u 16466]
50 :: [x 16906] [y 15120] / [m 11937] [u 16373]

最初の行は、先手が1を動かす場面から"先手が確実に勝利する経路が存在する局面"が14021通ある事を示す。ただこれは帰りの電車で適当に書いたプログラムなので多分何か間違っている。たぶん相手が人間的に指すであろうことを考慮していないのは重大な問題だろう。
アルゴリズムとしては、

  • すべての盤面を列挙(60480×6のベクタ) - gen-seq
  • すべての盤面の勝敗を算出 - ckwin
  • 盤面の移動可能性リストを作る - mknex
  • そのリストの転置リストを作る - mkinx
  • 両方が勝利しているケース*1を除外 - init
  • どちらか片方が勝利している盤面にフラグ(先手と後手の2種類)を立てる
  • 変化がおきなくなるまで繰り返す :
    • フラグが立っている盤面に移動できる盤面にもフラグを立てる
    • 先手と後手の両方にフラグが立っている場合はmixフラグ(m)を立てる

ゲームの完全な解析は非常に興味深いが、本題は、このプログラムはmoshで何故か異常に遅く、ypsilonだと常識的な速度で動作すること。以前のAO benchのケースでも長大なベクタを使っていたという共通点があるが。。
ypsilonは初期ヒープが限られている。デフォルトの64MBでは足りないので、このプログラムの場合は--heap-limit=256くらいにしておく。
こういう目的でちょっと使える言語処理系を何か一つ見つけておくべきだと思う。個人的にはこの目的のためにCやRubyを使っていたが、今はすっかりschemeでやるようになった。

(import (rnrs)
        (srfi :48))

(define x-side '(1 3 5))
(define y-side '(2 4 6))

(define (put-label l)
  (define (put-label-itr l x cur)
    (if (pair? l)
      (put-label-itr (cdr l) (+ 1 x) (cons (cons x (car l)) cur))
      cur))
  (put-label-itr l 0 '()))

(define (mkvector l)
  (define len (length l))
  (let ((v (make-vector len)))
    (for-all (lambda (x) (vector-set! v (car x) (cdr x))) l)
    v))

(define (expl v)
  (define (ex l)
    (define v (make-vector 9 'sp))
    (define (ex-itr x cur)
      (if (pair? cur)
        (begin
          (vector-set! v (car cur) x)
          (ex-itr (+ x 1) (cdr cur)))
        v))
    (ex-itr 1 l))
  (vector-map ex v))

(define (gen-seq)
  (define ret-list '())
  (define (push-list x) (set! ret-list (cons x ret-list)))
  (define (depth-itr cur rest l)
    (if (and (> 6 (length l))(pair? cur))
      (let ((top (car cur)))
        (depth-itr (append (cdr cur) rest) '() (cons top l))
        (depth-itr (cdr cur) (cons top rest) l))
      (if (not (pair? rest)) (push-list l))))
  (depth-itr '(0 1 2 3 4 5 6 7 8) '() '())
  (expl (mkvector (put-label ret-list))))

(define win-list
  (list
    '#(x x x s s s s s s) ;H
    '#(s s s x x x s s s)
    '#(s s s s s s x x x)

    '#(x s s x s s x s s) ;V
    '#(s x s s x s s x s)
    '#(s s x s s x s s x)

    '#(x s s s x s s s x) ;C
    '#(s s x s x s x s s) ))

(define (ckwin side v)
  (define (sim v)
    (define (re x)
      (if (member x side) 'x 's))
    (vector-map re v))
  (define (ck v)
   (if (member (sim v) win-list) #t #f))
  (vector-map ck v))

(define (countwin v)
  (fold-left (lambda (cnt x) (if x (+ cnt 1) cnt)) 0 (vector->list v)))

(define (mknex v)
  (define nums (vector 1 2 3 4 5 6))
  (define (mkknockout v a) ; make knocked out vector
    (vector-map (lambda (i) (if (or (eq? 'sp i) (= a i)) 'sp i)) v))
  (define (clean v)
    (define (check i l)
      (cond
        ((not (= 4 (length l))) (error (list i l)))
        ((not (memq i l) (error (list i l))))
        (else (remv i l))))
    (let ((len (vector-length v)))
      (do ((i 0 (+ i 1)))
        ((= i len))
        (vector-set! v i (check i (vector-ref v i)))))
    v)

  (define (findsame v)
    (let* ((len (vector-length v))
          (h (make-hashtable equal-hash equal? len)))
      (display "enter..")(display len)(newline)
      (do ((i 0 (+ i 1)))
        ((= i len))
        (hashtable-update! h (vector-ref v i) (lambda (c) (cons i c)) '()))
      (display "map..")(newline)
      (clean (vector-map (lambda (e) (hashtable-ref h e '())) v))))
  (let ((kv (vector-map (lambda (a)
                           (display a)(newline)
                           (vector-map (lambda (b)
                                         (mkknockout b a)) v)) nums)))

    (vector-map findsame kv)))

(define (mkinx v)
  (define (proc v)
    (display "trans...")(newline)
    (let* ((len (vector-length v))
           (tv (make-vector len '())))
      (do ((i 0 (+ i 1)))
        ((= i len))
        (for-each (lambda (o)
                    (vector-set! tv o (cons i (vector-ref tv o))))
                  (vector-ref v i)))
      tv))
  (vector-map proc v))


(let* ((v (gen-seq))
          (len (vector-length v))
          (vx (ckwin x-side v))
          (vy (ckwin y-side v))
          (nx (mknex v))
          (inx (mkinx nx)))
         (define (init)
           (vector-map (lambda (ex ey)
                         (cond
                           ((and ey (not ex)) 'yfinish)
                           ((and ex (not ey)) 'xfinish)
                           ((and ex ey) 'invalid)
                           (else 'undef))) vx vy))
         (define (displaystat x lines)
           (define (displaystat1 line)
             (define (count f l)
               (fold-left (lambda (cnt c)
                            (if (member c l) (+ cnt 1) cnt))
                          0 f))
             (let* ((lline (vector->list line))
                    (cntx (count lline '(xfinish xprocess)))
                    (cnty (count lline '(yfinish yprocess)))
                    (cntm (count lline '(mix)))
                    (cntu (count lline '(undef))))
               (format #t "~a :: [x ~a] [y ~a] / [m ~a] [u ~a] ~%"
                       x cntx cnty cntm cntu)))
           (vector-for-each displaystat1 lines)(newline))

         (define (itr x line)
           (define (circ v)
             (define (vr i) (vector-ref v i))
             (vector (vr 5) (vr 0) (vr 1) (vr 2) (vr 3) (vr 4)))
           (define (xp? s) (or (eq? s 'xfinish) (eq? s 'xprocess)))
           (define (yp? s) (or (eq? s 'yfinish) (eq? s 'yprocess)))
           (define (x? s) (or (xp? s) (eq? s 'mix)))
           (define (y? s) (or (yp? s) (eq? s 'mix)))
           (define (nline)
             (define (step v1 v0 vi)
               (define vn (make-vector len))
               (define (touch! i l p? sym)
                 (for-each (lambda (o)
                             (vector-set! vn o
                                          (if (p? (vector-ref vn o))
                                            'mix sym))) l))
               (do ((i 0 (+ i 1)))
                 ((= i len))
                 (let ((s (vector-ref v0 i))
                       (f (vector-ref vi i)))
                   (vector-set! vn i (vector-ref v1 i))
                   (cond
                     ((xp? s) (touch! i f y? 'xprocess))
                     ((yp? s) (touch! i f x? 'yprocess)))))
               vn)
             (vector-map step line (circ line) inx))

           (displaystat x line)
           (if (= x 50)
             line
             (itr (+ x 1) (nline))))

         (define (analyze line) line)
         (display len)(newline)
         (display (countwin vx))(newline)
         (display (countwin vy))(newline)
         (analyze (itr 0 (vector (init) (init) (init) (init) (init) (init)))))

*1:ゲームのルール上同時に勝利することは無い。つまり、片方が勝利した瞬間に移動を終了するはずが、さらに移動したということを示す。