Works but is slow

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

app/Main.hs

@@ -7,5 +7,5 @@ import System.Environment (getArgs)
 
 main :: IO ()
 main = getArgs >>= \case
-  [filename] -> readFile filename >>= print . parseStringToGrid
+  [filename] -> readFile filename >>= print . solve . parseStringToGrid
   _ -> error "Usage: Estinen filename"

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

@@ -0,0 +1,9 @@
+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 6 7 8 9
+4 5 6 7 8 9 1 2 3
+7 8 9 1 2 3 4 5 6
+2 3 4 5 6 7 8 9 1
+5 6 7 8 9 1 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

src/Sudoku.hs

@@ -1,19 +1,27 @@
 {-# LANGUAGE OverloadedStrings, LambdaCase, MultiWayIf #-}
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
 module Sudoku ( isValid
               , Cell(..)
               , Grid(..)
               , updateCell
               , emptyGrid
               , parseStringToGrid
+              , solve
+              , getSquare
               ) where
 
-import Data.Matrix hiding (getRow, getCol)
+import Data.Matrix hiding (getRow, getCol, trace)
 import Data.Matrix qualified as M
 import Data.Vector (Vector)
 import Data.Vector qualified as V
 import Data.Coerce
 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
@@ -26,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"
@@ -38,7 +46,7 @@ instance Show Cell where
   show Seven = "7"
   show Eight = "8"
   show Nine = "9"
-  show Unknown = " "
+  show Unknown = "_"
 
 cellFromChar :: String -> Cell
 cellFromChar "1" = One
@@ -60,12 +68,16 @@ newtype Column = Column (Vector Cell)
 newtype Row = Row (Vector Cell)
 -- Square is 3x3 
 newtype Square = Square (Matrix Cell)
+instance Show Square where
+  show (Square m) = prettyMatrix m
+
 -- Grid is 9x9
 newtype Grid = Grid (Matrix Cell)
+  deriving (Eq, Generic, NFData)
 
 instance Show Grid where
   show (Grid m) = prettyMatrix m
-
+  
 emptyGrid :: Grid
 emptyGrid = coerce $ matrix 9 9 (const Unknown)
 
@@ -82,6 +94,9 @@ parseStringToGrid str =
 isValidVector :: Vector Cell -> Bool
 isValidVector = V.all (<= 1) . (numbers >>=) . (((pure . V.length) .) . (. (==)) . flip V.filter)
 
+hasNoUnknownVector :: Vector Cell -> Bool
+hasNoUnknownVector = V.all (/= Unknown)
+
 isValidColumn :: Column -> Bool
 isValidColumn = isValidVector . coerce
 
@@ -91,11 +106,23 @@ isValidRow = isValidVector . coerce
 isValidSquare :: Square -> Bool
 isValidSquare = isValidVector . getMatrixAsVector . coerce
 
+hasNoUnknownColumn :: Column -> Bool
+hasNoUnknownColumn = hasNoUnknownVector . coerce
+
+hasNoUnknownRow :: Row -> Bool
+hasNoUnknownRow = hasNoUnknownVector . coerce
+
+hasNoUnknownSquare :: Square -> Bool
+hasNoUnknownSquare = hasNoUnknownVector . getMatrixAsVector . coerce
+
 getRow :: Int -> Grid -> Row
 getRow n
   | n > 0 && n <= 9 = Row . M.getRow n . coerce
   | otherwise       = error "Indexing row outside of grid"
 
+getRows :: Grid -> [Row]
+getRows = (getRow <$> [1..9] <*>) . pure
+
 getColumn :: Int -> Grid -> Column
 getColumn n
   | n > 0 && n <= 9 = Column . M.getCol n . coerce
@@ -103,20 +130,29 @@ getColumn n
 
 getSquare :: Int -> Grid -> Square
 getSquare n
-  | n > 0 && n <= 9 = let !sr = (n+2) `div` 3
+  | n > 0 && n <= 9 = let !sr = ((n-1) `div` 3) * 3 + 1
                           !er = sr + 2
-                          !sc = (n+2) `mod` 3 + 1
+                          !sc = ((n-1) `mod` 3) * 3 + 1
                           !ec = sc + 2
                       in Square . submatrix sr er sc ec . coerce
   | otherwise       = error "Indexing square outside of grid"
 
 isValid :: Grid -> Bool
-isValid g = and $ flip (parMap rpar) [1..9]
+isValid g = and $ flip map [1..9]
                    (\i ->
                       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
+                   )
+            
+hasNoUnknown :: Grid -> Bool
+hasNoUnknown g = and $ flip map [1..9]
+                   (\i ->
+                      let row = hasNoUnknownRow (getRow i g)
+                          col = hasNoUnknownColumn (getColumn i g)
+                          square = hasNoUnknownSquare (getSquare i g)
+                      in row && col && square
                    )
 
 updateCell :: Int -> Int -> Cell -> Grid -> Grid
@@ -127,5 +163,39 @@ updateCell n m
         coerce $ setElem c (n,m) mx else
         error "Updating non unkown value"
   | otherwise = error "Updating cell outside of grid"
-  
 
+leftToPlace :: Grid -> [Cell]
+leftToPlace =
+  V.toList .
+  (\v -> numbers >>= \i -> flip V.replicate i . (9-) . V.length $ V.elemIndices i v) .
+  getMatrixAsVector .
+  coerce
+
+leftToPlaceRow :: Row -> [Cell]
+leftToPlaceRow =
+  ((V.toList numbers) \\ ) .
+  V.toList .
+  coerce
+
+findEmptyRow :: Row -> [(Int)]
+findEmptyRow = V.toList . ((+1) <$>) . V.findIndices (== Unknown) . coerce
+
+findEmpty :: Grid -> [(Int,Int)]
+findEmpty = V.toList . ((\n -> ((n) `div` 9 + 1, n `mod` 9 + 1)) <$>) . V.findIndices (== Unknown) . getMatrixAsVector . coerce
+
+place :: Cell -> (Int,Int) -> Grid -> Grid
+place c pos g = coerce $ setElem c pos (coerce g)
+  
+solve :: Grid -> Grid
+solve = runEval . go . pure
+  where go :: [Grid] -> Eval Grid
+        go gs =
+          case filter hasNoUnknown gs of
+            [] -> 
+                parList rpar (gs >>= \g -> zip [(1 :: Int)..9] (getRows g) >>= \(i,v) -> findEmptyRow v >>= \j -> leftToPlaceRow v >>= pure . (i,j,,g)) >>=
+                parList rdeepseq . (>>= \(i,j,c,g) -> pure $ place c (i,j) g) >>=
+                filterM (pure . isValid) >>= \case
+                [] -> error "Uhoh"
+                xs -> go xs
+
+            (x:_) -> () `pseq` pure x

valid.sudoku

@@ -1,9 +1,9 @@
-1 2 3 4 5 6 X 8 9
-2 X 4 5 6 X 8 X 1
-3 4 5 X 7 8 9 1 2
-4 5 6 7 8 X 1 2 3
-5 X X 8 9 1 2 3 4
-6 7 8 9 X 2 3 X X
-7 X 9 1 2 3 X X X
-8 9 1 X 3 4 5 6 X
-9 1 2 3 4 5 6 7 8
+1 2 3 4 5 X 7 8 9
+4 5 6 7 X 9 1 2 3
+7 8 X 1 2 X 4 5 6
+2 X 4 5 6 7 X 9 1
+5 6 X 8 9 X 2 3 4
+8 9 X 2 X 4 5 6 7
+6 7 X 9 1 2 X 4 5
+9 X 2 3 4 5 X X 8
+3 4 5 6 7 8 X 1 2