P99 - 填字游戏
Crossword puzzles
官方模块：
Problems.P99核心函数：solveCrossword
数据表示
Left False 是黑格，Left True 是待填格，Right c 是预填字符。连续两个以上可填格形成横向或纵向单词槽。
1import Data.List (delete, minimumBy, transpose)
2import Data.Ord (comparing)
3
4data Crossword = Crossword
5 { word :: [String]
6 , grid :: [[Either Bool Char]]
7 } deriving (Eq, Show)
8
9type Position = (Int, Int)
10type Site = [Position]
11type Board = [[Maybe Char]]
提取单词槽
1allSites :: [[Either Bool Char]] -> [Site]
2allSites puzzle = horizontal ++ vertical
3 where
4 rows = length puzzle
5 cols = maximum (0 : map length puzzle)
6 cell r c
7 | r < rows && c < length (puzzle !! r) = puzzle !! r !! c
8 | otherwise = Left False
9 spot r c = case cell r c of
10 Left False -> Nothing
11 _ -> Just (r,c)
12 horizontal = concat
13 [runsFrom [spot r c | c <- [0..cols-1]] | r <- [0..rows-1]]
14 vertical = concat
15 [runsFrom [spot r c | r <- [0..rows-1]] | c <- [0..cols-1]]
16
17runsFrom :: [Maybe Position] -> [Site]
18runsFrom = filter ((>= 2) . length) . finish . foldl step ([],[])
19 where
20 step (done,current) Nothing = (reverse current:done, [])
21 step (done,current) (Just p) = (done, p:current)
22 finish (done,current) = reverse (reverse current:done)
回溯求解核心
方法一：每轮重新计算候选词
1solveCrossword :: Crossword -> Maybe Board
2solveCrossword (Crossword words puzzle) =
3 search initial (allSites puzzle) words
4 where
5 initial = [[initialCell cell | cell <- row] | row <- puzzle]
6 initialCell (Right c) = Just c
7 initialCell _ = Nothing
8
9search board [] _ = Just board
10search board remaining words = firstJust
11 [search (place board site candidate) (delete site remaining) (delete candidate words)
12 | candidate <- candidates]
13 where
14 ranked = [(site, matching board site words) | site <- remaining]
15 (site,candidates) = minimumBy (comparing (length . snd)) ranked
16
17matching board site words =
18 [w | w <- words, length w == length site, fits board site w]
19
20fits board site text = and
21 [maybe True (== c) (board !! r !! col)
22 | ((r,col),c) <- zip site text]
23
24place board site text = foldl put board (zip site text)
25 where
26 put rows ((r,c),value) =
27 take r rows ++ [take c row ++ [Just value] ++ drop (c+1) row]
28 ++ drop (r+1) rows
29 where row = rows !! r
30
31firstJust [] = Nothing
32firstJust (Just value:_) = Just value
33firstJust (Nothing:rest) = firstJust rest
搜索每次选择候选词最少的槽（MRV），填词后交叉位置会自动限制其他槽。
方法二：前向检查候选域
1solveCrosswordForward :: Crossword -> Maybe Board
2solveCrosswordForward (Crossword words puzzle) =
3 searchForward initial domains words
4 where
5 initial = [[initialCell cell | cell <- row] | row <- puzzle]
6 initialCell (Right c) = Just c
7 initialCell _ = Nothing
8 domains =
9 [(site, matching initial site words) | site <- allSites puzzle]
10
11searchForward :: Board -> [(Site, [String])] -> [String] -> Maybe Board
12searchForward board [] _ = Just board
13searchForward board domains words = firstJust
14 [advance candidate | candidate <- candidates]
15 where
16 (site, candidates) = minimumBy (comparing (length . snd)) domains
17
18 advance candidate
19 | any (null . snd) updatedDomains = Nothing
20 | otherwise = searchForward board' updatedDomains words'
21 where
22 board' = place board site candidate
23 words' = delete candidate words
24 remainingSites =
25 [otherSite | (otherSite, _) <- domains, otherSite /= site]
26 updatedDomains =
27 [(otherSite, matching board' otherSite words')
28 | otherSite <- remainingSites]
方法一只在选中某个槽时计算它的候选词；前向检查在每次填词后更新所有剩余槽的候选域。任一候选域变空就立即回溯，避免等到该槽被 MRV 选中才发现冲突。
方法对比
| 方法 | 填词后的工作 |
|---|---|
| 重新计算 | 下一轮只计算当前 MRV 排名所需候选 |
| 前向检查 | 更新所有剩余候选域并检测空域 |
测试
1>>> fmap (map (map (maybe '#' id))) (solveCrossword crosswordPuzzle)
2Just ["##P##","##O##","ALPHA","##P#R","##Y#E","####S"]
3>>> solveCrosswordForward crosswordPuzzle == solveCrossword crosswordPuzzle
4True
大型填字题的搜索空间仍可能很大，但“按长度预筛 + 交叉字符传播 + MRV”构成了完整的约束求解主线。