module Sudoku where

type Pos = (Int, Int)
type Cell = (Pos, Int)
type Sudoku = [Cell]
type Block = Int

sudoku :: Sudoku
sudoku = [((0,0),3),((0,1),6),((0,4),7),((0,5),1),((0,6),2),
          ((1,1),5),((1,6),1),((1,7),8),
          ((2,2),9),((2,3),2),((2,5),4),((2,6),7),
          ((3,4),1),((3,5),3),((3,7),2),((3,8),8),
          ((4,0),4),((4,3),5),((4,5),2),((4,8),9),
          ((5,0),2),((5,1),7),((5,3),4),((5,4),6),
          ((6,2),5),((6,3),3),((6,5),8),((6,6),9),
          ((7,1),8),((7,2),3),((7,7),6),
          ((8,2),7),((8,3),6),((8,4),9),((8,7),4),((8,8),3)]
sudoku2 :: Sudoku
sudoku2 = [((0,0),5),((0,1),3),((0,4),7),
           ((1,0),6),((1,3),1),((1,4),9),((1,5),5),
           ((2,1),9),((2,2),8),((2,7),6),
           ((3,0),8),((3,4),6),((3,8),3),
           ((4,0),4),((4,3),8),((4,5),3),((4,8),1),
           ((5,0),7),((5,4),2),((5,8),6),
           ((6,1),6),((6,6),2),((6,7),8),
           ((7,3),4),((7,4),1),((7,5),9),((7,8),5),
           ((8,4),8),((8,7),7),((8,8),9)]


numsInRow :: Sudoku -> Int -> [Int]
numsInRow [] y = []
numsInRow (((a,b),c):xs) y
    | a /= y = numsInRow xs y
    | a == y = [c] ++ numsInRow xs y

numsInCol :: Sudoku -> Int -> [Int]
numsInCol [] y = []
numsInCol (((a,b),c):xs) y
    | b /= y = numsInCol xs y
    | b == y = [c] ++ numsInCol xs y

posToBlock :: Pos -> Block
posToBlock (x,y) = x - (x `mod` 3) + y `div` 3

blockToPositions :: Block -> [Pos]
blockToPositions 0 = [(0, 0), (0, 1), (0, 2), (1, 0), (1, 1), (1, 2), (2, 0), (2, 1), (2, 2)]
blockToPositions 1 = [(0, 3), (0, 4), (0, 5), (1, 3), (1, 4), (1, 5), (2, 3), (2, 4), (2, 5)]
blockToPositions 2 = [(0, 6), (0, 7), (0, 8), (1, 6), (1, 7), (1, 8), (2, 6), (2, 7), (2, 8)]
blockToPositions 3 = [(3, 0), (3, 1), (3, 2), (4, 0), (4, 1), (4, 2), (5, 0), (5, 1), (5, 2)]
blockToPositions 4 = [(3, 3), (3, 4), (3, 5), (4, 3), (4, 4), (4, 5), (5, 3), (5, 4), (5, 5)]
blockToPositions 5 = [(3, 6), (3, 7), (3, 8), (4, 6), (4, 7), (4, 8), (5, 6), (5, 7), (5, 8)]
blockToPositions 6 = [(6, 0), (6, 1), (6, 2), (7, 0), (7, 1), (7, 2), (8, 0), (8, 1), (8, 2)]
blockToPositions 7 = [(6, 3), (6, 4), (6, 5), (7, 3), (7, 4), (7, 5), (8, 3), (8, 4), (8, 5)]
blockToPositions 8 = [(6, 6), (6, 7), (6, 8), (7, 6), (7, 7), (7, 8), (8, 6), (8, 7), (8, 8)]
blockToPositions x = error "bad block number x"

numsInBlock :: Sudoku -> Block -> [Int]
numsInBlock [] y = []
numsInBlock (((a,b),c):xs) y
    | or [ (a,b) == x | x <- blockToPositions y] = [c] ++ numsInBlock xs y
    | otherwise = numsInBlock xs y

allUnique :: Eq a => [a] -> Bool
allUnique [] = True
allUnique (x:xs) = x `notElem` xs && allUnique xs

