diff options
Diffstat (limited to 'hsolve')
| -rw-r--r-- | hsolve/FSu.hs | 2 | ||||
| -rw-r--r-- | hsolve/Main.hs | 161 | ||||
| -rwxr-xr-x | hsolve/verify.sh | 2 |
3 files changed, 116 insertions, 49 deletions
diff --git a/hsolve/FSu.hs b/hsolve/FSu.hs index dc0f4c6..7429da2 100644 --- a/hsolve/FSu.hs +++ b/hsolve/FSu.hs @@ -104,7 +104,7 @@ 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 +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 diff --git a/hsolve/Main.hs b/hsolve/Main.hs index 015cb0f..52a0edd 100644 --- a/hsolve/Main.hs +++ b/hsolve/Main.hs @@ -63,15 +63,26 @@ 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 +possExact1 ps = + Poss $ map (== 1) $ + foldl1 (zipWith (+)) $ map (\(Poss p) -> map b2i p) ps + +fullPoss :: Poss +fullPoss = Poss (replicate 9 True) + +emptyPoss :: Poss +emptyPoss = Poss (replicate 9 False) possMakeAllExcept :: Value -> Poss -possMakeAllExcept n = Poss $ map (\i -> if i == n then False else True) [0..8] +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 +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] @@ -82,7 +93,10 @@ backtrackSolve (Sudoku l) = do return $ Sudoku l' -data Region = Row Int Sudoku | Col Int Sudoku | Block Int Sudoku | Cell Int Sudoku +data Region = Row Int Sudoku + | Col Int Sudoku + | Block Int Sudoku + | Cell Int Sudoku deriving (Show, Eq) rowOf :: Region -> Region @@ -124,7 +138,8 @@ 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 +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 @@ -158,7 +173,8 @@ instance HasValues Sudoku where 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 + values reg = -- row, col, block + concatMap values [cell i reg | i <- indexRange reg] class UpdateValue a where @@ -180,9 +196,18 @@ 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] + 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] + + +-- Returns cells in first region that also occur in second region +intersectReg :: Region -> Region -> [Region] +intersectReg reg1 reg2 = + filter (\c -> c `cellIsIn` reg2) [cell i reg1 | i <- indexRange reg1] readSudoku :: String -> Sudoku @@ -196,7 +221,10 @@ 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]) + (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 @@ -225,8 +253,9 @@ writeSudokuDiff su1 su2 = (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 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 @@ -267,9 +296,11 @@ reasonReg (Block b _) = RBlockI b writeAction :: Action -> String writeAction (AResolve i n reason) = - "Resolved cell " ++ actionCellString i ++ " to value " ++ show (n + 1) ++ " (" ++ writeReason 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 ++ ")" + "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) ++ ")" @@ -315,36 +346,70 @@ scratchAroundCell cl@(Cell _ _) = 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] +scratchPossIndirectReg :: Region -> [Region] -> SM Sudoku +scratchPossIndirectReg mainreg intregs' = + let intregs = filter (\intreg -> not $ null $ intersectReg mainreg intreg) intregs' + su = sudokuOf mainreg + intcells = [intersectReg mainreg intreg | intreg <- intregs] + alloweds = [foldl possOr emptyPoss (map possOf l) | l <- intcells] + valOnlyInWhich = -- [(index, value)] for each value in only one intersection + concat [maybe [] (\i -> [(val, i)]) (possGetIfInOne alloweds val) + | val <- [0..8]] + in foldM (\su1 (i,v) -> + scratchInRegionExcept + v + (adaptRegion (intregs !! i) su1) + mainreg + (RCombine (reasonReg mainreg) (reasonReg (intregs !! i)))) + su valOnlyInWhich + +scratchPossIndirect :: Sudoku -> (Sudoku, [Action]) +scratchPossIndirect su = + let blocks = [Block i su | i <- [0..8]] + rows = [Row i su | i <- [0..8]] + cols = [Col i su | i <- [0..8]] + params = [(Row i, blocks) | i <- [0..8]] ++ + [(Col i, blocks) | i <- [0..8]] ++ + [(Block i, rows) | i <- [0..8]] ++ + [(Block i, cols) | i <- [0..8]] + in runWriter $ + foldM (\su' (regc, intregs) -> scratchPossIndirectReg (regc su') intregs) + su params + +-- 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] @@ -377,7 +442,7 @@ resolveRegions su = runWriter $ foldM func su [f i | f <- [Row, Col, Block], i < operations :: [Sudoku -> (Sudoku, [Action])] operations = [ - scratchPossBasic, scratchPossIndirectB, + scratchPossBasic, scratchPossIndirect, resolveCells, resolveRegions] @@ -394,7 +459,7 @@ main :: IO () main = do su <- liftM readSudoku getContents - let useBT = True + let useBT = False btSols = backtrackSolve su when useBT $ diff --git a/hsolve/verify.sh b/hsolve/verify.sh new file mode 100755 index 0000000..0aff88d --- /dev/null +++ b/hsolve/verify.sh @@ -0,0 +1,2 @@ +#!/usr/bin/env bash +diff -ys -W 43 <(stack exec hsolve <"$1" | tail -12) <(../solve_bt <"$1") |