An attempt at a sudoku solver using bitfields

sudoku_solver.hs

--let attempt2bitmap (x,y,n) = ((9*x+n)*9^4, (9*y+n)*9^2, 9*x+y)
--let allAttempts = [bit row .|. bit col .|. bit pos | x <- [0..8], y <- [0..8], n <- [0..8], let (row, col, pos) = attempt2bitmap (x,y,n)] :: [Integer]

--let attempt2bitmap x y n = bit (9*x + n) .|. bit (9*y + n + 9^2) .|. bit (9*boxOf x y + n + n^4) .|. bit (9*x + y + 9^6) :: Integer
let attempt2bitnr x y n = [9*x + n, 9*y + n, 9*boxOf x y + n, 9*x + y] :: [Int]
let attempt2bitmap x y n = sum [ bit $ a + 9^2*i | (i,a) <- zip [0..] $ attempt2bitnr x y n] :: Integer

let matrix2bitmaps rows = [ attempt2bitmap x y (n-1) | (x, row) <- zip [0..] rows, (y, n) <- zip [0..] row, n /= 0] 
let mapMatIdx f rows = [ f x y (n-1) | (x, row) <- zip [0..] rows, (y, n) <- zip [0..] row, n /= 0]
let matrix2tuples = mapMatIdx (,,)

-- Find the attempt that belongs to a bitmap, brute force method
 let getVal s = head [(x,y,n) | x <- [0..8], y <- [0..8], n <- [0..8],  s == attempt2bitmap x y n]

let boxOf x y = (y`div`3)+3*(x`div`3)
mapM_ print $ [[boxOf x y | y <- [0..8]]| x<- [0..8]]
let allAttempts = attempt2bitmap <$> [0..8] <*> [0..8] <*> [0..8]

let asBin n = showIntAtBase 2 intToDigit n ""

-- Example
let mat =  [[0,0,0,2,6,0,7,0,1], [6,8,0,0,7,0,0,9,0], [1,9,0,0,0,4,5,0,0], [8,2,0,1,0,0,0,4,0], [0,0,4,6,0,2,9,0,0], [0,5,0,0,0,3,0,2,8], [0,0,9,3,0,0,0,7,4], [0,4,0,0,5,0,0,3,6], [7,0,3,0,1,8,0,0,0]] :: [[Int]]
let bitmat = matrix2bitmap  mat

let challenge1 = getState  [[0,2,0,0,0,0,0,0,0], [0,0,0,6,0,0,0,0,3], [0,7,4,0,8,0,0,0,0], [0,0,0,0,0,3,0,0,2], [0,8,0,0,4,0,0,1,0], [6,0,0,5,0,0,0,0,0], [0,0,0,0,1,0,7,8,0], [5,0,0,0,0,9,0,0,0], [0,0,0,0,0,0,0,4,0]]
 
let mbits = foldl' (.|.) 0

-- Takes a matrix (with 0 to indicate empty) and returns the bitmap for it
getState :: [[Int]] -> Integer
getState = foldl (.|.) 0 . matrix2bitmap

allPossibilities :: Integer -> [Integer]
allPossibilities n = filter ((==0) . (n.&.)) $ allAttempts

-- Split a number into the least significant bit and the rest
let lsbSplit 0 = Nothing; lsbSplit n = Just (n-rest, rest) where rest = n.&.(n-1)
let bitlist = unfoldr lsbSplit
let lsb n = compliment (n-1) .&. n

prop_bitlist n = (sum.bitlist) n == n

-- A list of all the bits that only have one possible candidate
let easyBits = map head . filter ((==1).length) . group . sort . concatMap bitlist . allPossibilities
let getEasy n =  head . filter ((/=0).(.&. (head. easyBits) n)) $ allPossibilities n

-- The bit (or a bit) with the fewest possibilities
let bestBit = head . minimumBy (comparing length) . group . sort . concatMap bitlist . allPossibilities
let getBest n = filter ((/=0).(.&. bestBit n)) $ allPossibilities n
-- A list of possible guesses, sorted by number of possibilities after guess.
let nextAttempt s = snd <$> sort [(length $ allPossibilities s', s') | nxt <- getBest s, let s' =  nxt .|. s, isPossible s']
--let nextAttempt s = sortBy (comparing $ length . allPossibilities) . filter isPossible . map (.|.s)  . getBest $ s

let isSolved s = bit (4*9^2) == s + 1

let isPossible s = isSolved . foldl (.|.) s $ allPossibilities s


