Sudoku Solver in Haskell
This month will be a bit of short article since I haven’t had a whole lot of time on my hands lately. Haskell is a wonderful little language that has begun to pick up a bit of moment in the past year that I’ve been playing with on-and-off now for several years. Since I don’t post enough on Haskell, I figured I’d post my bare-bones Haskell Sudoku Solver.
import Data.List import Data.Maybe toRowColumn :: Int -> (Int, Int) toRowColumn index = (r, c) where r = div index 9 c = mod index 9 toIndex :: (Int, Int) -> Int toIndex (r, c) = r * 9 + c toRegion :: (Int, Int) -> Int toRegion (r, c) = (div r 3) * 3 + (div c 3) columnIndicies :: Int -> [Int] columnIndicies c = [c, c + 9..80] regionIndicies :: Int -> [Int] regionIndicies g = [toIndex(r + x, c + y) | x <- [0..2], y <- [0..2] ] where r = (div g 3) * 3 c = (mod g 3) * 3 rowIndicies :: Int -> [Int] rowIndicies r = [9 * r..9 * (r + 1) - 1] values :: [Int] -> [Int] -> [Int] values board indicies = filter (>0) (map (board!!) indicies) possibleValues :: [Int] -> (Int, Int) -> [Int] possibleValues board rowColumn = foldl (\\) [1..9] ( map (values board) ( map (\f -> (fst f . snd f) rowColumn) ( zip [rowIndicies, columnIndicies, regionIndicies] [fst, snd, toRegion] ) ) ) validBoard :: [Int] -> Bool validBoard board = (length board == 81) && (and $ map (==0) l) where l = map length s s = map (\\[1..9]) v v = [values board (xIndicies x) | x <- [0..8], xIndicies <- [rowIndicies, columnIndicies, regionIndicies]] solvedBoard :: [Int] -> Bool solvedBoard board = and $ map (>0) board hasUnassigned :: [Int] -> Bool hasUnassigned board = isJust $ elemIndex 0 board assignFirstUnassigned :: [Int] -> Int -> [Int] assignFirstUnassigned (b:bs) value | b == 0 = value : bs | otherwise = b : (assignFirstUnassigned bs value) possibleBoards :: [Int] -> [Int] -> [[Int]] possibleBoards board possibleAssignments = map (assignFirstUnassigned board) possibleAssignments solve :: [Int] -> [[Int]] solve board | not (validBoard board) = [] | solvedBoard board = [board] | not (hasUnassigned board) = [] | otherwise = concated where concated = concat mapped mapped = map solve filtered filtered = filter (not . null) possibleSolved possibleSolved = possibleBoards board possibleAssignments possibleAssignments = possibleValues board unassignedRowColumn unassignedRowColumn = toRowColumn unassignedIndex unassignedIndex = fromJust $ elemIndex 0 board demo :: [Int] demo = [2,0,0,0,8,0,3,0,0, 0,6,0,0,7,0,0,8,4, 0,3,0,5,0,0,2,0,9, 0,0,0,1,0,5,4,0,8, 0,0,0,0,0,0,0,0,0, 4,0,2,7,0,6,0,0,0, 3,0,1,0,0,7,0,4,0, 7,2,0,0,4,0,0,6,0, 0,0,4,0,1,0,0,0,3]