Add cabal, work on types

src/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for Sudoku
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

src/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2024 Leon Vatthauer
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

src/Sudoku.cabal

@@ -0,0 +1,130 @@
+cabal-version:      3.0
+-- The cabal-version field refers to the version of the .cabal specification,
+-- and can be different from the cabal-install (the tool) version and the
+-- Cabal (the library) version you are using. As such, the Cabal (the library)
+-- version used must be equal or greater than the version stated in this field.
+-- Starting from the specification version 2.2, the cabal-version field must be
+-- the first thing in the cabal file.
+
+-- Initial package description 'Sudoku' generated by
+-- 'cabal init'. For further documentation, see:
+--   http://haskell.org/cabal/users-guide/
+--
+-- The name of the package.
+name:               Sudoku
+
+-- The package version.
+-- See the Haskell package versioning policy (PVP) for standards
+-- guiding when and how versions should be incremented.
+-- https://pvp.haskell.org
+-- PVP summary:     +-+------- breaking API changes
+--                  | | +----- non-breaking API additions
+--                  | | | +--- code changes with no API change
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- The license under which the package is released.
+license:            MIT
+
+-- The file containing the license text.
+license-file:       LICENSE
+
+-- The package author(s).
+author:             Leon Vatthauer
+
+-- An email address to which users can send suggestions, bug reports, and patches.
+-- maintainer:
+
+-- A copyright notice.
+-- copyright:
+category:           Game
+build-type:         Simple
+
+-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.
+extra-doc-files:    CHANGELOG.md
+
+-- Extra source files to be distributed with the package, such as examples, or a tutorial module.
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall
+
+library
+    -- Import common warning flags.
+    import:           warnings
+
+    -- Modules exported by the library.
+    exposed-modules:  Types
+
+    -- Modules included in this library but not exported.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    -- Other library packages from which modules are imported.
+    build-depends:    base ^>=4.18.2.0,
+                      vector ^>=0.13.1.0,
+                      mtl ^>=2.3.1
+
+    -- Directories containing source files.
+    hs-source-dirs:   src
+
+    -- Base language which the package is written in.
+    default-language: Haskell2010
+
+executable Sudoku
+    -- Import common warning flags.
+    import:           warnings
+
+    -- .hs or .lhs file containing the Main module.
+    main-is:          Main.hs
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    -- Other library packages from which modules are imported.
+    build-depends:
+        base ^>=4.18.2.0,
+        Sudoku
+
+    -- Directories containing source files.
+    hs-source-dirs:   app
+
+    -- Base language which the package is written in.
+    default-language: Haskell2010
+
+test-suite Sudoku-test
+    -- Import common warning flags.
+    import:           warnings
+
+    -- Base language which the package is written in.
+    default-language: Haskell2010
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+
+    -- The interface type and version of the test suite.
+    type:             exitcode-stdio-1.0
+
+    -- Directories containing source files.
+    hs-source-dirs:   test
+
+    -- The entrypoint to the test suite.
+    main-is:          Main.hs
+
+    -- Test dependencies.
+    build-depends:
+        base ^>=4.18.2.0,
+        Sudoku

src/app/Main.hs

@@ -0,0 +1,13 @@
+module Main where
+
+import Types
+
+main :: IO ()
+main = do
+  putStrLn "Reading:"
+  print (read test :: Sudoku)
+  putStrLn "Pretty Printing:"
+  putStrLn . pretty $ (read test :: Sudoku)
+
+test :: String
+test = "070000043040009610800634900094052000358460020000800530080070091902100005007040802"

src/src/Types.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE InstanceSigs #-}
+
+module Types where
+
+import Control.Monad.State (State)
+import Data.Char (digitToInt, intToDigit)
+import Data.Vector (Vector)
+
+-- * Stateful Sudoku Type
+
+data SudokuState = SudokuState
+  { dimension :: Int,
+    grid :: Vector Int,
+    idxs :: Vector (Int, Int)
+  }
+
+type SudokuMonad = State SudokuState
+
+getField :: (Int, Int) -> SudokuMonad Int
+getField (x, y) = do
+  state <- get
+  return $ (x + y * dimension state) ! grid state
+
+getRow :: (Int, Int) -> SudokuMonad Int
+getRow (x, _) = return x
+
+getCol :: (Int, Int) -> SudokuMonad Int
+getCol (_, y) = return y
+
+getBox :: (Int, Int) -> SudokuMonad Int
+getBox (x, y) = do
+  d <- gets dimension
+  let xPart = x `div` d
+  let yPart = y `div` d
+  return $ xPart + d * yPart
+
+-- * 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)
+      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, dim, list)
+      prettyRow :: (Int, Int, [Int]) -> String
+      prettyRow (n, dim, xs) | n == 0 = prettyBlock (True, dim, xs)
+      prettyRow (n, dim, xs) = prettyBlock (False, dim, xs) ++ (' ' : prettyRow (n - 1, dim, drop dim xs))
+      -- prettyCol (isLast, n, dim, list)
+      prettyCol :: (Bool, Int, Int, [Int]) -> String
+      prettyCol (True, n, _, _) | n == 0 = ""
+      prettyCol (False, n, dim, _) | n == 0 = replicate (2 * dim * dim - 1 + 2 * (dim - 1)) '-'
+      prettyCol (_, _, _, []) = ""
+      prettyCol (b, n, dim, xs) = prettyRow (dim - 1, dim, xs) ++ ('\n' : prettyCol (b, n - 1, dim, drop (dim * dim) xs))
+      -- prettyHelper (n, dim, list)
+      prettyHelper :: (Int, Int, [Int]) -> String
+      prettyHelper (n, dim, xs) | n == 0 = prettyCol (True, dim, dim, xs)
+      prettyHelper (n, dim, xs) = prettyCol (False, dim, dim, xs) ++ ('\n' : prettyHelper (n - 1, dim, drop (dim * dim) xs))

src/test/Main.hs

@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = putStrLn "Test suite not yet implemented."