-- This module defines a function "solve", which uses MiniSat
-- (http://www.cs.chalmers.se/Cs/Research/FormalMethods/MiniSat/)
-- to solve a Sudoku game as a Boolean satisfiability problem.

-- Change miniSAT to point to the correct location, then try:
--      solve (convert test1)

module Sudoku_SAT where

import Sudoku (Board, rows, cols, boxs, convert, test1, test2, conflict)
import List (mapAccumL, tails)
import Control.Arrow ((&&&))
import Control.Monad (liftM2)
import Control.Exception (evaluate)
import Data.Maybe (listToMaybe)
import System.Process (runInteractiveProcess, waitForProcess)
import System.Posix.Temp (mkstemp)
import System.Posix.Files (removeLink)
import Control.Concurrent (forkIO)
import System.IO (hPutStr, hClose, hGetContents, stderr)
import qualified Data.Map as M

-- http://blog.moertel.com/articles/2007/09/01/clusterby-a-handy-little-function-for-the-toolbox
clusterBy :: Ord b => (a -> b) -> [a] -> [[a]]
clusterBy f = M.elems . M.map reverse . M.fromListWith (++)
            . map (f &&& return)

type Literal = Int
type Clause = [Literal]
type Formula = [Clause]

name :: Board [a] -> Board [(a,Literal)]
name = snd . mapAccumL (mapAccumL (mapAccumL (\l i -> (succ l, (i,l))))) 1

exists :: [(a,Literal)] -> Formula
exists xls = [map snd xls]

unique :: [(a,Literal)] -> Formula
unique xls = [ [-l1,-l2] | l1:l2s <- tails (map snd xls), l2 <- l2s ]

compat :: (Ord a) => [(a,Literal)] -> Formula
compat xls = clusterBy fst xls >>= unique

constraints :: (Ord a) => Board [(a,Literal)] -> Formula
constraints b = (concat b >>= \xls -> exists xls ++ unique xls)
             ++ ((rows b ++ cols b ++ boxs b) >>= compat . concat)

dimacs :: Formula -> String
dimacs lss = "c DIMACS format CNF file\n"
          ++ "p cnf " ++ show (maximum (map abs (concat lss)))
          ++ " " ++ show (length lss) ++ "\n"
          ++ concat [ concat [ show l ++ " " | l <- ls ] ++ "0\n" | ls <- lss ]

solve :: Board [Int] -> IO (Maybe (Board Int))
solve b = do
    let nb = name b
    (resultF, resultH) <- mkstemp "satXXXXXX"
    (inH, outH, errH, pid)
        <- runInteractiveProcess miniSAT ["-r", resultF] Nothing Nothing
    forkIO (hPutStr inH (dimacs (constraints nb)) >> hClose inH)
    forkIO (hGetContents outH >>= \c -> evaluate (last (' ':c)) >> return ())
    forkIO (hGetContents errH >>= hPutStr stderr)
    waitForProcess pid
    removeLink resultF
    result <- hGetContents resultH
    return (case lines result of
            "SAT":model:_ ->
                let selected = filter (>0) (map read (words model))
                    select xls = listToMaybe [ x | (x,l) <- xls
                                                 , l `elem` selected ]
                    solution = mapM (mapM select) nb
                in case solution of Just s | conflict s -> Nothing
                                    _ -> solution
            _ -> Nothing)

miniSAT :: FilePath
miniSAT = "/usr/local/src/prolog/MiniSat-p_v1.14/minisat"