Re: [心得] 拼磚計數

看板Mathematica作者chungyuandye (養花種魚數月亮賞星星)時間12年前 (2012/09/27 11:12)推噓1(1推 0噓 1→)

留言2則, 2人參與討論串2/2 (看更多)

※ 引述《jurian0101 (Hysterisis)》之銘言： : Entanglement是一個線上拼磚遊戲，目的是用一些畫有路線的六角形磚拼出最長的路線 : 可以連上遊戲網址看看它長怎樣 : http://entanglement.gopherwoodstudios.com/ : 可以發現各式六角磚非常多采多姿，所以我想枚舉有哪些六角磚 : 首先固定方位並把邊緣12個連線點加上1~12的記號 : 1 2 : 12 __ __ 3 : 11 ／＼ 4 : ／＼ : 10 ＼／ 5 : 9 ＼__ __／ 6 : 8 7 : 一種合法的拼磚例如 {1->2, 3->4, 5->6, 7->8, 9->10, 11-> 12} : (* 轉動一次= x_Integer -> Mod[x+2 ,12, 1] : 用NestList一共轉5次，連同未轉有六個位向 : /. (p_->q_) /;p>q -> (q->p) 的部分是把頭大尾小的連線調過來 : DeleteDuplicate 其實不必要，反正用Complement求差一樣是很慢，算debug方便 : 或是可以得知某config旋轉後的重數 *) : 最後得到總共有 1799種獨特的六角磚 Length@b= 1799 : 求結果檢查，3Q : Quest done! Clear[f]; f[list_List]/;EvenQ[Length@list]:= If[Length@list==2,{{Rule@@list}}, Flatten[Table[ Prepend[#,First@list->list[[i]]]&/@ f[Drop[list,{i}][[2;;]]],{i,2,Length@list}],1]] a=SortBy[#,First]&/@f[Range[12]];b={}; test=AbsoluteTiming@While[a!={},p0=First@a;b=Append[b,p0]; a=Complement[a,DeleteDuplicates@Map[SortBy[#,First]&, NestList[ReplaceAll[#,x_Integer->Mod[x+2,12,1]]&,p0, 5]/.(p_->q_)/;p>q->(q->p)]]]; f1[list_,n_]:=Block[{test},test=Min@Complement[Range[n],Flatten@list]; Flatten@{list,test,#}&/@ Complement[Range[n],Flatten[{list,test}]]]; f2[n_]:=Nest[Flatten[Map[f1[#,n]&,#],1]&,{1,#}&/@Range[2,n], n/2-1]; f3[mylist_List]:=Flatten[SortBy[#,First]]&/@ Map[Sort,Partition[#,2]&/@ NestList[#/.x_->Mod[x+2,12,1]&,mylist,5],{2}] data=f2[12]; ans=AbsoluteTiming@Quiet@Block[{temp},NestWhile[ (temp=Complement[#[[1]],f3[#[[1,1]]]];{temp, Insert[#[[2]],temp[[1]],-1]})&,{data,{}}, Length[#1[[1]]]>=1&,1] ]; (* 計算時間，個數 *) {First@test,Length@b} {7.288530, 1799} {ans[[1]],Length@ans[[2, -1]]} {2.893731, 1799} -- 養花種魚數月亮賞星星 http://chungyuandye.twbbs.org -- ※ 發信站: 批踢踢實業坊(ptt.cc) ◆ From: 218.173.131.71