この記事は ひとりアドベントカレンダーRosettaCodeで楽しむプログラミング Advent Calendar 2025の23日めの記事です。
タスク
与えられた二つの単語を繋ぐ、最短のことばの梯子を見つけよ。
使える語は unixdict.txt にあるもののみとする。
（与えられる語はその制約下にある？）
少なくとも以下の例を試せ：
- boy → bay → ban → man
- girl → gill → gall → gale → gaze → laze → lazy → lady
- john → cohn → conn → cone → cane → jane
- child から adult への梯子が存在しない
考える
次の単語
全体としては、幅優先探索をすることになるだろうが、それより問題なのは、今注目している単語と1文字だけ異なる単語を辞書の中から見つける仕事である。これを高速に行うために二つの方法を試す。
トライ：真っ当な解法
辞書中の全ての単語を持つ TRIE を構築しておく。
unixdict 中には数字や記号を含む項目も存在するが、ここでは便宜上アルファベット小文字だけを扱うことにする。
検索時には、与えられた語に対して一度だけ異なる文字の方に分岐した全ての結果を集める。
import Data.Array.IArray
import Data.Bool
data TRIE = NIL
| TRIE Bool (Array Char TRIE) -- ここで終端する語があるか ＋ 続く各文字のTRIEの配列
-- 与えられた語のリストに対応するTRIEを構築する
buildTrie :: [String] -> TRIE
buildTrie [] = NIL
buildTrie ws = TRIE stop arr
where
arr = amap buildTrie $ accumArray (flip (:)) [] ('a','z') [(c, cs) | c:cs <- ws]
stop = elem "" ws
-- TRIEを走査して、wと1文字違いの語を全列挙する
searchTrie :: TRIE -> String -> [String]
searchTrie t w = spread t w
where
-- 1文字違えるまで広がり続ける
spread NIL _ = [] -- 木が途切れたら失敗
spread (TRIE _ _) "" = [] -- 1文字違える前に語の字が尽きたら失敗
spread (TRIE _ arr) (c:cs) = -- c以外の枝にsingle, cの枝にspreadで進む
[d : res | (d,u) <- assocs arr, res <- bool single spread (c == d) u cs]
-- もう間違えずに終端まで降りれたら成功
single NIL _ = []
single (TRIE b _) "" = ["" | b]
single (TRIE _ arr) (c:cs) = map (c :) $ single (arr ! c) cs
あいまい辞書：富豪的解法
辞書の全ての語 w について、その全ての文字位置 i について、w の位置 i の文字を # に置き換えた文字列をキーとする辞書に、語 w を登録する。
検索時には、同様に # 混じりの（自身が含まれるような）全ての項目を語の長さ分だけ調べ、自身と異なる列を全て集める。
実装では、辞書の値には、# と置き換えられたその1文字だけのリストを持たせている。
import qualified Data.Map as M
buildDict :: [String] -> M.Map String String
buildDict ws = M.fromListWith (++)
[ (ww, [w !! i])
| w <- ws
, i <- [0 .. pred $ length w]
, let ww = take i w ++ '#' : drop (succ i) w ]
searchDict :: M.Map String String -> String -> [String]
searchDict dict w =
[ a ++ d : b
| i <- [0 .. pred $ length w]
, let (a,_:b) = splitAt i w
, let ww = a ++ '#' : b
, d <- M.findWithDefault [] ww dict
, d /= w !! i ]
幅優先探索
隣接が定義できたので、これを辿って最短経路を発見する幅優先探索を考える。
（最短距離だけでなく）最短経路を発見することが目的なことと、探索空間全体が広大なので、探索の過程で登場したものだけを扱うようにする点に注意して実装する。
到達した語に対して、開始語に至るための一歩手前の語を Map で記録する。
これが到達済みの表を兼ねる。
Data.Sequence でFIFOをする代わりに、二本立てのリストで模倣する。
bfs :: (String -> [String]) -- 隣接語を与える関数
-> String -> String -- 開始語、目標語
-> [String] -- 答え、経路がないときは空リスト
bfs f start goal = go (M.singleton start "") [start] []
where
go _ [] [] = [] -- 失敗
go m [] next = go m next [] -- 次の周
go m (x:xs) next
| x == goal = post m [goal]
| otherwise = go m1 xs (ys ++ next)
where
ys = [y | y <- f x, M.notMember y m]
m1 = M.union m $ M.fromList [(y,x) | y <- ys]
post m xs@(x:_)
| M.member x m = post m (m M.! x : xs)
| otherwise = tail xs
実行
あとはドライバを書いてテストするだけ。
test :: ([String] -> dat) -- unixdictから検索用データ構造を構築する関数
-> (dat -> String -> [String]) -- データ構造を使って語の近傍語を探す関数
-> IO ()
test build search = do
unixdict <- filter (all isLower) . lines <$> readFile "unixdict.txt"
let dat = build unixdict
mapM_ (\(a,b) -> print (a, b, bfs (search dat) a b)) wordPairs
wordPairs = [("boy","man"),("girl","lady"),("john","jane"),("child","adult"),("alien","drool")]
ghci> test buildTrie searchTrie
("boy","man",["boy","bay","ban","man"])
("girl","lady",["girl","gill","gall","gale","gaze","laze","lazy","lady"])
("john","jane",["john","cohn","conn","cone","cane","jane"])
("child","adult",[])
("alien","drool",["alien","alden","alder","alter","aster","ester","eater","eaten","eaton"
,"baton","baron","boron","moron","moran","moral","morel","monel","money","monty","month"
,"mouth","south","sooth","sloth","slosh","slash","flash","flask","flank","blank","bland"
,"blend","bleed","breed","bread","tread","triad","trial","trill","drill","droll","drool"])
(1.03 secs, 779,631,296 bytes)
ghci> test buildDict searchDict
[略]
(0.79 secs, 471,917,576 bytes)
TRIEの方は遅延評価で木が成長するのですぐ動き始めるが、辞書の方はファイルの内容を完全に処理し終えてから始まるので、最初に少し引っかかりがある。メモリも辞書の方が少ないが、辞書の語数が10倍とかになったら変わるんだろう。
Rosetta Code の Haskell 解
幅優先探索、両側からの幅優先探索、A*探索、とバリエーションがある。
両側からの幅優先探索が、経路が長いと効率が悪くなるとか書いてあるけれど、両側の検索済み語の空間を突き合わせる計算を、探索ステップと別に書いて、Data.Set.intersection でやって効率いいわけがない。
A*探索は、経路を発見するけれど、ヒューリスティック関数の出来と問題の構造によっては最短を保証できないはず。
そもそもそんなものを持ち出さなくてもBFSで十分速い。
コードを眺めてみる。
wordSpace = S.fromList $ filter ((length start ==) . length) dict
unixdict の語の中から、今回の開始語と同じ長さの語だけ選り分けた Set String を作っている。
f = foldr (\w -> S.union (S.filter (oneStepAway w) d)) mempty h
d は wordSpace 由来のものが渡される。w が現在の語。それと oneStepAway なものだけ d から選り分けた語を集めている。この f が次の検索語リストになり、また d からその要素が外され、既出の語は検索にひっかからなくなる。
oneStepAway x = (1 ==) . distance x
distance :: String -> String -> Int
distance s1 s2 = length $ filter not $ zipWith (==) s1 s2
文字列どうしを一文字ずつ等しいか調べ、そうでないものの個数(distance)が1であるものを、wordSpace 全体から選り分ける。
…そりゃそんなことやってちゃ遅いでしょ。A*も持ち出したくなるわ。
BFSの wordLadders の本体とかポイントフリーでかっこいい（嫌味）けど、力入れるところ完全に間違えてるじゃん。
走らせてみる。
( 9.32 secs, 10,311,345,096 bytes) # BFS
( 8.83 secs , 9,946,584,120 bytes) # 2sided BFS
(60.76 secs, 60,942,700,368 bytes) # A*
A*がむしろ遅いんだが。
その他
こうなると、この辞書のグラフに関して、語の長さごとの最大の連結な部分グラフの大きさとか、最短経路の最大長とか、知りたくなってしまうな。