diff options
| -rw-r--r-- | hsolve/Main.hs | 43 |
1 files changed, 22 insertions, 21 deletions
diff --git a/hsolve/Main.hs b/hsolve/Main.hs index 7d99854..6a9424d 100644 --- a/hsolve/Main.hs +++ b/hsolve/Main.hs @@ -316,6 +316,16 @@ writeReason (RBlockI i) = "situation in block " ++ show i writeReason (RCombine a b) = writeReason a ++ "; " ++ writeReason b +scratchPossBasicRegion :: Region -> Sudoku +scratchPossBasicRegion reg = maskPoss reg (listPoss $ [0..8] \\ values reg) + +scratchAroundCell :: Region -> Sudoku +scratchAroundCell cl@(Cell _ _) = + let su1 = scratchPossBasicRegion (rowOf cl) + su2 = scratchPossBasicRegion (colOf (adaptRegion cl su1)) + su3 = scratchPossBasicRegion (blockOf (adaptRegion cl su2)) + in su3 + scratchInRegionExcept :: Value -> Region -> Region -> Reason -> SM Sudoku scratchInRegionExcept val reg except reason = foldM (\su i -> @@ -329,22 +339,12 @@ scratchInRegionExcept val reg except reason = (sudokuOf reg) (indexRange reg) -scratchPossBasic :: Sudoku -> (Sudoku, [Action]) -scratchPossBasic su = +tacticPossBasic :: Sudoku -> (Sudoku, [Action]) +tacticPossBasic su = let su1 = foldl (\su' regc -> scratchPossBasicRegion (regc su')) su (concat [[Row i, Col i, Block i] | i <- [0..8]]) in (su1, []) -scratchPossBasicRegion :: Region -> Sudoku -scratchPossBasicRegion reg = maskPoss reg (listPoss $ [0..8] \\ values reg) - -scratchAroundCell :: Region -> Sudoku -scratchAroundCell cl@(Cell _ _) = - let su1 = scratchPossBasicRegion (rowOf cl) - su2 = scratchPossBasicRegion (colOf (adaptRegion cl su1)) - su3 = scratchPossBasicRegion (blockOf (adaptRegion cl su2)) - in su3 - scratchPossIndirectReg :: Region -> [Region] -> SM Sudoku scratchPossIndirectReg mainreg intregs' = let intregs = filter (\intreg -> not $ null $ intersectReg mainreg intreg) intregs' @@ -362,8 +362,8 @@ scratchPossIndirectReg mainreg intregs' = (RCombine (reasonReg mainreg) (reasonReg (intregs !! i)))) su valOnlyInWhich -scratchPossIndirect :: Sudoku -> (Sudoku, [Action]) -scratchPossIndirect su = +tacticPossIndirect :: Sudoku -> (Sudoku, [Action]) +tacticPossIndirect su = let blocks = [Block i su | i <- [0..8]] rows = [Row i su | i <- [0..8]] cols = [Col i su | i <- [0..8]] @@ -375,8 +375,8 @@ scratchPossIndirect su = foldM (\su' (regc, intregs) -> scratchPossIndirectReg (regc su') intregs) su params -resolveCells :: Sudoku -> (Sudoku, [Action]) -resolveCells su = runWriter $ foldM func su [0..80] +tacticResolveCells :: Sudoku -> (Sudoku, [Action]) +tacticResolveCells su = runWriter $ foldM func su [0..80] where func :: Sudoku -> Int -> SM Sudoku func su' i = case possList (su' `atp` i) of @@ -386,8 +386,9 @@ resolveCells su = runWriter $ foldM func su [0..80] return $ scratchAroundCell (cell i su1) _ -> return su' -resolveRegions :: Sudoku -> (Sudoku, [Action]) -resolveRegions su = runWriter $ foldM func su [f i | f <- [Row, Col, Block], i <- [0..8]] +tacticResolveRegions :: Sudoku -> (Sudoku, [Action]) +tacticResolveRegions su = + runWriter $ foldM func su [f i | f <- [Row, Col, Block], i <- [0..8]] where func :: Sudoku -> (Sudoku -> Region) -> SM Sudoku func su' regc = @@ -406,9 +407,9 @@ resolveRegions su = runWriter $ foldM func su [f i | f <- [Row, Col, Block], i < operations :: [Sudoku -> (Sudoku, [Action])] operations = [ - scratchPossBasic, scratchPossIndirect, - resolveCells, - resolveRegions] + tacticPossBasic, tacticPossIndirect, + tacticResolveCells, + tacticResolveRegions] solve :: Sudoku -> [(Sudoku, [Action])] solve su = |