{- ---------------------------------------- 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