-- 宿题を、忘れた廊下に、最 上川。
module Exercise03 where

import Data.List (intercalate, minimumBy, nub)
import Data.Ord (comparing)
import Text.Printf (printf)

-- HA 3.1a) i
selectRow :: [[a]] -> Int -> [a]
selectRow xss i = xss !! i

-- HA 3.1a) ii
selectColumn :: [[a]] -> Int -> [a]
selectColumn xss i = [xs !! i | xs <- xss]

-- HA 3.1a) iii
intRoot :: Int -> Int
intRoot = floor . sqrt . fromIntegral

--return numbers in square as a list. squares are numbered  from left to right and top to bottom
--e.g. :
--[0,1,2]
--[3,4,5]
--[6,7,8]
selectSquare :: [[a]] -> Int -> [a]
selectSquare xss i = [xs !! i | xs <- rows, i <- colIndex]
  where
    rows = [selectRow xss i | i <- rowIndex]
    rowIndex = map (+ row * root) [0 .. root -1]
    colIndex = map (+ col * root) [0 .. root -1]
    row = i `div` root
    col = i `mod` root
    root = intRoot $ length xss

-- HA 3.1b)
isValidSubsection :: [Int] -> Bool
isValidSubsection section = length noNulls == length (nub noNulls)
  where
    noNulls = filter (/= 0) section

isValidSudoku :: [[Int]] -> Bool
isValidSudoku xss = and [isValidSubsection $ func xss i | func <- funcs, i <- roots]
  where
    funcs = [selectRow, selectColumn, selectSquare]
    roots = [0 .. n -1]
    n = length xss

-- HA 3.1c)
setCell :: [[a]] -> (Int, Int) -> a -> [[a]]
setCell xss (x, y) n = [if x == xi then [if y == yi then n else xss !! xi !! yi | yi <- roots] else xss !! xi | xi <- roots]
  where
    roots = [0 .. length xss -1]

-- HA 3.1d)

{-WETT-}
getSquareI :: Int -> (Int, Int) -> Int
getSquareI root (x, y) = x `div` root * root + y `div` root

canFill :: [Int] -> [Int] -> [Int]
canFill ns canNotFill = filter (`notElem` canNotFill) ns

fillPossibilities :: [[Int]] -> [[[Int]]]
fillPossibilities xss = if again == xss then result else fillPossibilities again
  where
    n = length xss
    ns = [1 .. n]
    is = [0 .. n - 1]
    getSquareIndex = getSquareI root
    root = intRoot n
    rows = map (selectRow xss) is
    cols = map (selectColumn xss) is
    squares = map (selectSquare xss) is
    canNotFill (x, y) = (rows !! x) ++ (cols !! y) ++ (squares !! getSquareIndex (x, y))
    canFillHere (x, y) = canFill ns (canNotFill (x, y))
    result = [[if v == 0 then canFillHere (x, y) else [v] | y <- is, v <- [xss !! x !! y]] | x <- is]
    again = back result

-- improvePossibiilities :: [[[Int]]] -> [[[Int]]]
-- improvePossibiilities xsss = undefined
--   where
--     n = length xsss
--     ns = [1 .. n]
--     is = [0 .. n - 1]
--     getSquareIndex = getSquareI root
--     root = intRoot n
--     rows = map (selectRow xsss) is
--     cols = map (selectColumn xsss) is
--     squares = map (selectSquare xsss) is
--     canNotFill (x, y) = concat [p | p <- (rows !! x) ++ (cols !! y) ++ (squares !! getSquareIndex (x, y)), length p /= 1]

findNext :: [[[Int]]] -> (Int, Int, [Int])
findNext xsss = snd $ minimumBy (comparing fst) wait
  where
    wait = (9999999999, (-1, -1, [])) : [(v, (x, y, p)) | x <- [0 .. length xsss -1], y <- [0 .. length xsss -1], p <- [xsss !! x !! y], v <- [length p], v /= 1]

xis :: Int -> [Int]
xis i = [0 .. i]

xyi :: Int -> [(Int, Int)]
xyi i = [(x, y) | x <- xis i, y <- xis i]

testFill :: [[[Int]]] -> [[[Int]]]
testFill xsss = if valid then nsss else []
  where
    i = length xsss -1
    xss = back xsss
    nsss = fillPossibilities xss
    valid = isValidSudoku xss && and [not (null (nsss !! xi !! yi)) | (xi, yi) <- xyi i]

solve :: [[[Int]]] -> [[[Int]]]
solve xsss
  | noOptions = if isValidSudoku $ back xsss then xsss else []
  | badStep = solve otherStep
  | null resultNextStep = solve otherStep
  | otherwise = resultNextStep
  where
    (x, y, possible) = findNext xsss
    noOptions = x == -1
    firstPossible = head possible
    restPossible = tail possible
    nextStep = testFill $ setCell xsss (x, y) [firstPossible]
    resultNextStep = solve nextStep
    badStep = null nextStep
    otherStep = setCell xsss (x, y) restPossible

back :: [[[Int]]] -> [[Int]]
back xsss = [[if length v == 1 then head v else 0 | y <- xis i, v <- [xsss !! x !! y]] | x <- xis i]
  where
    i = length xsss - 1

solveSudoku :: [[Int]] -> [[Int]]
solveSudoku xss = if invalidPossibiilities then [] else final
  where
    possibilities = fillPossibilities xss
    invalidPossibiilities = null $ testFill possibilities
    result = solve possibilities
    final = back result

{-TTEW-}

simpleSudoku :: [[Int]]
simpleSudoku =
  [ [3, 0, 4, 2],
    [3, 0, 0, 0],
    [0, 0, 0, 0],
    [2, 0, 0, 3]
  ]

hardSudoku :: [[Int]]
hardSudoku =
  [ [8, 0, 0, 0, 0, 0, 0, 0, 0],
    [0, 0, 3, 6, 0, 0, 0, 0, 0],
    [0, 7, 0, 0, 9, 0, 2, 0, 0],
    [0, 5, 0, 0, 0, 7, 0, 0, 0],
    [0, 0, 0, 0, 4, 5, 7, 0, 0],
    [0, 0, 0, 1, 0, 0, 0, 3, 0],
    [0, 0, 1, 0, 0, 0, 0, 6, 8],
    [0, 0, 8, 5, 0, 0, 0, 1, 0],
    [0, 9, 0, 0, 0, 0, 4, 0, 0]
  ]

-- Utility method to show a sudoku
-- show sudoku with
-- >>> putStr (showSudoku sudoku)
showSudoku :: [[Int]] -> String
showSudoku xss = unlines $ intercalate [showDivider] $ chunksOf squareSize $ map showRow xss
  where
    size = length xss
    squareSize = intRoot size
    numberSize = size `div` 10 + 1

    showRowSection xs = unwords $ map (printf ("%0" ++ show numberSize ++ "d")) xs
    showRow xs = intercalate "|" $ map showRowSection $ chunksOf squareSize xs
    showDivider = intercalate "+" $ replicate squareSize $ replicate ((numberSize + 1) * squareSize - 1) '-'

    chunksOf :: Int -> [e] -> [[e]]
    chunksOf i [] = []
    chunksOf i ls = take i ls : chunksOf i (drop i ls)