Fastest finger first

早押しクイズ

早押しクイズが毎回最終問で決着する、ということは確率的にはないはずですが、実際にはどれくらいのでしょうか。

前提条件

• 解答者はN人である
• 早押しなので、ある問題は解答者のうち、誰か一人だけが正解する。簡単な問題ばかりなので、すべての問題は誰かが正解するとする。
• どの解答者がどのクイズに正解する確率も、独立で等しい(1/N)
• 誤答によるペナルティは無いとする

勝利条件

クイズをQ問出し(Qはあらかじめ分かっている)、最も多くの問題を正解した解答者が勝ちとする。

延長戦

Q問終了時点で、最もたくさん正解した解答者が複数いる場合、それらの解答者に追加の一問を出して解いた者を勝ちとする。

打ち切り

Q問終了前に、ある解答者が残りの問題を一問も解けず、その他すべての解答者のうち一人が残りの問題を全問解いたとしても解答数が届かないとする。その時点で、最多解答者を勝ちとする。

これはプロ野球日本シリーズで4勝2敗になったら、第7戦を開催しないのと同じである。

非効率的な解法

Q問それぞれをN人の誰かが解いたという順列、つまりQ^N通りについて調べる。コードは簡潔だが指数オーダーなので、とても時間が掛かる。それでも10問3人なら以下の通り、すぐに結果が出る。4割の確率で、最終問より前に勝敗が決まる。

6:0.00412 7:0.07407 8:0.13443 9:0.18351 10:0.43103 11:0.17284

-- 早押しクイズは何問目で決着するか
import Data.List
import Text.Printf
import System.Environment (getArgs)

-- n人目の正解数を1増やす
-- 0人目は、誰も正解できなかった場合とする
addScore scores 0 = scores
addScore scores n = f scores n
  where f (x:xs) 0 = (x + 1) : xs
        f (x:xs) i = x : f xs (i - 1)

-- 正解者を順に取り出し、何問目で決着したかを返す
-- 奇数問で2人なら、最終問で決着がつかないということはない
nextTurn [] _ turn = turn
nextTurn (x:xs) scores turn = if win then turn else nextTurn xs nextScore (turn + 1)
  where nextScore = addScore scores x
        sortedScores = reverse $ sort nextScore
        win = (sortedScores!!0 - sortedScores!!1) > (length xs)

-- 正解者の全順列から、何問目で決着することが何回あるかを集計する
-- それぞれの順列の結果を畳み込んだ方がメモリ使用量が少なくて済むはずだがそうはしていない
allTurns q n = map f $ groupBy (==) $ sort $ map g panelists
    where f xs = (head xs, length xs)
          g xs = nextTurn xs initialScores 1
          initialScores = replicate (n + 1) 0
          panelists = sequence $ replicate q [1..n]

-- 何問目で決着することがどれくらいあるか確率を集計する
probabilities :: Int -> Int -> [(Int, Double)]
probabilities q n = map (\(x,len) -> (x, fromIntegral(len) / total)) ps
  where ps = allTurns q n
        total = fromIntegral $ sum $ map snd ps

-- 何問目で決着することがどれくらいあるか確率を求めて文字列にする
solve q n = concatMap f $ probabilities q n
  where f x = show (fst x) ++ printf ":%.5f " (snd x)

-- コマンドライン引数を解析する。第一引数=問題数、第二引数=解答者数
paramSet (q:n:_) = (read q::Int, read n::Int)
paramSet (q:_) = (read q::Int, 2)
paramSet _ = (10, 3)

main = do
  args <- getArgs
  let (q,n) = paramSet args
  putStrLn $ solve q n