{- ----------------------------------------
Sudoku solver by Richard Bird.
From the Journal of Functional Programming vol. 16 (6): 671–679, 2006;
see .
Code extracted and tweaked by Fritz Ruehr for Willamette Universtiy
CS 154: Introduction to Functional Programming, Fall 2012.
Completions include definitions of single, groupBy and delete (from List);
corrections include s/"rows2"/"rows3"/ and extra map in sudoku;
additions include sample boards and display conveniences (at the end).
---------------------------------------- -}
module Sudoku where
import List (splitAt, (\\))
type Matrix a = [[a]]
type Board = Matrix Char
type Choices = [Char]
boardsize = 9
boxsize = 3
cellvals = "123456789"
blank = (=='.')
nodups :: Eq a => [a] -> Bool
nodups [ ] = True
nodups (x : xs) = notElem x xs && nodups xs
rows :: Matrix a -> Matrix a
rows = id
cols :: Matrix a -> Matrix a
cols [xs] = [[x] | x <- xs]
cols (xs : xss) = zipWith (:) xs (cols xss)
boxs :: Matrix a -> Matrix a
boxs = map ungroup . ungroup . map cols . group . map group
group :: [a] -> [[a]]
group = groupBy boxsize
groupBy :: Integer -> [a] -> [[a]]
groupBy n [] = []
groupBy n xs = as : groupBy n bs
where (as,bs) = splitAt (fromInteger n) xs
ungroup :: [[a]] -> [a]
ungroup = concat
choices :: Board -> Matrix Choices
choices = map (map choose)
single :: [a] -> Bool
single [x] = True
single y = False
choose e = if blank e then cellvals else [e]
fixed :: [Choices] -> Choices
fixed = concat . filter single
blocked :: Matrix Choices -> Bool
blocked cm = void cm || not (safe cm)
void :: Matrix Choices -> Bool
void = any (any null)
safe :: Matrix Choices -> Bool
safe cm = all (nodups . fixed) (rows cm) &&
all (nodups . fixed) (cols cm) &&
all (nodups . fixed) (boxs cm)
-- original code has "rows3" for "rows2" below
expand cm = [rows1 ++ [row1 ++ [c] : row2] ++ rows2 | c <- cs]
where (rows1, row : rows2) = break (any best) cm
(row1, cs : row2) = break best row
best cs = (length cs == n)
n = minchoice cm
minchoice = minimum . filter (> 1) . concat . map (map length)
reduce :: [Choices] -> [Choices]
reduce css = map (remove (fixed css)) css
remove fs cs = if single cs then cs else delete fs cs
delete xs ys = ys \\ xs
pruneBy f = f . map reduce . f
prune = pruneBy boxs . pruneBy cols . pruneBy rows
search :: Matrix Choices -> [Matrix Choices]
search cm | blocked cm = [ ]
| all (all single) cm = [cm]
| otherwise = (concat . map (search . prune) . expand) cm
-- original code has two maps rather than the three below
sudoku :: Board -> [Board]
sudoku = map (map (map head)) . search . prune . choices
---------------------------------
-- Sample boards & display functions
mkbd = groupBy boardsize
samples = map mkbd
[ "2....1.38........5.7...6..........13.981..25731....8..9..8...2..5..697844..25....",
".98..........7........15...1...........2....9...9.6.82.......3.5.1.........4...2.",
".5..6...1..48...7.8......522...57.3...........3.69...579......8.1...65..5...3..6."
]
wideopen = mkbd "123456789456789123789123456234567891567891234891234567..........................."
shrow = ('\t' :) . unwords . map (: [])
prt = putStr . ('\n' :) . unlines . map shrow
disp n = mapM_ prt . take n . sudoku