Code:
module Main where
import List
----------------- GENERIC HELPER FUNCTIONS ---------------------
-- Apply a list of functions to some data, one after the other,
-- from head to tail.
chainl :: [(a -> a)] -> a -> a
chainl [] x = x
chainl (f:fs) x = chainl fs (f x)
-- Repeat a function a number of times on a data item.
rp :: (a -> a) -> a -> Int -> a
rp _ x 0 = x
rp fn x n = rp fn (fn x) (n - 1)
-- Repeat a function a number of times on a data item, passing the counter.
rpn :: (a -> Int -> a) -> a -> Int -> a
rpn _ x 0 = x
rpn fn x n = rpn fn (fn x n) (n - 1)
-- Pad an array to a minimum length with the given item.
rpad :: a -> Int -> [a] -> [a]
rpad p len ls = ls ++ replicate (len - length ls) p
-------------------- TYPE DECLARATIONS -------------------------
-- The type of a row index
type RowIndex = Int
-- The type of a column index
type ColIndex = Int
-- The type of an area identifier
type AreaId = (Int, Int)
-- The type of a value collection
type PossibleValues = [Int]
-- The general value/values type of a field.
type FieldContent = Either Int [Int]
-- A Sudoku board: a collection of 81 fields.
data SudokuBoard =
SudokuBrd [SudokuField]
-- A Sudoku field: a pair of coordinates on the board and either a single
-- known value, or a list of possibilities.
data SudokuField =
SudokuUnsure RowIndex ColIndex PossibleValues |
SudokuSure RowIndex ColIndex Int
-- A group of fields: can be a row, a column or an area. Each group, when
-- applied to a board, yields 9 fields.
data SudokuGroup =
SudokuRow RowIndex |
SudokuCol ColIndex |
SudokuArea AreaId
-- The type of the dataset passed to init.
type InitData = [(RowIndex, ColIndex, Int)]
---------------- BASIC TYPE OPERATIONS ---------------------
----- FIELDS ------
-- Determine the ordering of two fields. Ordering works in reading order,
-- first across and then down.
fieldOrder :: SudokuField -> SudokuField -> Ordering
fieldOrder a b =
if ar < br then LT
else if ar > br then GT
else if ac < bc then LT
else if ac > bc then GT
else EQ
where
ac = col a
ar = row a
bc = col b
br = row b
-- Two fields are equal if their coordinates are the same; values are ignored.
instance Eq SudokuField where
(==) a b = fieldOrder a b == EQ
-- Fields can be ordered.
instance Ord SudokuField where
compare = fieldOrder
-- Fields can be displayed. Format is (row,column) -> values, where values
-- is either a list of possibilities, or the fixed value with a '!'.
instance Show SudokuField where
show (SudokuUnsure r c vals) = "(" ++ show r ++ "," ++ show c ++
") -> " ++ show vals
show (SudokuSure r c val) = "(" ++ show r ++ "," ++ show c ++
") -> " ++ show val ++ "!"
-- Get the row of a field.
row :: SudokuField -> RowIndex
row (SudokuUnsure r _ _) = r
row (SudokuSure r _ _) = r
-- Get the row group of a field.
rowOf :: SudokuField -> SudokuGroup
rowOf = SudokuRow . row
-- Get the column of a field.
col :: SudokuField -> ColIndex
col (SudokuUnsure _ c _) = c
col (SudokuSure _ c _) = c
-- Get the column group of a field.
colOf :: SudokuField -> SudokuGroup
colOf = SudokuCol . col
-- Create an area ID from a pair of field coordinates.
mkarea :: RowIndex -> ColIndex -> AreaId
mkarea r c = (r `div` 3, c `div` 3)
-- Get the area ID of a field.
area :: SudokuField -> AreaId
area (SudokuUnsure r c _) = mkarea r c
area (SudokuSure r c _) = mkarea r c
-- Get the area group of a field.
areaOf :: SudokuField -> SudokuGroup
areaOf = SudokuArea . area
-- Get the value/values of a field.
values :: SudokuField -> FieldContent
values (SudokuSure _ _ v) = Left v
values (SudokuUnsure _ _ vs) = Right vs
-- Create a field from coordinates and a value/values.
mkfield :: RowIndex -> ColIndex -> FieldContent -> SudokuField
mkfield r c (Left i) = SudokuSure r c i
mkfield r c (Right is) = SudokuUnsure r c is
isSure :: SudokuField -> Bool
isSure (SudokuUnsure _ _ _) = False
isSure (SudokuSure _ _ _) = True
-- Tells whether two fields share any group. Each field is related to 20 others.
related :: SudokuField -> SudokuField -> Bool
related f g = isIn g (rowOf f) ||
isIn g (colOf f) ||
isIn g (areaOf f)
------- BOARD -------
-- The board can be displayed. Each field is given a width of 12.
instance Show SudokuBoard where
show (SudokuBrd flds) = "Board:\n" ++ showBrd flds
where showBrd [] = "\n"
showBrd cs = showFlds (take 9 cs) ++ "\n"
++ showBrd (drop 9 cs)
showFlds [] = ""
showFlds ((SudokuSure _ _ v):cs) =
padF (show v) ++ showFlds cs
showFlds ((SudokuUnsure _ _ v):cs) =
padF (show v) ++ showFlds cs
padF = rpad ' ' 12
-- Get the empty board, where everything's possible.
emptyBoard :: SudokuBoard
emptyBoard = SudokuBrd [ SudokuUnsure x y [1..9] | x <- [0..8], y <- [0..8] ]
------ GROUPS -------
-- Get the fields on a board within a group.
fieldsIn :: SudokuBoard -> SudokuGroup -> [SudokuField]
fieldsIn (SudokuBrd flds) g = filter (\x -> isIn x g) flds
-- Get the fields on a board NOT within a group.
fieldsNotIn :: SudokuBoard -> SudokuGroup -> [SudokuField]
fieldsNotIn (SudokuBrd flds) g = filter (\x -> not (isIn x g)) flds
-- Whether a field is in a group.
isIn :: SudokuField -> SudokuGroup -> Bool
isIn f (SudokuRow r) = row f == r
isIn f (SudokuCol c) = col f == c
isIn f (SudokuArea a) = area f == a
-- Get all 27 groups of a board.
allGroups :: [SudokuGroup]
allGroups = allRows ++ allCols ++ allAreas
-- Get all row groups of a aboard.
allRows :: [SudokuGroup]
allRows = [SudokuRow x | x <- [0..8]]
-- Get all column groups of a board.
allCols :: [SudokuGroup]
allCols = [SudokuCol x | x <- [0..8]]
-- Get all area groups of a board.
allAreas :: [SudokuGroup]
allAreas = [SudokuArea (x, y) | x <- [0..2], y <- [0..2]]
---------------- GENERAL BOARD OPERATIONS --------------------
-- Sort a board so that the fields come in reading order.
sortBoard :: SudokuBoard -> SudokuBoard
sortBoard (SudokuBrd flds) = SudokuBrd (sort flds)
-- Create an irregular (could be less than 81 fields) board of only the known
-- fields.
solvedBoard :: SudokuBoard -> SudokuBoard
solvedBoard (SudokuBrd flds) = SudokuBrd (filter isSure flds)
-- Test whether a board has been completely solved, i.e. consists only of
-- certain fields.
isSolved :: SudokuBoard -> Bool
isSolved (SudokuBrd flds) = all isSure flds
--------------------- BOARD SETUP ----------------------------
-- Take a bunch of initialization data and prime a new board with it.
init :: InitData -> SudokuBoard
init = initInner emptyBoard
-- Apply the given initialization data to a board.
initInner :: SudokuBoard -> InitData -> SudokuBoard
initInner brd [] = brd
initInner brd (v:vs) = initInner (fixC brd v) vs
where fixC b (r, c, val) = fix b (r-1) (c-1) val
-- Fix a field to a specific value.
fix :: SudokuBoard -> RowIndex -> ColIndex -> Int -> SudokuBoard
fix (SudokuBrd flds) r c v =
SudokuBrd ((SudokuSure r c v) : (delete (SudokuSure r c 0) flds))
-------------------- BOARD SOLVING ----------------------------
-- Attempt to solve a board. WARNING: Current implementation will go into
-- infinite loop if it can't solve the board.
solve :: InitData -> SudokuBoard
solve = sortBoard . (until isSolved (chainl strategies)) . Main.init
-- List the solution strategies used in a single iteration.
-- strikeKnown is listed several times because it kind of performs cleanup
-- duty.
strategies :: [(SudokuBoard -> SudokuBoard)]
strategies =
[ strikeKnown -- Strike out numbers that belong to fixed values.
, strikePairs -- Strike values x, y where group contains exactly
-- two fields [x, y].
, strikeKnown -- This is more likely to catch something.
, fixLonely -- Find possibilities that occur only in one field
, strikeKnown -- This is more likely to catch something.
]
------------- SOLUTION STRATEGY I: STRIKE KNOWN -----------------
{-
This is the simplest of all strategies. It scans the board for known fields.
Then it strikes their values from the possibilities of all uncertain fields in
the three associated groups.
-}
-- Perform the Strike Known step.
strikeKnown :: SudokuBoard -> SudokuBoard
strikeKnown brd = let (SudokuBrd flds) = brd
in strikeKnownFields brd flds
-- The main controller of Strike Known. Iterates over all fields of a board
-- to strike the known values.
strikeKnownFields :: SudokuBoard -> [SudokuField] -> SudokuBoard
strikeKnownFields brd [] = brd
strikeKnownFields brd ((SudokuSure r c v):flds) =
strikeKnownFields newbrd flds
where newbrd = strikeFromGroup rowcolbrd (SudokuArea (mkarea r c)) v
rowcolbrd = strikeFromGroup rowbrd (SudokuCol c) v
rowbrd = strikeFromGroup brd (SudokuRow r) v
strikeKnownFields brd ((SudokuUnsure _ _ _):flds) =
strikeKnownFields brd flds
{-strikeKnownFields :: [SudokuField] -> [SudokuField]
strikeKnownFields -}
-- The workhorse of Strike Known. Given a board, a group and a value, this
-- function gives a new board where, in the given group, all unsure fields
-- have the value stricken from their possibilities.
strikeFromGroup :: SudokuBoard -> SudokuGroup -> Int -> SudokuBoard
strikeFromGroup brd grp val =
SudokuBrd (strikeFromFields (fieldsIn brd grp) val ++
fieldsNotIn brd grp)
strikeFromFields :: [SudokuField] -> Int -> [SudokuField]
strikeFromFields flds val = map (\f -> strikeFromField f val) flds
strikeFromField :: SudokuField -> Int -> SudokuField
strikeFromField (SudokuUnsure r c (a : b : [])) v
| a == v = SudokuSure r c b
| b == v = SudokuSure r c a
| otherwise = SudokuUnsure r c [a, b]
strikeFromField (SudokuUnsure r c vals) v = SudokuUnsure r c (delete v vals)
strikeFromField (SudokuSure r c v) _ = SudokuSure r c v
strikePairs :: SudokuBoard -> SudokuBoard
strikePairs brd = strikePairsInGroups brd allGroups
strikePairsInGroups :: SudokuBoard -> [SudokuGroup] -> SudokuBoard
strikePairsInGroups = foldl strikePairsInGroup
strikePairsInGroup :: SudokuBoard -> SudokuGroup -> SudokuBoard
strikePairsInGroup brd g = SudokuBrd (fieldsNotIn brd g ++
strikePairsInFieldList (fieldsIn brd g))
strikePairsInFieldList :: [SudokuField] -> [SudokuField]
strikePairsInFieldList flds = foldl strikePair flds pairs
where pairs = findPairs flds
findPairs :: [SudokuField] -> [(SudokuField, SudokuField)]
findPairs [] = []
findPairs (f:fs) = pairl ++ findPairs fs
where pair = findMatchFor f fs
pairl = maybe [] (\e -> [e]) pair
findMatchFor :: SudokuField -> [SudokuField] -> Maybe (SudokuField, SudokuField)
findMatchFor (SudokuSure _ _ _) _ = Nothing
findMatchFor f [] = Nothing
findMatchFor f ((SudokuUnsure x y [v1,v2]):fs) =
let (SudokuUnsure _ _ vals) = f
in if [v1,v2] == vals then Just (f, (SudokuUnsure x y [v1,v2]))
else findMatchFor f fs
findMatchFor f (_:fs) = findMatchFor f fs
strikePair :: [SudokuField] -> (SudokuField, SudokuField) -> [SudokuField]
strikePair [] _ = []
strikePair (g:gs) (f1, f2) = f : strikePair gs (f1, f2)
where f = if g == f1 || g == f2
then g
else strikeValuesOf f1 g
strikeValuesOf :: SudokuField -> SudokuField -> SudokuField
strikeValuesOf (SudokuUnsure _ _ svals) f = foldl strikeFromField f svals
fixLonely :: SudokuBoard -> SudokuBoard
fixLonely brd = fixLonelyInGroups brd allGroups
fixLonelyInGroups :: SudokuBoard -> [SudokuGroup] -> SudokuBoard
fixLonelyInGroups = foldl fixLonelyInGroup
fixLonelyInGroup :: SudokuBoard -> SudokuGroup -> SudokuBoard
fixLonelyInGroup brd g = SudokuBrd (fieldsNotIn brd g ++
fixLonelyInFieldList (fieldsIn brd g))
fixLonelyInFieldList :: [SudokuField] -> [SudokuField]
fixLonelyInFieldList fs = fixLonelyInFieldListInner fs fs
fixLonelyInFieldListInner :: [SudokuField] -> [SudokuField] -> [SudokuField]
fixLonelyInFieldListInner [] _ = []
fixLonelyInFieldListInner ((SudokuSure x y v):fs) ts =
(SudokuSure x y v) : fixLonelyInFieldListInner fs ts
fixLonelyInFieldListInner ((SudokuUnsure x y vs):fs) ts =
maybe (SudokuUnsure x y vs) (SudokuSure x y) fv :
fixLonelyInFieldListInner fs ts
where fv = findLonely vs mts mts
mts = (delete (SudokuUnsure x y vs) ts)
findLonely :: [Int] -> [SudokuField] -> [SudokuField] -> Maybe Int
findLonely [] _ _ = Nothing
findLonely (c:cs) [] mts = Just c
findLonely (c:cs) ((SudokuSure _ _ v):ts) mts =
if c == v then findLonely cs mts mts
else findLonely (c:cs) ts mts
findLonely (c:cs) ((SudokuUnsure _ _ vs):ts) mts =
if elem c vs then findLonely cs mts mts
else findLonely (c:cs) ts mts
nr119a :: InitData
nr119a = [
(1,6,8),
(2,5,5),
(2,6,4),
(2,8,2),
(2,9,8),
(3,3,3),
(3,5,1),
(3,8,5),
(3,9,7),
(4,5,3),
(4,7,9),
(5,2,9),
(5,3,7),
(5,4,1),
(5,8,8),
(6,1,3),
(6,2,8),
(6,6,9),
(6,8,4),
(7,4,5),
(7,9,9),
(8,2,5),
(8,3,4),
(8,5,7),
(8,6,3),
(8,9,1),
(9,2,7),
(9,3,8),
(9,7,5),
(9,8,3)
]
nr119b :: InitData
nr119b = [
(1,6,9),
(1,9,8),
(2,3,4),
(2,4,8),
(2,6,1),
(2,7,7),
(3,1,2),
(3,3,1),
(3,8,5),
(4,3,7),
(4,5,4),
(4,6,8),
(4,7,6),
(5,7,1),
(6,2,6),
(6,3,3),
(6,5,7),
(6,9,9),
(7,1,7),
(7,4,2),
(7,5,3),
(7,8,9),
(8,2,2),
(8,7,5),
(9,2,1),
(9,3,9),
(9,6,6),
(9,8,7)
]
nr119c :: InitData
nr119c = [
(1,6,5),
(1,8,9),
(1,9,2),
(2,1,5),
(2,2,4),
(2,5,6),
(2,6,9),
(2,7,8),
(3,3,2),
(3,5,7),
(3,9,4),
(4,2,8),
(4,6,4),
(4,7,2),
(5,4,3),
(5,6,2),
(6,3,4),
(6,4,7),
(6,8,8),
(7,1,4),
(7,5,2),
(7,7,1),
(8,3,3),
(8,4,9),
(8,5,1),
(8,8,6),
(8,9,8),
(9,1,1),
(9,2,6),
(9,4,5)
]
mad :: InitData
mad = [
(1,1,4),
(1,8,2),
(2,3,6),
(2,4,7),
(2,7,9),
(3,2,8),
(3,6,3),
(4,3,1),
(4,5,5),
(4,9,6),
(5,2,3),
(5,8,4),
(6,1,2),
(6,4,9),
(6,7,7),
(7,4,8),
(7,8,1),
(8,3,5),
(8,6,6),
(8,7,2),
(9,2,7),
(9,9,3)
]