r-statistics-fanの日記

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

多人数でババ抜きをすると何ターンかかるか(訂正)

多人数でババ抜きをすると何ターンかかるか(訂正)

ばば抜きのシミュレーション - 裏 RjpWikiさんの記事のお陰で、間違いが見つかった。

訂正版を記載する。

 

今回も非常に勉強になった。blogをはじめて本当に良かった。

 

それにしても、一から作りなおしたほうが楽じゃないかと思った。

デバッグって辛い作業ですな。でも、一から作りなおしたのでは

勉強にならないので頑張りました。

 

裏 RjpWikiさんでのcheck()とか、しびれました。from-toの変数導入も目からうろこ。

 

## ばば抜き##

baba <- function(n) {
    # n人数
    ct <- 0  #カウント
    tp <- c(rep( (1:13), 4), 14)
    tp <- sample(tp, replace = FALSE)  #シャッフル
    x <- as.list(NULL)  #各人で枚数が異なるのでlistにした

    for (i in 1:n) {
        lll <- seq(i, (i + n * ( (53 - i)%/%n)), n)  #i番目の人のカード
        x[[i]] <- tp[lll]
    }

    for (i in length(x):1) {
        # 除外するときに1行減ってズレるので数を減らす方向で回す
        y <- table(x[[i]])
        y <- y[(y != 2)]  #2枚同じもの消す
        y <- y[(y != 4)]  #4枚同じもの消す
        y <- as.integer(names(y))
        if (length(y) == 0) {
            x[[i]] <- NULL  #完全に消えたものは除外
        } else {
            x[[i]] <- y
        }
    }

    # ここまででまずは初期状態

    tori <- function(x, j) {
        # xのj番目でペアが出来たものを消す、NAも消す、終了も消す
        temp <- table(x[[j]])
        temp <- temp[(temp != 2)]
        temp <- as.integer(names(temp))
        if (length(temp) == 0) {
            return(NULL)
        } else {
            x[[j]] <- temp
        }
        return(x[[j]])
    }

    toren <- 0
    while (length(x) >= 2) {
        # 2人以上残ってる時に
        for (j in length(x):1) {
            if (length(x) == 1) {
                break
            }
            ct <- ct + 1  #カウンター
            if (toren == 1) {
                toren <- 0  #取るはずの人があがったら取れないルール
                next
            } else if (j == 1) 
                {
                  # 1番目の人は最後の人が引くので例外処理
                  get <- sample(length(x[[1]]), 1)  #ここも間違い
                  x[[length(x)]] <- c(x[[length(x)]], x[[1]][[get]])  #ここも間違い
                  if (is.null(tori(x, length(x)))) {
                    toren <- 1
                    x[[length(x)]] <- tori(x, length(x))
                    x[[1]][get] <- NA
                    x[[1]] <- tori(x, 1)
                    next
                  } else {
                    x[[length(x)]] <- tori(x, length(x))
                    x[[1]][get] <- NA
                    x[[1]] <- tori(x, 1)
                    next
                  }

                }  #1番目の人の例外処理終
 else {
                get <- sample(1:length(x[[j]]), 1, replace = FALSE)
                x[[j - 1]] <- c(x[[j - 1]], x[[j]][[get]])
                x[[j]][get] <- NA
                x[[j]] <- tori(x, j)
                if (is.null(tori(x, j - 1))) {
                  toren <- 1
                  x[[j - 1]] <- tori(x, j - 1)
                } else {
                  x[[j - 1]] <- tori(x, j - 1)
                  next
                }
            }
        }
    }
    return(ct)
}

niter <- 100
res <- matrix(0, niter, nrow = 53)

library(tcltk)

for (l in 2:53) {
    pb <- txtProgressBar(min = 1, max = 53, style = 3)
    setTxtProgressBar(pb, l)
    for (k in 1:niter) {
        res[l, k] <- baba(l)
    }
}

res_med <- apply(res, 1, median)
plot(res_med)

 

max(res_med)
## [1] 676.5
which(res_med == max(res_med))
## [1] 53

改訂版でも、53回が一番多くのターン数がかかる。
そして、その中央値は677回だ。

15 * median(res[26, ])/60  #1施行15秒で計算
## [1] 60
median(res[26, ])
## [1] 240

26人の場合、1ターン15秒だと60分/240ターンかかる。
hist(res[26, ], col = "blue", main = "26babanuki", freq = FALSE)

 


編集の都合で別の乱数になってしまうが > quantile(xx,c(0.025,0.975)) 2.5% 97.5% 134.975 394.025 > sum(xx <= 187) [1] 204

187ターンは20%タイルくらいになる。普通の範囲だ。