working version
This commit is contained in:
parent
42b22b91ca
commit
b7cb4c9cd7
SSH key fingerprint:
SHA256:G4+ddwoZmhLPRB1agvXzZMXIzkVJ36dUYZXf5NxT+u8
3 changed files with 170 additions and 271 deletions
|
|
@ -70,7 +70,8 @@ library
|
|||
-- Other library packages from which modules are imported.
|
||||
build-depends: base ^>=4.18.2.0,
|
||||
vector ^>=0.13.1.0,
|
||||
mtl ^>=2.3.1
|
||||
mtl ^>=2.3.1,
|
||||
split ^>=0.2.2
|
||||
|
||||
-- Directories containing source files.
|
||||
hs-source-dirs: src
|
||||
|
|
|
|||
139
app/Main.hs
139
app/Main.hs
|
|
@ -1,63 +1,102 @@
|
|||
module Main where
|
||||
|
||||
import Control.Monad.State (evalState)
|
||||
import Data.Char (digitToInt)
|
||||
import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe)
|
||||
import qualified Data.Vector as V
|
||||
import Types
|
||||
( Grid (Grid),
|
||||
allCells,
|
||||
colView,
|
||||
count,
|
||||
getCell,
|
||||
initGrid,
|
||||
mapGrid,
|
||||
printGrid,
|
||||
putCell,
|
||||
rowView,
|
||||
squareView,
|
||||
)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
-- putStrLn $ evalState (insert 5 (2, 5) >> showCandidates3) dummyState
|
||||
putStr $ printSudoku dummyGrid
|
||||
print $ isValidGrid dummyGrid
|
||||
putStr . printGrid . fromJust $ solve dummyGrid
|
||||
|
||||
-- print $ evalState (getBoxRange 1) dummyState
|
||||
-- print $ evalState (getBoxRange 2) dummyState
|
||||
-- print $ evalState (getBoxRange 3) dummyState
|
||||
-- print $ evalState (getBoxRange 4) dummyState
|
||||
-- print $ evalState (getBoxRange 5) dummyState
|
||||
-- print $ evalState (getBoxRange 6) dummyState
|
||||
-- print $ evalState (getBoxRange 7) dummyState
|
||||
-- print $ evalState (getBoxRange 8) dummyState
|
||||
-- print $ evalState (getBoxRange 9) dummyState
|
||||
|
||||
-- print $ evalState (getBox (1, 4)) dummyState
|
||||
|
||||
let sudoku = read test :: Sudoku
|
||||
|
||||
putStrLn "Reading:"
|
||||
print sudoku
|
||||
putStrLn "Pretty Printing:"
|
||||
putStrLn $ pretty sudoku
|
||||
|
||||
putStrLn "Candidates:"
|
||||
putStrLn $ evalState (insertAll sudoku >> showCandidates3) initState
|
||||
-- print $ colView dummyGrid 4
|
||||
-- print $ squareView dummyGrid 4
|
||||
-- print $ squareToCoords dummyGrid 0
|
||||
-- print $ squareToCoords dummyGrid 1
|
||||
-- print $ squareToCoords dummyGrid 2
|
||||
-- print $ squareToCoords dummyGrid 3
|
||||
-- print $ squareToCoords dummyGrid 4
|
||||
-- print $ squareToCoords dummyGrid 5
|
||||
-- print $ squareToCoords dummyGrid 6
|
||||
-- print $ squareToCoords dummyGrid 7
|
||||
-- print $ squareToCoords dummyGrid 8
|
||||
-- print $ allCells dummyGrid (>= 0)
|
||||
|
||||
test :: String
|
||||
test = "070000043040009610800634900094052000358460020000800530080070091902100005007040802"
|
||||
|
||||
{-
|
||||
070 000 043
|
||||
040 009 610
|
||||
800 634 900
|
||||
094 052 000
|
||||
358 460 020
|
||||
000 800 530
|
||||
080 070 091
|
||||
902 100 005
|
||||
007 040 802
|
||||
-}
|
||||
dummyState :: SudokuState
|
||||
dummyState =
|
||||
SudokuState
|
||||
{ dimension = 3,
|
||||
grid = V.replicate 81 0,
|
||||
idxs = V.fromList [(x, y) | x <- [1 .. 9], y <- [1 .. 9]],
|
||||
candidates = V.replicate 81 (V.replicate 9 True)
|
||||
}
|
||||
dummyGrid :: Grid (Maybe Int)
|
||||
dummyGrid = initGrid 3 (map toMaybeInt test)
|
||||
where
|
||||
toMaybeInt :: Char -> Maybe Int
|
||||
toMaybeInt c = if int == 0 then Nothing else Just int
|
||||
where
|
||||
int = digitToInt c
|
||||
|
||||
initState :: SudokuState
|
||||
initState =
|
||||
SudokuState
|
||||
{ dimension = 0,
|
||||
grid = V.empty,
|
||||
idxs = V.empty,
|
||||
candidates = V.empty
|
||||
}
|
||||
printSudoku :: Grid (Maybe Int) -> String
|
||||
printSudoku gr = printGrid mappedGrid
|
||||
where
|
||||
mappedGrid :: Grid Int
|
||||
mappedGrid = mapGrid (fromMaybe 0) gr
|
||||
|
||||
isValidGrid :: Grid (Maybe Int) -> Bool
|
||||
isValidGrid gr@(Grid _ d) =
|
||||
all isValidRow [0 .. d * d - 1]
|
||||
&& all isValidCol [0 .. d * d - 1]
|
||||
&& all isValidSquare [0 .. d * d - 1]
|
||||
where
|
||||
validView :: V.Vector (Maybe Int) -> Bool
|
||||
validView v = V.foldl (\drag (e, c) -> case e of Nothing -> drag; Just _ -> (c < 2) && drag) True counts
|
||||
where
|
||||
counts = V.map (\e -> (e, count v e)) v
|
||||
isValidRow :: Int -> Bool
|
||||
isValidRow y = validView $ rowView gr y
|
||||
isValidCol :: Int -> Bool
|
||||
isValidCol x = validView $ colView gr x
|
||||
isValidSquare :: Int -> Bool
|
||||
isValidSquare n = validView $ squareView gr n
|
||||
|
||||
isFull :: Grid (Maybe Int) -> Bool
|
||||
isFull gr = allCells gr isJust
|
||||
|
||||
isSolved :: Grid (Maybe Int) -> Bool
|
||||
isSolved gr@(Grid g d) = isValidGrid gr && isFull gr
|
||||
|
||||
extractSolution :: Grid (Maybe Int) -> Grid Int
|
||||
extractSolution gr =
|
||||
if not (isSolved gr)
|
||||
then error "trying to extract solution from unsolved grid"
|
||||
else mapGrid (fromMaybe 0) gr
|
||||
|
||||
solveHelper :: Grid (Maybe Int) -> (Int, Int) -> Maybe (Grid Int)
|
||||
solveHelper gr@(Grid _ d) (x, y)
|
||||
| not (isValidGrid gr) = Nothing
|
||||
| isSolved gr = Just (extractSolution gr)
|
||||
| otherwise = case cell of
|
||||
Nothing -> if not (null solvedGrids) then head solvedGrids else Nothing
|
||||
Just _ -> solveHelper gr nextCoord
|
||||
where
|
||||
placeAndSolve :: Int -> Maybe (Grid Int)
|
||||
placeAndSolve n = solveHelper newGrid nextCoord
|
||||
where
|
||||
newGrid = putCell gr (x, y) (Just n)
|
||||
solvedGrids = map Just (mapMaybe placeAndSolve [1 .. d * d])
|
||||
cell = getCell gr (x, y)
|
||||
nextCoord = if x < d * d - 1 then (x + 1, y) else (0, y + 1)
|
||||
|
||||
solve :: Grid (Maybe Int) -> Maybe (Grid Int)
|
||||
solve gr = solveHelper gr (0, 0)
|
||||
299
src/Types.hs
299
src/Types.hs
|
|
@ -1,245 +1,104 @@
|
|||
{-# LANGUAGE InstanceSigs #-}
|
||||
|
||||
module Types where
|
||||
|
||||
import Control.Monad (forM_, when)
|
||||
import Control.Monad.State (MonadState (put), State, get, gets, modify)
|
||||
import Data.Char (digitToInt, intToDigit)
|
||||
import Data.Vector (Vector, slice)
|
||||
import Data.List (intercalate)
|
||||
import Data.List.Split (chunksOf, keepDelimsL, split, splitWhen, whenElt)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Vector (Vector)
|
||||
import qualified Data.Vector as V
|
||||
import Debug.Trace
|
||||
|
||||
-- * Stateful Sudoku Type
|
||||
type Row a = Vector a
|
||||
|
||||
data SudokuState = SudokuState
|
||||
{ dimension :: Int,
|
||||
grid :: Vector Int,
|
||||
idxs :: Vector (Int, Int),
|
||||
candidates :: Vector (Vector Bool)
|
||||
data Grid a = Grid
|
||||
{ grid :: Vector (Row a),
|
||||
dimension :: Int
|
||||
}
|
||||
|
||||
type SudokuMonad = State SudokuState
|
||||
initGrid :: Int -> [a] -> Grid a
|
||||
initGrid d vs = Grid (V.fromList . map V.fromList $ chunksOf (d * d) vs) d
|
||||
|
||||
getField :: (Int, Int) -> SudokuMonad Int
|
||||
getField (x, y) = do
|
||||
state <- get
|
||||
return $ grid state ! (x + y * dimension state)
|
||||
getRow :: Grid a -> Int -> Row a
|
||||
getRow (Grid g d) y =
|
||||
if y >= d * d || y < 0
|
||||
then error ("getRow: y=" ++ show y ++ " is out of dimension=" ++ show d)
|
||||
else g V.! y
|
||||
|
||||
getRow :: (Int, Int) -> SudokuMonad Int
|
||||
getRow (_, y) = return y
|
||||
putRow :: Grid a -> Row a -> Int -> Grid a
|
||||
putRow (Grid g d) newRow y =
|
||||
if y >= d * d || y < 0
|
||||
then error ("putRow: y=" ++ show y ++ " is out of dimension=" ++ show d)
|
||||
else Grid (g V.// [(y, newRow)]) d
|
||||
|
||||
getCol :: (Int, Int) -> SudokuMonad Int
|
||||
getCol (x, _) = return x
|
||||
|
||||
getBox :: (Int, Int) -> SudokuMonad Int
|
||||
getBox (x, y) = do
|
||||
d <- gets dimension
|
||||
let xPart = ((x - 1) `div` d) + 1
|
||||
let yPart = (y - 1) `div` d
|
||||
return $ xPart + (d * yPart)
|
||||
|
||||
getRowRange :: Int -> SudokuMonad [Int]
|
||||
getRowRange row = do
|
||||
d <- gets dimension
|
||||
return [x + ((row - 1) * d * d) | x <- [1 .. d * d]]
|
||||
|
||||
getColRange :: Int -> SudokuMonad [Int]
|
||||
getColRange col = do
|
||||
d <- gets dimension
|
||||
return [col + ((x - 1) * d * d) | x <- [1 .. d * d]]
|
||||
|
||||
getBoxRange :: Int -> SudokuMonad [Int]
|
||||
getBoxRange box = do
|
||||
d <- gets dimension
|
||||
let (x, y) = getXY box
|
||||
flatIdx <- flattenIdx (x, y)
|
||||
return [flatIdx + n + (m * d * d) | m <- [0 .. d - 1], n <- [0 .. d - 1]]
|
||||
updateRow :: Grid a -> (Row a -> Row a) -> Int -> Grid a
|
||||
updateRow gr upd y = putRow gr (upd oldRow) y
|
||||
where
|
||||
-- \| Maps a box number to its upper left corner
|
||||
getXY :: Int -> (Int, Int)
|
||||
getXY 1 = (1, 1)
|
||||
getXY 2 = (4, 1)
|
||||
getXY 3 = (7, 1)
|
||||
getXY 4 = (1, 4)
|
||||
getXY 5 = (4, 4)
|
||||
getXY 6 = (7, 4)
|
||||
getXY 7 = (1, 7)
|
||||
getXY 8 = (4, 7)
|
||||
getXY 9 = (7, 7)
|
||||
getXY n = error $ "tried to getXY of box number: " ++ show n
|
||||
oldRow = getRow gr y
|
||||
|
||||
flattenIdx :: (Int, Int) -> SudokuMonad Int
|
||||
flattenIdx (x, y) = do
|
||||
d <- gets dimension
|
||||
return (x + (d * d * (y - 1)))
|
||||
putCell :: Grid a -> (Int, Int) -> a -> Grid a
|
||||
putCell gs@(Grid _ d) (x, y) v =
|
||||
if x >= d * d || x < 0
|
||||
then error "putCell out of bounds"
|
||||
else updateRow gs (\row -> row V.// [(x, v)]) y
|
||||
|
||||
updateVector :: Vector a -> Int -> a -> Vector a
|
||||
updateVector v idx x = V.update v (V.singleton (idx - 1, x))
|
||||
|
||||
dropCandidate :: Int -> Vector Bool -> Vector Bool
|
||||
dropCandidate n bs = updateVector bs n False
|
||||
|
||||
dropAllCandidates :: Vector Bool -> Vector Bool
|
||||
dropAllCandidates = V.map (const False)
|
||||
|
||||
(!) :: Vector a -> Int -> a
|
||||
v ! n = v V.! (n - 1)
|
||||
|
||||
gridInsert :: Int -> (Int, Int) -> SudokuMonad ()
|
||||
gridInsert n idx = do
|
||||
flatIdx <- flattenIdx idx
|
||||
g <- gets grid
|
||||
modify (\s -> s {grid = updateVector g flatIdx n})
|
||||
|
||||
removeInRow :: Int -> (Int, Int) -> SudokuMonad ()
|
||||
removeInRow n idx = do
|
||||
rr <- getRow idx >>= getRowRange
|
||||
forM_ rr remover
|
||||
getCell :: Grid a -> (Int, Int) -> a
|
||||
getCell gs@(Grid _ d) (x, y) =
|
||||
if x >= d * d || x < 0
|
||||
then error "getCell: x out of bounds"
|
||||
else row V.! x
|
||||
where
|
||||
remover :: Int -> SudokuMonad ()
|
||||
remover pos = do
|
||||
cs <- gets candidates
|
||||
let cand = cs ! pos
|
||||
let cand' = dropCandidate n cand
|
||||
modify (\s -> s {candidates = updateVector cs pos cand'})
|
||||
row = getRow gs y
|
||||
|
||||
removeInCol :: Int -> (Int, Int) -> SudokuMonad ()
|
||||
removeInCol n idx = do
|
||||
cr <- getCol idx >>= getColRange
|
||||
forM_ cr remover
|
||||
printGrid :: (Show a) => Grid a -> String
|
||||
printGrid gr@(Grid _ d) = unwords . intercalate ["\n"] . chunksOf 3 . (split . keepDelimsL . whenElt) (== '\n') . unlines $ map printRow [0 .. (d * d) - 1]
|
||||
where
|
||||
remover :: Int -> SudokuMonad ()
|
||||
remover pos = do
|
||||
cs <- gets candidates
|
||||
let cand = cs ! pos
|
||||
let cand' = dropCandidate n cand
|
||||
modify (\s -> s {candidates = updateVector cs pos cand'})
|
||||
printRow :: Int -> String
|
||||
printRow _y = unwords $ map printSquare [0 .. d - 1]
|
||||
where
|
||||
y = checkDimension d _y
|
||||
row = getRow gr y
|
||||
printSquare :: Int -> String
|
||||
printSquare n =
|
||||
if n * d >= d * d || n < 0
|
||||
then error ("trying to print square " ++ show n ++ " which is out of bounds (dimension: " ++ show d ++ ")")
|
||||
else concatMap (\m -> show $ row V.! (n * d + m)) [0 .. d - 1]
|
||||
|
||||
removeInBox :: Int -> (Int, Int) -> SudokuMonad ()
|
||||
removeInBox n idx = do
|
||||
br <- getBox idx >>= getBoxRange
|
||||
forM_ br remover
|
||||
checkDimension :: Int -> Int -> Int
|
||||
checkDimension d v =
|
||||
if v >= d * d || v < 0
|
||||
then error ("value " ++ show v ++ " out of dimension: " ++ show d)
|
||||
else v
|
||||
|
||||
update :: Grid a -> Int -> Int -> a -> Grid a
|
||||
update (Grid g d) _x _y v = Grid newG d
|
||||
where
|
||||
remover :: Int -> SudokuMonad ()
|
||||
remover pos = do
|
||||
cs <- gets candidates
|
||||
let cand = cs ! pos
|
||||
let cand' = dropCandidate n cand
|
||||
modify (\s -> s {candidates = updateVector cs pos cand'})
|
||||
x = checkDimension d _x
|
||||
y = checkDimension d _y
|
||||
row = g V.! y
|
||||
newRow = row V.// [(x, v)]
|
||||
newG = g V.// [(y, newRow)]
|
||||
|
||||
insert :: Int -> (Int, Int) -> SudokuMonad ()
|
||||
insert n idx = do
|
||||
gridInsert n idx
|
||||
-- traceM $ "inserting " ++ show n
|
||||
removeInRow n idx
|
||||
removeInCol n idx
|
||||
removeInBox n idx
|
||||
-- remove all candidates for this cell
|
||||
flatIdx <- flattenIdx idx
|
||||
cs <- gets candidates
|
||||
let cand = cs ! flatIdx
|
||||
let cand' = dropAllCandidates cand
|
||||
modify (\s -> s {candidates = updateVector cs flatIdx cand'})
|
||||
allCells :: Grid a -> (a -> Bool) -> Bool
|
||||
allCells (Grid g _) test = V.all id rows
|
||||
where
|
||||
rows :: Vector Bool
|
||||
rows = V.map (V.all test) g
|
||||
|
||||
insertAll :: Sudoku -> SudokuMonad ()
|
||||
insertAll (Sudoku d g) = do
|
||||
let coords = [(x, y) | y <- [1 .. d * d], x <- [1 .. d * d]]
|
||||
let initialState =
|
||||
SudokuState
|
||||
{ dimension = d,
|
||||
grid = V.replicate (d * d * d * d) 0,
|
||||
idxs = V.fromList coords,
|
||||
candidates = V.replicate (d * d * d * d) (V.replicate (d * d) True)
|
||||
}
|
||||
put initialState
|
||||
forM_ (zip g coords) (\(n, idx) -> when (n /= 0) (insert n idx))
|
||||
rowView :: Grid a -> Int -> Row a
|
||||
rowView = getRow
|
||||
|
||||
showCandidates3 :: SudokuMonad String
|
||||
showCandidates3 = do
|
||||
cs <- gets candidates
|
||||
let cs' = V.map (V.filter (/= 0) . V.imap (\idx b -> if b then idx + 1 else 0)) cs
|
||||
return $
|
||||
show (slice 0 9 cs')
|
||||
++ "\n"
|
||||
++ show (slice 9 9 cs')
|
||||
++ "\n"
|
||||
++ show (slice 18 9 cs')
|
||||
++ "\n"
|
||||
++ show (slice 27 9 cs')
|
||||
++ "\n"
|
||||
++ show (slice 36 9 cs')
|
||||
++ "\n"
|
||||
++ show (slice 45 9 cs')
|
||||
++ "\n"
|
||||
++ show (slice 54 9 cs')
|
||||
++ "\n"
|
||||
++ show (slice 63 9 cs')
|
||||
++ "\n"
|
||||
++ show (slice 72 9 cs')
|
||||
colView :: Grid a -> Int -> Row a
|
||||
colView gr@(Grid _ d) x = V.generate (d * d) (\y -> getCell gr (x, y))
|
||||
|
||||
showGrid :: SudokuMonad String
|
||||
showGrid = do
|
||||
g <- gets grid
|
||||
return $ show g
|
||||
-- returns topleft coords of the square
|
||||
squareToCoords :: Grid a -> Int -> (Int, Int)
|
||||
squareToCoords (Grid _ d) m = ((m `mod` d) * d, (m `div` d) * d)
|
||||
|
||||
-- * Stateless Sudoku Type
|
||||
squareView :: Grid a -> Int -> Row a
|
||||
squareView gr@(Grid _ d) n = V.concat (map (\y -> V.generate d (\x -> getCell gr (x + xoff, y + yoff))) [0 .. d - 1])
|
||||
where
|
||||
(xoff, yoff) = squareToCoords gr n
|
||||
|
||||
--
|
||||
count :: (Eq a) => Vector a -> a -> Int
|
||||
count v a = V.foldl (\c b -> if a == b then c + 1 else c) 0 v
|
||||
|
||||
-- $statelessFlattened
|
||||
--
|
||||
-- Here we define a simpler Sudoku type that would be very inneficient to work with
|
||||
-- but is suitable for pretty printing and reading
|
||||
|
||||
-- | Contains metadata concerning a Sudoku field
|
||||
data Sudoku = Sudoku
|
||||
{ -- | The dim of the Sudoku, e.g. a 9x9 Sudoku field has dim 3
|
||||
dim :: Int,
|
||||
-- | The Sudoku field as a flattened list
|
||||
grd :: [Int]
|
||||
}
|
||||
|
||||
instance Show Sudoku where
|
||||
show :: Sudoku -> String
|
||||
show = map intToDigit . grd
|
||||
|
||||
instance Read Sudoku where
|
||||
readsPrec :: Int -> ReadS Sudoku
|
||||
readsPrec _ s =
|
||||
if isInt dimDouble
|
||||
then [(Sudoku (floor dimDouble) (map digitToInt s), "")]
|
||||
else error ("Trying to parse malformed sudoku (number of digits [" ++ show (length s) ++ "] is not a quadratic root):\n" ++ s)
|
||||
where
|
||||
isInt x = x == fromInteger (round x)
|
||||
dimDouble = sqrt . sqrt $ (fromIntegral (length s) :: Double)
|
||||
|
||||
-- | Pretty printing of values. Analogous to the `Show` class, but does not harmonize with `Read`.
|
||||
class Pretty a where
|
||||
-- | Works like `show`, but is not inverse to `read`.
|
||||
pretty :: a -> String
|
||||
|
||||
-- TODO improve pretty printer, this is kind of a mess
|
||||
instance Pretty Sudoku where
|
||||
pretty :: Sudoku -> String
|
||||
pretty s = prettyHelper (dim s - 1, dim s, grd s)
|
||||
where
|
||||
-- prettyBlock (isLast, n, list)
|
||||
prettyBlock :: (Bool, Int, [Int]) -> String
|
||||
prettyBlock (_, _, []) = ""
|
||||
prettyBlock (True, n, _) | n == 0 = ""
|
||||
prettyBlock (False, n, _) | n == 0 = "|"
|
||||
prettyBlock (b, n, x : xs) = intToDigit x : ' ' : prettyBlock (b, n - 1, xs)
|
||||
-- prettyRow (n, d, list)
|
||||
prettyRow :: (Int, Int, [Int]) -> String
|
||||
prettyRow (n, d, xs) | n == 0 = prettyBlock (True, d, xs)
|
||||
prettyRow (n, d, xs) = prettyBlock (False, d, xs) ++ (' ' : prettyRow (n - 1, d, drop d xs))
|
||||
-- prettyCol (isLast, n, d, list)
|
||||
prettyCol :: (Bool, Int, Int, [Int]) -> String
|
||||
prettyCol (True, n, _, _) | n == 0 = ""
|
||||
prettyCol (False, n, d, _) | n == 0 = replicate (2 * d * d - 1 + 2 * (d - 1)) '-'
|
||||
prettyCol (_, _, _, []) = ""
|
||||
prettyCol (b, n, d, xs) = prettyRow (d - 1, d, xs) ++ ('\n' : prettyCol (b, n - 1, d, drop (d * d) xs))
|
||||
-- prettyHelper (n, d, list)
|
||||
prettyHelper :: (Int, Int, [Int]) -> String
|
||||
prettyHelper (n, d, xs) | n == 0 = prettyCol (True, d, d, xs)
|
||||
prettyHelper (n, d, xs) = prettyCol (False, d, d, xs) ++ ('\n' : prettyHelper (n - 1, d, drop (d * d * d) xs))
|
||||
mapGrid :: (a -> b) -> Grid a -> Grid b
|
||||
mapGrid f (Grid g d) = Grid (V.map (V.map f) g) d
|
||||
Loading…
Reference in a new issue