let solve s = mapM_ print .map asBin . takeWhile (not . isSolved) . map head $iterate (concatMap nextAttempt) [s]

let bench s = length . takeWhile (not . isSolved.head) . iterate (concatMap nextAttempt) . (:[]) <$> replicate 100 s

let nSteps = (`div`4).length.filter (=='1').asBin.mBits . allPossibilities
let takeIncluding p l = case span p l of (xs,x:_) -> xs++[x]; (xs,_) -> xs

let backtrack :: (a -> [a]) -> [a] -> [a]; backtrack f = go where go (x:xs) = f x ++ xs; go [] = []

-- NQueens
let nQueen n r c  = bit r .|. bit (c + n) .|. bit (d1 + 2*n) .|. bit (d2 + 4*n - 1) where d1 = r + c; d2 = r + (n-1-c)
let nQueens n = nQueen n <$> [0..n-1] <*> [0..n-1] :: [Integer]

let allPos s = filter ((==0) . (s.&.))
let bestBitX = head . minimumBy (comparing length) . group . sort . concatMap (take 2.bitlist)
let getBestX xs = filter ((/=0).(.&. bestBitX xs)) xs
let nextAttemptX (xs, s) = sort [(allPos s' xs, s') | nxt <- getBestX xs, let s' =  nxt .|. s]

-- let nextAttemptX (xs, s) = sort [(xs', s') | nxt <- getBestX xs, let s' =  nxt .|. s; xs' = allPos s' xs,  isPossibleX s' xs']
-- let isPossibleX s = isSolvedX . foldl' (.|.) s
-- let isSolvedX n s = bit (6*n - 2) == s + 1

let showQueens n = mapM_ print .map (asBin .snd . head) . takeWhile (not.null) $ iterate (concatMap nextAttemptX) [(nQueens n,0)]
let countQueens n =  length . (!!n) $ iterate (concatMap nextAttemptX) [(nQueens n,0)]

let nextAttemptX (xs, ss) = sort [(allPos s' xs, s':ss) | nxt <- getBestX xs, let s' =  nxt .|. head ss]

let solveQueen n = map unQueen.diff.snd.head . (!!n) $ iterate (concatMap nextAttemptX) [(nQueens n,[0])]

let unQueen n = (\(a:b:_) -> (a, b - n)) . map unbit . bitlist

----
let unbit n = head $ findIndices (testBit n) [0..]

let nextAttempt' ss@(s:_) = snd <$> sort [(length $ allPossibilities s', s':ss) | nxt <- getBest s, let s' =  nxt .|. s, isPossible s']
let nextAttempt3' ss@(s:_) = sortBy (comparing $ length . allPossibilities . head) . map (:ss) . filter isPossible . map (.|.s) . getBest $ s

let solveSudoku s = map (map unSudoku . diff) . takeWhile (not . isSolved . head) . map head $iterate (concatMap nextAttempt') [[s]]
let unSudoku' (a:b:_) = (a`div`9, (b -9*9)`div`9, a`mod`9)
let unSudoku = unSudoku' . map unbit . bitlist

let blankSudoku = replicate 9 . replicate 9 $ 0

let showSudokuSolution = mapM_ print . (map.map) (\(_,_,x) -> x+1) . groupBy (\(x,_,_) (y,_,_) -> x == y). sort . (map unSudoku challenge1_bm ++) . (map unSudoku . diff) . (!!62) . map head $iterate (concatMap nextAttempt') [[challenge1]]
-- mapM_ print . (map.map) (\(_,_,x) -> x+1) . groupBy (\(x,_,_) (y,_,_) -> x == y). sort . map unSudoku . (challenge1_bm++) . diff . (!!62) . map head $iterate (concatMap nextAttempt') [[challenge1]]
let diff xs = zipWith (-) xs $ tail xs
-- mapM_ (mapM_ print . (map.map) (\(_,_,x) -> x+1) . groupBy (\(x,_,_) (y,_,_) -> x == y). sort . map unSudoku . (challenge1_bm++) . diff . head) . takeWhile (not.null) $iterate (concatMap nextAttempt') [[challenge1]]

let solveMatrix m = (map.map) (\(_,_,x) -> x+1) . groupBy (\(x,_,_) (y,_,_) -> x == y). sort . map unSudoku . (mf++) . diff . (!!62) . map head $iterate (concatMap nextAttempt') [[mbits mf]] where mf = matrix2bitmap m