From b7cb4c9cd737299ce5bbf9254971b90987e8c461 Mon Sep 17 00:00:00 2001
From: Leon Vatthauer <leon.vatthauer@fau.de>
Date: Sat, 15 Jun 2024 13:21:06 +0200
Subject: [PATCH 1/2] working version

---
 Sudoku.cabal |   3 +-
 app/Main.hs  | 139 +++++++++++++++---------
 src/Types.hs | 299 ++++++++++++++-------------------------------------
 3 files changed, 170 insertions(+), 271 deletions(-)

diff --git a/Sudoku.cabal b/Sudoku.cabal
index 13343ae..2a4d834 100644
--- a/Sudoku.cabal
+++ b/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
diff --git a/app/Main.hs b/app/Main.hs
index 3da0c0e..01b4ebf 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,63 +1,102 @@
 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
+  putStr . printGrid . fromJust $ solve dummyGrid
 
-  -- 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
+-- print $ colView dummyGrid 4
+-- print $ squareView dummyGrid 4
+-- print $ squareToCoords dummyGrid 0
+-- print $ squareToCoords dummyGrid 1
+-- print $ squareToCoords dummyGrid 2
+-- print $ squareToCoords dummyGrid 3
+-- print $ squareToCoords dummyGrid 4
+-- print $ squareToCoords dummyGrid 5
+-- print $ squareToCoords dummyGrid 6
+-- print $ squareToCoords dummyGrid 7
+-- print $ squareToCoords dummyGrid 8
+-- print $ allCells dummyGrid (>= 0)
 
 test :: String
 test = "070000043040009610800634900094052000358460020000800530080070091902100005007040802"
 
-{-
-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)
-    }
+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
 
-initState :: SudokuState
-initState =
-  SudokuState
-    { dimension = 0,
-      grid = V.empty,
-      idxs = V.empty,
-      candidates = V.empty
-    }
\ No newline at end of file
+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@(Grid g d) = 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)
\ No newline at end of file
diff --git a/src/Types.hs b/src/Types.hs
index 65fdec2..4eeae41 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -1,245 +1,104 @@
-{-# LANGUAGE InstanceSigs #-}
-
 module Types where
 
-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 Data.List (intercalate)
+import Data.List.Split (chunksOf, keepDelimsL, split, splitWhen, whenElt)
+import Data.Maybe (isJust)
+import Data.Vector (Vector)
 import qualified Data.Vector as V
-import Debug.Trace
 
--- * Stateful Sudoku Type
+type Row a = Vector a
 
-data SudokuState = SudokuState
-  { dimension :: Int,
-    grid :: Vector Int,
-    idxs :: Vector (Int, Int),
-    candidates :: Vector (Vector Bool)
+data Grid a = Grid
+  { grid :: Vector (Row a),
+    dimension :: Int
   }
 
-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
-getField (x, y) = do
-  state <- get
-  return $ grid state ! (x + y * dimension state)
+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
 
-getRow :: (Int, Int) -> SudokuMonad Int
-getRow (_, y) = return y
+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
 
-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]]
+updateRow :: Grid a -> (Row a -> Row a) -> Int -> Grid a
+updateRow gr upd y = putRow gr (upd oldRow) y
   where
-    -- \| 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
+    oldRow = getRow gr y
 
-flattenIdx :: (Int, Int) -> SudokuMonad Int
-flattenIdx (x, y) = do
-  d <- gets dimension
-  return (x + (d * d * (y - 1)))
+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
 
-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
+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
   where
-    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'})
+    row = getRow gs y
 
-removeInCol :: Int -> (Int, Int) -> SudokuMonad ()
-removeInCol n idx = do
-  cr <- getCol idx >>= getColRange
-  forM_ cr remover
+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]
   where
-    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'})
+    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]
 
-removeInBox :: Int -> (Int, Int) -> SudokuMonad ()
-removeInBox n idx = do
-  br <- getBox idx >>= getBoxRange
-  forM_ br remover
+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
   where
-    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'})
+    x = checkDimension d _x
+    y = checkDimension d _y
+    row = g V.! y
+    newRow = row V.// [(x, v)]
+    newG = g V.// [(y, newRow)]
 
-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'})
+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
 
-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))
+rowView :: Grid a -> Int -> Row a
+rowView = getRow
 
-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')
+colView :: Grid a -> Int -> Row a
+colView gr@(Grid _ d) x = V.generate (d * d) (\y -> getCell gr (x, y))
 
-showGrid :: SudokuMonad String
-showGrid = do
-  g <- gets grid
-  return $ show g
+-- returns topleft coords of the square
+squareToCoords :: Grid a -> Int -> (Int, Int)
+squareToCoords (Grid _ d) m = ((m `mod` d) * d, (m `div` d) * d)
 
--- * Stateless Sudoku Type
+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
 
---
+count :: (Eq a) => Vector a -> a -> Int
+count v a = V.foldl (\c b -> if a == b then c + 1 else c) 0 v
 
--- $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))
+mapGrid :: (a -> b) -> Grid a -> Grid b
+mapGrid f (Grid g d) = Grid (V.map (V.map f) g) d
\ No newline at end of file
-- 
2.47.0


From a9eb2790497736c89714240edc41c33288745978 Mon Sep 17 00:00:00 2001
From: Leon Vatthauer <leon.vatthauer@fau.de>
Date: Sun, 16 Jun 2024 15:35:14 +0200
Subject: [PATCH 2/2] minor

---
 app/Main.hs  | 15 +--------------
 src/Types.hs |  3 +--
 2 files changed, 2 insertions(+), 16 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 01b4ebf..00e447e 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -23,19 +23,6 @@ main = do
   print $ isValidGrid dummyGrid
   putStr . printGrid . fromJust $ solve dummyGrid
 
--- print $ colView dummyGrid 4
--- print $ squareView dummyGrid 4
--- print $ squareToCoords dummyGrid 0
--- print $ squareToCoords dummyGrid 1
--- print $ squareToCoords dummyGrid 2
--- print $ squareToCoords dummyGrid 3
--- print $ squareToCoords dummyGrid 4
--- print $ squareToCoords dummyGrid 5
--- print $ squareToCoords dummyGrid 6
--- print $ squareToCoords dummyGrid 7
--- print $ squareToCoords dummyGrid 8
--- print $ allCells dummyGrid (>= 0)
-
 test :: String
 test = "070000043040009610800634900094052000358460020000800530080070091902100005007040802"
 
@@ -74,7 +61,7 @@ isFull :: Grid (Maybe Int) -> Bool
 isFull gr = allCells gr isJust
 
 isSolved :: Grid (Maybe Int) -> Bool
-isSolved gr@(Grid g d) = isValidGrid gr && isFull gr
+isSolved gr = isValidGrid gr && isFull gr
 
 extractSolution :: Grid (Maybe Int) -> Grid Int
 extractSolution gr =
diff --git a/src/Types.hs b/src/Types.hs
index 4eeae41..02ad916 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -1,8 +1,7 @@
 module Types where
 
 import Data.List (intercalate)
-import Data.List.Split (chunksOf, keepDelimsL, split, splitWhen, whenElt)
-import Data.Maybe (isJust)
+import Data.List.Split (chunksOf, keepDelimsL, split, whenElt)
 import Data.Vector (Vector)
 import qualified Data.Vector as V
 
-- 
2.47.0