diff --git a/Estinien.cabal b/Estinien.cabal index a248aa8..50cff73 100644 --- a/Estinien.cabal +++ b/Estinien.cabal @@ -50,12 +50,14 @@ extra-doc-files: CHANGELOG.md -- Extra source files to be distributed with the package, such as examples, or a tutorial module. -- extra-source-files: -common warnings +common default ghc-options: -Wall + -threaded + -rtsopts library -- Import common warning flags. - import: warnings + import: default -- Modules exported by the library. exposed-modules: Sudoku @@ -71,6 +73,7 @@ library , matrix , vector , parallel + , deepseq -- Directories containing source files. hs-source-dirs: src @@ -80,7 +83,7 @@ library executable Estinien -- Import common warning flags. - import: warnings + import: default -- .hs or .lhs file containing the Main module. main-is: Main.hs diff --git a/easy.sudoku b/easy.sudoku new file mode 100644 index 0000000..e9cb275 --- /dev/null +++ b/easy.sudoku @@ -0,0 +1,9 @@ +X X 3 1 6 5 7 9 8 +6 1 9 X X X 2 4 5 +5 8 7 X 4 X 1 X 6 +4 X 6 X 1 2 9 8 3 +X 9 X 8 X 4 6 X 2 +X X X 6 X 3 4 X 1 +9 X 2 5 X 7 8 X X +8 X X 4 2 1 3 X 9 +1 X X X X 6 5 2 7 diff --git a/fucky.sudoku b/fucky.sudoku index 5989e06..81559f9 100644 --- a/fucky.sudoku +++ b/fucky.sudoku @@ -1,9 +1,9 @@ -1 2 3 4 5 X 7 8 9 -4 5 6 7 X 9 1 2 3 -7 8 9 1 2 X 4 5 6 -2 3 4 5 6 7 X 9 1 -5 6 7 8 9 X 2 3 4 -8 9 1 2 3 4 5 6 7 -6 7 8 9 1 2 3 4 5 -9 1 2 3 4 5 6 7 8 -3 4 5 6 7 8 9 1 2 +X 7 3 X X X X X 8 +X 5 4 X 3 X X X X +2 8 X X 9 X X X X +X X X 5 6 X 4 X X +X X X X X 4 7 X X +X 6 X 8 X X 9 X X +X 3 X X 8 X X X 2 +X 9 X X 5 3 X X X +X 4 X X 7 1 X 9 X diff --git a/full.sudoku b/full.sudoku new file mode 100644 index 0000000..b61ddae --- /dev/null +++ b/full.sudoku @@ -0,0 +1,9 @@ +1 2 3 4 5 X 7 8 9 +4 5 6 7 8 X 1 2 3 +7 X X X X X X X X +2 3 X X X X X X X +5 6 7 8 9 X 2 3 4 +8 X 1 2 3 X 5 6 7 +6 7 8 9 1 X 3 4 5 +9 1 2 3 4 X 6 7 8 +3 4 5 6 7 X 9 1 2 diff --git a/src/Sudoku.hs b/src/Sudoku.hs index c561bab..c800785 100644 --- a/src/Sudoku.hs +++ b/src/Sudoku.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, LambdaCase, MultiWayIf #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Sudoku ( isValid , Cell(..) , Grid(..) @@ -18,6 +19,9 @@ import Control.Parallel import Control.Parallel.Strategies import Text.Printf import Data.List +import Control.Monad +import Control.DeepSeq +import GHC.Generics (Generic) data Cell where One :: Cell @@ -30,7 +34,7 @@ data Cell where Eight :: Cell Nine :: Cell Unknown :: Cell - deriving (Eq) + deriving (Eq, Generic, NFData) instance Show Cell where show One = "1" @@ -69,11 +73,11 @@ instance Show Square where -- Grid is 9x9 newtype Grid = Grid (Matrix Cell) - deriving Eq + deriving (Eq, Generic, NFData) instance Show Grid where show (Grid m) = prettyMatrix m - + emptyGrid :: Grid emptyGrid = coerce $ matrix 9 9 (const Unknown) @@ -124,7 +128,7 @@ isValid g = and $ flip (parMap rpar) [1..9] let row = isValidRow (getRow i g) col = isValidColumn (getColumn i g) square = isValidSquare (getSquare i g) - in col `par` square `par` row && col && square + in row && col && square ) updateCell :: Int -> Int -> Cell -> Grid -> Grid @@ -151,17 +155,13 @@ place c pos g = coerce $ setElem c pos (coerce g) solve :: Grid -> Grid solve g = let left = leftToPlace g in - case nub $ go g left of + case nub $ runEval (go [g] left) of [] -> error "No solution D:" [x] -> x xs -> error (printf "%d solutions" $ length xs) - where go :: Grid -> [Cell] -> [Grid] - go g [] = if isValid g then pure g else mempty - go g (x:xs) = if not $ isValid g then mempty else - let empties = findEmpty g in - go' xs $ flip (x `place`) g <$> empties - - go' :: [Cell] -> [Grid] -> [Grid] - go' _ [] = [] - go' xs (g:gs) = let sol = go g xs in - sol `par` go' xs gs <> sol + where go :: [Grid] -> [Cell] -> Eval [Grid] + go gs [] = filterM (pure . isValid) gs + go gs (x:xs) = filterM (pure . isValid) gs >>= + pure . (>>= \g' -> findEmpty g' >>= pure . (g',)) >>= + parList rdeepseq . ((uncurry $ flip (place x)) <$>) >>= + flip go xs