module Exercise03 where import Text.Printf (printf) import Data.List import qualified Data.Set as Set import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.IntMap as IntMap -- HA 3.1a) i selectRow :: [[Int]] -> Int -> [Int] selectRow xss i = xss !! i -- HA 3.1a) ii selectColumn :: [[Int]] -> Int -> [Int] selectColumn xss i = [xs !! i | xs <- 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 --e.g. : --[0,1,2] --[3,4,5] --[6,7,8] selectSquare :: [[Int]] -> Int -> [Int] selectSquare xss i = [x | r <- [drop (squareCol * n) (selectRow xss (squareRow * n + j)) | j <- [0..(pred n)]], x <- map (r!!) [0..(pred n)]] where n = intRoot $ length xss squareCol = mod i n squareRow = div i n -- HA 3.1b) isValidSubsection :: [Int] -> Bool isValidSubsection xs = validList xs Set.empty where validList [] _ = True validList (0 : zs) currSet = validList zs currSet validList (z : zs) currSet = not (Set.member z currSet) && validList zs (Set.insert z currSet) isValidSudoku :: [[Int]] -> Bool isValidSudoku xss = all (isValidSubsection . selectRow xss) [0..k] && all (isValidSubsection . selectColumn xss) [0..k] && all (isValidSubsection . selectSquare xss) [0..k] where k = pred $ length xss -- HA 3.1c) setCell :: [[Int]] -> (Int,Int) -> Int -> [[Int]] setCell xss (j, k) x = start ++ ((startOfRow ++ x : endOfRow) : end) where start = take j xss end = drop (succ j) xss row = xss!!j startOfRow = take k row endOfRow = drop (succ k) row -- HA 3.1d) ------------------------------------------------------------------------------------------------------------------------------------------- -- First normal backtracking Solution solveSudoku' :: [[Int]] -> [[Int]] solveSudoku' xss = solveSudokuoBacktracking xss 0 1 solveSudokuoBacktracking :: [[Int]] -> Int -> Int -> [[Int]] solveSudokuoBacktracking oldSudoku currPos newNum -- Predefined Cell | (oldSudoku!!iRow)!!iCol /= 0 = if currPos == k^2 - 1 then -- We are done oldSudoku else -- Otherwise go to next free cell solveSudokuoBacktracking oldSudoku (succ currPos) 1 -- No possibible value for this cell | newNum == succ k = [] -- New sudoku is valid | isValidSudoku currentSudoku = if currPos == k^2 - 1 then -- We are done currentSudoku else if null nextCellResult then -- From the current situation there is no possible solution sameCellResult -- then try the next number in the current Cell else -- otherwise we cascade the Solution back up nextCellResult -- New sudoku is not valid | otherwise = sameCellResult -- We try the next number in the current cell where k = length oldSudoku iRow = div currPos k iCol = mod currPos k currentSudoku = setCell oldSudoku (iRow, iCol) newNum nextCellResult = solveSudokuoBacktracking currentSudoku (succ currPos) 1 sameCellResult = solveSudokuoBacktracking oldSudoku currPos (succ newNum) ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- -- Trying a differenz approach -> Idea taken from Wikipedia, implemantation is all by myself. -- As one might see, the idea on how to sparse the matrix is also by myself, I have no idea if that's efficient at all... It seemed efficent to me tho -- It is quite fast at solving feasible Sudokus. The same thing sadly cannot be sad about infeasible ones. -- This might just be a mistake in my code, idk and I did already spent too much time on this anyway. -- However I do not completely understand why the order of difference is ~ *1000 since theoretically a feasible sudoku might aswell take just one less try than an infeasible one. {-WETT-} solveSudoku :: [[Int]] -> [[Int]] solveSudoku sudoku | (-1) `elem` rowList = [] | otherwise = foldl (\xss (row, col, num) -> setCell xss (row, col) num) sudoku indexedNumList where n = length sudoku (rowSet, colSet, rowMap, colMap) = createMatrix n (reducedRowSet, reducedColSet) = removeConstraintsFromGivenNumbers sudoku 0 rowSet colSet rowMap colMap rowList = solveSudokuRec reducedRowSet reducedColSet rowMap colMap (-1) IntSet.empty -- rowList = defaultRuleRows ++ ... indexedNumList = map (getPosNumFromMatrixRow n) rowList {-TTEW-} -- A try at Memoization using lazy evaluation. Idk if this actually helps but in case someone wants to try multiple Sudokus of the same size it might actually help. -- matrix = map createMatrix [1..] -- Creates sparse matrix which represents the different rules -- sudoku -> (rowSet , colSet , rowMap , colMap ) createMatrix :: Int -> (IntSet.IntSet, IntSet.IntSet, IntMap.IntMap IntSet.IntSet, IntMap.IntMap IntSet.IntSet) createMatrix n = (rowSet, colSet, rowMap, colMap) where boxLength = intRoot n nSqrt = n^2 nCbd = n^3 mRow = nCbd - 1 mCol = 4*nSqrt - 1 nColRule = nSqrt boxRow = enumFromThenTo 0 n (boxLength * n - 1) -- B1#1 box = concat [map (+j*nSqrt) boxRow | j <- [0..boxLength - 1]] rowSet = IntSet.fromDistinctAscList [0..mRow] colSet = IntSet.fromDistinctAscList [0..mCol] rowMap = IntMap.fromDistinctAscList [let row = div i nSqrt col = mod (div i n) n num = mod i n boxRow = div row boxLength boxCol = div col boxLength box = boxRow * boxLength + boxCol in (i, IntSet.fromDistinctAscList [row * n + col, nSqrt + row * n + num, 2*nSqrt + col * n + num, 3*nSqrt + box * n + num]) | i <- [0..mRow]] colMap = IntMap.fromDistinctAscList [let currRule = div i nColRule ruleIndex = mod i nColRule firstRuleIndex = div ruleIndex n secondRuleIndex = mod ruleIndex n rowNumStartRow = firstRuleIndex * nSqrt + secondRuleIndex colNumStartRow = firstRuleIndex * n + secondRuleIndex boxRow = div firstRuleIndex boxLength boxCol = mod firstRuleIndex boxLength boxNumStartRow = nSqrt * boxLength * boxRow + n * boxLength * boxCol + secondRuleIndex in -- Row Col if currRule == 0 then (i, IntSet.fromDistinctAscList [i*n..(i+1)*n - 1]) else -- Row Num if currRule == 1 then (i, IntSet.fromDistinctAscList $ enumFromThenTo rowNumStartRow (rowNumStartRow + n) (rowNumStartRow + nSqrt - 1)) else -- Col Num if currRule == 2 then (i, IntSet.fromDistinctAscList $ enumFromThenTo colNumStartRow (colNumStartRow + nSqrt) (nCbd - 1)) else -- Box Num (i, IntSet.fromDistinctAscList $ map (+ boxNumStartRow) box) | i <- [0..mCol]] -- TODO: Make this one faster by removing the use of Lists removeConstraintsFromGivenNumbers :: [[Int]] -> Int -> IntSet.IntSet -> IntSet.IntSet -> IntMap.IntMap IntSet.IntSet -> IntMap.IntMap IntSet.IntSet -> (IntSet.IntSet, IntSet.IntSet) removeConstraintsFromGivenNumbers sudoku currPos currRows currCols rowMap colMap -- We are at the end and finished | currPos == n^2 = (currRows, currCols) -- There was no given Number (0, but we subtract 1) | currNum == -1 = removeConstraintsFromGivenNumbers sudoku (succ currPos) currRows currCols rowMap colMap -- There was a given Number -> We remove everything we need but remember we chose currMatrixRow | otherwise = removeConstraintsFromGivenNumbers sudoku (succ currPos) reducedRows reducedCols rowMap colMap where n = length sudoku currRow = div currPos n currCol = mod currPos n currNum = sudoku!!currRow!!currCol - 1 currMatrixRow = getMatrixRowFromPosNum n currRow currCol currNum -- remove all Columns, which have a 1 in currRow (this includes currCol) activeCols = rowMap IntMap.! currMatrixRow reducedCols = currCols IntSet.\\ activeCols -- remove all rows, in which removed columns had an 1 activeRows = IntSet.foldl (\a b -> IntSet.union a (colMap IntMap.! b)) IntSet.empty activeCols reducedRows = currRows IntSet.\\ activeRows -- TODO Backtracking solveSudokuRec :: IntSet.IntSet -> IntSet.IntSet -> IntMap.IntMap IntSet.IntSet -> IntMap.IntMap IntSet.IntSet -> Int -> IntSet.IntSet -> [Int] solveSudokuRec rowSet colSet rowMap colMap oldCurrCol oldAvailableRows -- If we arrive at the empty Matrix we are done | IntSet.null colSet && IntSet.null rowSet = mempty -- Afterwards we check, if the currentCol is only zeros and if so the current Matrix is infeasible aswell -- This can also happen, if we tried all the rows in a column but all lead to infeasible solutions as in this case, rowSet won't be reduced but availbleRows will. | IntSet.null rowSet = [-1] -- faster | IntSet.null availableRows = [-1] -- Otherwise we choose the first row with A(currRow, currCol) = 1 and perform the algorithm on the reduced matrix. -- If the reduced matrix turns out to be infeasible, we get [-1] as the first result and have to retry with a different row -- If there are no rows left, we will eventuall return the -1 from the case above -- There are different cases for the return value. If the return value is [] this step was the last one and we return the value as we are done. -- This value will be cascaded back up | null reducedResult = [currRow] -- If the head is -1, our row led to infeasibilty. Therefore we need to try the next row | head reducedResult == -1 = if IntSet.null reducedAvailableRows then [-1] else nextRowResult -- Otherwise the we got a feasible solution and cascade the solution back up while adding our current Row | otherwise = currRow : reducedResult where -- Take first not yet decided column. If we stayed in the same column, take the old one for better running time currCol = if oldCurrCol == -1 then IntSet.findMin colSet else oldCurrCol -- take the first row that satisfies A(currRow, currCol) = 1 and is still in the Matrix. If we stayed in the same column, take the reducedAvailableRows from before availableRows = if IntSet.null oldAvailableRows then IntSet.intersection (colMap IntMap.! currCol) rowSet else oldAvailableRows (currRow, reducedAvailableRows) = IntSet.deleteFindMin availableRows -- remove all Columns, which have a 1 in currRow (this includes currCol) activeCols = rowMap IntMap.! currRow reducedCols = colSet IntSet.\\ activeCols -- remove all rows, in which removed columns had an 1 activeRows = IntSet.foldl (\a b -> IntSet.union a (colMap IntMap.! b)) IntSet.empty activeCols reducedRows = rowSet IntSet.\\ activeRows reducedResult = solveSudokuRec reducedRows reducedCols rowMap colMap (-1) IntSet.empty -- Update colMap in case the current row wasn't working out -> new row must be choosen nextRowResult = solveSudokuRec rowSet colSet rowMap colMap currCol reducedAvailableRows {- getColFromColSet :: IntSet.IntSet -> IntSet.IntSet -> IntMap.IntMap IntSet.IntSet -> Int getColFromColSet rowSet colSet colMap = snd (maximum listWithSizes) where colList = IntSet.toAscList colSet listWithSizes = map (\c -> (IntSet.size (IntSet.intersection (colMap IntMap.! c) rowSet), c)) colList -} getPosNumFromMatrixRow :: Int -> Int -> (Int, Int, Int) getPosNumFromMatrixRow n mRow = (row, col, num + 1) where nSqrt = n^2 row = div mRow nSqrt col = mod (div mRow n) n num = mod mRow n getMatrixRowFromPosNum :: Int -> Int -> Int -> Int -> Int getMatrixRowFromPosNum n row col num = row * n^2 + col * n + num ------------------------------ Testing ------------------------------ debugSudoku :: [[Int]] -> IO() debugSudoku sudoku = do print reducedRowSet print reducedColSet where n = length sudoku (rowSet, colSet, rowMap, colMap) = createMatrix n (reducedRowSet, reducedColSet) = removeConstraintsFromGivenNumbers sudoku 0 rowSet colSet rowMap colMap rowList = solveSudokuRec reducedRowSet reducedColSet rowMap colMap (-1) IntSet.empty indexedNumList = map (getPosNumFromMatrixRow n) rowList testDebug :: [[Int]] -> IO() testDebug xss = do print indexedNumList where n = length xss m = n^3 (updatedRows, updatedCols) = removeConstraintsFromGivenNumbers xss 0 rowSet colSet rowMap colMap rowList = solveSudokuRec updatedRows updatedCols rowMap colMap (-1) IntSet.empty indexedNumList = map (getPosNumFromMatrixRow n) rowList rowSet = IntSet.fromDistinctAscList [0..m - 1] colSet = IntSet.fromDistinctAscList [0..3*n^2 - 1] rowMap = IntMap.fromDistinctAscList [let row = div i $ n^2 col = mod (div i n) n num = mod i n in (i, IntSet.fromDistinctAscList [row * n + col, n^2 + row * n + num, 2*n^2 + col * n + num]) | i <- [0..m-1]] colMap = IntMap.fromDistinctAscList [let currRule = div i $ n^2 ruleIndex = mod i $ n^2 firstRuleIndex = div ruleIndex n secondRuleIndex = mod ruleIndex n rowNumStartRow = firstRuleIndex * n^2 + secondRuleIndex colNumStartRow = firstRuleIndex * n + secondRuleIndex in -- Row Col if currRule == 0 then (i, IntSet.fromDistinctAscList [i*n..(i+1)*n - 1]) else -- Row Num if currRule == 1 then (i, IntSet.fromDistinctAscList $ enumFromThenTo rowNumStartRow (rowNumStartRow + n) (rowNumStartRow + n^2 - 1)) else -- Col Num (i, IntSet.fromDistinctAscList $ enumFromThenTo colNumStartRow (colNumStartRow + n^2) (n^3 - 1)) | i <- [0..3*n^2 - 1]] testCreateMatrix :: Int -> Int -> IO() testCreateMatrix n colOfInterest = do print (map (getPosNumFromMatrixRow n) activeRowsInCol) where (rowSet, colSet, rowMap, colMap) = createMatrix n offSet = 3*n^2 activeRowsInCol = IntSet.toAscList $ colMap IntMap.! (offSet + colOfInterest) zeroes :: Int -> [[Int]] zeroes n = replicate n $ replicate n (0::Int) ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- -- This is not a valid Sudoku, but can be used to test stuff easyEx :: [[Int]] easyEx = [[1, 0], [2, 0]] medEx :: [[Int]] medEx = [[0,0,0,1], [0,0,0,2], [1,0,0,0], [3,0,0,4]] medEx2 :: [[Int]] medEx2 = [[1,0,0,0], [2,0,0,0], [0,0,0,1], [4,0,0,3]] hardSudoku :: [[Int]] hardSudoku = [[8,0,0,0,0,0,0,0,0], [0,0,3,6,0,0,0,0,0], [0,7,0,0,9,0,2,0,0], [0,5,0,0,0,7,0,0,0], [0,0,0,0,4,5,7,0,0], [0,0,0,1,0,0,0,3,0], [0,0,1,0,0,0,0,6,8], [0,0,8,5,0,0,0,1,0], [0,9,0,0,0,0,4,0,0]] hardSudoku2 :: [[Int]] hardSudoku2 = [[0,0,5, 3,0,0, 0,0,0], [8,0,0, 0,0,0, 0,2,0], [0,7,0, 0,1,0, 5,0,0], [4,0,0, 0,0,5, 3,0,0], [0,1,0, 0,7,0, 0,0,6], [0,0,3, 2,0,0, 0,8,0], [0,6,0, 5,0,0, 0,0,9], [0,0,4, 0,0,0, 0,3,0], [0,0,0, 0,0,9, 7,0,0]] wrongSmallSudoku :: [[Int]] wrongSmallSudoku = [[4,1, 0,0], [0,3, 0,0], [0,0, 2,4], [0,0, 0,0]] wrongBigSudoku1 :: [[Int]] wrongBigSudoku1 = [[2,0,0, 9,0,0, 0,0,0], [0,0,0, 0,0,0, 0,6,0], [0,0,0, 0,0,1, 0,0,0], [5,0,2, 6,0,0, 4,0,7], [0,0,0, 0,0,4, 1,0,0], [0,0,0, 0,9,8, 0,2,3], [0,0,0, 0,0,3, 0,8,0], [0,0,5, 0,1,0, 0,0,0], [0,0,7, 0,0,0, 0,0,0]] wrongBigSudoku2 :: [[Int]] wrongBigSudoku2 = [[0,0,0, 0,0,5, 0,8,0], [0,0,0, 6,0,1, 0,4,3], [0,0,0, 0,0,0, 0,0,0], [0,1,0, 5,0,0, 0,0,0], [0,0,0, 1,0,6, 0,0,0], [3,0,0, 0,0,0, 0,0,5], [5,3,0, 0,0,0, 0,6,1], [0,0,0, 0,0,0, 0,0,4], [0,0,0, 0,0,0, 0,0,0]] -- Utility method to show a sudoku -- show sudoku with -- >>> putStr (showSudoku 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 i [] = [] chunksOf i ls = take i ls : chunksOf i (drop i ls)