module Exercise03 where

import Text.Printf (printf)
import Data.List
import Data.Maybe
import Data.Function
import Control.Applicative ((<|>))

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

-- HA 3.1a) ii
selectColumn :: [[Int]] -> Int -> [Int]
selectColumn xss i = [ x !! i |x<-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]

getkoordinates :: [[Int]] -> Int -> ((Int, Int), (Int,Int))
getkoordinates sudoku nr = let kästchen = intRoot (length sudoku) in 
    let rowmin = (div nr kästchen) * kästchen in
      let  collummin = (mod nr kästchen) * kästchen in
        ((rowmin, (rowmin+kästchen-1)), (collummin, (collummin + kästchen-1)))

selectSquare :: [[Int]] -> Int -> [Int]
selectSquare xss i =  let ((y,y2),(x,x2))= getkoordinates xss i in
  [xss !! y' !! x' | y'<-[y..y2], x'<-[x..x2]]

-- HA 3.1b)
isValidSubsection :: [Int] -> Bool
isValidSubsection section = let ohneNull = [s | s<-section, s /=0] in
  (length ohneNull) == (length(nub ohneNull)) 

isValidSudoku :: [[Int]] -> Bool
isValidSudoku xss = and[isValidSubsection (selectRow xss x) |x<-[0..(length xss - 1)]] &&
  and[isValidSubsection (selectColumn xss x) |x<-[0..(length xss - 1)]] &&
  and[isValidSubsection (selectSquare xss x) |x<-[0..(length xss - 1)]] 

-- HA 3.1c)
setCell :: [[Int]] -> (Int,Int) -> Int -> [[Int]]
setCell xss (k, j) n = [if k /= x then selectRow xss x else [if p /= j then selectRow xss x !! p else n|p<-[0..length xss -1]] |x<-[0..length xss-1]]

-- HA 3.1d)
fillOne:: [[Int]] -> (Int, Int) -> [[Int]]
fillOne sudoku (x,y) = fillOneHelp sudoku (x,y) 1

fillOneHelp :: [[Int]] -> (Int,Int) ->Int ->  [[Int]]
fillOneHelp sudoku (x,y) val
  | y >= length sudoku = sudoku
  | sudoku !! x !! y /= 0 = fillOneHelp sudoku (getNextFree sudoku (x,y)) 1
  | val > length sudoku = []
  | otherwise = let a = setCell sudoku (x,y) val in 
    if isValidSudoku a 
      then 
        let versuch = fillOneHelp a (getNextFree sudoku (x,y)) 1 in
          if(versuch == [])
            then fillOneHelp sudoku (x,y) (val +1)
            else  versuch
      else fillOneHelp sudoku (x,y) (val+1)

getNextFree :: [[Int]] -> (Int,Int) -> (Int,Int)
getNextFree sudoku (x,y)
 | x == length sudoku -1 = (0,y+1)
 |otherwise = (x+1, y)




{-WETT-}
-- This algo is by far not the best (1 Day of work), but at least much better than the brutforce implementation (H3.1d)


-- If you want to use the Homework solution instead of the WETT, comment the other version out
solveSudoku :: [[Int]] -> [[Int]]
--solveSudoku xss = fillOne xss (0,0)
solveSudoku xss = parseBack(solveGrid(parseGrid xss))


-- Used Data to repesent the Sudokuu more effizent (still not best day)
data Cell = Fixed Int  | Possible [Int] deriving (Show, Eq)
type Row = [Cell]
type Grid = [Row]

--Parse the given input into the new Data
parseGrid :: [[Int]] -> Grid
parseGrid x = [(parseRow(selectRow x i)) | i<-[0..length x-1]]

parseRow :: [Int] -> Row
parseRow x = [if h == 0 then Possible [1..length x] else Fixed h |h <-x]



parseBack :: Maybe Grid -> [[Int]]
parseBack xs = case xs of
  Nothing -> []
  Just val -> [parseBackRow x | x<- val]
  where
    parseBackRow xs = [x |Fixed x<-xs]



--remove digits where we know that they dont fit
-- traverse better than foldl because the cells dont relay on each other
removeUseless :: [Cell] -> Maybe [Cell]
removeUseless cells = traverse removeHelp cells
  where
    known = [x | Fixed x <- cells]
    removeHelp (Possible xs) = case xs Data.List.\\ known of
      []  -> Nothing
      [x] -> Just $ Fixed x
      xs  -> Just $ Possible xs
    removeHelp x = Just x


