Sudoku.cabal

@@ -70,8 +70,7 @@ 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,
-                      split ^>=0.2.2
+                      mtl ^>=2.3.1
 
     -- Directories containing source files.
     hs-source-dirs:   src

app/Main.hs

@@ -1,89 +1,63 @@
 module Main where
 
-import Data.Char (digitToInt)
-import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe)
+import Control.Monad.State (evalState)
 import qualified Data.Vector as V
 import Types
-  ( Grid (Grid),
-    allCells,
-    colView,
-    count,
-    getCell,
-    initGrid,
-    mapGrid,
-    printGrid,
-    putCell,
-    rowView,
-    squareView,
-  )
 
 main :: IO ()
 main = do
-  putStr $ printSudoku dummyGrid
-  print $ isValidGrid dummyGrid
-  putStr . printGrid . fromJust $ solve dummyGrid
+  -- putStrLn $ evalState (insert 5 (2, 5) >> showCandidates3) dummyState
+
+  -- print $ evalState (getBoxRange 1) dummyState
+  -- 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)
-dummyGrid = initGrid 3 (map toMaybeInt test)
-  where
-    toMaybeInt :: Char -> Maybe Int
-    toMaybeInt c = if int == 0 then Nothing else Just int
-      where
-        int = digitToInt c
+{-
+070 000 043
+040 009 610
+800 634 900
+094 052 000
+358 460 020
+000 800 530
+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)
+    }
 
-printSudoku :: Grid (Maybe Int) -> String
-printSudoku gr = printGrid mappedGrid
-  where
-    mappedGrid :: Grid Int
-    mappedGrid = mapGrid (fromMaybe 0) gr
-
-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)
+initState :: SudokuState
+initState =
+  SudokuState
+    { dimension = 0,
+      grid = V.empty,
+      idxs = V.empty,
+      candidates = V.empty
+    }

src/Types.hs

