hsolve: stronger indirect scratching

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")