r-statistics-fanの日記

統計好きの現場の臨床医の覚書のようなもの

頭脳王:三山崩しの「逆型」をRで解く。更に高速化一般化

頭脳王:三山崩しの「逆型」

学生時代の旧友よりメールが来た。
数学に関しては私にとっては神様のような方で、学生時代には
よく自作の数学問題を披露してくれたりして、楽しんだものだ。懐かしい。

旧友によると、三山崩しに関しては非「逆型」の必勝法は数理ゲームの理論では
基本に類するそうです。「逆型」でも,三山崩しに関しては,大差はないそうです。

更に面白い問題も教えていただきました

##ゲーム(*)
・黒白2色の碁石がそれぞれいくつかある状態からスタート.
・交互に石を取る.ただし,
「黒だけを任意個数」「白だけを任意個数」「黒白を任意の同数」
のいずれかの取り方だけが可能.
最後の石を取った方が勝ち.(逆型では負け.)

この必勝法はいかに。
##

そして、今回拙ブログを見てR言語に初挑戦したそうです。
素朴に三山崩しの「逆型」を解析するコードを書いてみたそうです。(下記f1())
R言語ははじめて触るのに、なんかもうすでにこの時点で100倍以上高速。
清々しいほどにぶっちぎりです。
expand.gridの並びの性質を最大限利用して余計な論理判断を省いている
すばらしいコードです。正直、はじめは何でこれで正確な解になるのかが
分かりませんでした。

expand.gridの並びは行ナンバーAの局面を考えると、駒を取れば、
必ずX<Aとなる局面Xに移行するから、これでも良いわけですね。
しびれる~。本当に楽しい。

そして、evalを使って、expand.gridの行を一般化する手法を例示した後の
コードがf2()です。
更に余計な論理判断を省いてコードが短くなっています。
本当に短い!更に速い!

なお、このようなコーディングは、業務用では落第点らしいです。

それにしてもC言語の素養はあるとはいえ、ちょっとかじっただけで
これほどのコードを作ってしまうとは。いやー、楽しい。


以下コード

#f1 rをはじめて触った友人の初回コード勝手にfunction化したので一部改変
f1 <- function(m=3, n=10){## m = 色の数 # n = 各色の駒数の上限
x <- as.matrix(expand.grid(0:n,0:n,0:n,0)) ## 考察対象の列挙
## 最後の成分は,0: 未考察 1:必勝形 2:必敗形
x[1,m+1] <- 2 ## (0,0,0) にした人の負け
## 1手で変形できる必勝形があれば必敗,なければ必勝.
for (i in 1:nrow(x)) {
      y <- x[i,]; if (y[m+1]==0) {## 1つの局面を取り出し,まだ未考察なら,
            x[i,m+1] <- 1+any(x[,m+1]==1 & ## 必勝形で,なおかつ,
                                    ## 取り出した局面から1手で移行できるものを探す.
                                    ## あれば必敗,なければ必勝
                                    ((x[,1]==y[1] & x[,2]==y[2] & x[,3]<y[3]) |
                                           (x[,1]==y[1] & x[,3]==y[3] & x[,2]<y[2]) |
                                           (x[,2]==y[2] & x[,3]==y[3] & x[,1]<y[1])))}}
## この記述だと,山が増えると非常にめんどうになりますが,
## 言語をまだよく知らないので,とりあえずこれで...
return(subset(x,subset=x[,m+1]==1)[,1:m]) ## 得られた必勝形を表示
}

#f2 rをはじめて触った友人のコードVer2 勝手にfunction化したので一部改変
f2 <- function(M=3, N=10){ ## m = 色の数 # n = 各色の駒数の上限
x <- as.matrix(eval(parse(text = paste("expand.grid(",
                                       paste(rep("0:N", M), sep="", collapse=","), ",0)", sep=""))))
x[1,M+1] <- 2
for (i in 1:nrow(x)) {y <- x[i,]
                      if (y[M+1]==0) {x[i,M+1] <- y[M+1] <- 1
                                      x[i,M+1] <- 1+any(rowSums(!!(t(t(x)-y)))==1)}}
return(subset(x,subset=x[,M+1]==1)[,1:M]) ## 得られた必勝形を表示
}