@@ -1,103 +1,245 @@
+{-# LANGUAGE InstanceSigs #-}
+
 module Types where
 
-import Data.List (intercalate)
-import Data.List.Split (chunksOf, keepDelimsL, split, whenElt)
-import Data.Vector (Vector)
+import Control.Monad (forM_, when)
+import Control.Monad.State (MonadState (put), State, get, gets, modify)
+import Data.Char (digitToInt, intToDigit)
+import Data.Vector (Vector, slice)
 import qualified Data.Vector as V
+import Debug.Trace
 
-type Row a = Vector a
+-- * Stateful Sudoku Type
 
-data Grid a = Grid
-  { grid :: Vector (Row a),
-    dimension :: Int
+data SudokuState = SudokuState
+  { dimension :: Int,
+    grid :: Vector Int,
+    idxs :: Vector (Int, Int),
+    candidates :: Vector (Vector Bool)
   }
 
-initGrid :: Int -> [a] -> Grid a
-initGrid d vs = Grid (V.fromList . map V.fromList $ chunksOf (d * d) vs) d
+type SudokuMonad = State SudokuState
 
-getRow :: Grid a -> Int -> Row a
-getRow (Grid g d) y =
-  if y >= d * d || y < 0
-    then error ("getRow: y=" ++ show y ++ " is out of dimension=" ++ show d)
-    else g V.! y
+getField :: (Int, Int) -> SudokuMonad Int
+getField (x, y) = do
+  state <- get
+  return $ grid state ! (x + y * dimension state)
 
-putRow :: Grid a -> Row a -> Int -> Grid a
-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
+getRow :: (Int, Int) -> SudokuMonad Int
+getRow (_, y) = return y
 
-updateRow :: Grid a -> (Row a -> Row a) -> Int -> Grid a
-updateRow gr upd y = putRow gr (upd oldRow) y
+getCol :: (Int, Int) -> SudokuMonad Int
+getCol (x, _) = return x
+
+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
-    oldRow = getRow gr y
+    -- \| Maps a box number to its upper left corner
+    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
 
-putCell :: Grid a -> (Int, Int) -> a -> Grid a
-putCell gs@(Grid _ d) (x, y) v =
-  if x >= d * d || x < 0
-    then error "putCell out of bounds"
-    else updateRow gs (\row -> row V.// [(x, v)]) y
+flattenIdx :: (Int, Int) -> SudokuMonad Int
+flattenIdx (x, y) = do
+  d <- gets dimension
+  return (x + (d * d * (y - 1)))
 
-getCell :: Grid a -> (Int, Int) -> a
-getCell gs@(Grid _ d) (x, y) =
-  if x >= d * d || x < 0
-    then error "getCell: x out of bounds"
-    else row V.! x
+updateVector :: Vector a -> Int -> a -> Vector a
+updateVector v idx x = V.update v (V.singleton (idx - 1, x))
+
+dropCandidate :: Int -> Vector Bool -> Vector Bool
+dropCandidate n bs = updateVector bs n False
+
+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
-    row = getRow gs y
+    remover :: Int -> SudokuMonad ()
+    remover pos = do
+      cs <- gets candidates
+      let cand = cs ! pos
+      let cand' = dropCandidate n cand
+      modify (\s -> s {candidates = updateVector cs pos cand'})
 
-printGrid :: (Show a) => Grid a -> String
-printGrid gr@(Grid _ d) = unwords . intercalate ["\n"] . chunksOf 3 . (split . keepDelimsL . whenElt) (== '\n') . unlines $ map printRow [0 .. (d * d) - 1]
+removeInCol :: Int -> (Int, Int) -> SudokuMonad ()
+removeInCol n idx = do
+  cr <- getCol idx >>= getColRange
+  forM_ cr remover
   where
-    printRow :: Int -> String
-    printRow _y = unwords $ map printSquare [0 .. d - 1]
-      where
-        y = checkDimension d _y
-        row = getRow gr y
-        printSquare :: Int -> String
-        printSquare n =
-          if n * d >= d * d || n < 0
-            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]
+    remover :: Int -> SudokuMonad ()
+    remover pos = do
+      cs <- gets candidates
+      let cand = cs ! pos
+      let cand' = dropCandidate n cand
+      modify (\s -> s {candidates = updateVector cs pos cand'})
 
-checkDimension :: Int -> Int -> Int
-checkDimension d v =
-  if v >= d * d || v < 0
-    then error ("value " ++ show v ++ " out of dimension: " ++ show d)
-    else v
-
-update :: Grid a -> Int -> Int -> a -> Grid a
-update (Grid g d) _x _y v = Grid newG d
+removeInBox :: Int -> (Int, Int) -> SudokuMonad ()
+removeInBox n idx = do
+  br <- getBox idx >>= getBoxRange
+  forM_ br remover
   where
-    x = checkDimension d _x
-    y = checkDimension d _y
-    row = g V.! y
-    newRow = row V.// [(x, v)]
-    newG = g V.// [(y, newRow)]
+    remover :: Int -> SudokuMonad ()
+    remover pos = do
+      cs <- gets candidates
+      let cand = cs ! pos
+      let cand' = dropCandidate n cand
+      modify (\s -> s {candidates = updateVector cs pos cand'})
 
-allCells :: Grid a -> (a -> Bool) -> Bool
-allCells (Grid g _) test = V.all id rows
-  where
-    rows :: Vector Bool
-    rows = V.map (V.all test) g
+insert :: Int -> (Int, Int) -> SudokuMonad ()
+insert n idx = do
+  gridInsert n idx
+  -- traceM $ "inserting " ++ show n
+  removeInRow n idx
+  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'})
 
-rowView :: Grid a -> Int -> Row a
-rowView = getRow
+insertAll :: Sudoku -> SudokuMonad ()
+insertAll (Sudoku d g) = do
+  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))
 
-colView :: Grid a -> Int -> Row a
-colView gr@(Grid _ d) x = V.generate (d * d) (\y -> getCell gr (x, y))
+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')
 
--- returns topleft coords of the square
-squareToCoords :: Grid a -> Int -> (Int, Int)
-squareToCoords (Grid _ d) m = ((m `mod` d) * d, (m `div` d) * d)
+showGrid :: SudokuMonad String
+showGrid = do
+  g <- gets grid
+  return $ show g
 
-squareView :: Grid a -> Int -> Row a
-squareView gr@(Grid _ d) n = V.concat (map (\y -> V.generate d (\x -> getCell gr (x + xoff, y + yoff))) [0 .. d - 1])
-  where
-    (xoff, yoff) = squareToCoords gr n
+-- * Stateless Sudoku Type
 
-count :: (Eq a) => Vector a -> a -> Int
-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
+-- $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)
+      dimDouble = sqrt . sqrt $ (fromIntegral (length s) :: Double)
+
+-- | Pretty printing of values. Analogous to the `Show` class, but does not harmonize with `Read`.
+class Pretty a where
+  -- | 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)
+      prettyBlock :: (Bool, Int, [Int]) -> String
+      prettyBlock (_, _, []) = ""
+      prettyBlock (True, n, _) | n == 0 = ""
+      prettyBlock (False, n, _) | n == 0 = "|"
+      prettyBlock (b, n, x : xs) = intToDigit x : ' ' : prettyBlock (b, n - 1, xs)
+      -- prettyRow (n, d, list)
+      prettyRow :: (Int, Int, [Int]) -> String
+      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))
+      -- prettyCol (isLast, n, d, list)
+      prettyCol :: (Bool, Int, Int, [Int]) -> String
+      prettyCol (True, n, _, _) | n == 0 = ""
+      prettyCol (False, n, d, _) | n == 0 = replicate (2 * d * d - 1 + 2 * (d - 1)) '-'
+      prettyCol (_, _, _, []) = ""
+      prettyCol (b, n, d, xs) = prettyRow (d - 1, d, xs) ++ ('\n' : prettyCol (b, n - 1, d, drop (d * d) xs))
+      -- prettyHelper (n, d, list)
+      prettyHelper :: (Int, Int, [Int]) -> String
+      prettyHelper (n, d, xs) | n == 0 = prettyCol (True, d, d, xs)
+      prettyHelper (n, d, xs) = prettyCol (False, d, d, xs) ++ ('\n' : prettyHelper (n - 1, d, drop (d * d * d) xs))