diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile | 22 | ||||
| -rw-r--r-- | hsolve/.gitignore | 7 | ||||
| -rw-r--r-- | hsolve/FSu.hs | 152 | ||||
| -rw-r--r-- | hsolve/Main.hs | 427 | ||||
| -rw-r--r-- | hsolve/hsolve.cabal | 16 | ||||
| -rw-r--r-- | hsolve/stack.yaml | 65 | ||||
| -rw-r--r-- | solve2.cpp | 209 |
8 files changed, 883 insertions, 16 deletions
@@ -1,4 +1,5 @@ solve +solve2 *.o *.dSYM .DS_Store @@ -1,24 +1,14 @@ CXX = g++ -CXXFLAGS = -Wall -Wextra -std=c++11 -fwrapv -g -ifneq ($(DEBUG),) - CXXFLAGS += -g -else - CXXFLAGS += -O2 -endif -BIN = solve +CXXFLAGS = -Wall -Wextra -std=c++11 -fwrapv -O2 +CXXTARGETS = solve solve2 .PHONY: all clean remake -all: $(BIN) +all: $(CXXTARGETS) clean: - rm -rf $(BIN) *.o *.dSYM + rm -rf $(CXXTARGETS) *.o *.dSYM -remake: clean all - -$(BIN): $(patsubst %.cpp,%.o,$(wildcard *.cpp)) - $(CXX) -o $@ $^ - -%.o: %.cpp $(wildcard *.h) - $(CXX) $(CXXFLAGS) -c -o $@ $< +$(CXXTARGETS): %: %.cpp + $(CXX) $(CXXFLAGS) -o $@ $^ diff --git a/hsolve/.gitignore b/hsolve/.gitignore new file mode 100644 index 0000000..fc6561a --- /dev/null +++ b/hsolve/.gitignore @@ -0,0 +1,7 @@ +*.hi +*.o +.stack-work/ +.cabal-sandbox +cabal.sandbox.config +.DS_Store +*.swp
\ No newline at end of file diff --git a/hsolve/FSu.hs b/hsolve/FSu.hs new file mode 100644 index 0000000..1bd250a --- /dev/null +++ b/hsolve/FSu.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables, RankNTypes #-} +module FSu(solve) where + +import Control.Monad +import Control.Monad.ST +import Data.Array.ST +import Data.STRef + + +type Value = Int -- Sudoku value +type Index = Int -- Sudoku index + +type Arr s a = STArray s Int a + +data State s = State { stateMark :: Arr s Bool, stateResults :: STRef s [[Maybe Value]] } + +solve :: [Maybe Value] -> [[Maybe Value]] +solve input = runST $ do + arr <- newListArray (0,80) $ map (maybe (-1) id) input :: ST s (Arr s Value) + mark <- newArray (0,8) False :: ST s (Arr s Bool) + results <- newSTRef [] :: ST s (STRef s [[Maybe Value]]) + solveAt arr 0 (State mark results) + readSTRef results + +obtainResult :: Arr s Value -> ST s [Maybe Value] +obtainResult arr = do + elems <- getElems arr + return $ [if v == (-1) then Nothing else Just v | v <- elems] + +solveAt :: Arr s Value -> Index -> State s -> ST s () +solveAt arr !i st = do + valid <- isValid arr st + when valid $ do + if i == 81 + then do + res <- obtainResult arr + modifySTRef' (stateResults st) (res:) + else do + v <- readArray arr i + if v /= (-1) + then solveAt arr (i+1) st + else do + poss <- getPoss arr i st + tryAll arr i poss st + +tryAll :: Arr s Value -> Index -> [Value] -> State s -> ST s () +tryAll _ _ [] _ = return () +tryAll arr !i (v:vs) st = do + writeArray arr i v + solveAt arr (i+1) st + writeArray arr i (-1) + tryAll arr i vs st + +-- assumes the considered position is empty +getPoss :: forall s. Arr s Value -> Index -> State s -> ST s [Value] +getPoss arr i st = do + fillArray mark 0 8 True + goRow (rowOf i) 0 + goCol (colOf i) 0 + goBlock (blockOrigin (blockOf i)) 0 + bs <- liftM (zip [0..8]) (getElems mark) + return $ map fst $ filter snd bs + where + mark = stateMark st + + goRow :: Int -> Int -> ST s () + goRow _ 9 = return () + goRow r j = readArray arr (9 * r + j) >>= \v -> + when (v /= (-1)) (writeArray mark v False) >> goRow r (j+1) + + goCol :: Int -> Int -> ST s () + goCol _ 9 = return () + goCol c j = readArray arr (9 * j + c) >>= \v -> + when (v /= (-1)) (writeArray mark v False) >> goCol c (j+1) + + goBlock :: Int -> Int -> ST s () + goBlock _ 9 = return () + goBlock b j = readArray arr (b + 9 * (j `quot` 3) + j `rem` 3) >>= \v -> + when (v /= (-1)) (writeArray mark v False) >> goBlock b (j+1) + +isValid :: forall s. Arr s Value -> State s -> ST s Bool +isValid arr st = do + goRows 0 >>= \r1 -> if r1 + then goCols 0 >>= \r2 -> if r2 + then goBlocks 0 + else return False + else return False + where + goRows, goCols, goBlocks :: Int -> ST s Bool + goRows 9 = return True + goRows i = isValidRow arr i st >>= \r -> if r then goRows (i+1) else return False + + goCols 9 = return True + goCols i = isValidCol arr i st >>= \r -> if r then goCols (i+1) else return False + + goBlocks 9 = return True + goBlocks i = isValidBlock arr i st >>= \r -> if r then goBlocks (i+1) else return False + +isValidRow :: Arr s Value -> Index -> State s -> ST s Bool +isValidRow arr r st = indexSetNoDups arr [9 * r + i | i <- [0..8]] st + +isValidCol :: Arr s Value -> Index -> State s -> ST s Bool +isValidCol arr c st = indexSetNoDups arr [9 * i + c | i <- [0..8]] st + +isValidBlock :: Arr s Value -> Index -> State s -> ST s Bool +isValidBlock arr b st = indexSetNoDups arr [blockOrigin b + 9 * y + x| y <- [0..2], x <- [0..2]] st + +indexSetNoDups :: forall s. Arr s Value -> [Index] -> State s -> ST s Bool +indexSetNoDups arr set st = do + fillArray mark 0 8 False + applyInMark set + where + mark = stateMark st + + applyInMark :: [Int] -> ST s Bool + applyInMark [] = return True + applyInMark (i:is) = + readArray arr i >>= \v -> + if v == (-1) + then applyInMark is + else do + b <- readArray mark v + if b + then return False + else writeArray mark v True >> applyInMark is + +fillArray :: Arr s a -> Int -> Int -> a -> ST s () +fillArray arr !i1 !i2 v + | i1 <= i2 = do + writeArray arr i1 v + fillArray arr (i1 + 1) i2 v + | otherwise = return () + +rowOf :: Index -> Index +rowOf i = i `quot` 9 + +colOf :: Index -> Index +colOf i = i `rem` 9 + +blockOf :: Index -> Index +blockOf i = 3 * (i `quot` 27) + (i `rem` 9) `quot` 3 + +blockOrigin :: Index -> Index +blockOrigin 0 = 0 +blockOrigin 1 = 3 +blockOrigin 2 = 6 +blockOrigin 3 = 27 +blockOrigin 4 = 30 +blockOrigin 5 = 33 +blockOrigin 6 = 54 +blockOrigin 7 = 57 +blockOrigin 8 = 60 diff --git a/hsolve/Main.hs b/hsolve/Main.hs new file mode 100644 index 0000000..015cb0f --- /dev/null +++ b/hsolve/Main.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE RankNTypes #-} +module Main where + +import Control.Monad +import Control.Monad.Writer +import Data.Char +import Data.Either +import Data.List +import Data.Maybe +import System.Exit + +import qualified FSu + + +lupdate :: Int -> a -> [a] -> [a] +lupdate 0 v (_:xs) = v:xs +lupdate i v (x:xs) = x : lupdate (i-1) v xs +lupdate _ _ [] = error "Empty list in lupdate" + +b2i :: Bool -> Int +b2i = fromEnum + + +newtype Sudoku = Sudoku [Either Value Poss] -- length 81 + deriving (Show, Eq) + +type Value = Int + +newtype Poss = Poss [Bool] -- length 9 + deriving (Show, Eq) + + +at :: Sudoku -> Int -> Either Value Poss +at (Sudoku l) i = l !! i + +atv :: Sudoku -> Int -> Maybe Value +atv su i = case at su i of + Left v -> Just v + Right _ -> Nothing + +atp :: Sudoku -> Int -> Poss +atp su i = case at su i of + Left _ -> Poss (replicate 9 False) + Right p -> p + +update :: Int -> Either Value Poss -> Sudoku -> Sudoku +update i v (Sudoku l) = Sudoku $ lupdate i v l + +listPoss :: [Value] -> Poss +listPoss l = Poss [i `elem` l | i <- [0..8]] + +possList :: Poss -> [Value] +possList (Poss m) = map snd $ filter fst $ zip m [0..8] + +possAnd :: Poss -> Poss -> Poss +possAnd (Poss l1) (Poss l2) = Poss (zipWith (&&) l1 l2) + +possOr :: Poss -> Poss -> Poss +possOr (Poss l1) (Poss l2) = Poss (zipWith (||) l1 l2) + +possElem :: Value -> Poss -> Bool +possElem n (Poss l) = 0 <= n && n < 9 && l !! n + +possExact1 :: [Poss] -> Poss +possExact1 [] = Poss (replicate 9 False) +possExact1 ps = Poss $ map (== 1) $ foldl1 (zipWith (+)) $ map (\(Poss p) -> map b2i p) ps + +possMakeAllExcept :: Value -> Poss +possMakeAllExcept n = Poss $ map (\i -> if i == n then False else True) [0..8] + +possGetIfInOne :: [Poss] -> Value -> Maybe Int +possGetIfInOne ps n = case concatMap (\(p,i) -> if n `possElem` p then [i] else []) (zip ps [0..]) of + [i] -> Just i + _ -> Nothing + + +backtrackSolve :: Sudoku -> [Sudoku] +backtrackSolve (Sudoku l) = do + let ml = map (either Just (const Nothing)) l + res <- FSu.solve ml + let l' = map (maybe (Right (listPoss [0..8])) Left) res + return $ Sudoku l' + + +data Region = Row Int Sudoku | Col Int Sudoku | Block Int Sudoku | Cell Int Sudoku + deriving (Show, Eq) + +rowOf :: Region -> Region +rowOf (Cell i su) = Row (i `div` 9) su + +colOf :: Region -> Region +colOf (Cell i su) = Col (i `mod` 9) su + +blockOf :: Region -> Region +blockOf (Cell i su) = Block (3 * (i `div` 27) + (i `mod` 9) `div` 3) su + +valueOf :: Region -> Maybe Value +valueOf (Cell i su) = su `atv` i + +possOf :: Region -> Poss +possOf (Cell i su) = su `atp` i + +contentsOf :: Region -> Either Value Poss +contentsOf (Cell i su) = su `at` i + +indexOf :: Region -> Int +indexOf (Cell i _) = i + + +sudokuOf :: Region -> Sudoku +sudokuOf (Cell _ su) = su +sudokuOf (Row _ su) = su +sudokuOf (Col _ su) = su +sudokuOf (Block _ su) = su + +indexRange :: Region -> [Int] +indexRange (Cell _ _) = [0] +indexRange (Row _ _) = [0..8] +indexRange (Col _ _) = [0..8] +indexRange (Block _ _) = [0..8] + +-- Doesn't check sudoku equality +cellIsIn :: Region -> Region -> Bool +cellIsIn (Cell i _) (Cell j _) = i == j +cellIsIn (Cell i _) (Row r _) = i `div` 9 == r +cellIsIn (Cell i _) (Col c _) = i `mod` 9 == c +cellIsIn (Cell i _) (Block b _) = (i `mod` 9) `div` 3 == b `mod` 3 && i `div` 27 == b `div` 3 + +adaptRegion :: Region -> Sudoku -> Region +adaptRegion (Cell i _) su = Cell i su +adaptRegion (Row i _) su = Row i su +adaptRegion (Col i _) su = Col i su +adaptRegion (Block i _) su = Block i su + + +class HasCells a where + cell :: Int -> a -> Region + +instance HasCells Sudoku where + cell i su | 0 <= i && i < 81 = Cell i su + +instance HasCells Region where + cell i (Row r su) | 0 <= i && i < 9 = Cell (9 * r + i) su + cell i (Col c su) | 0 <= i && i < 9 = Cell (9 * i + c) su + cell i (Block b su) | 0 <= i && i < 9 = + let bx = 3 * (b `mod` 3) + by = 3 * (b `div` 3) + in Cell (9 * (by + i `div` 3) + bx + i `mod` 3) su + cell 0 c@(Cell _ _) = c + cell _ _ = undefined + + +class HasValues a where + values :: a -> [Value] + +instance HasValues Sudoku where + values (Sudoku l) = lefts l + +instance HasValues Region where + values (Cell i su) = maybe [] pure (su `atv` i) + values reg = concatMap values [cell i reg | i <- indexRange reg] -- row, col, block + + +class UpdateValue a where + updateValue :: Int -> Value -> a -> Sudoku + +instance UpdateValue Sudoku where + updateValue i v su = update i (Left v) su + +instance UpdateValue Region where + updateValue 0 v (Cell j su) = update j (Left v) su + updateValue _ _ (Cell _ _) = undefined + updateValue i v reg = updateValue 0 v (cell i reg) -- row, col, block + + +class MaskPoss a where + maskPoss :: a -> Poss -> Sudoku + +instance MaskPoss Region where + maskPoss (Cell i su) p = case su `at` i of + Left _ -> su + Right p' -> update i (Right (p `possAnd` p')) su + maskPoss row@(Row r _) p = sudokuOf $ foldl (\row' i -> Row r $ maskPoss (cell i row') p) row [0..8] + maskPoss col@(Col c _) p = sudokuOf $ foldl (\col' i -> Col c $ maskPoss (cell i col') p) col [0..8] + maskPoss blk@(Block b _) p = sudokuOf $ foldl (\blk' i -> Block b $ maskPoss (cell i blk') p) blk [0..8] + + +readSudoku :: String -> Sudoku +readSudoku s = Sudoku $ flip map (words s) $ \w -> case w of + "." -> Right (Poss $ replicate 9 True) + [c] | '1' <= c && c <= '9' -> Left (ord c - ord '1') + _ -> error "Invalid sudoku input" + +writeSudokuGeneric :: Sudoku -> Bool -> String +writeSudokuGeneric su full = + intercalate "\n" + [testinter n "\n" ++ + intercalate " " + (map (\i -> testinter i " " ++ printone (su `atv` i) ++ printposs (su `atp` i)) [9*n..9*n+8]) + | n <- [0..8]] + where + printone :: Maybe Value -> String + printone Nothing = "." + printone (Just n) = show (n + 1) + + printposs :: Poss -> String + printposs (Poss m) = + let s = map snd $ filter fst $ zip m ['1'..'9'] + padded = replicate (9 - length s) ' ' ++ s + in if full then "(" ++ padded ++ ")" else "" + + testinter :: Int -> String -> String + testinter i s = let n = i `mod` 9 in if n > 0 && n `mod` 3 == 0 then s else "" + +writeSudoku :: Sudoku -> String +writeSudoku su = writeSudokuGeneric su False + +writeSudokuFull :: Sudoku -> String +writeSudokuFull su = writeSudokuGeneric su True + +writeSudokuDiff :: Sudoku -> Sudoku -> String +writeSudokuDiff su1 su2 = + intercalate "\n" $ flip map [0..8] $ \r -> + let line = flip concatMap [0..8] $ \c -> + (if c > 1 && c `mod` 3 == 0 then " " else "") + ++ (if c > 1 then " " else "") + ++ case (su1 `at` (9 * r + c), su2 `at` (9 * r + c)) of + (Left v1, Left v2) | v1 == v2 -> show (v2 + 1) ++ printposs pe pe + | otherwise -> high (show (v2 + 1)) ++ printposs pe pe + (Left _, Right p) -> high ("." ++ printposs p p) + (Right _, Left v) -> high (show (v + 1) ++ printposs pe pe) + (Right p1, Right p2) -> "." ++ printposs p1 p2 + in (if r > 1 && r `mod` 3 == 0 then "\n" else "") ++ line + where + high :: String -> String + high s = "\x1B[41;1m" ++ s ++ "\x1B[0m" + + pe :: Poss + pe = listPoss [] + + printposs :: Poss -> Poss -> String + printposs (Poss m1) (Poss m2) = + let s = flip concatMap [0..8] $ \i -> case (m1 !! i, m2 !! i) of + (True, True) -> show (i + 1) + (True, False) -> high "." + (False, True) -> high (show (i + 1)) + (False, False) -> " " + in "(" ++ s ++ ")" + + +data Action = AResolve Int Value Reason + | AScratch Int Value Reason + deriving (Show) + +data Reason = RCell | RRow | RCol | RBlock + | RCellI Int | RRowI Int | RColI Int | RBlockI Int + | RCombine Reason Reason + deriving (Show) + +type SM = Writer [Action] + +reasonReg :: Region -> Reason +reasonReg (Cell i _) = RCellI i +reasonReg (Row r _) = RRowI r +reasonReg (Col c _) = RColI c +reasonReg (Block b _) = RBlockI b + +writeAction :: Action -> String +writeAction (AResolve i n reason) = + "Resolved cell " ++ actionCellString i ++ " to value " ++ show (n + 1) ++ " (" ++ writeReason reason ++ ")" +writeAction (AScratch i n reason) = + "Scratched possibility for " ++ show (n + 1) ++ " in cell " ++ actionCellString i ++ " (" ++ writeReason reason ++ ")" + +actionCellString :: Int -> String +actionCellString i = "(" ++ show (i `mod` 9) ++ "," ++ show (i `div` 9) ++ ")" + +writeReason :: Reason -> String +writeReason RCell = "cell" +writeReason RRow = "row" +writeReason RCol = "column" +writeReason RBlock = "block" +writeReason (RCellI i) = "situation in cell " ++ show i +writeReason (RRowI i) = "situation in row " ++ show i +writeReason (RColI i) = "situation in column " ++ show i +writeReason (RBlockI i) = "situation in block " ++ show i +writeReason (RCombine a b) = writeReason a ++ "; " ++ writeReason b + + +scratchInRegionExcept :: Value -> Region -> Region -> Reason -> SM Sudoku +scratchInRegionExcept val reg except reason = + foldM (\su i -> + let cl = cell i (adaptRegion reg su) + in if cl `cellIsIn` except + then return su + else if val `possElem` possOf cl + then let su' = maskPoss cl (possMakeAllExcept val) + in tell [AScratch (indexOf cl) val reason] >> return su' + else return su) + (sudokuOf reg) (indexRange reg) + + +scratchPossBasic :: Sudoku -> (Sudoku, [Action]) +scratchPossBasic su = + let su1 = foldl (\su' regc -> scratchPossBasicRegion (regc su')) + su (concat [[Row i, Col i, Block i] | i <- [0..8]]) + in (su1, []) + +scratchPossBasicRegion :: Region -> Sudoku +scratchPossBasicRegion reg = maskPoss reg (listPoss $ [0..8] \\ values reg) + +scratchAroundCell :: Region -> Sudoku +scratchAroundCell cl@(Cell _ _) = + let su1 = scratchPossBasicRegion (rowOf cl) + su2 = scratchPossBasicRegion (colOf (adaptRegion cl su1)) + su3 = scratchPossBasicRegion (blockOf (adaptRegion cl su2)) + in su3 + +scratchPossIndirectB :: Sudoku -> (Sudoku, [Action]) +scratchPossIndirectB su = runWriter $ foldM bfunc su [0..8] + where + bfunc :: Sudoku -> Int -> SM Sudoku + bfunc su' bi = + let rowAllowed = flip map [0..2] $ + \i -> [possOf $ cell (3 * i + j) (Block bi su') | j <- [0..2]] + colAllowed = flip map [0..2] $ + \i -> [possOf $ cell (3 * j + i) (Block bi su') | j <- [0..2]] + rowIndices = scratchPairsFromAllowed rowAllowed + colIndices = scratchPairsFromAllowed colAllowed + in do + rowsu <- foldM (\su1 (i,n) -> -- i: row number in block; n: value + scratchInRegionExcept n (rowOf (cell (3 * i) (Block bi su1))) + (Block bi su1) (RCombine (reasonReg (Block bi su1)) RRow)) + su' rowIndices + colsu <- foldM (\su1 (i,n) -> -- i: row number in block; n: value + scratchInRegionExcept n (colOf (cell i (Block bi su1))) + (Block bi su1) (RCombine (reasonReg (Block bi su1)) RCol)) + rowsu colIndices + return colsu + + -- return [(index, n)] for all the n that occur in only one blockrow + scratchPairsFromAllowed :: [[Poss]] -> [(Int, Value)] + scratchPairsFromAllowed plists = + let allowed = map (foldl1 possOr) plists + in catMaybes $ + map (\(mi,n) -> maybe Nothing (\i -> Just (i,n)) mi) $ + -- v [(Just index if n exists in only one blockrow and else Nothing, n)] + zip (map (possGetIfInOne allowed) [0..8]) [0..8] + +resolveCells :: Sudoku -> (Sudoku, [Action]) +resolveCells su = runWriter $ foldM func su [0..80] + where + func :: Sudoku -> Int -> SM Sudoku + func su' i = case possList (su' `atp` i) of + [n] -> do + tell [AResolve i n RCell] + let su1 = updateValue i n su' + return $ scratchAroundCell (cell i su1) + _ -> return su' + +resolveRegions :: Sudoku -> (Sudoku, [Action]) +resolveRegions su = runWriter $ foldM func su [f i | f <- [Row, Col, Block], i <- [0..8]] + where + func :: Sudoku -> (Sudoku -> Region) -> SM Sudoku + func su' regc = + foldM (\su1 n -> + let reg = regc su1 + ps = map possOf [cell i reg | i <- indexRange reg] + in case possGetIfInOne ps n of + Nothing -> return su1 + Just i -> do + let su_i = indexOf (cell i reg) + tell [AResolve su_i n (reasonReg reg)] + let su2 = updateValue i n reg + return $ scratchAroundCell (cell su_i su2)) + su' [0..8] + + +operations :: [Sudoku -> (Sudoku, [Action])] +operations = [ + scratchPossBasic, scratchPossIndirectB, + resolveCells, + resolveRegions] + +solve :: Sudoku -> [(Sudoku, [Action])] +solve su = + let l = tail $ go su operations + (su', _) = last l + in if su' == su then [] else l ++ solve su' + where + go :: Sudoku -> [Sudoku -> (Sudoku, [Action])] -> [(Sudoku, [Action])] + go su1 ops = scanl (\(su2, _) op -> op su2) (su1, []) ops + +main :: IO () +main = do + su <- liftM readSudoku getContents + + let useBT = True + btSols = backtrackSolve su + + when useBT $ + case btSols of + [] -> do + die "Cannot solve sudoku using backtracking" + list -> do + putStrLn $ "Backtracking gave " ++ show (length list) ++ " solutions:" + forM_ list $ \res -> do + putStrLn $ writeSudoku res + putStr "\n" + + let reslist = (su, []) : solve su + suRes = fst (last reslist) + + putStrLn (writeSudokuFull su) + + mapM_ (\((su', acts), (prevsu, _)) -> do + putStr "\n\n" + mapM_ (putStrLn . writeAction) acts + -- print acts + putStrLn (writeSudokuDiff prevsu su')) + (zip (tail reslist) reslist) + + putStrLn (writeSudoku suRes) + putStr "\n" + + when useBT $ + when (length btSols /= 1 || suRes /= btSols !! 0) $ + die "Incorrectly solved!" diff --git a/hsolve/hsolve.cabal b/hsolve/hsolve.cabal new file mode 100644 index 0000000..4489d0b --- /dev/null +++ b/hsolve/hsolve.cabal @@ -0,0 +1,16 @@ +name: hsolve +version: 0.1.0 +cabal-version: >= 1.10 +build-type: Simple +license: MIT +author: Tom Smeding +maintainer: tom.smeding@gmail.com + +executable hsolve + hs-source-dirs: . + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -Wall -O3 -Wno-incomplete-patterns + other-modules: FSu + build-depends: base >= 4 && < 5, + mtl, array diff --git a/hsolve/stack.yaml b/hsolve/stack.yaml new file mode 100644 index 0000000..eb2d377 --- /dev/null +++ b/hsolve/stack.yaml @@ -0,0 +1,65 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-12.5 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# using the same syntax as the packages field. +# (e.g., acme-missiles-0.3) +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.7" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor
\ No newline at end of file diff --git a/solve2.cpp b/solve2.cpp new file mode 100644 index 0000000..84ab2a1 --- /dev/null +++ b/solve2.cpp @@ -0,0 +1,209 @@ +#include <iostream> +#include <iomanip> +#include <string> +#include <cassert> + +using namespace std; + + +struct Sudoku { + int bd[81]; + bool poss[81][9]; + + int& operator[](int i) {return bd[i];} + const int& operator[](int i) const {return bd[i];} + + int nposs(int i) const { + int t = 0; + for (int j = 0; j < 9; j++) { + t += poss[i][j]; + } + return t; + } +}; + +istream& operator>>(istream &in, Sudoku &su) { + for (int i = 0; i < 81; i++) { + char c; + in >> c; + if (c == '.') { + su[i] = -1; + } else { + assert('1' <= c && c <= '9'); + su[i] = c - '1'; + } + + for (int j = 0; j < 9; j++) { + su.poss[i][j] = true; + } + } + return in; +} + +ostream& operator<<(ostream &os, const Sudoku &su) { + for (int y = 0; y < 9; y++) { + if (y != 0) { + os << endl; + if (y % 3 == 0) os << endl; + } + + for (int x = 0; x < 9; x++) { + if (x != 0) { + os << ' '; + if (x % 3 == 0) os << ' '; + } + int v = su[9 * y + x]; + if (v == -1) os << '.'; + else os << v + 1; + string s; + for (int i = 0; i < 9; i++) { + if (su.poss[9 * y + x][i]) s += '1' + i; + } + // os << '(' << setw(9) << s << ')'; + } + } + + return os; +} + +void cleanPossBase(Sudoku &su, bool print=true) { + for (int y = 0; y < 9; y++) + for (int x = 0; x < 9; x++) { + if (su[9 * y + x] != -1) { + for (int i = 0; i < 9; i++) { + su.poss[9 * y + x][i] = false; + } + continue; + } + + for (int i = 0; i < 9; i++) { + if (i != x && su[9 * y + i] != -1 && su.poss[9 * y + x][su[9 * y + i]]) { + if (print) cerr << "Removed poss " << su[9 * y + i]+1 << " at " << i << " because same number in row" << endl; + su.poss[9 * y + x][su[9 * y + i]] = false; + } + if (i != y && su[9 * i + x] != -1 && su.poss[9 * y + x][su[9 * i + x]]) { + if (print) cerr << "Removed poss " << su[9 * i + x]+1 << " at " << i << " because same number in column" << endl; + su.poss[9 * y + x][su[9 * i + x]] = false; + } + int bx = x / 3 * 3 + i % 3; + int by = y / 3 * 3 + i / 3; + if ((bx != x || by != y) && su[9 * by + bx] != -1 && su.poss[9 * y + x][su[9 * by + bx]]) { + if (print) cerr << "Removed poss " << su[9 * by + bx]+1 << " at " << i << " because same number in block" << endl; + su.poss[9 * y + x][su[9 * by + bx]] = false; + } + } + } +} + +void cleanPossIndirectRC(Sudoku &su) { + for (int n = 0; n < 9; n++) { + for (int bi = 0; bi < 9; bi++) { + bool haveR[3] = {false, false, false}; + bool haveC[3] = {false, false, false}; + int bx = bi % 3 * 3, by = bi / 3 * 3; + + for (int y = by; y < by + 3; y++) { + for (int x = bx; x < bx + 3; x++) { + if (su.poss[9 * y + x][n]) { + haveR[y - by] = true; + haveC[x - bx] = true; + } + } + } + + if (haveR[0] + haveR[1] + haveR[2] == 1) { + int y = by + 0 * haveR[0] + 1 * haveR[1] + 2 * haveR[2]; + for (int x = 0; x < 9; x++) { + if (su.poss[9 * y + x][n]) { + cerr << "Removed poss " << n+1 << " at " << 9*y+x << " because row-local numbers in block " << bi << endl; + su.poss[9 * y + x][n] = false; + } + } + } + + if (haveC[0] + haveC[1] + haveC[2] == 1) { + int x = bx + 0 * haveC[0] + 1 * haveC[1] + 2 * haveC[2]; + for (int y = 0; y < 9; y++) { + if (by <= y && y < by + 3) continue; + if (su.poss[9 * y + x][n]) { + cerr << "Removed poss " << n+1 << " at " << 9*y+x << " because row-local numbers in block " << bi << endl; + su.poss[9 * y + x][n] = false; + } + } + } + } + } +} + +bool applySingles(Sudoku &su) { + for (int i = 0; i < 81; i++) { + if (su.nposs(i) == 1) { + for (int j = 0; j < 9; j++) { + if (su.poss[i][j]) { + cerr << "Set " << i << " to " << j+1 << " since nposs=1" << endl; + su[i] = j; + return true; + } + } + } + } + + return false; +} + +bool applyOnlysB(Sudoku &su) { + for (int n = 0; n < 9; n++) { + for (int bi = 0; bi < 9; bi++) { + int bx = bi % 3 * 3, by = bi / 3 * 3; + + int idx = -1; + for (int y = by; y < by + 3; y++) { + for (int x = bx; x < bx + 3; x++) { + if (su.poss[9 * y + x][n]) { + if (idx == -1) idx = 9 * y + x; + else goto nope_next; + } + } + } + + if (idx != -1) { + cerr << "Set " << idx << " to " << n+1 << " since only there in block" << endl; + su[idx] = n; + return true; + } + + nope_next: ; + } + } + + return false; +} + +bool performStep(Sudoku &su) { + cleanPossBase(su); + cleanPossIndirectRC(su); + + if (applySingles(su)) return true; + if (applyOnlysB(su)) return true; + + return false; +} + +void solve(Sudoku &su) { + cleanPossBase(su, false); + while (performStep(su)) { + cout << su << endl << endl; + } +} + +int main() { + cout << "This solver is incorrect. On suvh.txt, it gives a 5 on x=0 y=3, while that should be an 8." << endl; + return 1; + + Sudoku su; + cin >> su; + + solve(su); + + cout << su << endl; +} |