public
Last active

Peter Norvig's beautiful Python program (http://norvig.com/sudoku.html) now in Haskell!

  • Download Gist
sudoku.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
-- Peter Norvig's beautiful Python program (http://norvig.com/sudoku.html)
-- that uses constraint propagation (and ultimately searching)
-- to solve Sudoku instances
--
-- Now in everybody's favorite language!
-- Haskell coding by Ashutosh Mehra (http://ashutoshmehra.net/blog/)
 
import List (elem, nub, filter, delete, intersperse, replicate)
import Data.Map (Map, fromList, (!), insert, keys, elems, toList)
import Data.List (intercalate)
import Data.Maybe
 
type Val = Char -- Value of a cell
type Square = String -- two-character square ID
type Board = Maybe (Map Square String) -- The board state
 
cross xs ys = [[x,y] | x <- xs, y <- ys]
rows = "ABCDEFGHI"
cols = "123456789"
digits = "123456789"
squares = cross rows cols
unitlist = [cross rows [c] | c <- cols]
++ [cross [r] cols | r <- rows]
++ [cross rs cs | rs <- ["ABC", "DEF", "GHI"], cs <- ["123","456","789"]]
units sq = filter (elem sq) unitlist
peers sq = delete sq . nub . concat $ units sq
 
-- Check for places where d appears in the units of sq
checkplaces :: Board -> Square -> Val -> Board
checkplaces b0 sq d = foldl f b0 (units sq)
where f b u
| isNothing b || len == 0 = Nothing
| len == 1 = assign b (head dplaces) d
| otherwise = b
where dplaces = [s | s <- u, elem d ((fromJust b)!s)]
-- dplaces is all squares in the unit u possibly containing d
len = length dplaces
 
eliminate :: Board -> Square -> Val -> Board
eliminate Nothing _ _ = Nothing
eliminate (Just b0) sq d
| notElem d v = Just b0 -- Already Eliminated
| length v' == 0 = Nothing -- Contradiction: Removed last value
| length v' == 1 = checkplaces b'' sq d -- Only 1 left: Remove from peers
| otherwise = checkplaces (Just b') sq d
where v = b0 ! sq
v' = delete d v
b' = insert sq v' b0
h = (head v')
b'' = foldl (\b p -> eliminate b p h) (Just b') (peers sq)
 
assign :: Board -> Square -> Val -> Board
assign Nothing _ _ = Nothing
assign b0 sq d0 = foldl f b0 ((fromJust b0) ! sq)
where f b d = if d0 == d then b else eliminate b sq d
 
parsegr :: String -> Board
parsegr s = foldl f b0 (zip squares s')
where s' = filter (\x -> elem x "0.-123456789") s
b0 = Just (fromList [(s, digits) | s <- squares])
f b (sq, d)
| isNothing b = Nothing
| notElem d digits = b
| otherwise = assign b sq d
 
search :: Board -> Board
search Nothing = Nothing
search (Just b) =
if all ((==1) . length) $ elems b then Just b else search' (b!s)
where minl = minimum [l | v <- elems b, let l = length v, l > 1]
s = head [sq | (sq, v) <- toList b, length v == minl]
search' [] = Nothing
search' (d:ds) = if isJust b' then b' else search' ds
where b' = search $ assign (Just b) s d
 
printgr :: Board -> String
printgr Nothing = "Unsolvable"
printgr (Just b) = concat [(fr r) ++ (if elem r "CF" then line else "") ++ "\n" | r<-rows]
where w = 1 + maximum [length (b!sq) | sq <- squares]
line = (++) "\n" $ intercalate "+" $ replicate 3 $ replicate (3 * w) '-'
fr r = concat [(fmt (b![r,c])) ++ (if elem c "36" then "|" else "") | c<-cols]
fmt s = s ++ replicate (w - (length s)) ' '
 
solve :: String -> IO ()
solve s = putStrLn $ printgr $ search $ parsegr s
 
-- Instance from http://programmingpraxis.com/2009/02/19/sudoku/2/
grid = "7..1......2.....15.....639.2...18....4..9..7....75...3.785.....56.....4......1..2"
 
main = solve grid

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.