高校数学の質問スレ（医者・東大卒専用） Part438 (991ﾚｽ)
上下前次1-新
抽出解除 必死ﾁｪｯｶｰ(本家) (べ) 自ID ﾚｽ栞 あぼーん
ﾘﾛｰﾄﾞ規制です｡10分ほどで解除するので､他のﾌﾞﾗｳｻﾞへ避難してください｡
108(2): １３２人目の素数さん [sage] 2024/08/21(水)08:28 ID:trPnwZW4(1/6)
>>106
で、３Dグラフの動画はまだできんのだが？
110: １３２人目の素数さん [sage] 2024/08/21(水)10:42 ID:trPnwZW4(2/6)
>>107
レスありがとうございます。
コードを解読しました。
(* a 人でジャンケンして参加者が b 人になる確率,a==b ならアイコ *)
p[a_,b_]:=p[a,b]=If[a==b,1-(2^a-2)/3^(a-1),Binomial[a,b]/3^(a-1)]
m=11;
(* 参加者数の変遷を列挙 *)
f=Flatten[Table[{m,m-x1,m-x2,m-x3,m-x4,m-x5,m-x6,m-x7,m-x8,m-x9,1},
{x1,0,m-1},{x2,x1,m-1},{x3,x2,m-1},{x4,x3,m-1},{x5,x4,m-1},
{x6,x5,m-1},{x7,x6,m-1},{x8,x7,m-1},{x9,x8,m-1}],8];
(* 変遷確率積の総和*)
Total[Product[p[#[[k]],#[[k+1]]],{k,1,10}] & /@f]
% // N
正しいように思いますので自分のコードのデバッグ作業に移ります。
111: １３２人目の素数さん [sage] 2024/08/21(水)11:14 ID:trPnwZW4(3/6)
デバッグして、数値が合致しました。
Wolfram Language 14.0.0 Engine for Microsoft Windows (64-bit)
Copyright 1988-2023 Wolfram Research, Inc.
In[1]:= (* jan[n_,m_] := n 人でジャンケンして参加者が m 人になる確率 *)
In[2]:= jan[n_,m_] := (
If[m==0 || m>n, Return[0]];
If[m==n,1 - 3*(2^n-2)/3^n,3*Binomial[n,m]/3^n]
)
In[3]:= n=11;
In[4]:= (* 10回以下で終了する確率*)
In[5]:= Total@Flatten@Table[jan[n,x1]jan[x1,x2]jan[x2,x3]jan[x3,x4]jan[x4,x5]jan[x5,x6]jan[x6,x7]jan[x7,x8]jan[x8,x9]jan[x9,1]
,{x1,1,n},{x2,1,x1},{x3,1,x2},{x4,1,x3},{x5,1,x4},{x6,1,x5},{x7,1,x6},{x8,1,x7},{x9,1,x8}]
449687340186660888579056289638229806808082
Out[5]= -------------------------------------------
2909321189362570808630465826492242446680483
112: １３２人目の素数さん [sage] 2024/08/21(水)11:27 ID:trPnwZW4(4/6)
(* 各回ごとの確率 *)
pn={jan[n,1]};
Total@Flatten@Table[jan[n,x1]jan[x1,1],{x1,2,n}]//AppendTo[pn,#]&;
Total@Flatten@Table[jan[n,x1]jan[x1,x2]jan[x2,1],{x1,2,n},{x2,2,x1}]//AppendTo[pn,#]&;
Total@Flatten@Table[jan[n,x1]jan[x1,x2]jan[x2,x3]jan[x3,1],{x1,2,n},{x2,2,x1},{x3,2,x2}]//AppendTo[pn,#]&;
Total@Flatten@Table[jan[n,x1]jan[x1,x2]jan[x2,x3]jan[x3,x4]jan[x4,1],{x1,2,n},{x2,2,x1},{x3,2,x2},{x4,2,x3}]//AppendTo[pn,#]&;
Total@Flatten@Table[jan[n,x1]jan[x1,x2]jan[x2,x3]jan[x3,x4]jan[x4,x5]jan[x5,1],{x1,2,n},{x2,2,x1},{x3,2,x2},{x4,2,x3},{x5,2,x4}]//AppendTo[pn,#]&;
Total@Flatten@Table[jan[n,x1]jan[x1,x2]jan[x2,x3]jan[x3,x4]jan[x4,x5]jan[x5,x6]jan[x6,1],{x1,2,n},{x2,2,x1},{x3,2,x2},{x4,2,x3},{x5,2,x4},{x6,2,x5}]//AppendTo[pn,#]&;
Total@Flatten@Table[jan[n,x1]jan[x1,x2]jan[x2,x3]jan[x3,x4]jan[x4,x5]jan[x5,x6]jan[x6,x7]jan[x7,1],{x1,2,n},{x2,2,x1},{x3,2,x2},{x4,2,x3},{x5,2,x4},{x6,2,x5},{x7,2,x6}]//AppendTo[pn,#]&;
Total@Flatten@Table[jan[n,x1]jan[x1,x2]jan[x2,x3]jan[x3,x4]jan[x4,x5]jan[x5,x6]jan[x6,x7]jan[x7,x8]jan[x8,1],{x1,2,n},{x2,2,x1},{x3,2,x2},{x4,2,x3},{x5,2,x4},{x6,2,x5},{x7,2,x6},{x8,2,x7}]//AppendTo[pn,#]&;
Total@Flatten@Table[jan[n,x1]jan[x1,x2]jan[x2,x3]jan[x3,x4]jan[x4,x5]jan[x5,x6]jan[x6,x7]jan[x7,x8]jan[x8,x9]jan[x9,1],{x1,2,n},{x2,2,x1},{x3,2,x2},{x4,2,x3},{x5,2,x4},{x6,2,x5},{x7,2,x6},{x8,2,x7},{x9,2,x8}]//AppendTo[pn,#]&
Total@pn
113(1): １３２人目の素数さん [sage] 2024/08/21(水)11:44 ID:trPnwZW4(5/6)
シミュレーションによる検証
Wolfram Language 14.0.0 Engine for Microsoft Windows (64-bit)
Copyright 1988-2023 Wolfram Research, Inc.
In[1]:= j[n_] :=( (* n人でジャンケンして勝者が決まるまでの回数と勝者の数*)
count=0;
Until[Length@Union@a==2,a=RandomChoice[Range[3],n];count++];
b=Sort@Union@a;
If[b=={1,2}, winners=Count[a,2]];
If[b=={2,3}, winners=Count[a,3]];
If[b=={1,3}, winners=Count[a,1]] ;
{winners,count}
)
In[2]:=
In[2]:= sim[n_] :=((* 勝者が一人になるまでの回数 *)
For[{winner,counts}=j[n],winner>1k=j[winner];winner=k[[1]];counts=counts+k[[2]]];
counts
)
In[3]:= res11=Table[sim[11],10^6];
In[4]:= Histogram[res11,"Scott","PDF"]
Out[4]= -Graphics-
In[5]:= Mean[res11] // N
Out[5]= 34.9504
In[6]:= Median[res11]
Out[6]= 27
In[7]:= N@Mean@Boole[#<=10&/@res11]
Out[7]= 0.154785
In[8]:= 449687340186660888579056289638229806808082/2909321189362570808630465826492242446680483
449687340186660888579056289638229806808082
Out[8]= -------------------------------------------
2909321189362570808630465826492242446680483
In[9]:= % // N
Out[9]= 0.154568
117(4): １３２人目の素数さん [sage] 2024/08/21(水)17:57 ID:trPnwZW4(6/6)
>>115
Flattenの使い方とか熟練者のコード解析は勉強になる。
上下前次1-新書関写板覧索設栞歴
ｽﾚ情報 赤ﾚｽ抽出 画像ﾚｽ抽出 歴の未読ｽﾚ AAｻﾑﾈｲﾙ
ぬこの手 ぬこTOP 0.035s