solve SUDOKU

gistfile1.hs

import Data.List
import Control.Applicative ()
import Control.Monad
--
--import Data.Set hiding(map,valid,filter,null,foldr)
--import Data.Maybe

type Board = [[Int]] -- [[Maybe Int]] にして、0 の代わりにNothing のほうがいいとは思う
question :: Board
question = [
 [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] ]

{--
constNumbers :: Board -> [[Bool]] -- Not in use
constNumbers = map (map (/=0))

liftBoard :: Board -> [[Maybe Int]] -- Not in use
liftBoard = map (map f)
  where 
    f :: Int -> Maybe Int
    f 0 = Nothing
    f n = Just n

--}

get :: [[a]] -> Int -> Int -> a -- x , y
get xss n m = xss !! m !! n

sliceX,sliceY :: [[a]] -> Int -> [a]
sliceY xss n = xss !! n
sliceX xss n = [ xs !! n | xs <- xss ]

solve :: Board -> [Board] -- ヤバすぎでは
solve q = return q >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren >>= vchildren

vchildren :: Board -> [Board]
vchildren b = [ x | x <- children b , valid x]

children :: Board -> [Board]
children board | null . filter (==0) $ concat board = [board]
  | otherwise = children3 board
--children = children3

children3 :: Board -> [Board]
--children3 =  map split9 . replace0 . concat
children3 =  replace0 . concat
  where
    split9 :: [Int] -> Board
    split9 (a:b:c:d:e:f:g:h:i:xs) = [[a,b,c,d,e,f,g,h,i]] ++ split9 xs
    split9 [] = []
    split9 _ = error ""
    --replace0 :: [Int] -> [[Int]]
     --replace0 b = map (\n ->map (\x -> if x == 0 then n else x) b) [1..9]
    --replace0 b = map (replace0imp b) [1..9]
    replace0 b = map (split9 . replace0imp b) [1..9]
    replace0imp :: [Int] -> Int -> [Int]
    replace0imp (0:xs) n = n: xs
    replace0imp (x:xs) n = x: replace0imp xs n
    replace0imp [] _ = []
--    replace0imp xs n = map  

valid :: Board -> Bool
valid = and . ap [checkY, checkX, checkArea] . return
--valid b = checkY b && checkX b && checkArea b 

checkX,checkY,checkArea :: Board -> Bool
checkX = checkX3
checkY = checkY3
checkArea = and . map check . splitArea

checkX3,checkY3:: Board -> Bool
checkX3 b = and $ map (check.sliceX b) [8,7..0]  -- [0..8]
checkY3 b = and $ map (check.sliceY b) [8,7..0]  -- [0..8]  

check :: [Int] -> Bool
--check = and . map ((<2).length) . group . sort . filter (/=0)
check x = length y == ( length $ nub y ) 
  where y = filter (/=0) x
--check = isJust . foldr (\x -> liftM (Data.Set.insert x) . (Control.Monad.mfilter) (notMember x)) (Just Data.Set.empty) . filter (/=0)

splitArea :: Board -> [[Int]]
splitArea = splitArea3

splitArea3 :: Board -> [[Int]]  --
splitArea3 b = [ get3 b 1 1, get3 b 4 1, get3 b 7 1,  get3 b 1 4, get3 b 4 4, get3 b 7 4, get3 b 1 7, get3 b 4 7, get3 b 7 7]
  where 
    get3 b' x y = [ get b' (x-1) (y-1), get b' x (y-1), get b' (x+1) (y-1), get b' (x-1) y, get b' x y, get b' (x+1) y, get b' (x-1) (y+1),get b' x (y+1), get b' (x+1) (y+1) ] 


readQuestion :: IO Board
readQuestion = return question -- 

printNumberPress :: Board -> IO ()
printNumberPress = mapM_ (putStrLn.show) 


main :: IO ()
--main = print $ sliceX question 2
--main = readQuestion >>= return . solve >>= mapM_ (\x -> printNumberPress x >> putStrLn "")
main = readQuestion >>= return . head . solve >>= printNumberPress

ふるいコード発掘したので置いとく