isSudokuPuzzle :: Sudoku -> Bool
isSudokuPuzzle [] = True
isSudokuPuzzle (((a,b),c):xs) = a >= 0 && a <= 8 && b >= 0 && b <= 8 && c >= 1 && c <= 9 && (and [allUnique (numsInRow (((a,b),c):xs) x) | x <- [0..8]])
 && (and [allUnique (numsInCol (((a,b),c):xs) x) | x <- [0..8]]) && (and [allUnique (numsInBlock (((a,b),c):xs) x) | x <- [0..8]])
 && isSudokuPuzzle xs

isFilled :: Sudoku -> Bool
isFilled (((a,b),c):xs)
    | length (((a,b),c):xs) == 81 && allUnique [a | (a,b) <- (((a,b),c):xs)] = True
    | otherwise = False

isSolved :: Sudoku -> Bool
isSolved sudo = isFilled sudo && isSudokuPuzzle sudo

isBlank :: Sudoku -> Pos -> Bool
isBlank [] x = True
isBlank (((a,b),c):xs) x = (a,b) /= x && isBlank xs x

blankPositions :: Sudoku -> [Pos]
blankPositions [] = []
blankPositions sudo = [(x,y) | x <- [0..8], y <- [0..8], isBlank sudo (x,y)]

possibleNumsOnPos :: Sudoku -> Pos -> [Int]
possibleNumsOnPos sudo (x,y) = [ a | a <- [1..9], isBlank sudo (x,y)
 && a `notElem` numsInBlock sudo (posToBlock (x,y)) && a `notElem` numsInCol sudo y && a `notElem` numsInRow sudo x]

possibleNumsForBlankPos :: Sudoku -> [(Pos, [Int])]
possibleNumsForBlankPos sudo = [(x, possibleNumsOnPos sudo x) | x <- blankPositions sudo]

hasSolution :: [(Pos, [Int])] -> Bool
hasSolution [((a,b), x)] = x /= [] && length [((a,b), x)] < 81
hasSolution [] = False
hasSolution (((a,b), x): xs) = x /= [] && length (((a,b), x): xs) < 81 && hasSolution xs

uniqueNumForBlankPos :: [(Pos, [Int])] -> [(Pos, Int)]
uniqueNumForBlankPos [] = []
uniqueNumForBlankPos (((a,b), x ):ys)
    | length x == 1 = [((a,b),x !! 0)] ++ uniqueNumForBlankPos ys
    | length x /= 1 = uniqueNumForBlankPos ys

insertElem :: Sudoku -> Pos -> Int -> Sudoku
insertElem sudo (a,b) x
    | isBlank sudo (a,b) = ((a,b),x):sudo
    | otherwise = error "position (a,b) is not blank"

step :: Sudoku -> [Sudoku]
step sudo
    | isSolved sudo = [sudo]
    | hasSolution (possibleNumsForBlankPos sudo) && (uniqueNumForBlankPos (possibleNumsForBlankPos sudo)) /= [] = take 1 [insertElem sudo (a,b) c |
    a <- [0..8], b <- [0..8], c <- possibleNumsOnPos sudo (a,b) ,(length (possibleNumsOnPos sudo (a,b)) == 1), isBlank sudo (a,b)]
    | otherwise = take (length (possibleNumsOnPos sudo ((blankPositions sudo) !! 0)))
    [insertElem sudo (a,b) c | a <- [0..8], b <- [0..8], c <- possibleNumsOnPos sudo (a,b), isBlank sudo (a,b)]


solve :: Sudoku -> [Sudoku]
solve sudo
    | ((isSudokuPuzzle sudo) == False) = error "improper sudoku"
    | (isSolved sudo) = sudo:[]
    | (length (step sudo)) > 1 && (hasSolution (possibleNumsForBlankPos sudo))  = [((solve ((step sudo) !! a)) !! 0) |
    a <- [0..((length (step sudo)) - 1)],(solve ((step sudo) !! a)) /= [], isSudokuPuzzle sudo, hasSolution (possibleNumsForBlankPos sudo)]
    | (hasSolution (possibleNumsForBlankPos sudo)) = solve ((step sudo) !! 0)
    | otherwise = []