summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--hsolve/Main.hs64
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 =