feat: implemented the program

.gitignore

@@ -0,0 +1,2 @@
+.stack-work/
+*~

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

README.md

@@ -0,0 +1 @@
+# solvedoku

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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 "<stdin>" 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
+

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 <https://github.com/githubuser/solvedoku#readme>
+
+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

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 <https://github.com/githubuser/solvedoku#readme>
+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

src/Data/Enum/Util.hs

@@ -0,0 +1,4 @@
+module Data.Enum.Util (enumerate) where
+
+enumerate :: (Bounded a, Enum a) => [a]
+enumerate = [minBound..maxBound]

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
+

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

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]
+      ]
+
+

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]
+

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)
+

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

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 ' '
+

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
+

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
+
+

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)
+

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

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

test/Spec.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"

test/example.s3

@@ -0,0 +1,9 @@
+003020600
+900305001
+001806400
+008102900
+700000008
+006708200
+002609500
+800203009
+005010300