Works but is slow

full.sudoku

@@ -1,9 +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
+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

@@ -94,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
 
@@ -103,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
@@ -123,13 +138,22 @@ getSquare n
   | 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 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
 updateCell n m 
@@ -147,6 +171,15 @@ leftToPlace =
   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
 
@@ -154,14 +187,15 @@ place :: Cell -> (Int,Int) -> Grid -> Grid
 place c pos g = coerce $ setElem c pos (coerce g)
   
 solve :: Grid -> Grid
-solve g = let left = leftToPlace g in
-          case nub $ runEval (go [g] left) of
-            []  -> error "No solution D:"
-            [x] -> x
-            xs   -> error (printf "%d solutions" $ length xs)
-  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
+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