四字熟語パズルの作成
Posted feedbacks - Haskell
重複のないデータ(熟語数8312)を使いました 漢字のエンコーディングはUTF8 実行結果 % time ./75 < 4moji.data 一切即一 擲 了 百 百 万夫不当 一切即一 擲 人 百 当 万万千千 一切即一 擲 切 百 衆 万死一生 ……途中略…… 白雲孤飛 馬 短 非 流 馬痩毛長 一日不食 琴 馬 一 解 鶴翼之囲 一箪之食 琴 馬 一 解 鶴翼之囲 総数 12109 個 ./75 < 4moji.data 169.67s user 0.57s system 97% cpu 2:55.13 total
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | module Main (main) where
import Data.List
import qualified System.IO.UTF8 as U
eqapp f x y = f x == f y
cmpapp f x y = f x `compare` f y
starling f g x = f x (g x)
main = listing . starling (,) length . rings . starling (,) (map reverse) . lines
=<< U.getContents
listing (ws,len) = mapM_ (U.putStrLn . showRing) ws
>> U.putStrLn ("総数 "++show len++" 個")
showRing [p,q,r,s] = unlines $ [p,f 1 q r,f 2 q r, s]
where f i x y = (r !! i):(" "++[q !! i])
rings = concatMap ring . comb 2
. groupBy (eqapp (head . snd)) . sortBy (cmpapp (head . snd))
. uncurry followings
followings xss yss = [(reverse ys,xs) | xs <- xss, ys <- yss, head xs == head ys]
ring [pqs,rss] = [[p,q,r,s] | (p,q) <- pqs, (r,s) <- rss
, head p == head r && last q == last s && uniq [p,q,r,s]]
uniq [] = True
uniq (x:xs) = notElem x xs && uniq xs
comb 0 _ = [[]]
comb _ [] = []
comb n (x:xs) = map (x:) (comb (n-1) xs) ++ comb n xs
|
Haskellでは文字列が文字の配列ではなくリストなので，文字列を辿る回数を 極力減らさないと遅くなる． この問題では熟語の最後の文字を参照するときに文字列を辿ることになる． そこで反転した文字列を使って尻取りペアを作るようにしてた．ところが 途中で元に戻したり，尻取りペア同志を比べるときに結局最後の要素まで 文字列を辿ったりして，元の黙阿弥だった．orz 最初に四字熟語の文字列を自分自身とその反転とのペアにするようにした． これで速くなるはず． ついでに，Data.Setを使って裏返し重複も除くようにしたら 12109 個だった 解が 12107 個になった． 実行結果は以下のとおり．実行時間は39秒とかなり改善された． 一切即一 上 切 一 衆 下化衆生 一切即一 上 念 一 化 下化衆生 一切即一 所 上 懸 一 命令一下 ……途中省略…… 阿諛追随 爺 侯 下 之 頷下之珠 雲壌懸隔 合 岸 霧 観 集中砲火 雲壌懸隔 屯 岸 霧 観 集中砲火 総数 12107 個
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | module Main (main) where
import Data.List
import qualified Data.Set as S
import qualified System.IO.UTF8 as U
-- small utilities
eqapp f x y = f x == f y
cmpapp f x y = f x `compare` f y
starling f g x = f x (g x)
uniq [] = True; uniq (x:xs) = notElem x xs && uniq xs
comb 0 _ = [[]]; comb _ [] = []; comb n (x:xs) = map (x:) (comb (n-1) xs) ++ comb n xs
-- Types
type AString = (String,String)
newtype Ring = Ring [String]
instance Eq Ring where
Ring xs == Ring ys = sort xs == sort ys
instance Ord Ring where
Ring xs `compare` Ring ys = sort xs `compare` sort ys
-- Main
main :: IO ()
main = listing . starling (,) S.size
. rings . map (starling (,) reverse)
. lines =<< U.getContents
listing :: (S.Set Ring, Int) -> IO ()
listing (ws,len)
= mapM_ (U.putStrLn . showRing) (S.toList ws) >> U.putStrLn ("総数 "++show len++" 個")
showRing :: Ring -> String
showRing (Ring [p,q,r,s])
= unlines $ [p,f 1 q r,f 2 q r,s]
where f i x y = (r !! i):" "++[q !! i]
rings :: [AString] -> S.Set Ring
rings = S.fromList
. map Ring
. concatMap ring
. comb 2
. groupBy (eqapp (head . fst . snd))
. sortBy (cmpapp (head . fst . snd))
. followings
followings :: [AString] -> [(AString,AString)]
followings xss = [(xs,ys) | xs <- xss, ys <- xss, head (snd xs) == head (fst ys)]
ring :: [[(AString,AString)]] -> [[String]]
ring [pqs,rss]
= [pqrs | (p,q) <- pqs, (r,s) <- rss, let pqrs = map fst [p,q,r,s]
, head (fst p) == head (fst r) && head (snd q) == head (snd s) && uniq pqrs]
|
コードを書いているうちにお題の次の部分に引っかかった．
「右上隅の漢字と左下隅の漢字は異なるものでなければなりません」
この制限は，たぶん
無憂無風
憂 林
無 火
風林火山
のような自明な解を排除しようとしたものではないかと思いますがどうでしょう？
ただ，上の制限では
雲合霧集
屯 腋
霧 成
集翠成裘
のような自明ではない解が排除されてしまいます．
これがいかにも残念なので，上の制限を勝手に(^^;)次のように変更してお題を
解きなおしてみました．
「4つの四字熟語はすべて異なるものでなければなりません」
また，お題の冒頭には
「与えられた四字熟語のリストから下のように四角く配置することのできる
熟語の組み合わせを探すプログラムを作成してください」
のように「組み合わせ」を求めよということなので，
#('一切即一' '一読三嘆' '一唱三嘆' '嘆息嗟嘆')
#('一切即一' '一唱三嘆' '一読三嘆' '嘆息嗟嘆')
などは同じ組み合わせであると見なすことにしました．
結果は以下のとおり．解は 14479 組でした．
(#3695でruckerさんが示したアルゴリズムを使ったらずいぶん速くなり 2.5 秒でした．)
一上一下
切 化
即 衆
一切衆生
一上一下
切 化
即 衆
一念化生
一切即一
所 上
懸 一
命令一下
……途中省略……
雲合霧集
壌 中
懸 砲
隔岸観火
雲壌懸隔
屯 岸
霧 観
集中砲火
雲合霧集
屯 腋
霧 成
集翠成裘
総数 14479 個
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | module Main (main) where
import Data.List
import qualified Data.Set as S
import qualified System.IO.UTF8 as U
-- small utilities
eqapp f x y = f x == f y
cmpapp f x y = f x `compare` f y
starling f g x = f x (g x)
uniq [] = True; uniq (x:xs) = notElem x xs && uniq xs
comb 0 _ = [[]]; comb _ [] = []; comb n (x:xs) = map (x:) (comb (n-1) xs) ++ comb n xs
-- Types
type AString = (String,String)
newtype Ring = Ring [String]
instance Eq Ring where
Ring xs == Ring ys = sort xs == sort ys
instance Ord Ring where
Ring xs `compare` Ring ys = sort xs `compare` sort ys
-- Main
main :: IO ()
main = listing . starling (,) S.size
. rings . map (starling (,) reverse)
. lines =<< U.getContents
listing :: (S.Set Ring, Int) -> IO ()
listing (ws,len)
= mapM_ (U.putStrLn . showRing) (S.toList ws) >> U.putStrLn ("総数 "++show len++" 個")
showRing :: Ring -> String
showRing (Ring [p,q,r,s])
= unlines $ [p,f 1 q r,f 2 q r,s]
where f i x y = (r !! i):" "++[q !! i]
rings :: [AString] -> S.Set Ring
rings = S.fromList
. map Ring
. filterMap uniq (concatMap (map fst))
. concatMap (comb 2)
. groupBy (eqapp hdtl)
. sortBy (cmpapp hdtl)
. followings
filterMap p f [] = []
filterMap p f (x:xs)
= let { fx = f x; j = p fx } in if j then fx : filterMap p f xs else filterMap p f xs
hdtl :: [AString] -> String
hdtl [(h:_,_),(_,t:_)] = [h,t]
followings :: [AString] -> [[AString]]
followings xss = [[xs,ys] | xs <- xss, ys <- xss, head (snd xs) == head (fst ys)]
ring :: [[(AString,AString)]] -> [[String]]
ring [pqs,rss]
= [pqrs | (p,q) <- pqs, (r,s) <- rss, let pqrs = map fst [p,q,r,s]
, head (fst p) == head (fst r) && head (snd q) == head (snd s) && uniq pqrs]
|
にしお
#3644()
Rating-1/1=-1.00
与えられた四字熟語のリストから下のように四角く配置することのできる熟語の組み合わせを探すプログラムを作成してください。
出力例:
四字熟語は左から右、上から下へ読むものとします。また右上隅の漢字と左下隅の漢字は異なるものでなければいけません。
四字熟語のデータは扱いやすい形(たとえばユニコード文字列のリスト)で与えられていると仮定して構いません。サンプルデータが必要であれば FOR Microsoft IME The四字熟語辞典(データ / 文書作成) にテキスト形式のデータが入っているのでそれを使えると思います。
問題の規模の参考までに、40行程度のPythonスクリプトでこのデータ(重複をのぞいて8312件)を処理してみたところ2.4GHzのCPUで13秒程度かかりました。結果は8133件出力されました。
[ reply ]