diff options
| -rw-r--r-- | hsolve/Main.hs | 64 |
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 = |