-- remove Collum Row and squares
removeAllHelp :: Grid -> Maybe Grid
removeAllHelp x = traverse removeUseless x
  >>= fmap transpose . traverse removeUseless . transpose
  >>= fmap squareToRow . traverse removeUseless . squareToRow


-- keep removing as long as we still remove stuff (check if removed Sudoku is same as before)
removeAll :: Grid -> Maybe Grid
removeAll = fixM removeAllHelp
  where
    fixM f x = f x >>= \x' -> if x' == x then return x else fixM f x'

--transform in a way that earlier squares are now Rows

squareToRow :: Grid -> Grid
squareToRow xs = [(squareToRowHelper xs i)|i <- [0.. length xs -1]]

squareToRowHelper :: Grid -> Int -> Row
squareToRowHelper xs i =
  let ((y,y2),(x,x2))= getkoordinatesGrid xs i in
  [xs !! y' !! x' | y'<-[y..y2], x'<-[x..x2]]

getkoordinatesGrid :: Grid -> Int -> ((Int, Int), (Int,Int))
getkoordinatesGrid grid nr = let kästchen = intRoot (length grid) in 
    let rowmin = (div nr kästchen) * kästchen in
      let  collummin = (mod nr kästchen) * kästchen in
        ((rowmin, (rowmin+kästchen-1)), (collummin, (collummin + kästchen-1)))

--Choosing next (optimal would be the one with the lowest ammount of remaining possibilities)
searchNextGrid :: Grid -> (Grid,Grid)
searchNextGrid grid = 
  let (i, first@(Fixed _), other) = fixCell . minimumBy (compare `Data.Function.on` (ammountPossible . snd))  . filter (isPossible . snd) . zip [0..] . concat $ grid in 
    (replace i first (length grid) grid, replace i other (length grid) grid)
      where
        isPossible (Possible _) = True
        isPossible (Fixed _) = False
        ammountPossible (Fixed _) = 1
        ammountPossible (Possible x) = length x
        -- when only 2 possibilities left, add each one into one of the fields, 
        --otherwise only set one and the other one is staying unsolved for now
        fixCell(i,Possible [x,y]) = (i, Fixed x, Fixed y)
        fixCell(i,Possible (x:xs)) = (i, Fixed x, Possible xs)



-- replace an "objects" in an "2D Array ", this part is not optimal
replace :: Int -> a ->Int-> [[a]]-> [[a]]
replace i v size =
  let (x, y) = (i `quot` size, i `mod` size) in replaceHelp x (replaceHelp y (const v))
    where
      replaceHelp p f xs = [if i == p then f x else x | (x, i) <- zip xs [0..]]


--Check if is solved / All Cells are Fixed
isSolved :: Grid -> Bool
isSolved x = null [()| Possible _ <- concat x]


--Check if invalid (same digit in a row / a field with no options left) -> NOT optimal to check all 3 
isInvalid:: Grid -> Bool
isInvalid xs = or [isInvalidRow x|x<-xs ] || or[isInvalidRow x |x<-(transpose xs)] || or[isInvalidRow x |x<-(squareToRow xs)]
 where 
   isInvalidRow row = 
    let alreadyDone = [x | Fixed x <- row] in let stillEmpty = [x |Possible x <-row, null x] in 
      (length(nub alreadyDone) /= (length alreadyDone)) || (not (null stillEmpty))
      



-- finally Actual Solving with <|> we can speed up the process eaven more
solveGrid :: Grid -> Maybe Grid
solveGrid grid = removeAll grid >>= solveH
  where 
    solveH h
      | isInvalid h = Nothing
      | isSolved h = Just h
      | otherwise = let (g1,g2) = searchNextGrid h in solveGrid g1 <|> solveGrid g2

{-TTEW-}


-- tests
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]]


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

wrongSudoku ::[[Int]]
wrongSudoku=  [[0,2,3,0],
               [0,3,0,0],
               [0,0,0,0],
               [0,0,3,0]]


simpleSudoku2 ::[[Int]]
simpleSudoku2 = [[4,3,1,0,9,0,7,0,6],
                 [2,0,6,1,0,0,3,4,0],
                 [7,8,9,3,4,6,1,2,0],
                 [1,0,3,4,5,7,6,0,8],
                 [0,4,7,0,8,0,0,0,3],
                 [0,9,8,2,0,3,4,5,7],
                 [3,0,2,8,6,0,9,7,4],
                 [8,7,4,9,3,0,5,0,2],
                 [9,0,5,7,2,0,8,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)