[心得] 拼磚計數
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}
要怎麼用Mathematica枚舉? 戴老師有言既然是Mathematica那就盡量別用procedural
programming，而是MM特色的functional programming
既然是 funcion 配合遞歸 首先要先預想 f 的形式
argument f[{1,2,3,4}]
output f[list_List] = f[{1,2,3,4}] = {{1->2, 3->4}, {1->3, 2->4}}
f[{1,2}] = {{1->2}} 這裡要注意正確的List層數
然後開始湊 expressions，過程省略只貼成果^^
Clear[f];
(*長度是奇數一定會錯誤，先排除*)
f[list_List]/;EvenQ[Length@list]:= If[Length@list==2,{{Rule@@list}},
(*遞歸跳出點*)
(*兩層List提醒您：代碼裡處處的用意需超級明白*)
Flatten[ (* <-這個flatten我也是糾錯糾好久才發現是必須，而且只能放這裡*)
Table[
Prepend[#, First@list->list[[i]] ]& /@ f[ Drop[list,{i}][[2;;]] ]
,{i,2,Length@list}]
,1] (* <- 而且flatten的參數必須是1，約略是饒過一層不壓的意思*)
]
測試一下
In[]:= Length@f[Range[12]]
Out[]:= 10395
其實就是說總共有 11 x 9 x 7 x 5 x 3 = 10395 種選法，result checked!
接下來要排除旋轉對稱的情形
說實在這部分方法就非常醜陋了，不得不用While
a = SortBy[#, First] & /@ f[Range[12]]; (* 先排序以求表達一致 *)
b = {};
Dynamic[{Length@a, Length@b}] (* 監看用 *)
While[a != {}, p0 = First@a; b = Append[b, p0];
a = Complement[a, (* 由a中扣掉五種轉動方法*)
DeleteDuplicates@
Map[SortBy[#, First] &,
NestList[ReplaceAll[#, x_Integer -> Mod[x + 2, 12, 1]] &, p0, 5]
/. (p_ -> q_) /; p > q -> (q -> p)]
]
]
(* 轉動一次= 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!
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 140.112.125.32
※ 編輯: jurian0101 來自: 140.112.213.88 (09/27 03:02)
討論串 (同標題文章)
Mathematica 近期熱門文章
PTT數位生活區 即時熱門文章
-4
30