Merge pull request 'refactor' (#1) from refactor into main

Reviewed-on: #1

Sudoku.cabal

@@ -70,7 +70,8 @@ library
     -- Other library packages from which modules are imported.
     build-depends:    base ^>=4.18.2.0,
                       vector ^>=0.13.1.0,
-                      mtl ^>=2.3.1
+                      mtl ^>=2.3.1,
+                      split ^>=0.2.2
 
     -- Directories containing source files.
     hs-source-dirs:   src

app/Main.hs

@@ -1,63 +1,89 @@
 module Main where
 
-import Control.Monad.State (evalState)
+import Data.Char (digitToInt)
+import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe)
 import qualified Data.Vector as V
 import Types
+  ( Grid (Grid),
+    allCells,
+    colView,
+    count,
+    getCell,
+    initGrid,
+    mapGrid,
+    printGrid,
+    putCell,
+    rowView,
+    squareView,
+  )
 
 main :: IO ()
 main = do
-  -- putStrLn $ evalState (insert 5 (2, 5) >> showCandidates3) dummyState
+  putStr $ printSudoku dummyGrid
-
+  print $ isValidGrid dummyGrid
-  -- print $ evalState (getBoxRange 1) dummyState
+  putStr . printGrid . fromJust $ solve dummyGrid
-  -- print $ evalState (getBoxRange 2) dummyState
-  -- print $ evalState (getBoxRange 3) dummyState
-  -- print $ evalState (getBoxRange 4) dummyState
-  -- print $ evalState (getBoxRange 5) dummyState
-  -- print $ evalState (getBoxRange 6) dummyState
-  -- print $ evalState (getBoxRange 7) dummyState
-  -- print $ evalState (getBoxRange 8) dummyState
-  -- print $ evalState (getBoxRange 9) dummyState
-
-  -- print $ evalState (getBox (1, 4)) dummyState
-
-  let sudoku = read test :: Sudoku
-
-  putStrLn "Reading:"
-  print sudoku
-  putStrLn "Pretty Printing:"
-  putStrLn $ pretty sudoku
-
-  putStrLn "Candidates:"
-  putStrLn $ evalState (insertAll sudoku >> showCandidates3) initState
 
 test :: String
 test = "070000043040009610800634900094052000358460020000800530080070091902100005007040802"
 
-{-
+dummyGrid :: Grid (Maybe Int)
-070 000 043
+dummyGrid = initGrid 3 (map toMaybeInt test)
-040 009 610
+  where
-800 634 900
+    toMaybeInt :: Char -> Maybe Int
-094 052 000
+    toMaybeInt c = if int == 0 then Nothing else Just int
-358 460 020
+      where
-000 800 530
+        int = digitToInt c
-080 070 091
-902 100 005
-007 040 802
--}
-dummyState :: SudokuState
-dummyState =
-  SudokuState
-    { dimension = 3,
-      grid = V.replicate 81 0,
-      idxs = V.fromList [(x, y) | x <- [1 .. 9], y <- [1 .. 9]],
-      candidates = V.replicate 81 (V.replicate 9 True)
-    }
 
