（元ネタは http://okajima.air-nifty.com/b/2011/01/2011-ffac.html を参照のこと）
思考の順番に書いてるのでそのまま。超効率悪いのは文系情弱の証である。
リスト操作だけでなんとかしようと頑張ってたらまるまる2時間かかったよ……
（当初、不当な仮定を置いて考えていたせいで、6連鎖までは正しいのにそこで
連鎖が止まってしまうという絶妙な罠にハマって数十分浪費した辺りが実にダメ）
０．フィールド全体を相互に連結したぷよの集合の集合に排他的に分割したい！
１．まず各ぷよごとにそれを基点とした5近傍内での局所的な連結集合を作る。
２．この各ぷよ毎の局所的な連結集合を更に連結して大域的な連結集合にしたい。
３．積が空集合でない連結集合同士は相互に連結しているので和を取ればいいよね。
４．総ての局所的な連結集合の間でこの操作をすれば分割の出来上がり。
これができれば、要素数が4以上の連結集合に属するぷよが消滅してその他のぷよが生存、となる。
あとの作業は自明。しかし、書いてしまえばたったこれだけのことを表現するのにやたら時間が……
我ながら文系情弱ぶりを遺憾なく発揮するにもほどがあるというか……
こんなコードでも0.035sとかで実行できるので速度的にはまずまずか。
PuyoPuyoSeries.hs
module Main where
import Data.List
import Data.Ord
data Colour = R | G | Y | E
deriving (Ord, Eq)
instance Show Colour where
show R = "R"
show G = "G"
show Y = "Y"
show E = " "
type Position = (Int,Int)
type Cell = (Position, Colour)
type Field = [Cell]
width = 6
depth = 13
given :: [[Colour]]
given =[[G,G,G,R,Y,Y,Y,G,Y,R,G,R,E],
[R,R,R,Y,R,G,G,Y,G,Y,Y,Y,E],
[Y,Y,Y,G,R,Y,Y,R,Y,G,G,Y,G],
[G,G,G,Y,G,R,R,Y,R,Y,Y,G,Y],
[Y,Y,Y,G,R,Y,Y,R,Y,R,R,Y,R],
[R,R,R,G,G,R,R,G,G,G,R,G,R]]
fromDoubleList :: [[Colour]] -> Field
fromDoubleList dl = [((x,y), (pad dl)!!(x-1)!!(y-1)) |x<-[1..width],y<-[1..depth]]
where
pad [] = []
pad (x:xs) = (take depth $ x ++ (repeat E)) : pad xs
toDoubleList :: Field -> [[Colour]]
toDoubleList asoc =
take width $ map (take depth) $ iterate (drop depth) $
map (lookupColour asoc) [(x,y)|x<-[1..width],y<-[1..depth]]
lookupColour :: Field -> Position -> Colour
lookupColour asoc key = case lookup key asoc of
Just x -> x
Nothing -> E
sameColourNeighbours :: Field -> Position -> [Position]
sameColourNeighbours f p@(x,y) =
filter (hasSameColour p) [(x-1,y),(x+1,y),(x,y-1),(x,y+1),(x,y)]
where hasSameColour p1 p2 =
lookupColour f p1 /= E && lookupColour f p2 /= E &&
(lookupColour f p1)==(lookupColour f p2)
sameColourCells :: Field -> Cell -> [Cell]
sameColourCells f (p@(x,y), c) = filter ((`elem` (sameColourNeighbours f p)).fst) f
-- 上下左右の近傍で同色のもののリストの各セルごとのリストを縮約して
-- 連結しているセルの集団ごとのリストを作る
groups :: Field -> [[Cell]]
groups f = reduce $ groups' f f
where groups' f [] = []
groups' f (c:cs) = (sameColourCells f c): groups' f cs
-- リストの各要素の間で交差が空でないもの同士を合併して縮約
reduce [] = []
reduce (x:xs) = case (and $ map null $ map (intersect x) xs) of
True -> x : reduce xs
False -> reduce (unionWithIntersectibles x xs)
-- リスト(y:ys)の要素に対して、xと交差する要素についてxを合併する
unionWithIntersectibles x [] = []
unionWithIntersectibles x (y:ys) = case intersect x y of
[] -> y : (unionWithIntersectibles x ys)
_ -> (union x y) : (unionWithIntersectibles x ys)
-- 連結しているセルの集団の数が4未満ならそれらの集団のセルは生残する
survival :: Field -> Field
survival = concat . filter ((<4).length) . groups
-- 二重リストに戻してEセルをフィルターすればそれで落下・消去処理ができる
erase :: Field -> Field
erase = fromDoubleList . map (filter (/=E)) . toDoubleList
-- 与えられたフィールド状態の次のフィールド状態を返す
step :: Field -> Field
step = erase. survival
-------------
-- 近傍を再帰的に探索していくヴァージョン（0.075sとこちらの方が少し遅い）
linkedcells :: Field -> Cell -> [Cell]
linkedcells f c = foldl union [] (findpath f c)
findpath :: Field -> Cell -> [[Cell]]
findpath f c = fpath f [] c
where fpath f p c = case (sameColourCells f c)\\(c:p) of
[] -> [(c:p)]
_ -> concat $ map (fpath f (c:p)) ((sameColourCells f c)\\(c:p))
survival' f = filter ((<4).length.linkedcells f) f
step' = erase. survival'
-------------
main = do
putStrLn ""
sequence $ map printfield $ take 20 $ iterate step $ fromDoubleList given
return ()
-------------
printfield :: Field -> IO ()
printfield [] = putStrLn ""
printfield f = do
let flist = reverse $ transpose $ toDoubleList f
putStrLn "\n\"\"\"\"\"\"\"\""
printlist flist
where
printlist [] = putStrLn "\"\"\"\"\"\"\"\""
printlist (l:ls) = (print $ concat $ map show l) >> (printlist ls)
--------------
一応出力結果
""""""""
" GYRR"
"RYYGYG"
"GYGYRR"
"RYGYRG"
"YGYRYG"
"GYRYRG"
"YGYRYR"
"YGYRYR"
"YRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" YRR"
"R GGYG"
"G GYRR"
"R GYRG"
"YGYRYG"
"GYRYRG"
"YGYRYR"
"YGYRYR"
"YRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" RR"
"R YYG"
"G YRR"
"R YRG"
"YGYRYG"
"GYRYRG"
"YGYRYR"
"YGYRYR"
"YRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" R"
"R RG"
"G RR"
"R RG"
"YGYRYG"
"GYRYRG"
"YGYRYR"
"YGYRYR"
"YRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" "
"R R"
"G G"
"R G"
"YGYRYG"
"GYRYRG"
"YGYRYR"
"YGYRYR"
"YRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" "
"R "
"G "
"R "
"YGYRY "
"GYRYRR"
"YGYRYR"
"YGYRYR"
"YRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" "
"R "
"G "
"R "
"YGYR "
"GYRYY "
"YGYRY "
"YGYRY "
"YRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" "
"R "
"G "
"R "
"YGY "
"GYRR "
"YGYR "
"YGYR "
"YRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" "
"R "
"G "
"R "
"YG "
"GYY "
"YGY "
"YGY "
"YRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" "
"R "
"G "
"R "
"Y "
"GG "
"YG "
"YG "
"YRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" "
" "
"R "
"G "
"R "
"Y "
"Y "
"Y "
"YRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" "
" "
" "
" "
" "
" "
"R "
"G "
"RRRGRG"
"RYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" "
" "
" "
" "
" "
" "
" "
" "
"R GRG"
"GYGYGG"
"GRYGYR"
"GRYGYR"
"GRYGYR"
""""""""
""""""""
" "
" "
" "
" "
" "
" "
" "
" "
" GRG"
" YGYGG"
" RYGYR"
" RYGYR"
"RRYGYR"
""""""""
""""""""
" "
" "
" "
" "
" "
" "
" "
" "
" GRG"
" GYGG"
" YGYR"
" YGYR"
" YYGYR"
""""""""
""""""""
" "
" "
" "
" "
" "
" "
" "
" "
" GRG"
" YGG"
" GYR"
" GYR"
" GGYR"
""""""""
""""""""
" "
" "
" "
" "
" "
" "
" "
" "
" RG"
" GG"
" YR"
" GYR"
" YYR"
""""""""
""""""""
" "
" "
" "
" "
" "
" "
" "
" "
" G"
" G"
" R"
" RR"
" GGR"
""""""""
""""""""
" "
" "
" "
" "
" "
" "
" "
" "
" "
" "
" "
" G"
" GGG"
""""""""
""""""""
" "
" "
" "
" "
" "
" "
" "
" "
" "
" "
" "
" "
" "
""""""""