[99p]NonoGram

import Data.List

----- predefined consts and inputs
type Matrix a = [[a]]
type Board = Matrix Int
type Puzzle a = ([[a]],[[a]])

nonopuz1 :: Puzzle Int
nonopuz1 = ([[4]],[[1],[1],[1],[0]])
nonopuz2 :: Puzzle Int
nonopuz2 = ([[3],[2,1],[3,2],[2,2],[6],[1,5],[6],[1],[2]], [[1,2],[3,1],[1,5],[7,1],[5],[3],[4],[3]])
nonopuz3 :: Puzzle Int
nonopuz3 = ([[1],[3],[1]], [[1],[3],[1]])
nonopuz4:: Puzzle Int
nonopuz4 = ([[2],[2,2],[3],[1,1],[2]], [[2,2],[2,1],[1],[2],[3]])
nonopuz5 :: Puzzle Int
nonopuz5 = ([[6],[3],[3,1],[2,2],[2,3],[5],[4],[5],[2,5],[1,6]], [[5,2],[5,1],[3],[1],[1,1],[1,1,3],[5],[6],[7],[8]])
nonopuz6 :: Puzzle Int
nonopuz6 = ([[5,2,4],[3,9],[3,5],[3,4],[4,3],[1,2,2],[1,1,1],[9,1,1],[1,4,4],[1,4,2,1],[4,3],[6],[4,1],[1,1,3],[1,8]]
           ,[[1,2,3,2],[8,2],[5,8],[3,9],[1,1,5],[6],[1,1],[3,2,3],[4,2,1,1],[4,3,1],[4,4,1],[5,2],[2,2],[2,1,2],[2,1,1,1,1]])
nonopuz7 :: Puzzle Int
nonopuz7 = ([[6,1,1],[1,6,2],[1,8,2,2],[2,3,6],[1,1,3,2,3],[1,3,1,1,2],[3,2,1,1],[4,2,1],[5,3,2],[1,6,2],[6,2,1,2],[2,7,3,1,1,3],[2,6,7,3],
             [3,7,6,3],[3,7,8,1],[3,9,3,4],[8,5,1],[4,8],[4,1,4,5],[3,4,1,3],[3,1,9],[1,2,3,8],[1,3,9],[2,1,13],[2,1,4,4]]
           ,[[3,10,4],[1,9,2],[3,6],[1,6,3],[3,11,2,2],[1,13,4],[3,5,7,3],[6,9],[5,1,6,3],[8,1,7],[2,3,8],[3,2,5],[1,3,3,3],[1,3,2,3],[4,3],
             [6,2],[4,1,3],[2,3,5],[1,2,5],[1,2,4],[2,2,2,7],[4,3,1,5],[4,3,7],[4,7,7],[4,7,6]])
nonopuz8 :: Puzzle Int
nonopuz8 = ([[2],[2],[2],[2]], [[2],[4],[2]])
nonopuz9 :: Puzzle Int
nonopuz9 = ([[2],[1,2],[1,1],[2],[1],[3],[3],[2,2],[2,1],[2,2,1],[2,3],[2,2]], [[2,1],[1,3],[2,4],[3,4],[4],[3],[3],[3],[2],[2]])

nonosol2 :: Board
nonosol2 = [[-1,1,-1], [1,1,1], [-1,1,-1]]
testtest :: Board
testtest = [[-1,2],[-1,2,3],[2,3,4],[3,4,5],[4,5,-6],[5,-6,7],[-6,7,8],[7,8,9],[8,9,-10],[9,-10]]

----- solution verification
lineCal :: (Num a, Ord a) => [a] -> [Int]
lineCal row  = map length $ filter (\xs -> (head xs > 0)) (groupBy (\x y -> (x > 0) == (y > 0)) row)
veriSol :: (Num a, Ord a) => Puzzle Int -> [[a]] -> Bool
veriSol puz brd = (fst puz == map lineCal brd) && (snd puz == map lineCal (transpose brd))

----- solution permutation
brdCreate :: Puzzle a -> Board
brdCreate puz = replicate (length $ fst puz) $ replicate (length $ snd puz) 0
choices :: Board -> Matrix [Int]
choices brd = map (map choice) brd
              where choice e = if (e == 0) then [-1, 1] else [e]
matCart :: Matrix [a] -> [Matrix a]
matCart = cartProd . (map cartProd)
          where cartProd :: [[a]] -> [[a]]
                cartProd [] = [[]]
                cartProd (ls:lss) = [ x:xs | x <- ls, xs <- cartProd lss ]
solPermu puz = filter (veriSol puz) ( matCart $ choices (brdCreate puz) )

