Skip to content

Instantly share code, notes, and snippets.

@matthayter
Created June 21, 2015 19:49

Revisions

  1. matthayter created this gist Jun 21, 2015.
    108 changes: 108 additions & 0 deletions Sudoku
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,108 @@
    import Data.Matrix
    import Data.Maybe
    import Data.List
    import Data.Char
    import Control.Monad
    import qualified Data.Vector

    type Puzzle = Matrix (Maybe Int)

    puzzle = puzzleFromLines
    ["7 5 - 8 9 1 - - -",
    "- - 1 6 - - 9 8 -",
    "- 9 - - - - 7 - -",
    "1 4 - - 5 - 3 7 -",
    "- 7 - - 3 - 6 1 4",
    "- - 9 - - 4 5 - -",
    "- - - - - - - 4 -",
    "- 6 - 3 - 2 1 - -",
    "2 - 3 - - 9 - 5 -"]

    showPuzzle = unlines . (map showRow) . toLists

    showRow = unwords . map showNumber

    showNumber :: Maybe Int -> String
    showNumber (Just n) = show n
    showNumber Nothing = "-"

    solvePuzzle :: Puzzle -> IO (Maybe Puzzle)
    solvePuzzle p = do
    putStrLn $ showPuzzle p
    if isFull p
    then return $ Just p
    else
    sequenceUntilJust $ map solvePuzzle $ genSinglePermutations p

    readPuzzle :: IO Puzzle
    readPuzzle = do
    lines <- sequence $ take 9 $ repeat getLine
    return $ puzzleFromLines lines

    puzzleFromLines lines =
    let chars = filter (not . isSpace) $ unwords lines
    in
    fromList 9 9 $ map toCell chars

    toCell :: Char -> Maybe Int
    toCell n = if isHexDigit n then Just (digitToInt n) else Nothing

    -- Special case of sequenceUntilJust to collapse the Maybe (Maybe a)
    sequenceUntilJust :: Monad m => [m (Maybe b)] -> m (Maybe b)
    sequenceUntilJust xs = join <$> (sequenceUntil isJust xs)

    sequenceUntil :: Monad m => (a -> Bool) -> [m a] -> m (Maybe a)
    sequenceUntil _ [] = return Nothing
    sequenceUntil test (x:xs) = do
    thisResult <- x
    if test thisResult
    then return (Just thisResult)
    else sequenceUntil test xs

    genSinglePermutations p =
    filter (checkValidity editLocation) $ permutations
    where
    editLocation = findFirstEmpty p
    permutations = map (setCellTo p editLocation) [1..9]

    isFull :: Puzzle -> Bool
    isFull =
    all isJust . toList

    checkValidity :: (Int, Int) -> Puzzle -> Bool
    checkValidity (x, y) p =
    checkRow newNum (getRow x p) &&
    checkRow newNum (getCol y p) &&
    boxIsValid (getBox p x y) newNum
    where newNum = fromMaybe (error "wut") $ getElem x y p

    getBox :: Puzzle -> Int -> Int -> Matrix (Maybe Int)
    getBox p x y = submatrix startRow endRow startCol endCol p
    where
    startRow = (((x-1) `div` 3)*3) + 1
    startCol = (((y-1) `div` 3)*3) + 1
    endRow = startRow + 2
    endCol = startCol + 2

    boxIsValid box val =
    1 == length (filter (== Just val) (toList box))

    checkRow :: Int -> Data.Vector.Vector (Maybe Int) -> Bool
    checkRow val row = length (Data.Vector.filter (== (Just val)) row) == 1

    findFirstEmpty :: Puzzle -> (Int, Int)
    findFirstEmpty p = fst $ head $ filter (isNothing . snd) $ map (getElemByPair p) listPairs

    getElemByPair :: Puzzle -> (Int, Int) -> ((Int, Int), Maybe Int)
    getElemByPair p (x, y) = ((x, y), getElem x y p)

    listPairs :: [(Int, Int)]
    listPairs = [(x, y) | x <- [1..9], y <- [1..9] ]

    setCellTo :: Puzzle -> (Int, Int) -> Int -> Puzzle
    setCellTo p loc value = setElem (Just value) loc p

    -- main = do
    -- p <- readPuzzle
    -- putStrLn $ showPuzzle p
    main = solvePuzzle puzzle