-initState :: SudokuState
+printSudoku :: Grid (Maybe Int) -> String
-initState =
+printSudoku gr = printGrid mappedGrid
-  SudokuState
+  where
-    { dimension = 0,
+    mappedGrid :: Grid Int
-      grid = V.empty,
+    mappedGrid = mapGrid (fromMaybe 0) gr
-      idxs = V.empty,
+
-      candidates = V.empty
+isValidGrid :: Grid (Maybe Int) -> Bool
-    }
+isValidGrid gr@(Grid _ d) =
+  all isValidRow [0 .. d * d - 1]
+    && all isValidCol [0 .. d * d - 1]
+    && all isValidSquare [0 .. d * d - 1]
+  where
+    validView :: V.Vector (Maybe Int) -> Bool
+    validView v = V.foldl (\drag (e, c) -> case e of Nothing -> drag; Just _ -> (c < 2) && drag) True counts
+      where
+        counts = V.map (\e -> (e, count v e)) v
+    isValidRow :: Int -> Bool
+    isValidRow y = validView $ rowView gr y
+    isValidCol :: Int -> Bool
+    isValidCol x = validView $ colView gr x
+    isValidSquare :: Int -> Bool
+    isValidSquare n = validView $ squareView gr n
+
+isFull :: Grid (Maybe Int) -> Bool
+isFull gr = allCells gr isJust
+
+isSolved :: Grid (Maybe Int) -> Bool
+isSolved gr = isValidGrid gr && isFull gr
+
+extractSolution :: Grid (Maybe Int) -> Grid Int
+extractSolution gr =
+  if not (isSolved gr)
+    then error "trying to extract solution from unsolved grid"
+    else mapGrid (fromMaybe 0) gr
+
+solveHelper :: Grid (Maybe Int) -> (Int, Int) -> Maybe (Grid Int)
+solveHelper gr@(Grid _ d) (x, y)
+  | not (isValidGrid gr) = Nothing
+  | isSolved gr = Just (extractSolution gr)
+  | otherwise = case cell of
+      Nothing -> if not (null solvedGrids) then head solvedGrids else Nothing
+      Just _ -> solveHelper gr nextCoord
+  where
+    placeAndSolve :: Int -> Maybe (Grid Int)
+    placeAndSolve n = solveHelper newGrid nextCoord
+      where
+        newGrid = putCell gr (x, y) (Just n)
+    solvedGrids = map Just (mapMaybe placeAndSolve [1 .. d * d])
+    cell = getCell gr (x, y)
+    nextCoord = if x < d * d - 1 then (x + 1, y) else (0, y + 1)
+
+solve :: Grid (Maybe Int) -> Maybe (Grid Int)
+solve gr = solveHelper gr (0, 0)

src/Types.hs