----- deduction solver
labeling :: [Int] -> [Int]
labeling clue = labeling' 1 clue
                where labeling' n []     = [-n,-n]
                      labeling' n (x:xs) = [-n,-n] ++ [n+1 .. n+x] ++ labeling' (n+x+1) xs

lbLinject :: [Int] -> [Int] -> [Int]
lbLinject _ [] = []
lbLinject clue curlabel = nub [snd x | x <- zippedlabelpair,  fst x `elem` curlabel]
                          where zippedlabelpair = zip (labeling clue) (tail $ labeling clue)
lbRinject :: [Int] -> [Int] -> [Int]
lbRinject _ [] = []
lbRinject clue curlabel = nub [fst x | x <- zippedlabelpair,  snd x `elem` curlabel]
                          where zippedlabelpair = zip (labeling clue) (tail $ labeling clue)

reduce :: [Int] -> Int -> [Int]
reduce xs blkstat
       |  blkstat == -1   = filter ( < 0 ) xs
       |  blkstat == 1    = filter ( > 0 ) xs
       |  blkstat == 0    = filter ( \x -> True ) xs

judgeLeft :: [Int] -> [Int] -> [[Int]]
judgeLeft clue stats = judgeLeft' startlabel stats
                       where startlabel = [-1,2]
                             judgeLeft' :: [Int] -> [Int] -> [[Int]]
                             judgeLeft' _ [] = []
                             judgeLeft' curlabel (cur:curstats) = (reduce curlabel cur) : (judgeLeft' nextlabel curstats)
                                                                   where nextlabel = lbLinject clue (reduce curlabel cur)
judgeRight :: [Int] -> [Int] -> [[Int]]
judgeRight clue stats = reverse ( judgeRight' startlabel (reverse stats) )
                        where startlabel = take 2 (nub $reverse $labeling clue)
                              judgeRight' :: [Int] -> [Int] -> [[Int]]
                              judgeRight' _ [] = []
                              judgeRight' curlabel (cur:curstats) = (reduce curlabel cur) : (judgeRight' nextlabel curstats)
                                                                    where nextlabel = lbRinject clue (reduce curlabel cur)
judgeMent :: [Int] -> [Int] -> [[Int]]
judgeMent clue stats = map (\x -> (fst x) `intersect` (snd x)) (zip (judgeLeft clue stats) (judgeRight clue stats) )
deterBlk :: [Int] -> Int
deterBlk lblist
          |  all (> 0) lblist  = 1
          |  all (< 0) lblist  = -1
          |  otherwise          = 0

lineSolve :: [Int] -> [Int] -> [Int]
lineSolve clue stats
          | clue == []    = replicate (length stats) (-1)
          | otherwise     = if ([] `elem` lblists) then [] else (map deterBlk lblists)
                            where lblists = (judgeMent clue stats)

rowsSolve :: [[Int]] -> Board -> Board
rowsSolve _ [] = []
rowsSolve (clue:rowclues) (stats:rowstats) = (lineSolve clue stats) : (rowsSolve rowclues rowstats)

allSolve :: Puzzle Int -> Board -> Board
allSolve _ [] = []
allSolve puz rowstats =  if ([] `elem` rowstats) then [] else
                          ( transpose (rowsSolve (snd puz) $ transpose (rowsSolve (fst puz) rowstats)) )

fixPt :: Eq a => (a -> a) -> a -> a
fixPt f x = if (x == f x) then x else (fixPt f $f x)

deduSolver :: Puzzle Int -> Board -> Board
deduSolver puz statz = fixPt (allSolve puz) statz

------ statz properties
failSol :: Board -> Bool
failSol statz = statz == []
compSol :: Board -> Bool
compSol statz = (statz /= []) && (and $map (all (/= 0)) statz)
incompSol :: Board -> Bool
incompSol statz = (statz /= []) && (or $map (any (== 0)) statz)

------ guessing incompletes
-- just replace first 0 with -1 and 1 (slow method)
fstZero :: [Int] -> [[Int]]
fstZero xs = [ x1 ++ [c] ++ x2 | c <- [-1,1] ]
             where (x1,(x:x2)) = break (== 0) xs
fzGuess :: Board -> [Board]
fzGuess statz = [rows1 ++ [row] ++ rows2 | row <- fstZero row ]
                where (rows1, (row:rows2)) = break (0 `elem`) statz

------ nonogram solver
nonoSolver :: Puzzle Int -> Board -> [Board]
nonoSolver puz statee
    | failSol statz      = []
    | compSol statz      = [statz]
    | incompSol statz    = concatMap (nonoSolver puz) (fzGuess statz)
    where statz = deduSolver puz statee
nonoSolve  :: Puzzle Int -> [Board]
nonoSolve puz = nonoSolver puz (brdCreate puz)