頭脳王：三山崩しの「逆型」を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が増えるとますます差が開くという。