@@ -1,245 +1,103 @@
-{-# LANGUAGE InstanceSigs #-}
-
 module Types where
 
-import Control.Monad (forM_, when)
+import Data.List (intercalate)
-import Control.Monad.State (MonadState (put), State, get, gets, modify)
+import Data.List.Split (chunksOf, keepDelimsL, split, whenElt)
-import Data.Char (digitToInt, intToDigit)
+import Data.Vector (Vector)
-import Data.Vector (Vector, slice)
 import qualified Data.Vector as V
-import Debug.Trace
 
--- * Stateful Sudoku Type
+type Row a = Vector a
 
-data SudokuState = SudokuState
+data Grid a = Grid
-  { dimension :: Int,
+  { grid :: Vector (Row a),
-    grid :: Vector Int,
+    dimension :: Int
-    idxs :: Vector (Int, Int),
-    candidates :: Vector (Vector Bool)
   }
 
-type SudokuMonad = State SudokuState
+initGrid :: Int -> [a] -> Grid a
+initGrid d vs = Grid (V.fromList . map V.fromList $ chunksOf (d * d) vs) d
 
-getField :: (Int, Int) -> SudokuMonad Int
+getRow :: Grid a -> Int -> Row a
-getField (x, y) = do
+getRow (Grid g d) y =
-  state <- get
+  if y >= d * d || y < 0
-  return $ grid state ! (x + y * dimension state)
+    then error ("getRow: y=" ++ show y ++ " is out of dimension=" ++ show d)
+    else g V.! y
 
-getRow :: (Int, Int) -> SudokuMonad Int
+putRow :: Grid a -> Row a -> Int -> Grid a
-getRow (_, y) = return y
+putRow (Grid g d) newRow y =
+  if y >= d * d || y < 0
+    then error ("putRow: y=" ++ show y ++ " is out of dimension=" ++ show d)
+    else Grid (g V.// [(y, newRow)]) d
 
-getCol :: (Int, Int) -> SudokuMonad Int
+updateRow :: Grid a -> (Row a -> Row a) -> Int -> Grid a
-getCol (x, _) = return x
+updateRow gr upd y = putRow gr (upd oldRow) y
-
-getBox :: (Int, Int) -> SudokuMonad Int
-getBox (x, y) = do
-  d <- gets dimension
-  let xPart = ((x - 1) `div` d) + 1
-  let yPart = (y - 1) `div` d
-  return $ xPart + (d * yPart)
-
-getRowRange :: Int -> SudokuMonad [Int]
-getRowRange row = do
-  d <- gets dimension
-  return [x + ((row - 1) * d * d) | x <- [1 .. d * d]]
-
-getColRange :: Int -> SudokuMonad [Int]
-getColRange col = do
-  d <- gets dimension
-  return [col + ((x - 1) * d * d) | x <- [1 .. d * d]]
-
-getBoxRange :: Int -> SudokuMonad [Int]
-getBoxRange box = do
-  d <- gets dimension
-  let (x, y) = getXY box
-  flatIdx <- flattenIdx (x, y)
-  return [flatIdx + n + (m * d * d) | m <- [0 .. d - 1], n <- [0 .. d - 1]]
   where
-    -- \| Maps a box number to its upper left corner
+    oldRow = getRow gr y
-    getXY :: Int -> (Int, Int)
-    getXY 1 = (1, 1)
-    getXY 2 = (4, 1)
-    getXY 3 = (7, 1)
-    getXY 4 = (1, 4)
-    getXY 5 = (4, 4)
-    getXY 6 = (7, 4)
-    getXY 7 = (1, 7)
-    getXY 8 = (4, 7)
-    getXY 9 = (7, 7)
-    getXY n = error $ "tried to getXY of box number: " ++ show n
 
-flattenIdx :: (Int, Int) -> SudokuMonad Int
+putCell :: Grid a -> (Int, Int) -> a -> Grid a
-flattenIdx (x, y) = do
+putCell gs@(Grid _ d) (x, y) v =
-  d <- gets dimension
+  if x >= d * d || x < 0
-  return (x + (d * d * (y - 1)))
+    then error "putCell out of bounds"
+    else updateRow gs (\row -> row V.// [(x, v)]) y
 
-updateVector :: Vector a -> Int -> a -> Vector a
+getCell :: Grid a -> (Int, Int) -> a
-updateVector v idx x = V.update v (V.singleton (idx - 1, x))
+getCell gs@(Grid _ d) (x, y) =
-
+  if x >= d * d || x < 0
-dropCandidate :: Int -> Vector Bool -> Vector Bool
+    then error "getCell: x out of bounds"
-dropCandidate n bs = updateVector bs n False
+    else row V.! x
-
-dropAllCandidates :: Vector Bool -> Vector Bool
-dropAllCandidates = V.map (const False)
-
-(!) :: Vector a -> Int -> a
-v ! n = v V.! (n - 1)
-
-gridInsert :: Int -> (Int, Int) -> SudokuMonad ()
-gridInsert n idx = do
-  flatIdx <- flattenIdx idx
-  g <- gets grid
-  modify (\s -> s {grid = updateVector g flatIdx n})
-
-removeInRow :: Int -> (Int, Int) -> SudokuMonad ()
-removeInRow n idx = do
-  rr <- getRow idx >>= getRowRange
-  forM_ rr remover
   where
-    remover :: Int -> SudokuMonad ()
+    row = getRow gs y
-    remover pos = do
-      cs <- gets candidates
-      let cand = cs ! pos
-      let cand' = dropCandidate n cand
-      modify (\s -> s {candidates = updateVector cs pos cand'})
 
-removeInCol :: Int -> (Int, Int) -> SudokuMonad ()
+printGrid :: (Show a) => Grid a -> String
-removeInCol n idx = do
+printGrid gr@(Grid _ d) = unwords . intercalate ["\n"] . chunksOf 3 . (split . keepDelimsL . whenElt) (== '\n') . unlines $ map printRow [0 .. (d * d) - 1]
-  cr <- getCol idx >>= getColRange
-  forM_ cr remover
   where
-    remover :: Int -> SudokuMonad ()
+    printRow :: Int -> String
-    remover pos = do
+    printRow _y = unwords $ map printSquare [0 .. d - 1]
-      cs <- gets candidates
-      let cand = cs ! pos
-      let cand' = dropCandidate n cand
-      modify (\s -> s {candidates = updateVector cs pos cand'})
-
-removeInBox :: Int -> (Int, Int) -> SudokuMonad ()
-removeInBox n idx = do
-  br <- getBox idx >>= getBoxRange
-  forM_ br remover
       where
-    remover :: Int -> SudokuMonad ()
+        y = checkDimension d _y
-    remover pos = do
+        row = getRow gr y
-      cs <- gets candidates
+        printSquare :: Int -> String
-      let cand = cs ! pos
+        printSquare n =
-      let cand' = dropCandidate n cand
+          if n * d >= d * d || n < 0
-      modify (\s -> s {candidates = updateVector cs pos cand'})
+            then error ("trying to print square " ++ show n ++ " which is out of bounds (dimension: " ++ show d ++ ")")
+            else concatMap (\m -> show $ row V.! (n * d + m)) [0 .. d - 1]
 
-insert :: Int -> (Int, Int) -> SudokuMonad ()
+checkDimension :: Int -> Int -> Int
-insert n idx = do
+checkDimension d v =
-  gridInsert n idx
+  if v >= d * d || v < 0
-  -- traceM $ "inserting " ++ show n
+    then error ("value " ++ show v ++ " out of dimension: " ++ show d)
-  removeInRow n idx
+    else v
-  removeInCol n idx
-  removeInBox n idx
-  -- remove all candidates for this cell
-  flatIdx <- flattenIdx idx
-  cs <- gets candidates
-  let cand = cs ! flatIdx
-  let cand' = dropAllCandidates cand
-  modify (\s -> s {candidates = updateVector cs flatIdx cand'})
 
-insertAll :: Sudoku -> SudokuMonad ()
+update :: Grid a -> Int -> Int -> a -> Grid a
-insertAll (Sudoku d g) = do
+update (Grid g d) _x _y v = Grid newG d
-  let coords = [(x, y) | y <- [1 .. d * d], x <- [1 .. d * d]]
-  let initialState =
-        SudokuState
-          { dimension = d,
-            grid = V.replicate (d * d * d * d) 0,
-            idxs = V.fromList coords,
-            candidates = V.replicate (d * d * d * d) (V.replicate (d * d) True)
-          }
-  put initialState
-  forM_ (zip g coords) (\(n, idx) -> when (n /= 0) (insert n idx))
-
-showCandidates3 :: SudokuMonad String
-showCandidates3 = do
-  cs <- gets candidates
-  let cs' = V.map (V.filter (/= 0) . V.imap (\idx b -> if b then idx + 1 else 0)) cs
-  return $
-    show (slice 0 9 cs')
-      ++ "\n"
-      ++ show (slice 9 9 cs')
-      ++ "\n"
-      ++ show (slice 18 9 cs')
-      ++ "\n"
-      ++ show (slice 27 9 cs')
-      ++ "\n"
-      ++ show (slice 36 9 cs')
-      ++ "\n"
-      ++ show (slice 45 9 cs')
-      ++ "\n"
-      ++ show (slice 54 9 cs')
-      ++ "\n"
-      ++ show (slice 63 9 cs')
-      ++ "\n"
-      ++ show (slice 72 9 cs')
-
-showGrid :: SudokuMonad String
-showGrid = do
-  g <- gets grid
-  return $ show g
-
--- * Stateless Sudoku Type
-
---
-
--- $statelessFlattened
---
--- Here we define a simpler Sudoku type that would be very inneficient to work with
--- but is suitable for pretty printing and reading
-
--- | Contains metadata concerning a Sudoku field
-data Sudoku = Sudoku
-  { -- | The dim of the Sudoku, e.g. a 9x9 Sudoku field has dim 3
-    dim :: Int,
-    -- | The Sudoku field as a flattened list
-    grd :: [Int]
-  }
-
-instance Show Sudoku where
-  show :: Sudoku -> String
-  show = map intToDigit . grd
-
-instance Read Sudoku where
-  readsPrec :: Int -> ReadS Sudoku
-  readsPrec _ s =
-    if isInt dimDouble
-      then [(Sudoku (floor dimDouble) (map digitToInt s), "")]
-      else error ("Trying to parse malformed sudoku (number of digits [" ++ show (length s) ++ "] is not a quadratic root):\n" ++ s)
   where
-      isInt x = x == fromInteger (round x)
+    x = checkDimension d _x
-      dimDouble = sqrt . sqrt $ (fromIntegral (length s) :: Double)
+    y = checkDimension d _y
+    row = g V.! y
+    newRow = row V.// [(x, v)]
+    newG = g V.// [(y, newRow)]
 
--- | Pretty printing of values. Analogous to the `Show` class, but does not harmonize with `Read`.
+allCells :: Grid a -> (a -> Bool) -> Bool
-class Pretty a where
+allCells (Grid g _) test = V.all id rows
-  -- | Works like `show`, but is not inverse to `read`.
-  pretty :: a -> String
-
--- TODO improve pretty printer, this is kind of a mess
-instance Pretty Sudoku where
-  pretty :: Sudoku -> String
-  pretty s = prettyHelper (dim s - 1, dim s, grd s)
   where
-      -- prettyBlock (isLast, n, list)
+    rows :: Vector Bool
-      prettyBlock :: (Bool, Int, [Int]) -> String
+    rows = V.map (V.all test) g
-      prettyBlock (_, _, []) = ""
+
-      prettyBlock (True, n, _) | n == 0 = ""
+rowView :: Grid a -> Int -> Row a
-      prettyBlock (False, n, _) | n == 0 = "|"
+rowView = getRow
-      prettyBlock (b, n, x : xs) = intToDigit x : ' ' : prettyBlock (b, n - 1, xs)
+
-      -- prettyRow (n, d, list)
+colView :: Grid a -> Int -> Row a
-      prettyRow :: (Int, Int, [Int]) -> String
+colView gr@(Grid _ d) x = V.generate (d * d) (\y -> getCell gr (x, y))
-      prettyRow (n, d, xs) | n == 0 = prettyBlock (True, d, xs)
+
-      prettyRow (n, d, xs) = prettyBlock (False, d, xs) ++ (' ' : prettyRow (n - 1, d, drop d xs))
+-- returns topleft coords of the square
-      -- prettyCol (isLast, n, d, list)
+squareToCoords :: Grid a -> Int -> (Int, Int)
-      prettyCol :: (Bool, Int, Int, [Int]) -> String
+squareToCoords (Grid _ d) m = ((m `mod` d) * d, (m `div` d) * d)
-      prettyCol (True, n, _, _) | n == 0 = ""
+
-      prettyCol (False, n, d, _) | n == 0 = replicate (2 * d * d - 1 + 2 * (d - 1)) '-'
+squareView :: Grid a -> Int -> Row a
-      prettyCol (_, _, _, []) = ""
+squareView gr@(Grid _ d) n = V.concat (map (\y -> V.generate d (\x -> getCell gr (x + xoff, y + yoff))) [0 .. d - 1])
-      prettyCol (b, n, d, xs) = prettyRow (d - 1, d, xs) ++ ('\n' : prettyCol (b, n - 1, d, drop (d * d) xs))
+  where
-      -- prettyHelper (n, d, list)
+    (xoff, yoff) = squareToCoords gr n
-      prettyHelper :: (Int, Int, [Int]) -> String
+
-      prettyHelper (n, d, xs) | n == 0 = prettyCol (True, d, d, xs)
+count :: (Eq a) => Vector a -> a -> Int
-      prettyHelper (n, d, xs) = prettyCol (False, d, d, xs) ++ ('\n' : prettyHelper (n - 1, d, drop (d * d * d) xs))
+count v a = V.foldl (\c b -> if a == b then c + 1 else c) 0 v
+
+mapGrid :: (a -> b) -> Grid a -> Grid b
+mapGrid f (Grid g d) = Grid (V.map (V.map f) g) d