{-# OPTIONS_GHC -fglasgow-exts #-}
module Properties where
{-
This file is part of funsat.
funsat is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
funsat is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with funsat. If not, see .
Copyright 2008 Denis Bueno
-}
import Funsat.Solver hiding ((==>))
import Control.Monad (replicateM)
import Data.Array.Unboxed
import Data.BitSet (hash)
import Data.Bits
import Data.Foldable hiding (sequence_)
import Data.List (nub, splitAt, unfoldr, delete, sort, sortBy)
import Data.Maybe
import Data.Ord( comparing )
import Debug.Trace
import Funsat.Solver( verify )
import Funsat.Types
import Funsat.Utils
import Language.CNF.Parse.ParseDIMACS( parseFile )
import Prelude hiding ( or, and, all, any, elem, minimum, foldr, splitAt, concatMap
, sum, concat )
import Funsat.Resolution( ResolutionTrace(..), initResolutionTrace )
import System.Random
import Test.QuickCheck hiding (defaultConfig)
import qualified Data.Foldable as Foldable
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Funsat.Resolution as Resolution
import qualified Language.CNF.Parse.ParseDIMACS as ParseCNF
import qualified Test.QuickCheck as QC
main :: IO ()
main = do
-- let s = solve1 prob1
-- case s of
-- Unsat -> return ()
-- Sat m -> if not (verifyBool m prob1)
-- then putStrLn (show (find (`isFalseUnder` m) prob1))
-- else return ()
--setStdGen (mkStdGen 42)
check config prop_randAssign
check config prop_allIsTrueUnderA
check config prop_noneIsFalseUnderA
check config prop_noneIsUndefUnderA
check config prop_negIsFalseUnder
check config prop_negNotUndefUnder
check config prop_outsideUndefUnder
check config prop_clauseStatusUnderA
check config prop_negDefNotUndefUnder
check config prop_undefUnderImpliesNegUndef
check config prop_litHash
check config prop_varHash
check config prop_count
-- Add more tests above here. Setting the rng keeps the SAT instances
-- the same even if more tests are added above. Reproducible results
-- are important.
setStdGen (mkStdGen 42)
check solveConfig prop_solveCorrect
setStdGen (mkStdGen 42)
check resChkConfig prop_resolutionChecker
config = QC.defaultConfig { configMaxTest = 1000 }
-- Special configuration for the "solve this random instance" tests.
solveConfig = QC.defaultConfig { configMaxTest = 2000 }
resChkConfig = QC.defaultConfig{ configMaxTest = 1200 }
myConfigEvery testnum args = show testnum ++ ": " ++ show args ++ "\n\n"
-- * Tests
prop_solveCorrect (cnf :: CNF) =
label "prop_solveCorrect" $
trivial (numClauses cnf < 2 || numVars cnf < 2) $
classify (numClauses cnf > 15 || numVars cnf > 10) "c>15, v>10" $
classify (numClauses cnf > 30 || numVars cnf > 20) "c>30, v>20" $
classify (numVars cnf > 20) "c>30, v>30" $
case solve (defaultConfig cnf) cnf of
(Sat m,_,rt) -> label "SAT" $ verifyBool (Sat m) rt cnf
(Unsat _,_,rt) -> label "UNSAT" $
case Resolution.checkDepthFirst (fromJust rt) of
Left e ->
trace ("rt = " ++ show rt ++ "\n"
++ "Resolution checker error: " ++ show e)
$ False
Right _ -> True
prop_resolutionChecker (cnf :: UnsatCNF) =
label "prop_resolutionChecker" $
case solve1 (unUnsatCNF cnf) of
(Sat _,_,_) -> label "SAT" True
(Unsat _,_,rt) -> label "UNSAT" $
case Resolution.checkDepthFirst (fromJust rt) of
Left e -> False
Right unsatCore ->
case solve1 ((unUnsatCNF cnf){ clauses = Set.fromList unsatCore}) of
(Sat _,_,_) -> False
(Unsat _,_,_) -> True
prop_allIsTrueUnderA (m :: IAssignment) =
label "prop_allIsTrueUnderA"$
allA (\i -> if i /= 0 then L i `isTrueUnder` m else True) m
prop_noneIsFalseUnderA (m :: IAssignment) =
label "prop_noneIsFalseUnderA"$
not $ anyA (\i -> if i /= 0 then L i `isFalseUnder` m else False) m
prop_noneIsUndefUnderA (m :: IAssignment) =
label "prop_noneIsUndefUnderA"$
not $ anyA (\i -> if i /= 0 then L i `isUndefUnder` m else False) m
prop_negIsFalseUnder (m :: IAssignment) =
label "prop_negIsFalseUnder"$
allA (\l -> if l /= 0 then negate (L l) `isFalseUnder` m else True) m
prop_negNotUndefUnder (m :: IAssignment) =
label "prop_negNotUndefUnder"$
allA (\l -> if l /= 0 then not (negate (L l) `isUndefUnder` m) else True) m
prop_outsideUndefUnder (l :: Lit) (m :: IAssignment) =
label "prop_outsideUndefUnder"$
trivial ((unVar . var) l > rangeSize (bounds m)) $
inRange (bounds m) (var l) ==>
trivial (m `contains` l || m `contains` negate l) $
not (m `contains` l) && not (m `contains` (negate l)) ==>
l `isUndefUnder` m
prop_negDefNotUndefUnder (l :: Lit) (m :: IAssignment) =
label "prop_negDefNotUndefUnder" $
inRange (bounds m) (var l) ==>
m `contains` l || m `contains` (negate l) ==>
l `isTrueUnder` m || negate l `isTrueUnder` m
prop_undefUnderImpliesNegUndef (l :: Lit) (m :: IAssignment) =
label "prop_undefUnderImpliesNegUndef" $
inRange (bounds m) (var l) ==>
trivial (m `contains` l) $
l `isUndefUnder` m ==> negate l `isUndefUnder` m
prop_clauseStatusUnderA (c :: Clause) (m :: IAssignment) =
label "prop_clauseStatusUnderA" $
classify expectTrueTest "expectTrue"$
classify expectFalseTest "expectFalseTest"$
classify expectUndefTest "expectUndefTest"$
if expectTrueTest then c `isTrueUnder` m
else if expectFalseTest then c `isFalseUnder` m
else c `isUndefUnder` m
where
expectTrueTest = not . null $ c `List.intersect` (map L $ elems m)
expectFalseTest = all (`isFalseUnder` m) c
expectUndefTest = not expectTrueTest && not expectFalseTest
-- Verify assignments generated are sane, i.e. no assignment contains an
-- element and its negation.
prop_randAssign (a :: IAssignment) =
label "randAssign"$
not $ anyA (\l -> if l /= 0 then a `contains` (negate $ L l) else False) a
-- unitPropFar should stop only if it can't propagate anymore.
-- prop_unitPropFarthest (m :: Assignment) (cnf :: CNF) =
-- label "prop_unitPropFarthest"$
-- case unitPropFar m cnf of
-- Nothing -> label "no propagation" True
-- Just m' -> label "propagated" $ not (anyUnit m' cnf)
-- Unit propagation may only add to the given assignment.
-- prop_unitPropOnlyAdds (m :: Assignment) (cnf :: CNF) =
-- label "prop_unitPropOnlyAdds"$
-- case unitPropFar m cnf of
-- Nothing -> label "no propagation" True
-- Just m' -> label "propagated" $ all (\l -> elem l m') m
-- Make sure the bit set will work.
prop_litHash (k :: Lit) (l :: Lit) =
label "prop_litHash" $
hash k == hash l <==> k == l
prop_varHash (k :: Var) l =
label "prop_varHash" $
hash k == hash l <==> k == l
(<==>) = iff
infixl 3 <==>
-- newtype WPTest s = WPTest (WatchedPair s)
-- instance Arbitrary (WPTest s) where
-- arbitrary = sized sizedWPTest
-- where sizedWPTest n = do
-- [lit1, lit2] <- 2 `uniqElts` 1
-- clause :: Clause <- arbitrary
-- return $ runST $
-- do r <- newSTRef (lit1, lit2)
-- return (r, lit1 : lit2 : clause)
newtype Nat = Nat { unNat :: Int }
deriving (Eq, Ord)
instance Show Nat where
show (Nat i) = "Nat " ++ show i
instance Num Nat where
(Nat x) + (Nat y) = Nat (x + y)
(Nat x) - (Nat y) | x >= y = Nat (x - y)
| x < y = error "Nat: subtraction out of range"
(Nat x) * (Nat y) = Nat (x * y)
abs = id
signum (Nat n) | n == 0 = 0
| n > 0 = 1
| n < 0 = error "Nat: signum of negative number"
fromInteger n | n >= 0 = Nat (fromInteger n)
| n < 0 = error "Negative natural literal found"
instance Arbitrary Nat where
arbitrary = sized $ \n -> do i <- choose (0, n)
return (fromIntegral i)
-- sanity checking for Arbitrary Nat instance.
prop_nat (xs :: [Nat]) = trivial (null xs) $ sum xs >= 0
prop_nat1 (xs :: [Nat]) = trivial (null xs) $ unNat (sum xs) == sum (map unNat xs)
prop_count p xs =
label "prop_count" $
count p xs == length (filter p xs)
where _types = xs :: [Int]
prop_argmin f x y =
label "prop_argmin" $
f x /= f y ==>
argmin f x y == m
where m = if f x < f y then x else y
instance Show (a -> b) where
show = const ""
------------------------------------------------------------------------------
-- * Helpers
------------------------------------------------------------------------------
allA :: (IArray a e, Ix i) => (e -> Bool) -> a i e -> Bool
allA p a = all (p . (a !)) (range . bounds $ a)
anyA :: (IArray a e, Ix i) => (e -> Bool) -> a i e -> Bool
anyA p a = any (p . (a !)) (range . bounds $ a)
_findA :: (IArray a e, Ix i) => (e -> Bool) -> a i e -> Maybe e
_findA p a = (a !) `fmap` find (p . (a !)) (range . bounds $ a)
-- Generate exactly n distinct, random things from given enum, starting at
-- element given. Obviously only really works for infinite enumerations.
uniqElts :: (Enum a) => Int -> a -> Gen [a]
uniqElts n x =
do is <- return [x..]
choices <-
sequence $ map
(\i -> do {b <- oneof [return True, return False];
return $ if b then Just i else Nothing})
is
return $ take n $ catMaybes choices
-- Send this as a patch for quickcheck, maybe.
iff :: Bool -> Bool -> Property
first `iff` second =
classify first "first" $
classify (not first) "not first" $
classify second "second" $
classify (not second) "not second" $
if first then second
else not second
&& if second then first
else not first
fromRight (Right x) = x
fromRight (Left _) = error "fromRight: Left"
_intAssignment :: Int -> Integer -> [Lit]
_intAssignment n i = map nthBitLit [0..n-1]
-- nth bit of i as a literal
where nthBitLit n = toLit (n + 1) $ i `testBit` n
toLit n True = L n
toLit n False = negate $ L n
_powerset :: [a] -> [[a]]
_powerset [] = [[]]
_powerset (x:xs) = xss /\/ map (x:) xss
where
xss = _powerset xs
(/\/) :: [a] -> [a] -> [a]
[] /\/ ys = ys
(x:xs) /\/ ys = x : (ys /\/ xs)
------------------------------------------------------------------------------
-- * Generators
------------------------------------------------------------------------------
instance Arbitrary Var where
arbitrary = sized $ \n -> V `fmap` choose (1, n)
instance Arbitrary Lit where
arbitrary = sized $ sizedLit
-- Generates assignment that never has a subset {l, -l}.
instance Arbitrary IAssignment where
arbitrary = sized assign'
where
assign' n = do lits :: [Lit] <- vector n
return $ array (V 1, V n) $ map (\i -> (var i, unLit i))
(nub lits)
instance Arbitrary CNF where
arbitrary = sized (genRandom3SAT 3.0)
sizedLit n = do
v <- choose (1, n)
t <- oneof [return id, return negate]
return $ L (t v)
-- Generate a random 3SAT problem with the given ratio of clauses/variable.
--
-- Current research suggests:
--
-- * ~ 4.3: hardest instances
-- * < 4.3: SAT & easy
-- * > 4.3: UNSAT & easy
genRandom3SAT :: Double -> Int -> Gen CNF
genRandom3SAT clausesPerVar n =
do let nClauses = ceiling (fromIntegral nVars * clausesPerVar)
clauseList <- replicateM nClauses arbClause
return $ CNF { numVars = nVars
, numClauses = nClauses
, clauses = Set.fromList clauseList }
where
nVars = n `div` 3
arbClause :: Gen Clause
arbClause = do
a <- sizedLit nVars
b <- sizedLit nVars
c <- sizedLit nVars
return [a,b,c]
windows :: Int -> [a] -> [[a]]
windows n xs = if length xs < n
then []
else take n xs : windows n (drop n xs)
permute :: [a] -> Gen [a]
permute [] = return []
permute xs = choose (0, length xs - 1) >>= \idx ->
case splitAt idx xs of
(pfx, x:xs') -> do perm <- permute $ pfx ++ xs'
return $ x : perm
_ -> error "permute: bug"
newtype UnsatCNF = UnsatCNF { unUnsatCNF :: CNF } deriving (Show)
instance Arbitrary UnsatCNF where
arbitrary = do
f <- sized (genRandom3SAT 5.19)
return (UnsatCNF f)
------------------------------------------------------------------------------
-- ** Simplification
------------------------------------------------------------------------------
class WellFoundedSimplifier a where
-- | If the argument can be made simpler, a list of one-step simpler
-- objects. Only in cases where there are multiple "dimensions" to
-- simplify should the returned list have length more than 1. Otherwise
-- returns the empty list.
simplify :: a -> [a]
instance WellFoundedSimplifier a => WellFoundedSimplifier [a] where
simplify [] = []
simplify (x:xs) = case simplify x of
[] -> [xs]
x's-> map (:xs) x's
instance WellFoundedSimplifier () where
simplify () = []
instance WellFoundedSimplifier Bool where
simplify True = [False]
simplify False = []
instance WellFoundedSimplifier Int where
simplify i | i == 0 = []
| i > 0 = [i-1]
| i < 0 = [i+1]
-- Assign the highest variable and reduce the number of variables.
instance WellFoundedSimplifier CNF where
simplify f
| numVars f <= 1 = []
| numVars f > 1 = [ f{ numVars = numVars f - 1
, clauses = clauses'
, numClauses = Set.size clauses' }
-- , f{ clauses = Set.deleteMax (clauses f)
-- , numClauses = numClauses f - 1 }
]
where
clauses' = foldl' assignVar Set.empty (clauses f)
pos = L (numVars f)
neg = negate pos
assignVar outClauses clause =
let clause' = neg `delete` clause
in if pos `elem` clause || null clause' then outClauses
else clause' `Set.insert` outClauses
simplifications :: WellFoundedSimplifier a => a -> [a]
simplifications a = concat $ unfoldr (\ xs -> let r = concatMap simplify xs
in if null r then Nothing
else Just (r, r))
[a]
-- Returns smallest CNF simplification that also gives erroneous output.
minimalError :: CNF -> CNF
minimalError f = lastST f satAndWrong (simplifications f)
where satAndWrong f_inner =
trace (show (numVars f_inner) ++ "/" ++ show (numClauses f_inner)) $
case solve1 f_inner of
(Unsat _,_,_) -> False
(Sat a,_,rt) -> not (verifyBool (Sat a) rt f_inner)
-- last (takeWhile p xs) in the common case.
-- mnemonic: "last Such That"
lastST def _ [] = def
lastST def p (x:xs) = if p x then lastST x p xs else def
prop_lastST (x :: Int) =
if not (null xs) && xa > 3 then
classify True "nontrivial" $
last (takeWhile p xs) == lastST undefined p xs
else True `trivial` True
where p = (> xa `div` 2)
xs = simplifications xa
xa = abs x
getCNF :: Int -> IO CNF
getCNF maxVars = do g <- newStdGen
return (generate (maxVars * 3) g arbitrary)
prob :: IO ParseCNF.CNF
prob = do cnfOrError <- parseFile "./tests/problems/uf20/uf20-0119.cnf"
case cnfOrError of
Left err -> error . show $ err
Right c -> return c
-- | Convert parsed CNF to internal representation.
asCNF :: ParseCNF.CNF -> CNF
asCNF (ParseCNF.CNF v c is) =
CNF {numVars = v
,numClauses = c
,clauses = Set.fromList . map (map fromIntegral . elems) $ is}
-- import qualified Data.ByteString.Char8 as B
-- hStrictGetContents :: Handle -> IO String
-- hStrictGetContents h = do
-- bs <- B.hGetContents h
-- hClose h -- not sure if this is required; ByteString documentation isn't clear.
-- return $ B.unpack bs -- lazy unpack into String
verifyBool :: Solution -> Maybe ResolutionTrace -> CNF -> Bool
verifyBool sol maybeRT formula = isNothing $ verify sol maybeRT formula