From cd5de79e24132f900236ec737d8bfa94dc5253e1 Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Fri, 18 Jul 2025 15:47:38 +0200 Subject: [PATCH] feat: implemented the program --- .gitignore | 2 + CHANGELOG.md | 11 +++ README.md | 1 + Setup.hs | 2 + app/Main.hs | 36 +++++++++ package.yaml | 66 ++++++++++++++++ solvedoku.cabal | 101 ++++++++++++++++++++++++ src/Data/Enum/Util.hs | 4 + src/Data/Functor/Representable.hs | 21 +++++ src/Data/ImplicitMultiMap.hs | 15 ++++ src/Graphics/Text/Box.hs | 126 ++++++++++++++++++++++++++++++ src/Sudoku.hs | 125 +++++++++++++++++++++++++++++ src/Sudoku/Area.hs | 41 ++++++++++ src/Sudoku/Field.hs | 31 ++++++++ src/Sudoku/Render.hs | 35 +++++++++ src/Sudoku/Solve.hs | 58 ++++++++++++++ src/Sudoku/State.hs | 117 +++++++++++++++++++++++++++ src/Sudoku/Triple.hs | 48 ++++++++++++ stack.yaml | 67 ++++++++++++++++ stack.yaml.lock | 12 +++ test/Spec.hs | 2 + test/example.s3 | 9 +++ 22 files changed, 930 insertions(+) create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 app/Main.hs create mode 100644 package.yaml create mode 100644 solvedoku.cabal create mode 100644 src/Data/Enum/Util.hs create mode 100644 src/Data/Functor/Representable.hs create mode 100644 src/Data/ImplicitMultiMap.hs create mode 100644 src/Graphics/Text/Box.hs create mode 100644 src/Sudoku.hs create mode 100644 src/Sudoku/Area.hs create mode 100644 src/Sudoku/Field.hs create mode 100644 src/Sudoku/Render.hs create mode 100644 src/Sudoku/Solve.hs create mode 100644 src/Sudoku/State.hs create mode 100644 src/Sudoku/Triple.hs create mode 100644 stack.yaml create mode 100644 stack.yaml.lock create mode 100644 test/Spec.hs create mode 100644 test/example.s3 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c368d45 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +.stack-work/ +*~ \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..7bbb507 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `solvedoku` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/README.md b/README.md new file mode 100644 index 0000000..9bd5c4d --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# solvedoku diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..6eaf119 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,36 @@ +module Main (main) where +import qualified Data.Text.IO as Text +import Text.Megaparsec (errorBundlePretty, runParser) +import qualified Data.Text as Text +import qualified Sudoku +import qualified Sudoku.Solve as Solve +import qualified Sudoku.Render as Render +import Sudoku.State (State) +import Options.Applicative (subparser, command, info, Parser, progDesc, execParser) +import System.Exit (exitFailure) + +data Mode + = Solve + | Hints + +parseMode :: Parser Mode +parseMode = subparser + ( command "solve" (info (pure Solve) (progDesc "Solve the supplied sudoku entirely.")) + <> command "hints" (info (pure Hints) (progDesc "Show hints for the sudoku.")) + ) + +main :: IO () +main = do + mode <- execParser (info parseMode mempty) + input <- Text.getContents + sudoku <- case runParser Sudoku.parse "" input of + Left errorBundle -> (Text.putStr . Text.pack . errorBundlePretty $ errorBundle) >> exitFailure + Right s -> pure s + + Text.putStr $ case mode of + Solve -> Text.pack . show $ Solve.solve State sudoku + Hints -> let + hints = Solve.hints State sudoku + + in Render.hints hints + diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..378a8fd --- /dev/null +++ b/package.yaml @@ -0,0 +1,66 @@ +name: solvedoku +version: 0.1.0.0 +license: AGPL-3.0 +author: "VegOwOtenks" +maintainer: "vegowotenks@jossco.de" +copyright: "2025 VegOwOtenks" + +extra-source-files: +- README.md +- CHANGELOG.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- adjunctions +- array +- base >= 4.7 && < 5 +- containers +- distributive +- megaparsec +- optparse-applicative +- text +- QuickCheck + +ghc-options: +- -Wall +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wmissing-export-lists +- -Wmissing-home-modules +- -Wpartial-fields +- -Wredundant-constraints + +library: + source-dirs: src + +executables: + solvedoku-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - solvedoku + +tests: + solvedoku-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - solvedoku diff --git a/solvedoku.cabal b/solvedoku.cabal new file mode 100644 index 0000000..0565f04 --- /dev/null +++ b/solvedoku.cabal @@ -0,0 +1,101 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.38.1. +-- +-- see: https://github.com/sol/hpack + +name: solvedoku +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/solvedoku#readme +bug-reports: https://github.com/githubuser/solvedoku/issues +author: Author name here +maintainer: example@example.com +copyright: 2025 Author name here +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/githubuser/solvedoku + +library + exposed-modules: + Data.Enum.Util + Data.Functor.Representable + Data.ImplicitMultiMap + Graphics.Text.Box + Sudoku + Sudoku.Area + Sudoku.Field + Sudoku.Render + Sudoku.Solve + Sudoku.State + Sudoku.Triple + other-modules: + Paths_solvedoku + autogen-modules: + Paths_solvedoku + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + QuickCheck + , adjunctions + , array + , base >=4.7 && <5 + , containers + , distributive + , megaparsec + , optparse-applicative + , text + default-language: Haskell2010 + +executable solvedoku-exe + main-is: Main.hs + other-modules: + Paths_solvedoku + autogen-modules: + Paths_solvedoku + hs-source-dirs: + app + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , adjunctions + , array + , base >=4.7 && <5 + , containers + , distributive + , megaparsec + , optparse-applicative + , solvedoku + , text + default-language: Haskell2010 + +test-suite solvedoku-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_solvedoku + autogen-modules: + Paths_solvedoku + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , adjunctions + , array + , base >=4.7 && <5 + , containers + , distributive + , megaparsec + , optparse-applicative + , solvedoku + , text + default-language: Haskell2010 diff --git a/src/Data/Enum/Util.hs b/src/Data/Enum/Util.hs new file mode 100644 index 0000000..37536d6 --- /dev/null +++ b/src/Data/Enum/Util.hs @@ -0,0 +1,4 @@ +module Data.Enum.Util (enumerate) where + +enumerate :: (Bounded a, Enum a) => [a] +enumerate = [minBound..maxBound] diff --git a/src/Data/Functor/Representable.hs b/src/Data/Functor/Representable.hs new file mode 100644 index 0000000..d1b4de6 --- /dev/null +++ b/src/Data/Functor/Representable.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleContexts #-} +module Data.Functor.Representable (set, get, adjust) where +import Data.Functor.Rep (Representable(index, Rep, tabulate)) + +get :: Representable f => f a -> Rep f -> a +get = index + +set :: (Representable f, Eq (Rep f)) => Rep f -> a -> f a -> f a +set i x old = tabulate override + where + override j + | i == j = x + | otherwise = index old j + +adjust :: (Representable f, Eq (Rep f)) => Rep f -> (a -> a) -> f a -> f a +adjust i f old = tabulate override + where + override j + | i == j = f (index old j) + | otherwise = index old j + diff --git a/src/Data/ImplicitMultiMap.hs b/src/Data/ImplicitMultiMap.hs new file mode 100644 index 0000000..410dafb --- /dev/null +++ b/src/Data/ImplicitMultiMap.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TypeFamilies #-} +module Data.ImplicitMultiMap (ImplicitMultiMap, DeriveKey(..), empty) where +import Data.Kind (Type) +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map + +class DeriveKey a where + type KeyOf a :: Type + deriveKey :: a -> KeyOf a + +newtype ImplicitMultiMap a = ImplicitMultiMap (Map (KeyOf a) (Set a)) + +empty :: ImplicitMultiMap a +empty = ImplicitMultiMap Map.empty diff --git a/src/Graphics/Text/Box.hs b/src/Graphics/Text/Box.hs new file mode 100644 index 0000000..c7ede68 --- /dev/null +++ b/src/Graphics/Text/Box.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NPlusKPatterns #-} +{-# LANGUAGE MultiWayIf #-} +module Graphics.Text.Box (Box, square, Border(..), asciiBorder, grid, asciiGrid, size, lookup, render) where + +import Prelude hiding (lookup) + +import Data.Array.IArray (Array, genArray) +import Data.Text (Text) +import qualified Data.Array.IArray as Array +import Control.Monad (join) +import Data.Bifunctor ( Bifunctor(bimap) ) +import qualified Data.Maybe as Maybe +import qualified Data.Foldable as Foldable +import Control.Arrow (Arrow ((***))) +import qualified Data.Text as Text + +data Box + = Raw (Array (Int, Int) Char) + | Grid (Array (Int, Int) Box) (Maybe Border) + +data Border = Border + { top, right, left, bottom, topRight, bottomRight, bottomLeft, topLeft, crosssection, verticalBetween, horizontalBetween :: Char } + +asciiBorder :: Border +asciiBorder = Border {top='-', right='|', left='|', bottom='-', topRight='\\', bottomRight='/', bottomLeft='\\', topLeft='/', crosssection='+', verticalBetween='|', horizontalBetween='-'} + +type Row = Int +type Column = Int + +square :: Int -> ((Row, Column) -> Char) -> Box +square dim f = Raw $ genArray ((0, 0), (dim - 1, dim - 1)) f + +grid :: Maybe Border -> (Int, Int) -> ((Int, Int) -> Box) -> Box +grid border (rows, cols) f = let + + boxes = genArray ((0, 0), (rows - 1, cols - 1)) f + + in Grid boxes border + +asciiGrid :: (Int, Int) -> ((Int, Int) -> Box) -> Box +asciiGrid = grid $ Just asciiBorder + +gridCellSize :: Array (Int, Int) Box -> (Int, Int) +gridCellSize = let + updateMaxSize box (height, width) = (max height *** max width) $ size box + in Foldable.foldr updateMaxSize (0, 0) + +size :: Box -> (Int, Int) +size = \case + Raw chars -> arraySize chars -- snd takes the higher bound, +1 because the array has inclusive ranges + Grid boxes border -> let + + (boxRows, boxColumns) = arraySize boxes + (cellHeight, cellWidth) = gridCellSize boxes + borderSize = case border of + Just _ -> 1 + Nothing -> 0 + + in (boxRows * (cellHeight + borderSize) + 1 , boxColumns * (cellWidth + borderSize) + 1) + +arraySize :: Array (Int, Int) a -> (Int, Int) +arraySize = join bimap (+1) . snd . Array.bounds + +orElse :: Maybe a -> a -> a +orElse option x = Maybe.fromMaybe x option + +lookup :: Box -> (Int, Int) -> Maybe Char +lookup b index@(row, col) = case b of + Raw chars -> chars Array.!? index + Grid boxes borderM -> let + + (boxRows, boxColumns) = arraySize boxes + (boxHeight, boxWidth) = gridCellSize boxes + + in case borderM of + + Nothing -> let + (boxRow, boxRowIndex) = row `divMod` boxHeight + (boxCol, boxColIndex) = col `divMod` boxWidth + in do + innerBox <- boxes Array.!? (boxRow, boxCol) + lookup innerBox (boxRowIndex, boxColIndex) + + Just border -> if + | row == 0 && col == 0 -> Just border.topLeft + | row == 0 -> Just border.top + | col == 0 -> Just border.left + -- ^ outer border cases are easy + | otherwise -> let + row' = row - 1 + col' = col - 1 + (boxRow, boxRowIndex) = row' `divMod` (boxHeight + 1) + (boxCol, boxColIndex) = col' `divMod` (boxWidth + 1) + + in if + | boxRowIndex == boxHeight && boxColIndex == boxWidth -> Just $ + if boxRow == boxRows - 1 && boxCol == boxColumns - 1 -- is it the last row and col? + then border.bottomRight + else border.crosssection + | boxRowIndex == boxHeight -> Just $ + if boxRow == boxRows - 1 -- is it the last row? + then border.bottom + else border.horizontalBetween + | boxColIndex == boxWidth -> Just $ + if boxCol == boxColumns - 1 -- is it the last column? + then border.right + else border.verticalBetween + | otherwise -> do -- it's not at the border between boxes at all + innerBox <- boxes Array.!? (boxRow, boxCol) + lookup innerBox (boxRowIndex, boxColIndex) + +render :: Box -> Text +render box = let + (rows, cols) = join bimap pred $ size box + in Text.unlines + [ + Text.pack [ + lookup box (row, col) `orElse` ' ' + | col <- [0..cols] + ] + | row <- [0..rows] + ] + + diff --git a/src/Sudoku.hs b/src/Sudoku.hs new file mode 100644 index 0000000..fcf3b98 --- /dev/null +++ b/src/Sudoku.hs @@ -0,0 +1,125 @@ +-- | A t'Sudoku' is a 3x3 grid of 3x3 grids. + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeApplications #-} +module Sudoku (Sudoku(..), FieldIndex, parse, entireRowOf, entireColumnOf, entireAreaOf, translateIntIndex, orderedIntIndices, orderedIndices, affectedFieldsOf) where + +import Sudoku.Area (Area) +import Data.Functor.Compose (Compose) +import Text.Megaparsec (Parsec) +import Data.Void (Void) +import Sudoku.Field (Field) +import Data.Text (Text) +import Data.Array.IArray (Array) +import Data.Array (listArray) +import qualified Data.List as List +import qualified Sudoku.Field as Field +import qualified Text.Megaparsec.Char as Megaparsec +import Control.Monad (replicateM, join) +import Control.Monad.Representable.Reader +import Data.Distributive (Distributive (..)) +import qualified Data.Array.IArray as Array +import Sudoku.Triple (Index) +import Data.Enum.Util (enumerate) +import Data.Bifunctor (bimap) +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Functor.Rep as Representable + +-- | Composing two areas produces a Sudoku. +-- +-- Index order is: +-- - outer row +-- - outer column +-- - inner row +-- - inner column + +type FieldIndex = ((Index, Index), (Index, Index)) + +newtype Sudoku a = Sudoku { get :: Compose Area Area a } + deriving stock (Foldable, Traversable) + deriving newtype (Functor, Representable, Show) + +instance Distributive Sudoku where + distribute :: Functor f => f (Sudoku a) -> Sudoku (f a) + distribute = Sudoku . distribute . fmap get + +parseSudokuArray :: Parsec Void Text (Array (Int, Int) (Maybe Field)) +parseSudokuArray = listArray ((0, 0), (8, 8)) . List.concat <$> (9 `times` sudokuLine) + +sudokuLine :: Parsec Void Text [Maybe Field] +sudokuLine = (9 `times` Field.parse) <* Megaparsec.eol + +times :: Monad m => Int -> m a -> m [a] +times = replicateM + +-- | Numbers are read from digits, 0 is for empty fields. + +parse :: Parsec Void Text (Sudoku (Maybe Field)) +parse = do + numbers <- parseSudokuArray + + let lookupIndex ix = numbers Array.! translateIndex ix + + pure (tabulate lookupIndex) + +translateIndex :: FieldIndex -> (Int, Int) +translateIndex ((outerRow, outerCol), (innerRow, innerCol)) = let + translatePair major minor = fromEnum major * 3 + fromEnum minor + row = translatePair outerRow innerRow + col = translatePair outerCol innerCol + in (row, col) + +translateIntIndex :: (Int, Int) -> FieldIndex +translateIntIndex (row, col) = let + + (outerRow, innerRow) = join bimap toEnum $ row `divMod` 3 + (outerCol, innerCol) = join bimap toEnum $ col `divMod` 3 + + in ((outerRow, outerCol), (innerRow, innerCol)) + +orderedIntIndices :: (Enum a, Num a) => [[(a, a)]] +orderedIntIndices = [ [(i, j) | j <- [0..8]] | i <- [0..8]] + +orderedIndices :: [[FieldIndex]] +orderedIndices = (translateIntIndex <$>) <$> orderedIntIndices + +-- >>> import Data.Functor.Rep +-- >>> :kind! Rep Sudoku +-- Rep Sudoku :: * +-- = ((Index, Index), (Index, Index)) + +-- | Calculate the indices of all the fields in the same row as the argument. + +entireRowOf :: FieldIndex -> [FieldIndex] +entireRowOf ((_, outerColumn), (_, innerColumn)) = [((outerRow, outerColumn), (innerRow, innerColumn)) | outerRow <- enumerate, innerRow <- enumerate] + +-- | Calculate the indices of all the fields in the same column as the argument. + +entireColumnOf :: FieldIndex -> [FieldIndex] +entireColumnOf ((outerRow, _), (innerRow, _)) = do + outerColumn <- enumerate + innerColumn <- enumerate + pure ((outerRow, outerColumn), (innerRow, innerColumn)) + +-- | Calculate all the indices of the fields in the same area as the argument. + +entireAreaOf :: FieldIndex -> [FieldIndex] +entireAreaOf (outer, _) = do + innerRow <- enumerate + innerColumn <- enumerate + pure (outer, (innerRow, innerColumn)) + +affectedFieldsOf :: FieldIndex -> Set FieldIndex +affectedFieldsOf = Representable.index affectedFields + +affectedFields :: Sudoku (Set FieldIndex) +affectedFields = tabulate @Sudoku (Set.fromList . allAffectedFieldsOf) + where + allAffectedFieldsOf :: FieldIndex -> [FieldIndex] + allAffectedFieldsOf position = List.concatMap ($ position) [entireRowOf, entireColumnOf, entireAreaOf] + diff --git a/src/Sudoku/Area.hs b/src/Sudoku/Area.hs new file mode 100644 index 0000000..09d0c96 --- /dev/null +++ b/src/Sudoku/Area.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DeriveTraversable #-} +module Sudoku.Area (Area(..), indexFromDigit) where + +import Sudoku.Triple (Triple, Index) +import Data.Functor.Compose (Compose(..)) +import Data.Functor.Rep (Representable) +import Data.Distributive (Distributive (..)) +import Data.Bifunctor (Bifunctor(..)) +import Control.Monad (join) + +newtype Area a = Area { get :: Compose Triple Triple a } + deriving stock (Foldable, Traversable) + deriving newtype (Functor, Representable, Show) + +instance Distributive Area where + distribute :: Functor f => f (Area a) -> Area (f a) + distribute = Area . distribute . fmap get + +indexFromDigit :: Int -> (Index, Index) +indexFromDigit i = join bimap toEnum $ i `divMod` 3 + +digitFromIndex :: (Index, Index) -> Int +digitFromIndex (outer, inner) = fromEnum outer * 3 + fromEnum inner + +-- prop> \ i -> digitFromIndex (indexFromDigit (i `mod` 9)) == i `mod` 9 +-- +++ OK, passed 100 tests. + +-- >>> import Sudoku.Triple (Index(..)) +-- >>> digitFromIndex (First, First) +-- 0 +-- +-- >>> indexFromDigit 9 +-- *** Exception: Enum.toEnum{Index}: tag (3) is outside of enumeration's range (0,2) +-- +-- >>> indexFromDigit 6 +-- (Third,First) + diff --git a/src/Sudoku/Field.hs b/src/Sudoku/Field.hs new file mode 100644 index 0000000..67bb144 --- /dev/null +++ b/src/Sudoku/Field.hs @@ -0,0 +1,31 @@ +module Sudoku.Field (Field(..), parse, toDigit, maybeToDigit) where +import qualified Text.Megaparsec.Char as MegaParsec +import Text.Megaparsec (Parsec) +import Data.Void (Void) +import Data.Text (Text) +import qualified Data.Char as Char + +data Field + = One + | Two + | Three + | Four + | Five + | Six + | Seven + | Eight + | Nine + deriving (Show, Ord, Eq, Enum, Bounded) + +parse :: Parsec Void Text (Maybe Field) +parse = do + c <- MegaParsec.digitChar + pure $ case c of + '0' -> Nothing + _ -> Just $ toEnum (Char.digitToInt c - 1) + +toDigit :: Field -> Char +toDigit = Char.intToDigit . (+1) . fromEnum + +maybeToDigit :: Maybe Field -> Char +maybeToDigit = maybe '_' toDigit diff --git a/src/Sudoku/Render.hs b/src/Sudoku/Render.hs new file mode 100644 index 0000000..f48cc71 --- /dev/null +++ b/src/Sudoku/Render.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE LambdaCase #-} +module Sudoku.Render (unstructured, hints) where +import Sudoku (Sudoku, orderedIndices, translateIntIndex) +import Sudoku.Field (Field) +import qualified Sudoku.Field as Field +import qualified Data.Functor.Rep as Representable +import Data.Set (Set) +import Graphics.Text.Box (Box) +import qualified Graphics.Text.Box as Box +import qualified Data.Set as Set +import Data.Text (Text) + +unstructured :: Sudoku (Maybe Field) -> String +unstructured sudoku = let + characters = Field.maybeToDigit <$> sudoku + + in unlines $ (Representable.index characters <$>) <$> orderedIndices + +hints :: Sudoku (Either Field (Set Field)) -> Text +hints sudoku = let + + boxes = fieldBox <$> sudoku :: Sudoku Box + + in Box.render $ Box.asciiGrid (9, 9) (Representable.index boxes . Sudoku.translateIntIndex) + +fieldBox :: Either Field (Set Field) -> Box +fieldBox = \case + Left value -> Box.square 3 (const $ Field.toDigit value) + Right options -> Box.square 3 $ \ (row, col) -> let + option = toEnum $ row * 3 + col + + in if option `Set.member` options + then Field.toDigit option + else ' ' + diff --git a/src/Sudoku/Solve.hs b/src/Sudoku/Solve.hs new file mode 100644 index 0000000..f589f2b --- /dev/null +++ b/src/Sudoku/Solve.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RequiredTypeArguments #-} +{-# LANGUAGE LambdaCase #-} +module Sudoku.Solve (solve, SolveError, hints) where +import Sudoku (Sudoku) +import Sudoku.Field (Field) +import qualified Sudoku.State as SudokuState +import Sudoku.State (SudokuState) +import qualified Data.Set as Set +import qualified Data.Functor.Representable as Representable +import Data.Set ( Set ) +import Data.Functor.Rep (imapRep) + +data SolveError + = InvalidStartState + deriving (Show) + +-- | Given a state implementation and a sudoku. Calculate all the hints + +hints :: forall s -> SudokuState s => Sudoku (Maybe Field) -> Sudoku (Either Field (Set Field)) +hints s sudoku = let + state = SudokuState.build @s sudoku + + getHint position = \case + Just x -> Left x -- field is already filled + Nothing -> Right $ SudokuState.fieldOptions state position + + in imapRep getHint sudoku + +-- | Given a State implementation and a sudoku field, try to solve it. + +solve :: forall s -> SudokuState s => Sudoku (Maybe Field) -> Either SolveError [Sudoku Field] +solve s sudoku = let + state = SudokuState.build @s sudoku + in case SudokuState.isValid state of + False -> Left InvalidStartState + True -> Right $ solveWithState s sudoku state + +solveWithState :: forall s -> SudokuState s => Sudoku (Maybe Field) -> s -> [Sudoku Field] +solveWithState s sudoku state = case sequence sudoku of + Just solution -> [solution] + Nothing -> fillField s sudoku state + +fillField :: forall s -> SudokuState s => Sudoku (Maybe Field) -> s -> [Sudoku Field] +fillField s sudoku state = case SudokuState.nextField state of + Nothing -> [] -- unsolvable + Just position -> do + -- list monad threads the execution + fieldValue <- Set.toList (SudokuState.fieldOptions state position) + + -- update the stuff + let newBoard = Representable.set position (Just fieldValue) sudoku + let newState = SudokuState.setField state position fieldValue + + -- recurse + solveWithState s newBoard newState + diff --git a/src/Sudoku/State.hs b/src/Sudoku/State.hs new file mode 100644 index 0000000..c8a0093 --- /dev/null +++ b/src/Sudoku/State.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +module Sudoku.State (SudokuState(..), State) where + +import Control.Arrow ((>>>)) + +import Data.Bifunctor (Bifunctor(bimap)) +import Data.Enum.Util (enumerate) +import Data.Functor.Rep (imapRep) +import Data.Set (Set) +import Data.Map (Map) +import Data.Maybe (mapMaybe, catMaybes, fromMaybe) + +import qualified Data.Foldable as Foldable +import qualified Data.Functor.Rep as Representable +import qualified Data.Functor.Representable as Representable +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set + +import Sudoku (Sudoku, FieldIndex, entireAreaOf, entireRowOf, entireColumnOf, affectedFieldsOf) +import Sudoku.Field (Field) + +class SudokuState a where + build :: Sudoku (Maybe Field) -> a + isValid :: a -> Bool + nextField :: a -> Maybe FieldIndex + fieldOptions :: a -> FieldIndex -> Set Field + setField :: a -> FieldIndex -> Field -> a + +data State = State + { fieldOptions :: Sudoku (Maybe (Set Field)) + , optionCounts :: Map Int (Set FieldIndex) + } + deriving (Show) + +collectConstraints :: Sudoku (Maybe Field) -> FieldIndex -> Maybe Field -> Maybe (Set Field) +collectConstraints sudoku position = \case + Just _ -> Nothing + Nothing -> Just $ let + collectPosition = Set.fromList . mapMaybe (Representable.index sudoku) + + areaConstraints = collectPosition $ Sudoku.entireAreaOf position + rowConstraints = collectPosition $ Sudoku.entireRowOf position + columnConstraints = collectPosition $ Sudoku.entireColumnOf position + + in Set.unions [areaConstraints, rowConstraints, columnConstraints] + +collectOptions :: Sudoku (Maybe Field) -> FieldIndex -> Maybe Field -> Maybe (Set Field) +collectOptions sudoku position fieldValue = (Set.fromList enumerate `Set.difference`) <$> collectConstraints sudoku position fieldValue + +instance SudokuState State where + build :: Sudoku (Maybe Field) -> State + build sudoku = let + + options = imapRep (collectOptions sudoku) sudoku + counts = imapRep (\ pos -> fmap (, pos)) -- Sudoku (Maybe (FieldIndex, Set Field)) + >>> catMaybes . Foldable.toList -- keep only non-present types + >>> fmap (bimap Set.size Set.singleton) -- set keys and values up + >>> Map.fromListWith Set.union -- combine them all + $ options + + in State options counts + + isValid :: State -> Bool + isValid (State options counts) = let + optionsValid = all (maybe True (not . Set.null)) options + countsValid = Maybe.isNothing (Map.lookup 0 counts) + + in optionsValid && countsValid + + nextField :: State -> Maybe FieldIndex + nextField (State _ counts) = Map.lookupMin counts >>= Set.lookupMin . snd + + fieldOptions :: State -> FieldIndex -> Set Field + fieldOptions (State options _) = fromMaybe Set.empty . Representable.index options + + setField :: State -> FieldIndex -> Field -> State + setField (State options counts) position value = let + + affectedFields = affectedFieldsOf position + + newOptions = Representable.set position Nothing -- remove the field where the value was set + >>> adjustAffectedOptions affectedFields value -- remove a lot of options in affected fields + $ options + + oldOptionsCount = maybe 0 Set.size $ Representable.index options position -- how many options did the field have before it was set? + newCounts = Map.adjust (Set.delete position) oldOptionsCount -- forget the set field + >>> adjustAffectedCounts options newOptions affectedFields + >>> Map.filter (not . Set.null) -- remove empty sets, they would interfere with future operations + $ counts + + in State newOptions newCounts + +adjustAffectedCounts :: Sudoku (Maybe (Set Field)) -> Sudoku (Maybe (Set Field)) -> Set FieldIndex -> Map Int (Set FieldIndex) -> Map Int (Set FieldIndex) +adjustAffectedCounts newOptions oldOptions affectedFields counts = Set.foldl' (adjustCount newOptions oldOptions) counts affectedFields + +adjustCount :: Sudoku (Maybe (Set Field)) -> Sudoku (Maybe (Set Field)) -> Map Int (Set FieldIndex) -> FieldIndex -> Map Int (Set FieldIndex) +adjustCount oldOptions newOptions counts position = let + oldOptionCount = maybe 0 Set.size $ Representable.index oldOptions position + newOptionCount = maybe 0 Set.size $ Representable.index newOptions position + + in Map.adjust (Set.delete position) oldOptionCount + >>> Map.adjust (Set.insert position) newOptionCount + $ counts + +adjustAffectedOptions :: Set FieldIndex -> Field -> Sudoku (Maybe (Set Field)) -> Sudoku (Maybe (Set Field)) +adjustAffectedOptions fields value = imapRep adjustOptionField + where + adjustOptionField i + | i `Set.member` fields = fmap (Set.delete value) + | otherwise = id +-- Set.foldl' (removeOption value) options fields: Folding took a lot of time because of immutability + + diff --git a/src/Sudoku/Triple.hs b/src/Sudoku/Triple.hs new file mode 100644 index 0000000..c26cc80 --- /dev/null +++ b/src/Sudoku/Triple.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +module Sudoku.Triple (Triple(..), Index(..), first, second, third) where +import Data.Distributive (Distributive (distribute, collect)) +import Data.Functor.Rep + ( Representable(Rep, tabulate, index), Co, Co(..) ) + +data Triple a = Triple a a a + deriving stock (Show, Eq, Functor, Foldable, Traversable) + deriving (Applicative, Monad) via Co Triple + +first :: Triple a -> a +first (Triple x _ _) = x +second :: Triple a -> a +second (Triple _ x _) = x +third :: Triple a -> a +third (Triple _ _ x) = x + +instance Distributive Triple where + distribute :: Functor f => f (Triple a) -> Triple (f a) + distribute x = Triple (fmap first x) (fmap second x) (fmap third x) + collect :: Functor f => (a -> Triple b) -> f a -> Triple (f b) + collect f x = distribute $ fmap f x + +data Index = First | Second | Third + deriving (Show, Eq, Ord, Enum, Bounded) + +-- >>> toEnum 0 :: Index +-- First + +instance Representable Triple where + type Rep Triple = Index + + tabulate :: (Rep Triple -> a) -> Triple a + tabulate f = Triple (f First) (f Second) (f Third) + + index :: Triple a -> Rep Triple -> a + index (Triple x1 x2 x3) = \case + First -> x1 + Second -> x2 + Third -> x3 + +-- >>> tabulate (const $ tabulate id) :: Triple (Triple Index) +-- Triple (Triple First Second Third) (Triple First Second Third) (Triple First Second Third) + diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..b2bfe5b --- /dev/null +++ b/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/configure/yaml/ + +# A 'specific' Stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# snapshot: lts-23.24 +# snapshot: nightly-2025-06-15 +# snapshot: ghc-9.8.4 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# snapshot: ./custom-snapshot.yaml +# snapshot: https://example.com/snapshots/2024-01-01.yaml +snapshot: nightly-2025-07-09 +compiler: ghc-9.12.1 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the snapshot. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for project packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of Stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=3.7" +# +# Override the architecture used by Stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by Stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..9295f59 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/topics/lock_files + +packages: [] +snapshots: +- completed: + sha256: 193b933e68724f1cd2b266649318f8c102f6f6d7a52415a8eee8dc604fb5d6b2 + size: 723871 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2025/7/9.yaml + original: nightly-2025-07-09 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/test/example.s3 b/test/example.s3 new file mode 100644 index 0000000..98cbd6b --- /dev/null +++ b/test/example.s3 @@ -0,0 +1,9 @@ +003020600 +900305001 +001806400 +008102900 +700000008 +006708200 +002609500 +800203009 +005010300