From c6cc36515181a18f9058b3f1f5305d8c0c408ec8 Mon Sep 17 00:00:00 2001
From: Abhinav Sarkar <abhinav@abhinavsarkar.net>
Date: Wed, 18 Jul 2018 16:43:48 +0530
Subject: [PATCH] Adds parallelism

---
 package.yaml  |  5 +++++
 src/Sudoku.hs | 20 +++++++++++++-------
 2 files changed, 18 insertions(+), 7 deletions(-)

diff --git a/package.yaml b/package.yaml
index b1710aa..fb42f8d 100644
--- a/package.yaml
+++ b/package.yaml
@@ -15,6 +15,8 @@ dependencies:
 - base >= 4.7 && < 5
 - containers
 - vector
+- parallel
+- deepseq
 
 executables:
   sudoku:
@@ -22,6 +24,9 @@ executables:
     source-dirs:         src
     ghc-options:
     - -O2
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
     dependencies:
     - split
 
diff --git a/src/Sudoku.hs b/src/Sudoku.hs
index bfd22d2..b384722 100644
--- a/src/Sudoku.hs
+++ b/src/Sudoku.hs
@@ -14,6 +14,8 @@ import qualified Data.Bits
 import Data.Vector.Unboxed ((!))
 import qualified Data.Vector.Unboxed.Mutable
 import qualified Data.Vector.Unboxed
+import qualified Data.Maybe
+import Control.Parallel.Strategies (withStrategy, rdeepseq, parBuffer)
 
 fixM :: (Eq t, Monad m) => (t -> m t) -> t -> m t
 fixM f x = f x >>= \x' -> if x' == x then return x else fixM f x'
@@ -250,10 +252,14 @@ solve grid = pruneGrid grid >>= solve'
 
 main :: IO ()
 main = do
-  inputs <- lines <$> getContents
-  Control.Monad.forM_ inputs $ \input ->
-    case readGrid input of
-      Nothing   -> putStrLn "Invalid input"
-      Just grid -> case solve grid of
-        Nothing    -> putStrLn "No solution found"
-        Just grid' -> putStrLn $ showGrid grid'
+  grids <- lines <$> getContents
+  let solutions = parMap readAndSolve grids
+  putStrLn $
+    show (length $ filter Data.Maybe.isJust solutions) ++ "/" ++ show (length grids) ++ " solved"
+  where
+    readAndSolve grid = case readGrid grid of
+      Nothing -> Nothing
+      Just b  -> solve b
+
+    chunkSize = 1000
+    parMap f = withStrategy (parBuffer chunkSize rdeepseq) . map f