module Exercise03 where import Text.Printf (printf) import Data.List as L ( filter, length, null, drop, replicate, take, (\\), elemIndex, findIndex, intercalate, find ) import Data.Foldable ( Foldable(toList), foldl' ) import Data.Containers.ListUtils ( nubInt ) import Data.Sequence as S ( (><), drop, elemIndexL, elemIndexR, empty, filter, findIndexL, findIndexR, fromList, index, length, null, take, update, Seq ) import Data.Maybe ( fromJust, isJust, isNothing, fromMaybe ) -- HA 3.1a) i selectRow :: [[Int]] -> Int -> [Int] selectRow xss i = xss !! i selectRowSeq :: Seq (Seq Int) -> Int -> Seq Int selectRowSeq = index -- HA 3.1a) ii selectColumn :: [[Int]] -> Int -> [Int] selectColumn xss i = [ xs !! i | xs <- xss] selectColumnSeq :: Seq (Seq Int) -> Int -> Seq Int selectColumnSeq xss i = fmap (`index` 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 --e.g. : --[0,1,2] --[3,4,5] --[6,7,8] selectSquare :: [[Int]] -> Int -> [Int] selectSquare xss i = concatMap (L.take size . L.drop (squareColumn * size)) selectedRows where size = intRoot (L.length xss) squareColumn = i `mod` size -- in 9x9 0 for first row, 2 for middle, 3 for last squareRow = snd $until (\x -> fst x < size) (\x -> (fst x - size, snd x +1)) (i, 0) -- I'm sure there is a better way selectedRows = L.take size (L.drop (squareRow * size) xss) selectSquareSeq :: Seq (Seq Int) -> Int -> Seq Int selectSquareSeq xss i = foldl' (S.><) empty (fmap (S.take size . S.drop (squareColumn * size)) selectedRows) where size = intRoot (S.length xss) squareColumn = i `mod` size -- in 9x9 0 for first row, 2 for middle, 3 for last -- squareRow = snd $until (\x -> fst x < size) (\x -> (fst x - size, snd x +1)) (i, 0) -- I'm sure there is a better way squareRow = i `div` size selectedRows = S.take size (S.drop (squareRow * size) xss) -- HA 3.1b) isValidSubsection :: [Int] -> Bool isValidSubsection xs = L.length (nubInt no_zeroes) == L.length no_zeroes where no_zeroes = L.filter (0 /=) xs isValidSubsectionSeq :: Seq Int -> Bool isValidSubsectionSeq xs = let lnz = toList no_zeroes in L.length (nubInt lnz) == L.length lnz where no_zeroes = S.filter (0 /=) xs isValidSudoku :: [[Int]] -> Bool isValidSudoku xss = rows && columns && squares where count = [0..L.length xss-1] rows = all (isValidSubsection . selectRow xss) count columns = all (isValidSubsection . selectColumn xss) count squares = all (isValidSubsection . selectSquare xss) count isValidSudokuSeq :: Seq (Seq Int) -> Bool isValidSudokuSeq xss = rows && columns && squares where count = [0..S.length xss-1] rows = all (isValidSubsectionSeq . selectRowSeq xss) count columns = all (isValidSubsectionSeq . selectColumnSeq xss) count squares = all (isValidSubsectionSeq . selectSquareSeq xss) count -- HA 3.1c) setCell :: [[Int]] -> (Int,Int) -> Int -> [[Int]] setCell xss (j, k) x = toList (update j newRow sudSequence) where row = xss !! j newRow = toList (update k x $fromList row) sudSequence = fromList xss setCellSeq :: Seq (Seq Int) -> (Int, Int) -> Int -> Seq (Seq Int) setCellSeq xss (j, k) x = update j (update k x (index xss j)) xss toSeq :: [[Int]] -> Seq(Seq Int) toSeq xss = fromList (map fromList xss) -- HA 3.1d) {-WETT-} solveSudoku :: [[Int]] -> [[Int]] solveSudoku xss | isSolved xss = xss | not $ isValidSudokuSeq sudSeq = [] | otherwise = fmap toList (toList btseq) where sudSeq = fromList $map fromList xss btseq = backTrackingSeq sudSeq backTrackingSeq :: Seq (Seq Int) -> Seq (Seq Int) backTrackingSeq sud | L.null nm = empty | isJust solvedNM = fromJust solvedNM | otherwise = let solvedBTSeq = L.find (\ s -> not (S.null s) && isSolvedSeq s) $map backTrackingSeq nm in fromMaybe empty solvedBTSeq where nm = nextMovesSeq sud solvedNM = L.find isSolvedSeq nm nextMovesSeq :: Seq (Seq Int) -> [Seq (Seq Int)] nextMovesSeq xss | isJust columnIndex = map (setCellSeq xss (fromJust rowWith0, fromJust columnIndex)) allowedNumbers | otherwise = [] where rowWith0 = S.findIndexL (isJust . elemIndexR 0) xss columnIndex = if isJust rowWith0 then elemIndexL 0 (index xss (fromJust rowWith0)) else Nothing allowedNumbers = (([1..L.length xss] \\ toList (selectRowSeq xss $fromJust rowWith0)) \\ toList (selectColumnSeq xss $fromJust columnIndex)) \\ toList (getSquareFromRC xss (fromJust rowWith0) (fromJust columnIndex)) getSquareFromRC :: Seq (Seq Int) -> Int -> Int -> Seq Int getSquareFromRC xss row column = selectSquareSeq xss squareNo where size = intRoot $S.length xss squareColumn = column `div` size squareRow = row `div` size squareNo = squareRow * size + squareColumn isSolvedSeq :: Seq (Seq Int) -> Bool isSolvedSeq s = isNothing (S.findIndexR (isJust . elemIndexR 0) s) {-TTEW-} {- 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 -} sud :: [[Int]] sud = [ [0,4,0,3], [0,1,0,0], [0,0,4,0], [0,0,0,0]] sud2 :: [[Int]] sud2 = [[0,0,0,2,6,0,7,0,1], [6,8,0,0,7,0,0,9,0], [1,9,0,0,0,4,5,0,0], [8,2,0,1,0,0,0,4,0], [0,0,4,6,0,2,9,0,0], [0,5,0,0,0,3,0,2,8], [0,0,9,3,0,0,0,7,4], [0,4,0,0,5,0,0,3,6], [7,0,3,0,1,8,0,0,0]] 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]] -- 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 = L.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 "+" $ L.replicate squareSize $ L.replicate ((numberSize + 1) * squareSize - 1) '-' chunksOf :: Int -> [e] -> [[e]] chunksOf i [] = [] chunksOf i ls = L.take i ls : chunksOf i (L.drop i ls) {-OLD VERSIONS USING LISTS-} isSolvedSeq2 :: Seq (Seq Int) -> Bool isSolvedSeq2 s = isNothing (elemIndexR 0 (foldl' (S.><) empty s)) backTracking :: [[Int]] -> [[Int]] backTracking xss | L.null nm = [] | or solved = head $L.filter isSolved nm | otherwise = let solved = L.filter isSolved bt in if L.null solved then [] else head solved where nm = L.filter (not . L.null) $nextMoves xss solved = map isSolved nm bt = L.filter (not . L.null) $map backTracking nm nextMoves :: [[Int]] -> [[[Int]]] nextMoves xss | isJust rowWith0 = let columnIndex = fromJust $elemIndex 0 (xss !! fromJust rowWith0) in L.filter isValidSudoku $map (setCell xss (fromJust rowWith0, columnIndex)) [1..L.length xss] | otherwise = [] where rowWith0 = findIndex (elem 0) xss isSolved :: [[Int]] -> Bool isSolved s = 0 `notElem` concat s