Works kinda

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

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

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

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

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