hsolve: use cell coverings to scratch

1 files changed, 59 insertions, 5 deletions

diff --git a/hsolve/Main.hs b/hsolve/Main.hs
index 6a9424d..7688b4e 100644
--- a/hsolve/Main.hs
+++ b/hsolve/Main.hs
@@ -19,11 +19,15 @@ lupdate _ _ [] = error "Empty list in lupdate"
 b2i :: Bool -> Int
 b2i = fromEnum
 
+subsets :: [a] -> [[a]]
+subsets [] = [[]]
+subsets (x:xs) = let s = subsets xs in s ++ map (x :) s
+
 
 newtype Sudoku = Sudoku [Either Value Poss]  -- length 81
   deriving (Show, Eq)
 
-type Value = Int
+type Value = Int  -- 0..8
 
 newtype Poss = Poss [Bool]  -- length 9
   deriving (Show, Eq)
@@ -150,9 +154,13 @@ adaptRegion (Block i _) su = Block i su
 class HasCells a where
     cell :: Int -> a -> Region
 
+    cells :: a -> [Region]
+
 instance HasCells Sudoku where
     cell i su | 0 <= i && i < 81 = Cell i su
 
+    cells su = [Cell i su | i <- [0..80]]
+
 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
@@ -163,6 +171,8 @@ instance HasCells Region where
     cell 0 c@(Cell _ _) = c
     cell _ _ = undefined
 
+    cells r = [cell i r | i <- [0..8]]
+
 
 class HasValues a where
     values :: a -> [Value]
@@ -282,6 +292,7 @@ data Action = AResolve Int Value Reason
 
 data Reason = RCell | RRow | RCol | RBlock
             | RCellI Int | RRowI Int | RColI Int | RBlockI Int
+            | RMultiCellI [Int] [Value]
             | RCombine Reason Reason
   deriving (Show)
 
@@ -313,6 +324,9 @@ 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 (RMultiCellI idcs vs) =
+    "covering of cells " ++ intercalate ", " (map actionCellString idcs) ++
+    " with values " ++ intercalate ", " (map (\n -> show (n + 1)) vs)
 writeReason (RCombine a b) = writeReason a ++ "; " ++ writeReason b
 
 
@@ -394,7 +408,7 @@ tacticResolveRegions su =
     func su' regc =
         foldM (\su1 n ->
                     let reg = regc su1
-                        ps = map possOf [cell i reg | i <- indexRange reg]
+                        ps = map possOf (cells reg)
                     in case possGetIfInOne ps n of
                         Nothing -> return su1
                         Just i -> do
@@ -404,12 +418,52 @@ tacticResolveRegions su =
                                     return $ scratchAroundCell (cell su_i su2))
               su' [0..8]
 
+tacticPossCover :: Sudoku -> (Sudoku, [Action])
+tacticPossCover su =
+    runWriter $ foldM func su [f i | f <- [Row, Col, Block], i <- [0..8]]
+  where
+    func :: Sudoku -> (Sudoku -> Region) -> SM Sudoku
+    func su' regc =
+        let numsets =
+                -- tacticResolveRegions has better Reason for this
+                filter (\s -> length s > 1) $
+                -- all numbers cover all squares, all right, but not useful
+                init $
+                subsets ([0..8] \\ values (regc su'))
+        in foldM (\su1 ns ->
+                    let reg = regc su1
+                        ps = map possOf (cells reg)
+                        idcslist =
+                            [map fst $
+                                filter (\(_, p) -> n `possElem` p) $ zip [0..8] ps
+                            | n <- ns]
+                        idcs = sort $ foldl union [] idcslist
+                    in if length idcs == length ns &&
+                                -- tacticResolveRegions has better Reason for this
+                                all (\l -> length l > 1) idcslist
+                        then applyCover reg ns idcs
+                        else return su1)
+                 su' numsets
+
+    applyCover :: Region -> [Value] -> [Int] -> SM Sudoku
+    applyCover reg ns idcs =
+        let su' = sudokuOf reg
+            mask = listPoss ns
+            reasonIdcs = [indexOf (cell i reg) | i <- idcs]
+            reason = RCombine (reasonReg reg) (RMultiCellI reasonIdcs ns)
+        in foldM (\su1 i ->
+                    let reg1 = adaptRegion reg su1
+                    in do
+                        forM_ (possList (possOf (cell i reg1)) \\ ns) $
+                              \n -> tell [AScratch (indexOf (cell i reg1)) n reason]
+                        return $ maskPoss (cell i reg1) mask)
+                 su' idcs
+
 
 operations :: [Sudoku -> (Sudoku, [Action])]
 operations = [
-    tacticPossBasic, tacticPossIndirect,
-    tacticResolveCells,
-    tacticResolveRegions]
+    tacticPossBasic, tacticPossIndirect, tacticPossCover,
+    tacticResolveCells, tacticResolveRegions]
 
 solve :: Sudoku -> [(Sudoku, [Action])]
 solve su =