Sudoku Solver

import Data.Time.Clock
import Data.List
import Data.Function (on)
import Data.Char
import Control.Monad

data Number = Known Int | Uncertain [Int] deriving (Show, Eq)
instance Ord Number where
  (Known _) <= (Uncertain _) = True
  (Uncertain _) <= (Known _) = False
  a <= b = (allPossible a) <= (allPossible b)
e = Uncertain [1..9] -- empty cell can be anything
k n = Known n
type Sudoku = [[Number]]
type Coords = (Int, Int)
isUncertain (Uncertain _) = True
isUncertain _ = False
isKnown (Uncertain _) = False
isKnown _ = True

canBe :: Int -> Number -> Bool
canBe i (Known n) = n == i
canBe i (Uncertain ns) = i `elem` ns

allPossible :: Number -> [Int]
allPossible (Known n) = [n]
allPossible (Uncertain l) = l

inSameSquare (a, b) (x, y) = (a `div` 3, b `div` 3) == (x `div` 3, y `div` 3)
inSameColumn (a, b) (x, y) = a == x
inSameRow (a, b) (x, y) = b == y
inSameX (a, b) (x, y)
  | a == b && x == y  =True
  | a + b == 8 && x + y == 8  =True
  | otherwise =False

neighbours :: (Coords -> Coords -> Bool) -> Sudoku -> Coords -> [Number]
neighbours criteria sudoku (a, b) = [sudoku !!y!!x | x <- [0..8], y <- [0..8], (a, b) /= (x, y), criteria (a, b) (x, y)]

allCriteria = [inSameSquare, inSameColumn, inSameRow, inSameX]
allNeighbours (a, b) (x, y) = any (\f -> f (a,b) (x,y)) allCriteria

isSolved sudoku = all (==False) $ map (\y -> any isUncertain y) sudoku
invert numbers = foldl (\acc z -> delete z acc) [1..9] numbers

solve :: Sudoku -> Sudoku
solve oldSudoku
  | isSolved oldSudoku = oldSudoku
  | oldSudoku == newSudoku = oldSudoku
  | otherwise = solve newSudoku
  where newSudoku = [[newValue oldSudoku (x, y) | x <- [0..8]] | y <- [0..8]]
        newValue sudoku (x, y)
          | isKnown $ sudoku !!y!!x = sudoku !!y!!x
          | length allPossibleValues == 1 = k $ head allPossibleValues
          | otherwise = Uncertain allPossibleValues
          where allPossibleValues = invert (
                    concat [n | c <- allCriteria, v <- subsequences (neighbours c sudoku (x, y)), let n = nub $ concat $ map allPossible v, length v == length n]
                  )


allKnowns :: [Number] -> [Int]
allKnowns numbers = nub $ map numberToInt $ filter isKnown numbers

-- main = interact $ show . solve . map(\y -> map(\x -> toNumber x) y) . lines
main = do
  sudokuString <- getContents
  let solvedSudoku = solve $ map(\y -> map(\x -> toNumber x) y) $ lines sudokuString
  printSudoku solvedSudoku
  return $ show solvedSudoku

toNumber :: Char -> Number
toNumber c
  | isDigit c = k (read (c:[]))
  | otherwise = e

numberToInt (Known n) = n
printSudoku = putStr . showSudoku
showSudoku :: Sudoku -> String
showSudoku sudoku = unlines $ map(\y -> map(\x -> toChar x) y) sudoku
toChar (Known n) = head $ show n
toChar (Uncertain []) = '?'
toChar (Uncertain _) = '.'


sudoku1 = [[(k 7), (k 8), e, e, e, e, e, e, e],
           [e, (k 9), e, (k 6), (k 7), (k 1), e, (k 3), (k 8)],
           [e, e, (k 4), e, (k 8), e, e, e, e],
           [(k 1), (k 5), e, (k 2), e, e, (k 3), e, (k 9)],
           [(k 4), (k 3), e, (k 8), e, (k 5), e, (k 6), (k 7)],
           [(k 9), e, (k 8), e, e, (k 7), e, (k 2), (k 4)],
           [e, e, e, e, (k 3), e, (k 2), e, e],
           [(k 8), (k 4), e, (k 5), (k 2), (k 6), e, (k 9), e],
           [e, e, e, e, e, e, e, (k 5), (k 1)]]

sudoku2 = [[e, (k 2), (k 6), e, e, e, e, e, (k 9)],
           [e, e, (k 4), e, (k 3), (k 9), e, e, e],
           [(k 8), e, e, (k 4), e, e, e, e, (k 1)],
           [e, (k 8), e, (k 3), (k 2), e, e, (k 7), e],
           [e, e, e, e, e, e, e, e, e],
           [e, (k 9), e, e, (k 5), (k 7), e, (k 4), e],
           [(k 4), e, e, e, e, (k 1), e, e, (k 7)],
           [e, e, e, (k 7), (k 4), e, (k 5), e, e],
           [(k 1), e, e, e, e, e, (k 8), (k 2), e]]

-- sudoku3 is really really hard
sudoku3 = [[(k 3), e, e, e, e, e, e, (k 2), e],
           [e, (k 5), e, e, (k 9), e, (k 6), e, (k 1)],
           [(k 1), e, e, e, e, e, (k 4), e, (k 3)],
           [e, e, (k 2), e, e, (k 1), e, (k 9), e],
           [e, (k 8), e, e, (k 5), e, e, (k 4), e],
           [e, (k 9), e, (k 2), e, e, (k 5), e, e],
           [(k 6), e, (k 7), e, e, e, e, e, (k 8)],
           [(k 8), e, (k 4), e, (k 2), e, e, (k 6), e],
           [e, (k 3), e, e, e, e, e, e, (k 4)]]

sudokuX = [[e, e, e, (k 3), e, e, (k 6), e, e],
           [e, (k 4), e, e, e, e, e, e, e],
           [e, (k 5), e, (k 1), e, e, (k 2), e, e],
           [e, e, e, (k 5), e, (k 7), e, e, e],
           [e, e, (k 3), e, (k 9), e, (k 1), e, e],
           [e, e, e, e, e, e, e, (k 8), e],
           [(k 4), (k 9), e, e, e, e, (k 8), (k 7), e],
           [(k 7), e, e, e, (k 1), e, e, e, e],
           [(k 6), (k 2), (k 8), e, e, e, (k 9), e, e]]