-- Advanced Programming, HW 3
-- answer by Stephanie Weirich
{-# LANGUAGE FlexibleInstances #-}
module Sat where
import Data.Map (Map) -- use finite map data structure from standard library
import qualified Data.Map as Map
import Data.List (nub)
import Control.Monad (liftM,liftM2,MonadPlus(..)) -- can import more if necessary
import Data.Boolean.SatSolver
import Test.QuickCheck
-- | An expression in CNF, the conjunction of clauses
newtype CNF = CNF [ Clause ] deriving (Eq, Ord, Show)
unCNF :: CNF -> [ Clause ]
unCNF (CNF cs) = cs
-- | A clause -- the disjunction of a number of literals
type Clause = [ Lit ]
-- | A literal, either a positive or negative variable
data Lit = Lit Bool Var deriving (Eq, Ord, Show)
-- | A variable
data Var = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z | AA | AB | AC | AD | AE| AF | AG | AH | AI | AJ | AK | AL | AM | AN | AO | AP | AQ | AR | AS | AT | AU | AV | AW | AX | AY | AZ
deriving (Read, Eq, Ord, Show, Enum, Bounded)
-- | invert the polarity of a literal
invert :: Lit -> Lit
invert (Lit b x) = Lit (not b) x
-- | Get the name of the variable
var :: Lit -> Var
var (Lit _ x) = x
-- | Is the literal positive?
isPos :: Lit -> Bool
isPos (Lit b _) = b
exampleFormula :: CNF
exampleFormula = CNF [[Lit True A],[Lit True B,Lit False A]]
exampleAssignment :: Map Var Bool
exampleAssignment = Map.fromList [(A, True), (B, True)]
interpLit :: Map Var Bool -> Lit -> Bool
interpLit m (Lit b k) = maybe b (if b then id else not) (Map.lookup k m)
interp :: Map Var Bool -> CNF -> Bool
interp m (CNF formula) = all (any (interpLit m)) formula
solved :: Solver -> Bool
solved (Solver cnf m) = interp m (CNF cnf)
prop_interpExample :: Bool
prop_interpExample = interp exampleAssignment exampleFormula
dpll :: CNF -> Maybe (Map Var Bool)
dpll (CNF cnf) = loop initial where
initial :: Solver
initial = (Solver (removeTrivial (map nub cnf)) Map.empty)
loop :: Solver -> Maybe (Map Var Bool)
loop s =
let s1 = unitPropagate s in
let s2 = pureLitAssign s1 in
let cs = clauses s2 in
if solved s2
then return $ assignment s2
else if any null cs
then mzero
else
let l = chooseLit cs in
loop (addClause [l] s2) `mplus`
(loop (addClause [invert l] s2))
addClause :: Clause -> Solver -> Solver
addClause c (Solver cs m) = Solver (c : cs) m
-- remove any clauses with both A and not A, as they are guaranteed to be
-- true. Only do this for the initial formula, as the algorithm will never
-- introduce any new clauses with this property
removeTrivial :: [Clause] -> [Clause]
removeTrivial cs =
(filter (\c -> null [ () | l1 <- c, l2 <- c, l1 == invert l2]) cs)
data Solver = Solver { clauses :: [Clause] , assignment :: (Map Var Bool) }
deriving (Eq, Ord, Show)
-- | If a clause is a unit clause, i.e. it contains only a single
-- unassigned literal, this clause can only be satisfied by assigning
-- the necessary value to make this literal true. Unit propagation updates
-- the map with the assignment and simplifies the clauses to reflect this
-- reasoning.
unitPropagate :: Solver -> Solver
unitPropagate s =
if null unitLits then s else unitPropagate (foldr setTrue s unitLits)
where unitLits = [ l | [ l ] <- clauses s ]
-- | If a propositional variable occurs with only one polarity in the
-- formula, it is called pure. Pure literals can always be assigned in
-- a way that makes all clauses containing them true. Thus, these
-- clauses do not constrain the search anymore and can be deleted.
pureLitAssign :: Solver -> Solver
pureLitAssign s =
if null pureLits then s else pureLitAssign (foldr setTrue s pureLits)
where pureLits = nub [ lit | clause <- clauses s,
lit <- clause,
not (any ((invert lit) `elem`) $ clauses s) ]
setTrue :: Lit -> Solver -> Solver
setTrue literal (Solver cs m) = (Solver cs'' m') where
-- remove clauses containing the positive literal (they are trivially satisfied)
cs' = filter (not . (literal `elem`)) cs
-- remove negative literal from all other clauses
-- (other lits must satisfy the clause)
cs'' = map (filter ((invert literal)/=)) cs'
-- record the assignment
m' = Map.insert (var literal) (isPos literal) m
prop_dpll :: CNF -> Property
prop_dpll c =
case dpll c of
Just m -> classify True "sat" $ property (interp m c)
Nothing -> classify True "unsat" $ property True
instance Arbitrary CNF where
arbitrary = fmap CNF arbitrary
shrink (CNF cs) = map CNF (shrink cs)
instance Arbitrary Var where
arbitrary = elements [A .. ]
instance Arbitrary Lit where
arbitrary = liftM2 Lit arbitrary arbitrary
instance Arbitrary Solver where
arbitrary = liftM simplify (liftM2 Solver arbitrary arbMap) where
arbMap = fmap Map.fromList (listOf (liftM2 (,) arbitrary arbitrary))
simplify (Solver cs m) = foldr (\(x,b) -> setTrue (Lit b x))
(Solver (map nub cs) m)
(Map.assocs m)
-- | Pick a literal to split on.
chooseLit :: [Clause] -> Lit
chooseLit ((lit:_) : _) = lit
chooseLit _ = error "BUG: should be nonempty"
-- Generating hard test cases
-- r : number of clauses
-- m : number of variables
-- hard cases are in the range r ~= 4.26 * m
hard3SatGen :: Int -> Int -> Gen CNF
hard3SatGen r m = liftM CNF (vectorOf r arbcls) where
arbcls :: Gen Clause
arbcls = vectorOf 3 (liftM2 Lit arbitrary (elements [A .. toEnum m]))
fromLit :: Lit -> Boolean
fromLit (Lit True x) = Var (fromEnum x)
fromLit (Lit False x) = Not (Var (fromEnum x))
toBoolean :: CNF -> Boolean
toBoolean (CNF cs) = foldr (\xs y -> (foldr (\ l z -> fromLit l :||: z) No xs) :&&: y) Yes cs
prop_eqSatSolver :: CNF -> Bool
prop_eqSatSolver cnf =
case (assertTrue (toBoolean cnf) newSatSolver) of
Just ss -> case (isSolvable ss, dpll cnf) of
(True, Just m) -> solved (Solver (unCNF cnf) m)
(False, Nothing) -> True
(_,_) -> False
Nothing -> case dpll cnf of
Just m -> not (solved (Solver (unCNF cnf) m))
Nothing -> True
main :: IO ()
main = do
-- quickCheck prop_dpll
quickCheck $ forAll (hard3SatGen 86 20) prop_dpll
-- quickCheck prop_eqSatSolver
-- quickCheck $ forAll (hard3SatGen 86 20) prop_eqSatSolver
data SatM a = SatM (Solver -> Maybe (a, Solver))
instance Monad SatM where
return _ = undefined
_ >>= _ = undefined
instance MonadPlus SatM where
mzero = undefined
mplus = undefined
get :: SatM Solver
get = undefined
put :: Solver -> SatM ()
put = undefined
runSat :: SatM a -> Solver -> Maybe a
runSat = undefined