#自分のコード
f3 <- function(n=10){ # n = 駒の最大数
dat <- expand.grid(0:n,0:n,0:n)
dat <- dat[-1,]
nr <- nrow(dat)
row.names(dat) <- seq_len(nr)

flag2 <- flag <- numeric(nr)
flag3 <- 0
dat <- as.matrix(dat)

flag[apply(dat, 1, function(x) sum(x)==1)] <- 1 #flag1=win、1,0,0を相手に渡すと勝利確定 flag=2は負け確定 flag=0は未定

tsugi <- function(x){   #次に考えられる組合せ
      if (x[1]==0){
            temp1 <- NULL
      }else{
            temp1 <- expand.grid(0:(x[1]-1), x[2], x[3])
      }
      if (x[2]==0){
            temp2 <- NULL
      }else{
            temp2 <- expand.grid(x[1], 0:(x[2]-1), x[3])
      }
      if (x[3]==0){
            temp3 <- NULL      
      }else{
            temp3 <- expand.grid(x[1], x[2], 0:(x[3]-1))
      }
      return(rbind(temp1, temp2, temp3))
}

mae <-  function(x){   #前に考えられる組合せ
      if (x[1] == n){
            temp1 <- NULL
      }else{
            temp1 <- expand.grid((x[1]+1):n, x[2], x[3])
      }
      if (x[2] == n){
            temp2 <- NULL
      }else{
            temp2 <- expand.grid(x[1], (x[2]+1):n, x[3])
      }
      if (x[3] == n){
            temp3 <- NULL      
      }else{
            temp3 <- expand.grid(x[1], x[2], (x[3]+1):n)
      }
      return(rbind(temp1, temp2, temp3))
}

same <- function(y){
      which(apply(dat, 1, function(x) all(x == y)))
}

while(sum(flag==0) != 0){
      cat(sum(flag==0),"st")
      if (sum(flag == 1 & flag2 == 0) != 0){
            make.check <- dat[(flag == 1 & flag2 == 0),]
            flag2[flag == 1] <- 1
            temp1 <- NULL
            for (i in seq_len(nrow(make.check))){
                  temp1 <- rbind(temp1, mae(make.check[i,])) 
            }
            temp1 <-  as.matrix(unique(temp1, 1, incomparables = FALSE))
            for (i in seq_len(nrow(temp1))){
                  flag[apply(dat, 1, function(x) all(x == temp1[i,]))] <- 2
            }
      } ##ここまで絶対負けのチェック
      
      if (sum(flag==0) != 0){  #未確定が残っていれば
            temp3 <- dat[flag == 0,] #未確定のもの
            cat(sum(flag==0),"make", temp3[1,])
            for (k in seq_len(nrow(temp3))){
                  temp4 <- tsugi(temp3[k,])
                  if( all(flag[apply(temp4, 1, same)]  == 2)){  #次がすべて負の場合
                        flag[same(temp3[k,])] <- 1 #勝ちフラグ達成
                  }
            } 
      }
}

return(dat[flag==1,])  ##勝ち
}

library(rbenchmark)
benchmark(f1(n=5), f2(N=5), f3(n=5), replications = 10)

#       test replications elapsed relative user.self sys.self user.child sys.child
#1 f1(n = 5)           10    0.26    1.857      0.26     0.00         NA        NA
#2 f2(N = 5)           10    0.14    1.000      0.14     0.00         NA        NA
#3 f3(n = 5)           10   40.52  289.429     40.17     0.01         NA        NA
#1 f1,f2=友人 f3=自分

旧友0.14秒と自分45.2秒。圧倒的な差ですね。
しかもnが増えるとますます差が開くという。