{-# LANGUAGE MultiWayIf #-} module Exercise03 where import Text.Printf (printf) import Data.List (intercalate, delete) import qualified Data.Set as Set -- HA 3.1a) i selectRow :: [[Int]] -> Int -> [Int] selectRow xss i = xss !! i -- HA 3.1a) ii selectColumn :: [[Int]] -> Int -> [Int] selectColumn xss i = map (!! i) xss -- HA 3.1a) iii intRoot :: Int -> Int intRoot = floor . sqrt . fromIntegral --return numbers in square as a list. squares are numbered from left to right and top to bottom selectSquare :: [[Int]] -> Int -> [Int] selectSquare xss i = let squareSize = intRoot (length xss) yPos = i `div` squareSize squareRows = take squareSize (drop (squareSize * yPos) xss) xPos = i `mod` squareSize squareCols row = take squareSize (drop (squareSize * xPos) row) in concatMap squareCols squareRows -- HA 3.1b) isValidSubsection :: [Int] -> Bool isValidSubsection xs = hasNoDuplicates (filter (/= 0) xs) where hasNoDuplicates ys = length ys == length (Set.fromList ys) isValidSudoku :: [[Int]] -> Bool isValidSudoku xss = all (\n -> isValidSubsection (selectRow xss n) && isValidSubsection (selectColumn xss n) && isValidSubsection (selectSquare xss n)) [0..length xss - 1] -- HA 3.1c) setCell :: [[Int]] -> (Int,Int) -> Int -> [[Int]] setCell (xs:xss) (row, column) n | row > 0 = xs : setCell xss (row - 1, column) n | otherwise = set xs column n : xss where set (_:xs) 0 n = n : xs set (x:xs) i n = x : set xs (i - 1) n -- HA 3.1d) {-WETT-} {- This is a basic sudoku solver that uses a simple backtracking algorithm with two small optimizations - which turned out to be very effective. -} solveSudoku :: [[Int]] -> [[Int]] solveSudoku xss -- determine possible values for every cell and solve sudoku | isValidSudoku xss = solve xss (determinePossibleValues xss) (length xss) -- provided sudoku is already not valid, thus there is no solution | otherwise = [] -- Main solving function solve :: [[Int]] -> [(Int, Int, [Int])] -> Int -> [[Int]] solve sudoku possibleValues size | hasCellWithNoPossibleValue possibleValues = [] | otherwise = let emptyCellsCount = length possibleValues afterOptimization = if emptyCellsCount > 0 -- only apply optimizations if the sudoku is not solved then applyOptimizations sudoku possibleValues size else (sudoku, possibleValues) newSudoku = fst afterOptimization newPossibleValues = snd afterOptimization newDeterminedCellsRel = ((emptyCellsCount - length newPossibleValues) * 100) `div` (size * size) in if | null newSudoku -- no solution -> [] | null newPossibleValues -- no more empty cells --> found solution -> newSudoku -- apply backtracking if less than 3 % of all cells could be determined with the optimization functions | newDeterminedCellsRel < 3 -> attemptGuess newSudoku newPossibleValues size | otherwise -- no backtracking -> solve newSudoku newPossibleValues size {--- Useful functions ---} -- Function that determines all possible values for every cell determinePossibleValues :: [[Int]] -> [(Int, Int, [Int])] determinePossibleValues sudoku = let n = length sudoku squareSize = intRoot n cells = zip [0..] (concat sudoku) -- all cells with index emptyCells = filter (\cell -> snd cell == 0) cells -- empty cells with index coordEmptyCells = map (\(i, _) -> (i `div` n, i `mod` n, [])) emptyCells -- empty cells with row, -- column and empty list -- possible values are all numbers [1..n] that are not already present in row, column or square of the cell possibleValues row column = filter (\i -> i `notElem` selectRow sudoku row && i `notElem` selectColumn sudoku column && i `notElem` selectSquare sudoku (coordinatesToSquare row column squareSize)) [1..n] in -- fill lists with possible values map (\(row, column, _) -> (row, column, possibleValues row column)) coordEmptyCells -- Function that tests if there is any cell that has no possible value hasCellWithNoPossibleValue :: [(Int, Int, [Int])] -> Bool hasCellWithNoPossibleValue = any (\(_, _, values) -> null values) {- Function that sets the cell in the specified row and column to the specified value and - updates the possible values for all cells. -} setCellAndUpdate :: [[Int]] -> [(Int, Int, [Int])] -> Int -> Int -> Int -> Int -> ([[Int]], [(Int, Int, [Int])]) setCellAndUpdate sudoku possibleValues size row column value = let squareSize = intRoot size square = coordinatesToSquare row column squareSize -- possible values for all cells except the cell that is to be set valuesWithoutSetCell = filter (\(r, c, _) -> r /= row || c /= column) possibleValues -- delete value from all cells in same row, column or square updatedValues = map (\(r, c, vs) -> (r, c, if r == row || c == column || coordinatesToSquare r c squareSize == square then value `delete` vs else vs) ) valuesWithoutSetCell in (setCell sudoku (row, column) value, updatedValues) -- Backtracking function that guesses the value of an empty cell attemptGuess :: [[Int]] -> [(Int, Int, [Int])] -> Int -> [[Int]] attemptGuess sudoku possibleValues size = let cell = head possibleValues -- first empty cell is to be set row = fst3 cell column = snd3 cell values = trd3 cell try value = -- Function that sets the cell to let afterSetAndUpdate = -- the specified value and setCellAndUpdate sudoku possibleValues size row column value -- recursively calls the solving in -- function uncurry solve afterSetAndUpdate size attempts = map try values -- all possible attempts validAttempts = filter (not . null) attempts -- all attempts that lead to a in -- solution if null validAttempts then [] else head validAttempts -- Function that sets all empty cells in a list to the specified values if they are valid setAllCells :: [[Int]] -> [(Int, Int, [Int])] -> Int -> [(Int, Int, Int)] -> ([[Int]], [(Int, Int, [Int])]) setAllCells [] possibleValues _ _ = ([], possibleValues) -- sudoku is empty, nothing to do setAllCells sudoku possibleValues _ [] = (sudoku, possibleValues) -- no cells to set setAllCells sudoku possibleValues size (cell:cells) = let squareSize = intRoot size row = fst3 cell column = snd3 cell value = trd3 cell -- ensure that this value has not already been set in the same row, column or square isValidValue = value `notElem` selectRow sudoku row && value `notElem` selectColumn sudoku column && value `notElem` selectSquare sudoku (coordinatesToSquare row column squareSize) -- set cell and update possible values afterSetAndUpdate = setCellAndUpdate sudoku possibleValues size row column value in if | selectRow sudoku row !! column == value -- cell already set, skip -> setAllCells sudoku possibleValues size cells | isValidValue -- set cell and continue with other cells -> uncurry setAllCells afterSetAndUpdate size cells | otherwise -- value invalid, skip -> ([], possibleValues) {--- Optimizations ---} {- An optimization function takes a sudoku, possible values for all cells and the size of the sudoku - and returns an optimized sudoku with the corresponding possible values for all cells. An - optimization function is based on rules and not on brute force. -} type Optimization = [[Int]] -> [(Int, Int, [Int])] -> Int -> ([[Int]], [(Int, Int, [Int])]) -- Function that applies all optimization functions applyOptimizations :: Optimization applyOptimizations sudoku possibleValues size = let afterOpt1 = applyOptimization1 sudoku possibleValues size afterOpt2 = uncurry applyOptimization2 afterOpt1 size in afterOpt2 -- Rule 1: There is only one possible value for a cell --> set this value applyOptimization1 :: Optimization applyOptimization1 [] possibleValues _ = ([], possibleValues) applyOptimization1 sudoku possibleValues size = let cells = [(row, column, v) | (row, column, [v]) <- possibleValues] -- all cells with only one possible value in if null cells then (sudoku, possibleValues) -- no more optimization by rule 1 possible else let cell = head cells row = fst3 cell column = snd3 cell value = trd3 cell afterSetAndUpdate = setCellAndUpdate sudoku possibleValues size row column value in uncurry applyOptimization1 afterSetAndUpdate size -- set cell with only one possible value and try to -- apply rule 1 again -- Rule 2: A value is only possible in one cell in a row/column --> set this value applyOptimization2 :: Optimization applyOptimization2 [] possibleValues _ = ([], possibleValues) applyOptimization2 sudoku possibleValues size = -- possible values for all rows and cols let rows = map (\n -> filter (\x -> fst3 x == n) possibleValues) [1..size] cols = map (\n -> filter (\x -> snd3 x == n) possibleValues) [1..size] rowsAndCols = rows ++ cols -- all cells in a row or column that have a certain possible value cellsForValue rowOrCol value = [(r, c, value) | (r, c, values) <- rowOrCol, value `elem` values] -- all cells that are the only ones with a certain possible value in the row/column filterRelevant rowsAndCols = [x | [x] <- rowsAndCols] -- all relevant cells in all rows and columns for a certain value relevantCellsForValue value = filterRelevant (map (`cellsForValue` value) rowsAndCols) -- all cells to set according to rule 1 cells = concatMap relevantCellsForValue [1..size] in if null possibleValues then (sudoku, possibleValues) else setAllCells sudoku possibleValues size cells {--- Utilities ---} -- Functions for selecting a value of a 3-tuple fst3 :: (a, b, c) -> a fst3 (a, _, _) = a snd3 :: (a, b, c) -> b snd3 (_, b, _) = b trd3 :: (a, b, c) -> c trd3 (_, _, c) = c -- Function that determines the square in which a cell is located coordinatesToSquare :: Int -> Int -> Int -> Int coordinatesToSquare row column squareSize = squareSize * (row `div` squareSize) + (column `div` squareSize) {-TTEW-} -- Function to show a sudoku showSudoku :: [[Int]] -> String showSudoku xss = unlines $ intercalate [showDivider] $ chunksOf squareSize $ map showRow xss where size = length xss squareSize = intRoot size numberSize = size `div` 10 + 1 showRowSection xs = unwords $ map (printf ("%0" ++ show numberSize ++ "d")) xs showRow xs = intercalate "|" $ map showRowSection $ chunksOf squareSize xs showDivider = intercalate "+" $ replicate squareSize $ replicate ((numberSize + 1) * squareSize - 1) '-' chunksOf :: Int -> [e] -> [[e]] chunksOf _ [] = [] chunksOf i ls = take i ls : chunksOf i (drop i ls) -- Function to print a sudoku printSudoku :: [[Int]] -> IO () printSudoku = putStr . showSudoku -- Function to solve a sudoku and print the solution solveAndPrint :: [[Int]] -> IO () solveAndPrint = printSudoku . solveSudoku