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]

Advertisements