sbv 8.7 → 8.8
raw patch · 152 files changed
+4077/−1942 lines, 152 filesdep +bench-showdep −generic-derivingdep ~basedep ~crackNum
Dependencies added: bench-show
Dependencies removed: generic-deriving
Dependency ranges changed: base, crackNum
Files
- CHANGES.md +48/−16
- Data/SBV.hs +31/−22
- Data/SBV/Char.hs +1/−1
- Data/SBV/Client.hs +92/−11
- Data/SBV/Client/BaseIO.hs +28/−4
- Data/SBV/Compilers/C.hs +52/−52
- Data/SBV/Compilers/CodeGen.hs +4/−4
- Data/SBV/Control/BaseIO.hs +2/−2
- Data/SBV/Control/Query.hs +43/−33
- Data/SBV/Control/Types.hs +56/−15
- Data/SBV/Control/Utils.hs +278/−226
- Data/SBV/Core/AlgReals.hs +61/−20
- Data/SBV/Core/Concrete.hs +27/−18
- Data/SBV/Core/Data.hs +58/−17
- Data/SBV/Core/Floating.hs +9/−9
- Data/SBV/Core/Kind.hs +172/−167
- Data/SBV/Core/Model.hs +92/−52
- Data/SBV/Core/Operations.hs +13/−15
- Data/SBV/Core/Symbolic.hs +131/−55
- Data/SBV/Internals.hs +2/−2
- Data/SBV/Provers/ABC.hs +5/−0
- Data/SBV/Provers/Boolector.hs +5/−0
- Data/SBV/Provers/CVC4.hs +5/−0
- Data/SBV/Provers/DReal.hs +64/−0
- Data/SBV/Provers/MathSAT.hs +5/−0
- Data/SBV/Provers/Prover.hs +82/−33
- Data/SBV/Provers/Yices.hs +5/−0
- Data/SBV/Provers/Z3.hs +5/−0
- Data/SBV/RegExp.hs +2/−2
- Data/SBV/SMT/SMT.hs +86/−49
- Data/SBV/SMT/SMTLib.hs +1/−1
- Data/SBV/SMT/SMTLib2.hs +108/−70
- Data/SBV/Tools/BMC.hs +10/−9
- Data/SBV/Tools/GenTest.hs +88/−88
- Data/SBV/Tools/Induction.hs +7/−6
- Data/SBV/Tools/Overflow.hs +1/−1
- Data/SBV/Tools/Polynomial.hs +2/−2
- Data/SBV/Tools/Range.hs +9/−7
- Data/SBV/Tools/WeakestPreconditions.hs +38/−36
- Data/SBV/Trans.hs +1/−1
- Data/SBV/Utils/PrettyNum.hs +10/−10
- Data/SBV/Utils/SExpr.hs +9/−4
- Documentation/SBV/Examples/BitPrecise/Legato.hs +1/−1
- Documentation/SBV/Examples/BitPrecise/MergeSort.hs +1/−1
- Documentation/SBV/Examples/BitPrecise/MultMask.hs +2/−5
- Documentation/SBV/Examples/CodeGeneration/CRC_USB5.hs +1/−1
- Documentation/SBV/Examples/Crypto/AES.hs +3/−3
- Documentation/SBV/Examples/Crypto/SHA.hs +1/−1
- Documentation/SBV/Examples/DeltaSat/DeltaSat.hs +35/−0
- Documentation/SBV/Examples/Existentials/CRCPolynomial.hs +1/−1
- Documentation/SBV/Examples/Lists/BoundedMutex.hs +31/−44
- Documentation/SBV/Examples/Lists/Fibonacci.hs +4/−3
- Documentation/SBV/Examples/Lists/Nested.hs +5/−4
- Documentation/SBV/Examples/Misc/Enumerate.hs +2/−5
- Documentation/SBV/Examples/Misc/Floating.hs +24/−24
- Documentation/SBV/Examples/Optimization/Enumerate.hs +15/−18
- Documentation/SBV/Examples/Optimization/ExtField.hs +2/−2
- Documentation/SBV/Examples/Puzzles/Garden.hs +2/−2
- Documentation/SBV/Examples/Puzzles/HexPuzzle.hs +20/−20
- Documentation/SBV/Examples/Puzzles/U2Bridge.hs +23/−37
- Documentation/SBV/Examples/Queries/AllSat.hs +14/−13
- Documentation/SBV/Examples/Queries/Concurrency.hs +35/−31
- Documentation/SBV/Examples/Queries/Enums.hs +1/−5
- Documentation/SBV/Examples/Queries/FourFours.hs +4/−10
- Documentation/SBV/Examples/Queries/GuessNumber.hs +17/−16
- Documentation/SBV/Examples/Queries/Interpolants.hs +5/−4
- Documentation/SBV/Examples/Strings/RegexCrossword.hs +5/−4
- Documentation/SBV/Examples/Strings/SQLInjection.hs +5/−4
- Documentation/SBV/Examples/Transformers/SymbolicEval.hs +5/−4
- Documentation/SBV/Examples/Uninterpreted/Deduce.hs +6/−5
- Documentation/SBV/Examples/Uninterpreted/Multiply.hs +1/−1
- Documentation/SBV/Examples/Uninterpreted/Sort.hs +10/−6
- Documentation/SBV/Examples/Uninterpreted/UISortAllSat.hs +9/−15
- Documentation/SBV/Examples/WeakestPreconditions/Basics.hs +1/−1
- Documentation/SBV/Examples/WeakestPreconditions/Sum.hs +1/−1
- README.md +4/−4
- SBVBenchSuite/BenchSuite/Bench/Bench.hs +55/−35
- SBVBenchSuite/BenchSuite/BitPrecise/BrokenSearch.hs +1/−1
- SBVBenchSuite/BenchSuite/BitPrecise/MergeSort.hs +4/−6
- SBVBenchSuite/BenchSuite/Lists/BoundedMutex.hs +4/−4
- SBVBenchSuite/BenchSuite/Misc/SoftConstrain.hs +1/−1
- SBVBenchSuite/BenchSuite/Misc/Tuple.hs +1/−1
- SBVBenchSuite/BenchSuite/Optimization/ExtField.hs +3/−1
- SBVBenchSuite/BenchSuite/ProofTools/BMC.hs +2/−2
- SBVBenchSuite/BenchSuite/ProofTools/Fibonacci.hs +1/−1
- SBVBenchSuite/BenchSuite/ProofTools/Strengthen.hs +6/−6
- SBVBenchSuite/BenchSuite/ProofTools/Sum.hs +1/−1
- SBVBenchSuite/BenchSuite/Puzzles/Birthday.hs +3/−1
- SBVBenchSuite/BenchSuite/Puzzles/Coins.hs +2/−2
- SBVBenchSuite/BenchSuite/Puzzles/Counts.hs +3/−3
- SBVBenchSuite/BenchSuite/Puzzles/DogCatMouse.hs +1/−1
- SBVBenchSuite/BenchSuite/Puzzles/Euler185.hs +1/−1
- SBVBenchSuite/BenchSuite/Puzzles/Garden.hs +1/−1
- SBVBenchSuite/BenchSuite/Puzzles/LadyAndTigers.hs +1/−1
- SBVBenchSuite/BenchSuite/Puzzles/SendMoreMoney.hs +1/−1
- SBVBenchSuite/BenchSuite/Puzzles/Sudoku.hs +1/−1
- SBVBenchSuite/BenchSuite/Puzzles/U2Bridge.hs +5/−5
- SBVBenchSuite/BenchSuite/Strings/SQLInjection.hs +3/−1
- SBVBenchSuite/BenchSuite/Uninterpreted/UISortAllSat.hs +3/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Basics.hs +6/−6
- SBVBenchSuite/SBVBench.hs +33/−280
- SBVBenchSuite/SBVBenchmark.hs +394/−0
- SBVBenchSuite/Utils/SBVBenchFramework.hs +150/−1
- SBVTestSuite/GoldFiles/array_caching_01.gold +41/−0
- SBVTestSuite/GoldFiles/array_caching_02.gold +41/−0
- SBVTestSuite/GoldFiles/constArr2_SArray.gold +73/−0
- SBVTestSuite/GoldFiles/constArr2_SFunArray.gold +67/−0
- SBVTestSuite/GoldFiles/constArr_SArray.gold +74/−0
- SBVTestSuite/GoldFiles/constArr_SFunArray.gold +68/−0
- SBVTestSuite/GoldFiles/dsat01.gold +70/−0
- SBVTestSuite/GoldFiles/qUninterp1.gold +6/−3
- SBVTestSuite/GoldFiles/queryArrays2.gold +2/−2
- SBVTestSuite/GoldFiles/queryArrays3.gold +2/−2
- SBVTestSuite/GoldFiles/queryArrays4.gold +2/−2
- SBVTestSuite/GoldFiles/queryTables.gold +139/−0
- SBVTestSuite/GoldFiles/query_cvc4.gold +3/−3
- SBVTestSuite/GoldFiles/set_uninterp1.gold +15/−15
- SBVTestSuite/GoldFiles/tgen_c.gold +10/−10
- SBVTestSuite/GoldFiles/tgen_forte.gold +10/−10
- SBVTestSuite/GoldFiles/tgen_haskell.gold +10/−10
- SBVTestSuite/GoldFiles/unint-axioms-query.gold +1/−1
- SBVTestSuite/GoldFiles/validate_2.gold +4/−4
- SBVTestSuite/SBVConnectionTest.hs +78/−0
- SBVTestSuite/SBVDocTest.hs +11/−2
- SBVTestSuite/SBVTest.hs +6/−0
- SBVTestSuite/TestSuite/Arrays/Caching.hs +45/−0
- SBVTestSuite/TestSuite/Arrays/InitVals.hs +34/−4
- SBVTestSuite/TestSuite/Arrays/Query.hs +13/−11
- SBVTestSuite/TestSuite/Basics/AllSat.hs +6/−5
- SBVTestSuite/TestSuite/Basics/BoundedList.hs +4/−3
- SBVTestSuite/TestSuite/Basics/DynSign.hs +2/−2
- SBVTestSuite/TestSuite/Basics/List.hs +4/−3
- SBVTestSuite/TestSuite/Basics/PseudoBoolean.hs +4/−3
- SBVTestSuite/TestSuite/Basics/Recursive.hs +2/−2
- SBVTestSuite/TestSuite/Basics/Set.hs +3/−0
- SBVTestSuite/TestSuite/Basics/SmallShifts.hs +3/−3
- SBVTestSuite/TestSuite/Basics/String.hs +4/−3
- SBVTestSuite/TestSuite/Basics/Sum.hs +4/−3
- SBVTestSuite/TestSuite/Basics/Tuple.hs +4/−1
- SBVTestSuite/TestSuite/Puzzles/Temperature.hs +2/−2
- SBVTestSuite/TestSuite/Puzzles/U2Bridge.hs +2/−1
- SBVTestSuite/TestSuite/Queries/DSat.hs +69/−0
- SBVTestSuite/TestSuite/Queries/Enums.hs +0/−1
- SBVTestSuite/TestSuite/Queries/FreshVars.hs +4/−3
- SBVTestSuite/TestSuite/Queries/Int_ABC.hs +6/−5
- SBVTestSuite/TestSuite/Queries/Tables.hs +170/−0
- SBVTestSuite/TestSuite/Queries/UISat.hs +4/−3
- SBVTestSuite/TestSuite/Queries/Uninterpreted.hs +7/−9
- SBVTestSuite/TestSuite/Uninterpreted/Axioms.hs +8/−8
- SBVTestSuite/TestSuite/Uninterpreted/Sort.hs +7/−10
- SBVTestSuite/Utils/SBVTestFramework.hs +21/−14
- sbv.cabal +181/−58
CHANGES.md view
@@ -1,18 +1,50 @@ * Hackage: <http://hackage.haskell.org/package/sbv> * GitHub: <http://leventerkok.github.com/sbv/> -* Latest Hackage released version: 8.7, 2020-06-30+* Latest Hackage released version: 8.8, 2020-09-04 +### Version 8.8, 2020-09-04++ * Reworked uninterpreted sorts. Added new function `mkUninterpretedSort` to make+ declaration of completely uninterpreted sorts easier. In particular, we now+ automatically introduce the symbolic variant of the type (by prefixing the+ underlying type with `S`) so it becomes automatically available, both for uninterpreted+ sorts and enumerations. In the latter case, we also automatically introduce the value `sX`+ for each enumeration constant `X`, defined to be precisely `literal X`.++ * Handle incremental mode table-declarations that depend on freshly declared variables. Thanks+ to Gergő Érdi for reporting.++ * Fix a soundness bug in SFunArray caching. Thanks to Gergő Érdi for reporting. See+ https://github.com/LeventErkok/sbv/issues/541 for details.++ * Add support for the dReal solver, and introduce the notion of delta-satisfiability,+ where you can now check properties to be satisfiable against delta-perturbations.+ See "Documentation.SBV.Examples.DeltaSat.DeltaSat" for a basic example.++ * Add "extraArgs" parameter to SMTConfig to simplify passing extra command line+ arguments to the solver.++ * Add a method ++ sListArray :: (HasKind a, SymVal b) => b -> [(SBV a, SBV b)] -> array a b++ to the `SymArray` class, which allows for creation of arrays from lists of constant or + symbolic lists of pairs. The first argument is the value to use for uninitialized entries.+ Note that the initializer must be a known constant, i.e., it cannot be symbolic. Latter+ elements of the list will overwrite the earlier ones, if there are repeated keys.++ * Thanks to Jan Hrcek, a whole bunch of typos were fixed in the documentation and+ the source code. Much appreciated!+ ### Version 8.7, 2020-06-30 - * Add support for concurrent versions of solvers for query- problems. Similar to 'satWithAny', 'proveWithAny' etc.,- except when we have queries. Thanks to Jeffrey Young+ * Add support for concurrent versions of solvers for query problems. Similar to+ `satWithAny`, `proveWithAny` etc., except when we have queries. Thanks to Jeffrey Young for the idea and the implementation. - * Add "Documentation.SBV.Examples.Misc.Newtypes", demonstrating- how to use newtypes over existing symbolic types as- symbolic quantities themselves. Thanks to Curran McConnell+ * Add "Documentation.SBV.Examples.Misc.Newtypes", demonstrating how to use newtypes+ over existing symbolic types as symbolic quantities themselves. Thanks to Curran McConnell for the example. * Added new predicate `sNotElem`, negating `sElem`.@@ -290,7 +322,7 @@ 'SDouble'. For the floating types, it is object equality, that is 'NaN .=== Nan' and '0 ./== -0'. Use the regular equality for float/double's as they follow the IEEE754 rules, but occasionally we need to express object equality in a polymorphic- way. Essentially this method is the polymorphic equaivalent of 'fpIsEqualObject'+ way. Essentially this method is the polymorphic equivalent of 'fpIsEqualObject' except it works on all types. * Removed the redundant 'SDivisible' constraint on rotate-left and rotate-right operations.@@ -318,11 +350,11 @@ It accepts bit-vectors as arguments and an unsigned rotation quantity to keep things simple. - * Added new configuration option 'allowQueryQuantifers', default is set to False.+ * Added new configuration option 'allowQuantifiedQueries', default is set to False. SBV normally doesn't allow quantifiers in a query context, because there are issues surrounding 'getValue'. However, Joel Burget pointed out this check is too strict for certain scenarios. So, as an escape hatch, you can define- 'allowQueryQuantifers' to be 'True' and SBV will bypass this check. Of course,+ 'allowQuantifiedQueries' to be 'True' and SBV will bypass this check. Of course, if you do this, then you are on your own regarding calls to `getValue` with quantified parameters! See http://github.com/LeventErkok/sbv/issues/459 for details.@@ -768,7 +800,7 @@ suggestion. * Add 'observe'. This function allows internal expressions to be- given values, which will be part of the satisfyin model or+ given values, which will be part of the satisfying model or the counter-example upon model construction. Useful for tracking expected/returned values. Also works with quickCheck. @@ -799,7 +831,7 @@ ### Version 7.5, Released 2018-01-13 - * Remove obsolote references to tactics in a few haddock comments. Thanks+ * Remove obsolete references to tactics in a few haddock comments. Thanks to Matthew Pickering for reporting. * Added logic Logic_NONE, to be used in cases where SBV should not@@ -848,7 +880,7 @@ sPopCount :: SBV a -> SWord8 -- ^ Variant of 'popCount', returning a symbolic value. setBitTo :: SBV a -> Int -> SBool -> SBV a -- ^ A combo of 'setBit' and 'clearBit', when the bit to be set is symbolic. fullAdder :: SBV a -> SBV a -> (SBool, SBV a) -- ^ Full adder, returns carry-out from the addition. Only for unsigned quantities.- fullMultiplier :: SBV a -> SBV a -> (SBV a, SBV a) -- ^ Full multipler, returns both high and low-order bits. Only for unsigned quantities.+ fullMultiplier :: SBV a -> SBV a -> (SBV a, SBV a) -- ^ Full multiplier, returns both high and low-order bits. Only for unsigned quantities. sCountLeadingZeros :: SBV a -> SWord8 -- ^ Count leading zeros in a word, big-endian interpretation sCountTrailingZeros :: SBV a -> SWord8 -- ^ Count trailing zeros in a word, big-endian interpretation @@ -1262,7 +1294,7 @@ ### Version 5.12, 2016-06-06 - * Fix GHC8.0 compliation issues, and warning clean-up. Thanks to Adam Foltzer for the bulk+ * Fix GHC8.0 compilation issues, and warning clean-up. Thanks to Adam Foltzer for the bulk of the work and Tom Sydney Kerckhove for the initial patch for 8.0 compatibility. * Minor fix to printing models with floats when the base is 2/16, making sure the alignment@@ -1385,7 +1417,7 @@ * fpMin, fpMax: If these functions receive +0/-0 as their two arguments, i.e., both zeros but alternating signs in any order, then SMTLib requires the output to be- nondeterministicly chosen. Previously, we fixed this result as +0 following the+ nondeterministically chosen. Previously, we fixed this result as +0 following the interpretation in Z3, but Z3 recently changed and now incorporates the nondeterministic output. SBV similarly changed to allow for non-determinism here. @@ -1572,7 +1604,7 @@ Value: +2.0 (NORMAL) ``` - * Change how we print type info; for models insted of SType just print Type (i.e.,+ * Change how we print type info; for models instead of SType just print Type (i.e., for SWord8, instead print Word8) which makes more sense and is more consistent. This change should be mostly relevant as how we see the counter-example output.
Data/SBV.hs view
@@ -116,6 +116,8 @@ -- -- * Yices from SRI: <http://yices.csl.sri.com/> --+-- * DReal from CMU: <http://dreal.github.io/>+-- -- * Z3 from Microsoft: <http://github.com/Z3Prover/z3/wiki> -- -- SBV requires recent versions of these solvers; please see the file@@ -156,7 +158,7 @@ , SFloat, SDouble -- ** Algebraic reals -- $algReals- , SReal, AlgReal, sRealToSInteger, algRealToRational+ , SReal, AlgReal(..), sRealToSInteger, algRealToRational, RealPoint(..), realPoint, RationalCV(..) -- ** Characters, Strings and Regular Expressions -- $strings , SChar, SString@@ -171,7 +173,7 @@ -- ** Sets , RCSet(..), SSet -- * Arrays of symbolic values- , SymArray(readArray, writeArray, mergeArrays), newArray_, newArray, SArray, SFunArray+ , SymArray(readArray, writeArray, mergeArrays, sListArray), newArray_, newArray, SArray, SFunArray -- * Creating symbolic values -- ** Single value@@ -244,15 +246,20 @@ -- * Uninterpreted sorts, axioms, constants, and functions -- $uninterpreted- , Uninterpreted(..), addAxiom+ , mkUninterpretedSort, Uninterpreted(..), addAxiom -- * Properties, proofs, and satisfiability -- $proveIntro -- $noteOnNestedQuantifiers -- $multiIntro , Predicate, Goal- , Provable, forAll_, forAll, forSome_, forSome, prove, proveWith, sat- , satWith, allSat, allSatWith, optimize, optimizeWith, isVacuous+ , Provable, forAll_, forAll, forSome_, forSome+ , prove, proveWith+ , dprove, dproveWith+ , sat, satWith+ , dsat, dsatWith+ , allSat, allSatWith+ , optimize, optimizeWith, isVacuous , isVacuousWith, isTheorem, isTheoremWith, isSatisfiable, isSatisfiableWith , proveWithAll, proveWithAny, satWithAll , proveConcurrentWithAny, proveConcurrentWithAll, satConcurrentWithAny, satConcurrentWithAll@@ -323,9 +330,9 @@ -- $verbosity -- ** Solvers- , boolector, cvc4, yices, z3, mathSAT, abc+ , boolector, cvc4, yices, dReal, z3, mathSAT, abc -- ** Configurations- , defaultSolverConfig, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers+ , defaultSolverConfig, defaultSMTCfg, defaultDeltaSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers , setLogic, Logic(..), setOption, setInfo, setTimeOut -- ** SBV exceptions , SBVException(..)@@ -370,6 +377,7 @@ import Data.SBV.Provers.Prover hiding (forAll_, forAll, forSome_, forSome, prove, proveWith, sat, satWith, allSat,+ dsat, dsatWith, dprove, dproveWith, allSatWith, optimize, optimizeWith, isVacuous, isVacuousWith, isTheorem, isTheoremWith, isSatisfiable,@@ -835,18 +843,19 @@ -} {- $uninterpreted-Users can introduce new uninterpreted sorts simply by defining a data-type in Haskell and registering it as such. The+Users can introduce new uninterpreted sorts simply by defining an empty data-type in Haskell and registering it as such. The following example demonstrates: @- data B = B () deriving (Eq, Ord, Show, Read, Data, SymVal, HasKind, SatModel)+ data B+ mkUninterpretedSort ''B @ -(Note that you'll also need to use the language pragmas @DeriveDataTypeable@, @DeriveAnyClass@, and import @Data.Generics@ for the above to work.)+(Note that you'll also need to use pragmas @TemplateHaskell@, @StandAloneDeriving@, @DeriveDataTypeable@, and @DeriveAnyClass@ for this to work, follow GHC's error messages!) This is all it takes to introduce @B@ as an uninterpreted sort in SBV, which makes the type @SBV B@ automagically become available as the type-of symbolic values that ranges over @B@ values. Note that the @()@ argument is important to distinguish it from enumerations, which will be-translated to proper SMT data-types.+of symbolic values that ranges over @B@ values. Note that this will also introduce the type @SB@ into your environment, which is a synonym+for @SBV B@. Uninterpreted functions over both uninterpreted and regular sorts can be declared using the facilities introduced by@@ -854,8 +863,9 @@ -} {- $enumerations-If the uninterpreted sort definition takes the form of an enumeration (i.e., a simple data type with all nullary constructors), then SBV will actually-translate that as just such a data-type to SMT-Lib, and will use the constructors as the inhabitants of the said sort. A simple example is:+If the uninterpreted sort definition takes the form of an enumeration (i.e., a simple data type with all nullary constructors), then +tou can use the 'mkSymbolicEnumeration' functio to turn it into an enumeration in SMTLib.+A simple example is: @ data X = A | B | C@@ -870,17 +880,17 @@ > LANGUAGE DeriveDataTypeable > LANGUAGE DeriveAnyClass -Now, the user can define+The declaration will automatically introduce the type: @ type SX = SBV X @ -and treat @SX@ as a regular symbolic type ranging over the values @A@, @B@, and @C@. Such values can be compared for equality, and with the usual-other comparison operators, such as @.==@, @./=@, @.>@, @.>=@, @<@, and @<=@.+along with symbolic values of each of the enumerated values @sA@, @sB@, and @sC@. This way,+you can refer to the symbolic version as @SX@, treating it as a regular symbolic type ranging over the values @A@, @B@, and @C@. Such values can be compared for equality, and with the usual+other comparison operators, such as @.==@, @./=@, @.>@, @.>=@, @<@, and @<=@. For each enumerated value @X@, the symbolic versions @sX@ is defined to be equal to @literal X@. -Note that in this latter case the type is no longer uninterpreted, but is properly represented as a simple enumeration of the said elements. A simple-query would look like:+A simple query would look like: @ allSat $ \x -> x .== (x :: SX)@@ -898,14 +908,13 @@ Found 3 different solutions. @ -Note that the result is properly typed as @X@ elements; these are not mere strings. So, in a 'getModelAssignment' scenario, the user can recover actual-elements of the domain and program further with those values as usual.+Note that the result is properly typed as @X@ elements; these are not mere strings. See "Documentation.SBV.Examples.Misc.Enumerate" for an extended example on how to use symbolic enumerations. -} {- $noteOnNestedQuantifiers-=== A note on reasoning in the presence of quantifers+=== A note on reasoning in the presence of quantifiers Note that SBV allows reasoning with quantifiers: Inputs can be existentially or universally quantified. Predicates can be built with arbitrary nesting of such quantifiers as well. However, SBV always /assumes/ that the input is in
Data/SBV/Char.hs view
@@ -151,7 +151,7 @@ where uc = toUpper c o = ord uc --- | Convert an an integer to a digit, inverse of 'digitToInt'. If the integer is out of+-- | Convert an integer to a digit, inverse of 'digitToInt'. If the integer is out of -- bounds, we return the arbitrarily chosen space character. Note that for hexadecimal -- letters, we return the corresponding lowercase letter. --
Data/SBV/Client.hs view
@@ -22,6 +22,7 @@ , defaultSolverConfig , sbvAvailableSolvers , mkSymbolicEnumeration+ , mkUninterpretedSort ) where import Control.Monad (filterM)@@ -48,6 +49,7 @@ defaultSolverConfig :: Solver -> SMTConfig defaultSolverConfig Z3 = z3 defaultSolverConfig Yices = yices+defaultSolverConfig DReal = dReal defaultSolverConfig Boolector = boolector defaultSolverConfig CVC4 = cvc4 defaultSolverConfig MathSAT = mathSAT@@ -57,16 +59,95 @@ sbvAvailableSolvers :: IO [SMTConfig] sbvAvailableSolvers = filterM sbvCheckSolverInstallation (map defaultSolverConfig [minBound .. maxBound]) +-- | Turn a name into a symbolic type. If first argument is true, we'll also derive Eq and Ord instances.+declareSymbolic :: Bool -> TH.Name -> TH.Q [TH.Dec]+declareSymbolic isEnum typeName = do+ let typeCon = TH.conT typeName++ cstrs <- if isEnum then ensureEnumeration typeName+ else ensureEmptyData typeName++ deriveEqOrds <- if isEnum+ then [d| deriving instance Eq $(typeCon)+ deriving instance Ord $(typeCon)+ |]+ else pure []++ derives <- [d| deriving instance Show $(typeCon)+ deriving instance Read $(typeCon)+ deriving instance Data $(typeCon)+ deriving instance SymVal $(typeCon)+ deriving instance HasKind $(typeCon)+ deriving instance SatModel $(typeCon)+ |]+++ sType <- TH.conT ''SBV `TH.appT` typeCon++ let declConstructor c = [sig, def]+ where nm = TH.mkName $ 's' : TH.nameBase c+ def = TH.FunD nm [TH.Clause [] (TH.NormalB body) []]+ body = TH.AppE (TH.VarE 'literal) (TH.ConE c)+ sig = TH.SigD nm sType++ cdecl = concatMap declConstructor cstrs++ let tdecl = TH.TySynD (TH.mkName ('S' : TH.nameBase typeName)) [] sType+ pure $ deriveEqOrds ++ derives ++ [tdecl] ++ cdecl+ -- | Make an enumeration a symbolic type. mkSymbolicEnumeration :: TH.Name -> TH.Q [TH.Dec]-mkSymbolicEnumeration typeName = do- let typeCon = TH.conT typeName- [d| deriving instance Eq $(typeCon)- deriving instance Show $(typeCon)- deriving instance Ord $(typeCon)- deriving instance Read $(typeCon)- deriving instance Data $(typeCon)- deriving instance SymVal $(typeCon)- deriving instance HasKind $(typeCon)- deriving instance SatModel $(typeCon)- |]+mkSymbolicEnumeration = declareSymbolic True++-- | Make an uninterpred sort.+mkUninterpretedSort :: TH.Name -> TH.Q [TH.Dec]+mkUninterpretedSort = declareSymbolic False++-- | Make sure the given type is an enumeration+ensureEnumeration :: TH.Name -> TH.Q [TH.Name]+ensureEnumeration nm = do+ c <- TH.reify nm+ case c of+ TH.TyConI d -> case d of+ TH.DataD _ _ _ _ cons _ -> case cons of+ [] -> bad "The datatype given has no constructors."+ xs -> concat <$> mapM check xs+ _ -> bad "The name given is not a datatype."++ _ -> bad "The name given is not a datatype."+ where n = TH.nameBase nm++ check (TH.NormalC c xs) = case xs of+ [] -> pure [c]+ _ -> bad $ "Constructor " ++ show c ++ " has arguments."++ check c = bad $ "Constructor " ++ show c ++ " is not an enumeration value."++ bad m = do TH.reportError $ unlines [ "Data.SBV.mkSymbolicEnumeration: Invalid argument " ++ show n+ , ""+ , " Expected an enumeration. " ++ m+ , ""+ , " To create an enumerated sort, use a simple Haskell enumerated type."+ ]+ pure []++-- | Make sure the given type is an empty data+ensureEmptyData :: TH.Name -> TH.Q [TH.Name]+ensureEmptyData nm = do+ c <- TH.reify nm+ case c of+ TH.TyConI d -> case d of+ TH.DataD _ _ _ _ cons _ -> case cons of+ [] -> pure []+ _ -> bad "The datatype given has constructors."+ _ -> bad "The name given is not a datatype."++ _ -> bad "The name given is not a datatype."+ where n = TH.nameBase nm+ bad m = do TH.reportError $ unlines [ "Data.SBV.mkUninterpretedSort: Invalid argument " ++ show n+ , ""+ , " Expected an empty datatype. " ++ m+ , ""+ , " To create an uninterpreted sort, use an empty datatype declaration."+ ]+ pure []
Data/SBV/Client/BaseIO.hs view
@@ -30,7 +30,7 @@ SWord64, SEither, SMaybe, SSet) import Data.SBV.Core.Sized (SInt, SWord, IntN, WordN, IsNonZero) import Data.SBV.Core.Model (Metric(..), SymTuple)-import Data.SBV.Core.Symbolic (Objective, OptimizeStyle, Quantifier, Result,+import Data.SBV.Core.Symbolic (Objective, OptimizeStyle, Result, VarContext, Symbolic, SBVRunMode, SMTConfig, SVal) import Data.SBV.Control.Types (SMTOption) import Data.SBV.Provers.Prover (Provable, SExecutable, ThmResult)@@ -103,6 +103,18 @@ proveWith :: Provable a => SMTConfig -> a -> IO ThmResult proveWith = Trans.proveWith +-- | Prove a predicate with delta-satisfiability, using the default solver.+--+-- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.prove'+dprove :: Provable a => a -> IO ThmResult+dprove = Trans.dprove++-- | Prove the predicate with delta-satisfiability using the given SMT-solver.+--+-- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.proveWith'+dproveWith :: Provable a => SMTConfig -> a -> IO ThmResult+dproveWith = Trans.dproveWith+ -- | Find a satisfying assignment for a predicate, using the default solver. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.sat'@@ -115,6 +127,18 @@ satWith :: Provable a => SMTConfig -> a -> IO SatResult satWith = Trans.satWith +-- | Find a delta-satisfying assignment for a predicate, using the default solver for delta-satisfiability.+--+-- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.dsat'+dsat :: Provable a => a -> IO SatResult+dsat = Trans.dsat++-- | Find a satisfying assignment using the given SMT-solver.+--+-- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.satWith'+dsatWith :: Provable a => SMTConfig -> a -> IO SatResult+dsatWith = Trans.dsatWith+ -- | Find all satisfying assignments, using the default solver. -- Equivalent to @'allSatWith' 'Data.SBV.defaultSMTCfg'@. See 'allSatWith' for details. --@@ -223,7 +247,7 @@ -- | Create a symbolic variable. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.mkSymSBV'-mkSymSBV :: Maybe Quantifier -> Kind -> Maybe String -> Symbolic (SBV a)+mkSymSBV :: VarContext -> Kind -> Maybe String -> Symbolic (SBV a) mkSymSBV = Trans.mkSymSBV -- | Convert a symbolic value to an SV, inside the Symbolic monad@@ -308,7 +332,7 @@ -- | One stop allocator -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.mkSymVal'-mkSymVal :: SymVal a => Maybe Quantifier -> Maybe String -> Symbolic (SBV a)+mkSymVal :: SymVal a => VarContext -> Maybe String -> Symbolic (SBV a) mkSymVal = Trans.mkSymVal -- | Create a new anonymous array, possibly with a default initial value.@@ -328,7 +352,7 @@ -- | Generically make a symbolic var -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.genMkSymVar'-genMkSymVar :: Kind -> Maybe Quantifier -> Maybe String -> Symbolic (SBV a)+genMkSymVar :: Kind -> VarContext -> Maybe String -> Symbolic (SBV a) genMkSymVar = Trans.genMkSymVar -- | Declare a named 'SBool'
Data/SBV/Compilers/C.hs view
@@ -193,20 +193,20 @@ -- | The printf specifier for the type specifier :: CgConfig -> SV -> Doc specifier cfg sv = case kindOf sv of- KBool -> spec (False, 1)- KBounded b i -> spec (b, i)- KUnbounded -> spec (True, fromJust (cgInteger cfg))- KReal -> specF (fromJust (cgReal cfg))- KFloat -> specF CgFloat- KDouble -> specF CgDouble- KString -> text "%s"- KChar -> text "%c"- KList k -> die $ "list sort: " ++ show k- KSet k -> die $ "set sort: " ++ show k- KUninterpreted s _ -> die $ "uninterpreted sort: " ++ s- KTuple k -> die $ "tuple sort: " ++ show k- KMaybe k -> die $ "maybe sort: " ++ show k- KEither k1 k2 -> die $ "either sort: " ++ show (k1, k2)+ KBool -> spec (False, 1)+ KBounded b i -> spec (b, i)+ KUnbounded -> spec (True, fromJust (cgInteger cfg))+ KReal -> specF (fromJust (cgReal cfg))+ KFloat -> specF CgFloat+ KDouble -> specF CgDouble+ KString -> text "%s"+ KChar -> text "%c"+ KList k -> die $ "list sort: " ++ show k+ KSet k -> die $ "set sort: " ++ show k+ KUserSort s _ -> die $ "user sort: " ++ s+ KTuple k -> die $ "tuple sort: " ++ show k+ KMaybe k -> die $ "maybe sort: " ++ show k+ KEither k1 k2 -> die $ "either sort: " ++ show (k1, k2) where u8InHex = cgShowU8InHex cfg spec :: (Bool, Int) -> Doc@@ -476,7 +476,7 @@ where asserts | cgIgnoreAsserts cfg = [] | True = origAsserts - usorts = [s | KUninterpreted s _ <- Set.toList kindInfo, s /= "RoundingMode"] -- No support for any sorts other than RoundingMode!+ usorts = [s | KUserSort s _ <- Set.toList kindInfo, s /= "RoundingMode"] -- No support for any sorts other than RoundingMode! pre = text "/* File:" <+> doubleQuotes (nm P.<> text ".c") P.<> text ". Automatically generated by SBV. Do not edit! */" $$ text ""@@ -511,21 +511,21 @@ $$ text "" typeWidth = getMax 0 $ [len (kindOf s) | (s, _) <- assignments] ++ [len (kindOf s) | (_, (s, _)) <- fst ins]- where len KReal{} = 5- len KFloat{} = 6 -- SFloat- len KDouble{} = 7 -- SDouble- len KString{} = 7 -- SString- len KChar{} = 5 -- SChar- len KUnbounded{} = 8- len KBool = 5 -- SBool- len (KBounded False n) = 5 + length (show n) -- SWordN- len (KBounded True n) = 4 + length (show n) -- SIntN- len (KList s) = die $ "List sort: " ++ show s- len (KSet s) = die $ "Set sort: " ++ show s- len (KTuple s) = die $ "Tuple sort: " ++ show s- len (KMaybe k) = die $ "Maybe sort: " ++ show k- len (KEither k1 k2) = die $ "Either sort: " ++ show (k1, k2)- len (KUninterpreted s _) = die $ "Uninterpreted sort: " ++ s+ where len KReal{} = 5+ len KFloat{} = 6 -- SFloat+ len KDouble{} = 7 -- SDouble+ len KString{} = 7 -- SString+ len KChar{} = 5 -- SChar+ len KUnbounded{} = 8+ len KBool = 5 -- SBool+ len (KBounded False n) = 5 + length (show n) -- SWordN+ len (KBounded True n) = 4 + length (show n) -- SIntN+ len (KList s) = die $ "List sort: " ++ show s+ len (KSet s) = die $ "Set sort: " ++ show s+ len (KTuple s) = die $ "Tuple sort: " ++ show s+ len (KMaybe k) = die $ "Maybe sort: " ++ show k+ len (KEither k1 k2) = die $ "Either sort: " ++ show (k1, k2)+ len (KUserSort s _) = die $ "Uninterpreted sort: " ++ s getMax 8 _ = 8 -- 8 is the max we can get with SInteger, so don't bother looking any further getMax m [] = m@@ -671,16 +671,16 @@ fpArgs = case as of [] -> [] ((m, _):args) -> case kindOf m of- KUninterpreted "RoundingMode" _ -> case checkRM (m `lookup` consts) of- Nothing -> args- Just (Left msg) -> die msg- Just (Right msg) -> tbd msg- _ -> as+ KUserSort "RoundingMode" _ -> case checkRM (m `lookup` consts) of+ Nothing -> args+ Just (Left msg) -> die msg+ Just (Right msg) -> tbd msg+ _ -> as -- Check that the RM is RoundNearestTiesToEven. -- If we start supporting other rounding-modes, this would be the point where we'd insert the rounding-mode set/reset code -- instead of merely returning OK or not- checkRM (Just cv@(CV (KUninterpreted "RoundingMode" _) v)) =+ checkRM (Just cv@(CV (KUserSort "RoundingMode" _) v)) = case v of CUserSort (_, "RoundNearestTiesToEven") -> Nothing CUserSort (_, s) -> Just (Right $ "handleIEEE: Unsupported rounding-mode: " ++ show s ++ " for: " ++ show w)@@ -771,22 +771,22 @@ canOverflow False sz = (2::Integer)^sz -1 >= fromIntegral len (needsCheckL, needsCheckR) = case k of- KBool -> (False, canOverflow False (1::Int))- KBounded sg sz -> (sg, canOverflow sg sz)- KReal -> die "array index with real value"- KFloat -> die "array index with float value"- KDouble -> die "array index with double value"- KString -> die "array index with string value"- KChar -> die "array index with character value"- KUnbounded -> case cgInteger cfg of- Nothing -> (True, True) -- won't matter, it'll be rejected later- Just i -> (True, canOverflow True i)- KList s -> die $ "List sort " ++ show s- KSet s -> die $ "Set sort " ++ show s- KTuple s -> die $ "Tuple sort " ++ show s- KMaybe ek -> die $ "Maybe sort " ++ show ek- KEither k1 k2 -> die $ "Either sort " ++ show (k1, k2)- KUninterpreted s _ -> die $ "Uninterpreted sort: " ++ s+ KBool -> (False, canOverflow False (1::Int))+ KBounded sg sz -> (sg, canOverflow sg sz)+ KReal -> die "array index with real value"+ KFloat -> die "array index with float value"+ KDouble -> die "array index with double value"+ KString -> die "array index with string value"+ KChar -> die "array index with character value"+ KUnbounded -> case cgInteger cfg of+ Nothing -> (True, True) -- won't matter, it'll be rejected later+ Just i -> (True, canOverflow True i)+ KList s -> die $ "List sort " ++ show s+ KSet s -> die $ "Set sort " ++ show s+ KTuple s -> die $ "Tuple sort " ++ show s+ KMaybe ek -> die $ "Maybe sort " ++ show ek+ KEither k1 k2 -> die $ "Either sort " ++ show (k1, k2)+ KUserSort s _ -> die $ "Uninterpreted sort: " ++ s -- Div/Rem should be careful on 0, in the SBV world x `div` 0 is 0, x `rem` 0 is x -- NB: Quot is supposed to truncate toward 0; Not clear to me if C guarantees this behavior.
Data/SBV/Compilers/CodeGen.hs view
@@ -55,7 +55,7 @@ import qualified Text.PrettyPrint.HughesPJ as P (render) import Data.SBV.Core.Data-import Data.SBV.Core.Symbolic (MonadSymbolic(..), svToSymSV, svMkSymVar, outputSVal)+import Data.SBV.Core.Symbolic (MonadSymbolic(..), svToSymSV, svMkSymVar, outputSVal, VarContext(..)) #if MIN_VERSION_base(4,11,0) import Control.Monad.Fail as Fail@@ -173,7 +173,7 @@ cgSRealType rt = modify' (\s -> s {cgFinalConfig = (cgFinalConfig s) { cgReal = Just rt }}) -- | Should we generate a driver program? Default: 'True'. When a library is generated, it will have--- a driver if any of the contituent functions has a driver. (See 'Data.SBV.Tools.CodeGen.compileToCLib'.)+-- a driver if any of the constituent functions has a driver. (See 'Data.SBV.Tools.CodeGen.compileToCLib'.) cgGenerateDriver :: Bool -> SBVCodeGen () cgGenerateDriver b = modify' (\s -> s { cgFinalConfig = (cgFinalConfig s) { cgGenDriver = b } }) @@ -216,7 +216,7 @@ -- | Creates an atomic input in the generated code. svCgInput :: Kind -> String -> SBVCodeGen SVal-svCgInput k nm = do r <- symbolicEnv >>= liftIO . svMkSymVar (Just ALL) k Nothing+svCgInput k nm = do r <- symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar (Just ALL)) k Nothing sv <- svToSymSV r modify' (\s -> s { cgInputs = (nm, CgAtomic sv) : cgInputs s }) return r@@ -225,7 +225,7 @@ svCgInputArr :: Kind -> Int -> String -> SBVCodeGen [SVal] svCgInputArr k sz nm | sz < 1 = error $ "SBV.cgInputArr: Array inputs must have at least one element, given " ++ show sz ++ " for " ++ show nm- | True = do rs <- symbolicEnv >>= liftIO . replicateM sz . svMkSymVar (Just ALL) k Nothing+ | True = do rs <- symbolicEnv >>= liftIO . replicateM sz . svMkSymVar (NonQueryVar (Just ALL)) k Nothing sws <- mapM svToSymSV rs modify' (\s -> s { cgInputs = (nm, CgArray sws) : cgInputs s }) return rs
Data/SBV/Control/BaseIO.hs view
@@ -54,7 +54,7 @@ getObservables :: Query [(String, CV)] getObservables = Trans.getObservables --- | Get the uinterpreted constants/functions recorded during a run.+-- | Get the uninterpreted constants/functions recorded during a run. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.getUIs' getUIs :: Query [(String, SBVType)]@@ -488,7 +488,7 @@ -- Semantics: The call @timeout n q@ causes the timeout value to be applied to all interactive calls that take place -- as we execute the query @q@. That is, each call that happens during the execution of @q@ gets a separate -- time-out value, as opposed to one timeout value that limits the whole query. This is typically the intended behavior.--- It is advisible to apply this combinator to calls that involve a single call to the solver for+-- It is advisable to apply this combinator to calls that involve a single call to the solver for -- finer control, as opposed to an entire set of interactions. However, different use cases might call for different scenarios. -- -- If the solver responds within the time-out specified, then we continue as usual. However, if the backend solver times-out
Data/SBV/Control/Query.hs view
@@ -208,22 +208,24 @@ ensureSat = do cfg <- getConfig cs <- checkSatUsing $ satCmd cfg case cs of- Sat -> return ()- Unk -> do s <- getUnknownReason- error $ unlines [ ""- , "*** Data.SBV.ensureSat: Solver reported Unknown!"- , "*** Reason: " ++ show s- ]- Unsat -> error "Data.SBV.ensureSat: Solver reported Unsat!"+ Sat -> return ()+ DSat{} -> return ()+ Unk -> do s <- getUnknownReason+ error $ unlines [ ""+ , "*** Data.SBV.ensureSat: Solver reported Unknown!"+ , "*** Reason: " ++ show s+ ]+ Unsat -> error "Data.SBV.ensureSat: Solver reported Unsat!" -- | Generalization of 'Data.SBV.Control.getSMTResult' getSMTResult :: (MonadIO m, MonadQuery m) => m SMTResult getSMTResult = do cfg <- getConfig cs <- checkSat case cs of- Unsat -> Unsatisfiable cfg <$> getUnsatCoreIfRequested- Sat -> Satisfiable cfg <$> getModel- Unk -> Unknown cfg <$> getUnknownReason+ Unsat -> Unsatisfiable cfg <$> getUnsatCoreIfRequested+ Sat -> Satisfiable cfg <$> getModel+ DSat p -> DeltaSat cfg p <$> getModel+ Unk -> Unknown cfg <$> getUnknownReason -- | Classify a model based on whether it has unbound objectives or not. classifyModel :: SMTConfig -> SMTModel -> SMTResult@@ -237,9 +239,10 @@ getLexicographicOptResults = do cfg <- getConfig cs <- checkSat case cs of- Unsat -> Unsatisfiable cfg <$> getUnsatCoreIfRequested- Sat -> classifyModel cfg <$> getModelWithObjectives- Unk -> Unknown cfg <$> getUnknownReason+ Unsat -> Unsatisfiable cfg <$> getUnsatCoreIfRequested+ Sat -> classifyModel cfg <$> getModelWithObjectives+ DSat{} -> classifyModel cfg <$> getModelWithObjectives+ Unk -> Unknown cfg <$> getUnknownReason where getModelWithObjectives = do objectiveValues <- getObjectiveValues m <- getModel return m {modelObjectives = objectiveValues}@@ -250,10 +253,11 @@ cs <- checkSat case cs of- Unsat -> getUnsatCoreIfRequested >>= \mbUC -> return [(nm, Unsatisfiable cfg mbUC) | nm <- objNames]- Sat -> continue (classifyModel cfg)- Unk -> do ur <- Unknown cfg <$> getUnknownReason- return [(nm, ur) | nm <- objNames]+ Unsat -> getUnsatCoreIfRequested >>= \mbUC -> return [(nm, Unsatisfiable cfg mbUC) | nm <- objNames]+ Sat -> continue (classifyModel cfg)+ DSat{} -> continue (classifyModel cfg)+ Unk -> do ur <- Unknown cfg <$> getUnknownReason+ return [(nm, ur) | nm <- objNames] where continue classify = do objectiveValues <- getObjectiveValues nms <- zipWithM getIndependentResult [0..] objNames@@ -271,10 +275,11 @@ cs <- checkSat case cs of- Unsat -> return (False, [])- Sat -> continue (classifyModel cfg)- Unk -> do ur <- getUnknownReason- return (False, [ProofError cfg [show ur] Nothing])+ Unsat -> return (False, [])+ Sat -> continue (classifyModel cfg)+ DSat{} -> continue (classifyModel cfg)+ Unk -> do ur <- getUnknownReason+ return (False, [ProofError cfg [show ur] Nothing]) where continue classify = do m <- getModel (limReached, fronts) <- getParetoFronts (subtract 1 <$> mbN) [m]@@ -285,9 +290,10 @@ getParetoFronts mbi sofar = do cs <- checkSat let more = getModel >>= \m -> getParetoFronts (subtract 1 <$> mbi) (m : sofar) case cs of- Unsat -> return (False, sofar)- Sat -> more- Unk -> more+ Unsat -> return (False, sofar)+ Sat -> more+ DSat{} -> more+ Unk -> more -- | Generalization of 'Data.SBV.Control.getModel' getModel :: (MonadIO m, MonadQuery m) => m SMTModel@@ -297,7 +303,7 @@ getModelAtIndex :: (MonadIO m, MonadQuery m) => Maybe Int -> m SMTModel getModelAtIndex mbi = do State{runMode} <- queryState- rm <- io $ readIORef runMode+ rm <- io $ readIORef runMode case rm of m@CodeGen -> error $ "SBV.getModel: Model is not available in mode: " ++ show m m@Concrete{} -> error $ "SBV.getModel: Model is not available in mode: " ++ show m@@ -545,16 +551,20 @@ r <- checkSatAssuming [c] case r of- Unsat -> do notify "Unsatisfiable"- go cfg ncs+ Unsat -> do notify "Unsatisfiable"+ go cfg ncs - Sat -> do notify "Satisfiable"- res <- Satisfiable cfg <$> getModel- return $ Just (n, res)+ Sat -> do notify "Satisfiable"+ res <- Satisfiable cfg <$> getModel+ return $ Just (n, res) - Unk -> do notify "Unknown"- res <- Unknown cfg <$> getUnknownReason- return $ Just (n, res)+ DSat mbP -> do notify $ "Delta satisfiable" ++ maybe "" (" (precision: " ++) mbP+ res <- DeltaSat cfg mbP <$> getModel+ return $ Just (n, res)++ Unk -> do notify "Unknown"+ res <- Unknown cfg <$> getUnknownReason+ return $ Just (n, res) -- | Generalization of 'Data.SBV.Control.resetAssertions' resetAssertions :: (MonadIO m, MonadQuery m) => m ()
Data/SBV/Control/Types.hs view
@@ -9,30 +9,25 @@ -- Types related to interactive queries ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}- {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Control.Types ( CheckSatResult(..) , Logic(..)- , SMTOption(..), isStartModeOption, setSMTOption+ , SMTOption(..), isStartModeOption, isOnlyOnceOption, setSMTOption , SMTInfoFlag(..) , SMTErrorBehavior(..) , SMTReasonUnknown(..) , SMTInfoResponse(..) ) where -import Generics.Deriving.Base (Generic)-import Generics.Deriving.Show (GShow, gshow)- import Control.DeepSeq (NFData(..)) -- | Result of a 'Data.SBV.Control.checkSat' or 'Data.SBV.Control.checkSatAssuming' call.-data CheckSatResult = Sat -- ^ Satisfiable: A model is available, which can be queried with 'Data.SBV.Control.getValue'.- | Unsat -- ^ Unsatisfiable: No model is available. Unsat cores might be obtained via 'Data.SBV.Control.getUnsatCore'.- | Unk -- ^ Unknown: Use 'Data.SBV.Control.getUnknownReason' to obtain an explanation why this might be the case.+data CheckSatResult = Sat -- ^ Satisfiable: A model is available, which can be queried with 'Data.SBV.Control.getValue'.+ | DSat (Maybe String) -- ^ Delta-satisfiable: A delta-sat model is available. String is the precision info, if available.+ | Unsat -- ^ Unsatisfiable: No model is available. Unsat cores might be obtained via 'Data.SBV.Control.getUnsatCore'.+ | Unk -- ^ Unknown: Use 'Data.SBV.Control.getUnknownReason' to obtain an explanation why this might be the case. deriving (Eq, Show) -- | Collectable information from the solver.@@ -55,8 +50,10 @@ | UnknownIncomplete | UnknownTimeOut | UnknownOther String- deriving (Generic, NFData) +-- | Trivial rnf instance+instance NFData SMTReasonUnknown where rnf a = seq a ()+ -- | Show instance for unknown instance Show SMTReasonUnknown where show UnknownMemOut = "memout"@@ -114,7 +111,7 @@ | OptionKeyword String [String] | SetLogic Logic | SetInfo String [String]- deriving (Show, Generic, NFData)+ deriving Show -- | Can this command only be run at the very beginning? If 'True' then -- we will reject setting these options in the query mode. Note that this@@ -134,6 +131,24 @@ isStartModeOption SetLogic{} = True isStartModeOption SetInfo{} = False +-- | Can this option be set multiple times? I'm only making a guess here.+-- If this returns True, then we'll only send the last instance we see.+-- We might need to update as necessary.+isOnlyOnceOption :: SMTOption -> Bool+isOnlyOnceOption DiagnosticOutputChannel{} = True+isOnlyOnceOption ProduceAssertions{} = True+isOnlyOnceOption ProduceAssignments{} = True+isOnlyOnceOption ProduceProofs{} = True+isOnlyOnceOption ProduceInterpolants{} = True+isOnlyOnceOption ProduceUnsatAssumptions{} = True+isOnlyOnceOption ProduceUnsatCores{} = True+isOnlyOnceOption RandomSeed{} = False+isOnlyOnceOption ReproducibleResourceLimit{} = False+isOnlyOnceOption SMTVerbosity{} = False+isOnlyOnceOption OptionKeyword{} = False -- This is really hard to determine. Just being permissive+isOnlyOnceOption SetLogic{} = True+isOnlyOnceOption SetInfo{} = False+ -- SMTLib's True/False is spelled differently than Haskell's. smtBool :: Bool -> String smtBool True = "true"@@ -197,14 +212,40 @@ | Logic_ALL -- ^ The catch-all value. | Logic_NONE -- ^ Use this value when you want SBV to simply not set the logic. | CustomLogic String -- ^ In case you need a really custom string!- deriving (Generic, NFData) -- The show instance is "almost" the derived one, but not quite!-instance GShow Logic instance Show Logic where+ show AUFLIA = "AUFLIA"+ show AUFLIRA = "AUFLIRA"+ show AUFNIRA = "AUFNIRA"+ show LRA = "LRA"+ show QF_ABV = "QF_ABV"+ show QF_AUFBV = "QF_AUFBV"+ show QF_AUFLIA = "QF_AUFLIA"+ show QF_AX = "QF_AX"+ show QF_BV = "QF_BV"+ show QF_IDL = "QF_IDL"+ show QF_LIA = "QF_LIA"+ show QF_LRA = "QF_LRA"+ show QF_NIA = "QF_NIA"+ show QF_NRA = "QF_NRA"+ show QF_RDL = "QF_RDL"+ show QF_UF = "QF_UF"+ show QF_UFBV = "QF_UFBV"+ show QF_UFIDL = "QF_UFIDL"+ show QF_UFLIA = "QF_UFLIA"+ show QF_UFLRA = "QF_UFLRA"+ show QF_UFNRA = "QF_UFNRA"+ show QF_UFNIRA = "QF_UFNIRA"+ show UFLRA = "UFLRA"+ show UFNIA = "UFNIA"+ show QF_FPBV = "QF_FPBV"+ show QF_FP = "QF_FP"+ show QF_FD = "QF_FD"+ show QF_S = "QF_S" show Logic_ALL = "ALL"+ show Logic_NONE = "Logic_NONE" show (CustomLogic l) = l- show l = gshow l {-# ANN type SMTInfoResponse ("HLint: ignore Use camelCase" :: String) #-} {-# ANN type Logic ("HLint: ignore Use camelCase" :: String) #-}
Data/SBV/Control/Utils.hs view
@@ -56,6 +56,8 @@ import Control.Monad.Trans (lift) import Control.Monad.Reader (runReaderT) +import Data.Maybe (isNothing, isJust)+ import Data.IORef (readIORef, writeIORef) import Data.Time (getZonedTime)@@ -72,17 +74,17 @@ ) import Data.SBV.Core.Symbolic ( IncState(..), withNewIncState, State(..), svToSV, symbolicEnv, SymbolicT- , MonadQuery(..), QueryContext(..), Queriable(..), Fresh(..)+ , MonadQuery(..), QueryContext(..), Queriable(..), Fresh(..), VarContext(..) , registerLabel, svMkSymVar, validationRequested , isSafetyCheckingIStage, isSetupIStage, isRunIStage, IStage(..), QueryT(..) , extractSymbolicSimulationState, MonadSymbolic(..), newUninterpreted ) -import Data.SBV.Core.AlgReals (mergeAlgReals)+import Data.SBV.Core.AlgReals (mergeAlgReals, AlgReal(..), RealPoint(..)) import Data.SBV.Core.Kind (smtType, hasUninterpretedSorts) import Data.SBV.Core.Operations (svNot, svNotEqual, svOr) -import Data.SBV.SMT.SMT (showModel, parseCVs, SatModel)+import Data.SBV.SMT.SMT (showModel, parseCVs, SatModel, AllSatResult(..)) import Data.SBV.SMT.SMTLib (toIncSMTLib, toSMTLib) import Data.SBV.SMT.Utils (showTimeoutValue, addAnnotations, alignPlain, debug, mergeSExpr, SBVException(..)) @@ -202,7 +204,7 @@ syncUpSolver is return r --- | Generic 'Queriable' instance for 'SymVal'/'SMTValue' values+-- | Generic 'Queriable' instance for 'SymVal' values instance (MonadIO m, SymVal a) => Queriable m (SBV a) a where create = freshVar_ project = getValue@@ -216,12 +218,12 @@ -- | Generalization of 'Data.SBV.Control.freshVar_' freshVar_ :: forall a m. (MonadIO m, MonadQuery m, SymVal a) => m (SBV a)-freshVar_ = inNewContext $ fmap SBV . svMkSymVar (Just EX) k Nothing+freshVar_ = inNewContext $ fmap SBV . svMkSymVar QueryVar k Nothing where k = kindOf (Proxy @a) -- | Generalization of 'Data.SBV.Control.freshVar' freshVar :: forall a m. (MonadIO m, MonadQuery m, SymVal a) => String -> m (SBV a)-freshVar nm = inNewContext $ fmap SBV . svMkSymVar (Just EX) k (Just nm)+freshVar nm = inNewContext $ fmap SBV . svMkSymVar QueryVar k (Just nm) where k = kindOf (Proxy @a) -- | Generalization of 'Data.SBV.Control.freshArray_'@@ -668,25 +670,25 @@ getUninterpretedValue :: (MonadIO m, MonadQuery m, HasKind a) => SBV a -> m String getUninterpretedValue s = case kindOf s of- KUninterpreted _ (Left _) -> do sv <- inNewContext (`sbvToSV` s)+ KUserSort _ Nothing -> do sv <- inNewContext (`sbvToSV` s) - let nm = show sv- cmd = "(get-value (" ++ nm ++ "))"- bad = unexpected "getValue" cmd "a model value" Nothing+ let nm = show sv+ cmd = "(get-value (" ++ nm ++ "))"+ bad = unexpected "getValue" cmd "a model value" Nothing - r <- ask cmd+ r <- ask cmd - parse r bad $ \case EApp [EApp [ECon o, ECon v]] | o == show sv -> return v- _ -> bad r Nothing+ parse r bad $ \case EApp [EApp [ECon o, ECon v]] | o == show sv -> return v+ _ -> bad r Nothing - k -> error $ unlines [""- , "*** SBV.getUninterpretedValue: Called on an 'interpreted' kind"- , "*** "- , "*** Kind: " ++ show k- , "*** Hint: Use 'getValue' to extract value for interpreted kinds."- , "*** "- , "*** Only truly uninterpreted sorts should be used with 'getUninterpretedValue.'"- ]+ k -> error $ unlines [""+ , "*** SBV.getUninterpretedValue: Called on an 'interpreted' kind"+ , "*** "+ , "*** Kind: " ++ show k+ , "*** Hint: Use 'getValue' to extract value for interpreted kinds."+ , "*** "+ , "*** Only truly uninterpreted sorts should be used with 'getUninterpretedValue.'"+ ] -- | Get the value of a term, but in CV form. Used internally. The model-index, in particular is extremely Z3 specific! getValueCVHelper :: (MonadIO m, MonadQuery m) => Maybe Int -> SV -> m CV@@ -709,34 +711,36 @@ r <- ask cmd - parse r bad $ \case EApp [EApp [ECon v, val]] | v == nm -> case recoverKindedValue (kindOf s) val of- Just cv -> return cv- Nothing -> bad r Nothing+ let recover val = case recoverKindedValue (kindOf s) val of+ Just cv -> return cv+ Nothing -> bad r Nothing++ parse r bad $ \case EApp [EApp [ECon v, val]] | v == nm -> recover val _ -> bad r Nothing -- | "Make up" a CV for this type. Like zero, but smarter. defaultKindedValue :: Kind -> Maybe CV defaultKindedValue k = CV k <$> cvt k where cvt :: Kind -> Maybe CVal- cvt KBool = Just $ CInteger 0- cvt KBounded{} = Just $ CInteger 0- cvt KUnbounded = Just $ CInteger 0- cvt KReal = Just $ CAlgReal 0- cvt (KUninterpreted _ ui) = uninterp ui- cvt KFloat = Just $ CFloat 0- cvt KDouble = Just $ CDouble 0- cvt KChar = Just $ CChar '\NUL' -- why not?- cvt KString = Just $ CString ""- cvt (KList _) = Just $ CList []- cvt (KSet _) = Just $ CSet $ RegularSet Set.empty -- why not? Arguably, could be the universal set- cvt (KTuple ks) = CTuple <$> mapM cvt ks- cvt (KMaybe _) = Just $ CMaybe Nothing- cvt (KEither k1 _) = CEither . Left <$> cvt k1 -- why not?+ cvt KBool = Just $ CInteger 0+ cvt KBounded{} = Just $ CInteger 0+ cvt KUnbounded = Just $ CInteger 0+ cvt KReal = Just $ CAlgReal 0+ cvt (KUserSort _ ui) = uninterp ui+ cvt KFloat = Just $ CFloat 0+ cvt KDouble = Just $ CDouble 0+ cvt KChar = Just $ CChar '\NUL' -- why not?+ cvt KString = Just $ CString ""+ cvt (KList _) = Just $ CList []+ cvt (KSet _) = Just $ CSet $ RegularSet Set.empty -- why not? Arguably, could be the universal set+ cvt (KTuple ks) = CTuple <$> mapM cvt ks+ cvt (KMaybe _) = Just $ CMaybe Nothing+ cvt (KEither k1 _) = CEither . Left <$> cvt k1 -- why not? -- Tricky case of uninterpreted- uninterp (Right (c:_)) = Just $ CUserSort (Just 1, c)- uninterp (Right []) = Nothing -- I don't think this can actually happen, but just in case- uninterp (Left _) = Nothing -- Out of luck, truly uninterpreted; we don't even know if it's inhabited.+ uninterp (Just (c:_)) = Just $ CUserSort (Just 1, c)+ uninterp (Just []) = Nothing -- I don't think this can actually happen, but just in case+ uninterp Nothing = Nothing -- Out of luck, truly uninterpreted; we don't even know if it's inhabited. -- | Go from an SExpr directly to a value sexprToVal :: forall a. SymVal a => SExpr -> Maybe a@@ -745,48 +749,48 @@ -- | Recover a given solver-printed value with a possible interpretation recoverKindedValue :: Kind -> SExpr -> Maybe CV recoverKindedValue k e = case k of- KBool | ENum (i, _) <- e -> Just $ mkConstCV k i- | True -> Nothing+ KBool | ENum (i, _) <- e -> Just $ mkConstCV k i+ | True -> Nothing - KBounded{} | ENum (i, _) <- e -> Just $ mkConstCV k i- | True -> Nothing+ KBounded{} | ENum (i, _) <- e -> Just $ mkConstCV k i+ | True -> Nothing - KUnbounded | ENum (i, _) <- e -> Just $ mkConstCV k i- | True -> Nothing+ KUnbounded | ENum (i, _) <- e -> Just $ mkConstCV k i+ | True -> Nothing - KReal | ENum (i, _) <- e -> Just $ mkConstCV k i- | EReal i <- e -> Just $ CV KReal (CAlgReal i)- | True -> Nothing+ KReal | ENum (i, _) <- e -> Just $ mkConstCV k i+ | EReal i <- e -> Just $ CV KReal (CAlgReal i)+ | True -> interpretInterval e - KUninterpreted{} | ECon s <- e -> Just $ CV k $ CUserSort (getUIIndex k s, s)- | True -> Nothing+ KUserSort{} | ECon s <- e -> Just $ CV k $ CUserSort (getUIIndex k s, s)+ | True -> Nothing - KFloat | ENum (i, _) <- e -> Just $ mkConstCV k i- | EFloat i <- e -> Just $ CV KFloat (CFloat i)- | True -> Nothing+ KFloat | ENum (i, _) <- e -> Just $ mkConstCV k i+ | EFloat i <- e -> Just $ CV KFloat (CFloat i)+ | True -> Nothing - KDouble | ENum (i, _) <- e -> Just $ mkConstCV k i- | EDouble i <- e -> Just $ CV KDouble (CDouble i)- | True -> Nothing+ KDouble | ENum (i, _) <- e -> Just $ mkConstCV k i+ | EDouble i <- e -> Just $ CV KDouble (CDouble i)+ | True -> Nothing - KChar | ENum (i, _) <- e -> Just $ CV KChar $ CChar $ chr $ fromIntegral i- | True -> Nothing+ KChar | ENum (i, _) <- e -> Just $ CV KChar $ CChar $ chr $ fromIntegral i+ | True -> Nothing - KString | ECon s <- e -> Just $ CV KString $ CString $ interpretString s- | True -> Nothing+ KString | ECon s <- e -> Just $ CV KString $ CString $ interpretString s+ | True -> Nothing - KList ek -> Just $ CV k $ CList $ interpretList ek e+ KList ek -> Just $ CV k $ CList $ interpretList ek e - KSet ek -> Just $ CV k $ CSet $ interpretSet ek e+ KSet ek -> Just $ CV k $ CSet $ interpretSet ek e - KTuple{} -> Just $ CV k $ CTuple $ interpretTuple e+ KTuple{} -> Just $ CV k $ CTuple $ interpretTuple e - KMaybe{} -> Just $ CV k $ CMaybe $ interpretMaybe k e+ KMaybe{} -> Just $ CV k $ CMaybe $ interpretMaybe k e - KEither{} -> Just $ CV k $ CEither $ interpretEither k e+ KEither{} -> Just $ CV k $ CEither $ interpretEither k e - where getUIIndex (KUninterpreted _ (Right xs)) i = i `elemIndex` xs- getUIIndex _ _ = Nothing+ where getUIIndex (KUserSort _ (Just xs)) i = i `elemIndex` xs+ getUIIndex _ _ = Nothing stringLike xs = length xs >= 2 && head xs == '"' && last xs == '"' @@ -917,7 +921,20 @@ interpretEither _ other = error $ "Expected an SEither sexpr, but received: " ++ show (k, other) + -- Intervals, for dReal+ interpretInterval expr = case expr of+ EApp [ECon "interval", lo, hi] -> do vlo <- getBorder lo+ vhi <- getBorder hi+ pure $ CV KReal (CAlgReal (AlgInterval vlo vhi))+ _ -> Nothing+ where getBorder (EApp [ECon "open", v]) = recoverKindedValue KReal v >>= border OpenPoint+ getBorder (EApp [ECon "closed", v]) = recoverKindedValue KReal v >>= border ClosedPoint+ getBorder _ = Nothing + border b (CV KReal (CAlgReal (AlgRational True v))) = pure $ b v+ border _ other = error $ "Data.SBV.interpretInterval.border: Expected a real-valued sexp, but received: " ++ show other++ -- | Generalization of 'Data.SBV.Control.getValueCV' getValueCV :: (MonadIO m, MonadQuery m) => Maybe Int -> SV -> m CV getValueCV mbi s@@ -964,7 +981,7 @@ toRes :: SExpr -> Maybe CV toRes = recoverKindedValue rt - -- In case we end up in the pointwise scenerio, boolify the result+ -- In case we end up in the pointwise scenario, boolify the result -- as that's the only type we support here. tryPointWise bailOut = do mbSExprs <- pointWiseExtract nm typ case mbSExprs of@@ -997,11 +1014,18 @@ r <- askIgnoring cmd ignoreList - parse r bad $ \case ECon "sat" -> return Sat- ECon "unsat" -> return Unsat- ECon "unknown" -> return Unk- _ -> bad r Nothing+ -- query for the precision if supported+ let getPrecision = do cfg <- getConfig+ case supportsDeltaSat (capabilities (solver cfg)) of+ Nothing -> pure Nothing+ Just o -> Just <$> ask o + parse r bad $ \case ECon "sat" -> return Sat+ ECon "unsat" -> return Unsat+ ECon "unknown" -> return Unk+ ECon "delta-sat" -> DSat <$> getPrecision+ _ -> bad r Nothing+ -- | What are the top level inputs? Trackers are returned as top level existentials getQuantifiedInputs :: (MonadIO m, MonadQuery m) => m [(Quantifier, NamedSymVar)] getQuantifiedInputs = do State{rinps} <- queryState@@ -1039,8 +1063,8 @@ return $ nub $ sort $ Map.toList prior ++ Map.toList new -- | Repeatedly issue check-sat, after refuting the previous model.--- The bool is true if the model is unique upto prefix existentials.-getAllSatResult :: forall m. (MonadIO m, MonadQuery m, SolverContext m) => m (Bool, Bool, Bool, [SMTResult])+-- For the meaning of the booleans, see the comment on 'AllSatResult'+getAllSatResult :: forall m. (MonadIO m, MonadQuery m, SolverContext m) => m AllSatResult getAllSatResult = do queryDebug ["*** Checking Satisfiability, all solutions.."] cfg <- getConfig@@ -1081,7 +1105,7 @@ Nothing -> return () Just cmds -> mapM_ (send True) cmds - let usorts = [s | us@(KUninterpreted s _) <- Set.toAscList ki, isFree us]+ let usorts = [s | us@(KUserSort s _) <- Set.toAscList ki, isFree us] unless (null usorts) $ queryDebug [ "*** SBV.allSat: Uninterpreted sorts present: " ++ unwords usorts , "*** SBV will use equivalence classes to generate all-satisfying instances."@@ -1105,194 +1129,209 @@ -- If we have any universals, then the solutions are unique upto prefix existentials. w = ALL `elem` map fst qinps - (sc, unk, ms) <- loop grabObservables topState (allUiFuns, uiFuns) qinps vars cfg- return (sc, w, unk, reverse ms)+ res <- loop grabObservables topState (allUiFuns, uiFuns) qinps vars cfg AllSatResult { allSatMaxModelCountReached = False+ , allSatHasPrefixExistentials = w+ , allSatSolverReturnedUnknown = False+ , allSatSolverReturnedDSat = False+ , allSatResults = []+ }+ -- results come out in reverse order, so reverse them:+ pure $ res { allSatResults = reverse (allSatResults res) } - where isFree (KUninterpreted _ (Left _)) = True- isFree _ = False+ where isFree (KUserSort _ Nothing) = True+ isFree _ = False - loop grabObservables topState (allUiFuns, uiFunsToReject) qinps vars cfg = go (1::Int) []- where go :: Int -> [SMTResult] -> m (Bool, Bool, [SMTResult])+ loop grabObservables topState (allUiFuns, uiFunsToReject) qinps vars cfg = go (1::Int)+ where go :: Int -> AllSatResult -> m AllSatResult go !cnt sofar | Just maxModels <- allSatMaxModelCount cfg, cnt > maxModels = do queryDebug ["*** Maximum model count request of " ++ show maxModels ++ " reached, stopping the search."] when (allSatPrintAlong cfg) $ io $ putStrLn "Search stopped since model count request was reached." - return (True, False, sofar)+ return $ sofar { allSatMaxModelCountReached = True } | True = do queryDebug ["Looking for solution " ++ show cnt] - let endMsg = when (allSatPrintAlong cfg && not (null sofar)) $ do- let msg 0 = "No solutions found."- msg 1 = "This is the only solution."- msg n = "Found " ++ show n ++ " different solutions."- io . putStrLn $ msg (cnt - 1)+ let endMsg extra = when (allSatPrintAlong cfg && not (null (allSatResults sofar))) $ do+ let msg 0 = "No solutions found."+ msg 1 = "This is the only solution."+ msg n = "Found " ++ show n ++ " different solutions."+ io . putStrLn $ msg (cnt - 1)+ case extra of+ Nothing -> pure ()+ Just m -> io $ putStrLn m cs <- checkSat case cs of- Unsat -> do endMsg- return (False, False, sofar)+ Unsat -> do endMsg Nothing+ return sofar - Unk -> do queryDebug ["*** Solver returned unknown, terminating query."]- endMsg- return (False, True, sofar)+ Unk -> do let m = "Solver returned unknown, terminating query."+ queryDebug ["*** " ++ m]+ endMsg $ Just $ "[" ++ m ++ "]"+ return sofar{ allSatSolverReturnedUnknown = True } - Sat -> do assocs <- mapM (\(sval, (sv, n)) -> do cv <- getValueCV Nothing sv- return (sv, (n, (sval, cv)))) vars+ DSat _ -> do let m = "Solver returned delta-sat, terminating query."+ queryDebug ["*** " ++ m]+ endMsg $ Just $ "[" ++ m ++ "]"+ return sofar{ allSatSolverReturnedDSat = True } - let getUIFun ui@(nm, t) = do cvs <- getUIFunCVAssoc Nothing ui- return (nm, (t, cvs))- uiFunVals <- mapM getUIFun allUiFuns+ Sat -> do assocs <- mapM (\(sval, (sv, n)) -> do cv <- getValueCV Nothing sv+ return (sv, (n, (sval, cv)))) vars - -- Add on observables if we're asked to do so:- obsvs <- if grabObservables- then getObservables- else do queryDebug ["*** In a quantified context, observables will not be printed."]- return []+ let getUIFun ui@(nm, t) = do cvs <- getUIFunCVAssoc Nothing ui+ return (nm, (t, cvs))+ uiFunVals <- mapM getUIFun allUiFuns - bindings <- let grab i@(ALL, _) = return (i, Nothing)- grab i@(EX, (sv, _)) = case sv `lookup` assocs of- Just (_, (_, cv)) -> return (i, Just cv)- Nothing -> do cv <- getValueCV Nothing sv- return (i, Just cv)- in if validationRequested cfg- then Just <$> mapM grab qinps- else return Nothing+ -- Add on observables if we're asked to do so:+ obsvs <- if grabObservables+ then getObservables+ else do queryDebug ["*** In a quantified context, observables will not be printed."]+ return [] - let model = SMTModel { modelObjectives = []- , modelBindings = bindings- , modelAssocs = sortOn fst obsvs ++ [(n, cv) | (_, (n, (_, cv))) <- assocs]- , modelUIFuns = uiFunVals- }- m = Satisfiable cfg model+ bindings <- let grab i@(ALL, _) = return (i, Nothing)+ grab i@(EX, (sv, _)) = case sv `lookup` assocs of+ Just (_, (_, cv)) -> return (i, Just cv)+ Nothing -> do cv <- getValueCV Nothing sv+ return (i, Just cv)+ in if validationRequested cfg+ then Just <$> mapM grab qinps+ else return Nothing - (interpreteds, uninterpreteds) = partition (not . isFree . kindOf . fst) (map (snd . snd) assocs)+ let model = SMTModel { modelObjectives = []+ , modelBindings = bindings+ , modelAssocs = sortOn fst obsvs ++ [(n, cv) | (_, (n, (_, cv))) <- assocs]+ , modelUIFuns = uiFunVals+ }+ m = Satisfiable cfg model - -- For each interpreted variable, figure out the model equivalence- -- NB. When the kind is floating, we *have* to be careful, since +/- zero, and NaN's- -- and equality don't get along!- interpretedEqs :: [SVal]- interpretedEqs = [mkNotEq (kindOf sv) sv (SVal (kindOf sv) (Left cv)) | (sv, cv) <- interpreteds]- where mkNotEq k a b- | isDouble k || isFloat k = svNot (a `fpNotEq` b)- | True = a `svNotEqual` b+ (interpreteds, uninterpreteds) = partition (not . isFree . kindOf . fst) (map (snd . snd) assocs) - fpNotEq a b = SVal KBool $ Right $ cache r- where r st = do sva <- svToSV st a- svb <- svToSV st b- newExpr st KBool (SBVApp (IEEEFP FP_ObjEqual) [sva, svb])+ -- For each interpreted variable, figure out the model equivalence+ -- NB. When the kind is floating, we *have* to be careful, since +/- zero, and NaN's+ -- and equality don't get along!+ interpretedEqs :: [SVal]+ interpretedEqs = [mkNotEq (kindOf sv) sv (SVal (kindOf sv) (Left cv)) | (sv, cv) <- interpreteds]+ where mkNotEq k a b+ | isDouble k || isFloat k = svNot (a `fpNotEq` b)+ | True = a `svNotEqual` b - -- For each uninterpreted constant, use equivalence class- uninterpretedEqs :: [SVal]- uninterpretedEqs = concatMap pwDistinct -- Assert that they are pairwise distinct- . filter (\l -> length l > 1) -- Only need this class if it has at least two members- . map (map fst) -- throw away values, we only need svals- . groupBy ((==) `on` snd) -- make sure they belong to the same sort and have the same value- . sortOn snd -- sort them according to their CV (i.e., sort/value)- $ uninterpreteds- where pwDistinct :: [SVal] -> [SVal]- pwDistinct ss = [x `svNotEqual` y | (x:ys) <- tails ss, y <- ys]+ fpNotEq a b = SVal KBool $ Right $ cache r+ where r st = do sva <- svToSV st a+ svb <- svToSV st b+ newExpr st KBool (SBVApp (IEEEFP FP_ObjEqual) [sva, svb]) - -- For each uninterpreted function, create a disqualifying equation- -- We do this rather brute-force, since we need to create a new function- -- and do an existential assertion.- uninterpretedReject :: Maybe [String]- uninterpretedFuns :: [String]- (uninterpretedReject, uninterpretedFuns) = (uiReject, concat defs)- where uiReject = case rejects of- [] -> Nothing- xs -> Just xs+ -- For each uninterpreted constant, use equivalence class+ uninterpretedEqs :: [SVal]+ uninterpretedEqs = concatMap pwDistinct -- Assert that they are pairwise distinct+ . filter (\l -> length l > 1) -- Only need this class if it has at least two members+ . map (map fst) -- throw away values, we only need svals+ . groupBy ((==) `on` snd) -- make sure they belong to the same sort and have the same value+ . sortOn snd -- sort them according to their CV (i.e., sort/value)+ $ uninterpreteds+ where pwDistinct :: [SVal] -> [SVal]+ pwDistinct ss = [x `svNotEqual` y | (x:ys) <- tails ss, y <- ys] - (rejects, defs) = unzip [mkNotEq ui | ui@(nm, _) <- uiFunVals, nm `elem` uiFunsToReject]+ -- For each uninterpreted function, create a disqualifying equation+ -- We do this rather brute-force, since we need to create a new function+ -- and do an existential assertion.+ uninterpretedReject :: Maybe [String]+ uninterpretedFuns :: [String]+ (uninterpretedReject, uninterpretedFuns) = (uiReject, concat defs)+ where uiReject = case rejects of+ [] -> Nothing+ xs -> Just xs - -- Otherwise, we have things to refute, go for it:- mkNotEq (nm, (SBVType ts, vs)) = (reject, def ++ dif)- where nm' = nm ++ "_model" ++ show cnt+ (rejects, defs) = unzip [mkNotEq ui | ui@(nm, _) <- uiFunVals, nm `elem` uiFunsToReject] - reject = nm' ++ "_reject"+ -- Otherwise, we have things to refute, go for it:+ mkNotEq (nm, (SBVType ts, vs)) = (reject, def ++ dif)+ where nm' = nm ++ "_model" ++ show cnt - -- rounding mode doesn't matter here, just pick one- scv = cvToSMTLib RoundNearestTiesToEven+ reject = nm' ++ "_reject" - (ats, rt) = (init ts, last ts)+ -- rounding mode doesn't matter here, just pick one+ scv = cvToSMTLib RoundNearestTiesToEven - args = unwords ["(x!" ++ show i ++ " " ++ smtType t ++ ")" | (t, i) <- zip ats [(0::Int)..]]- res = smtType rt+ (ats, rt) = (init ts, last ts) - params = ["x!" ++ show i | (_, i) <- zip ats [(0::Int)..]]+ args = unwords ["(x!" ++ show i ++ " " ++ smtType t ++ ")" | (t, i) <- zip ats [(0::Int)..]]+ res = smtType rt - uparams = unwords params+ params = ["x!" ++ show i | (_, i) <- zip ats [(0::Int)..]] - chain (vals, fallThru) = walk vals- where walk [] = [" " ++ scv fallThru ++ replicate (length vals) ')']- walk ((as, r) : rest) = (" (ite " ++ cond as ++ " " ++ scv r ++ "") : walk rest+ uparams = unwords params - cond as = "(and " ++ unwords (zipWith eq params as) ++ ")"- eq p a = "(= " ++ p ++ " " ++ scv a ++ ")"+ chain (vals, fallThru) = walk vals+ where walk [] = [" " ++ scv fallThru ++ replicate (length vals) ')']+ walk ((as, r) : rest) = (" (ite " ++ cond as ++ " " ++ scv r ++ "") : walk rest - def = ("(define-fun " ++ nm' ++ " (" ++ args ++ ") " ++ res)- : chain vs- ++ [")"]+ cond as = "(and " ++ unwords (zipWith eq params as) ++ ")"+ eq p a = "(= " ++ p ++ " " ++ scv a ++ ")" - pad = replicate (1 + length nm' - length nm) ' '+ def = ("(define-fun " ++ nm' ++ " (" ++ args ++ ") " ++ res)+ : chain vs+ ++ [")"] - dif = [ "(define-fun " ++ reject ++ " () Bool"- , " (exists (" ++ args ++ ")"- , " (distinct (" ++ nm ++ pad ++ uparams ++ ")"- , " (" ++ nm' ++ " " ++ uparams ++ "))))"- ]+ pad = replicate (1 + length nm' - length nm) ' ' - eqs = interpretedEqs ++ uninterpretedEqs+ dif = [ "(define-fun " ++ reject ++ " () Bool"+ , " (exists (" ++ args ++ ")"+ , " (distinct (" ++ nm ++ pad ++ uparams ++ ")"+ , " (" ++ nm' ++ " " ++ uparams ++ "))))"+ ] - disallow = case eqs of- [] -> Nothing- _ -> Just $ SBV $ foldr1 svOr eqs+ eqs = interpretedEqs ++ uninterpretedEqs - when (allSatPrintAlong cfg) $ do- io $ putStrLn $ "Solution #" ++ show cnt ++ ":"- io $ putStrLn $ showModel cfg model+ disallow = case eqs of+ [] -> Nothing+ _ -> Just $ SBV $ foldr1 svOr eqs - let resultsSoFar = m : sofar+ when (allSatPrintAlong cfg) $ do+ io $ putStrLn $ "Solution #" ++ show cnt ++ ":"+ io $ putStrLn $ showModel cfg model - -- This is clunky, but let's not generate a rejector unless we really need it- needMoreIterations- | Just maxModels <- allSatMaxModelCount cfg, (cnt+1) > maxModels = False- | True = True+ let resultsSoFar = sofar { allSatResults = m : allSatResults sofar } - -- Send function disequalities, if any:- if not needMoreIterations- then go (cnt+1) resultsSoFar- else do let uiFunRejector = "uiFunRejector_model_" ++ show cnt- header = "define-fun " ++ uiFunRejector ++ " () Bool "+ -- This is clunky, but let's not generate a rejector unless we really need it+ needMoreIterations+ | Just maxModels <- allSatMaxModelCount cfg, (cnt+1) > maxModels = False+ | True = True - defineRejector [] = return ()- defineRejector [x] = send True $ "(" ++ header ++ x ++ ")"- defineRejector (x:xs) = mapM_ (send True) $ mergeSExpr $ ("(" ++ header)- : (" (or " ++ x)- : [" " ++ e | e <- xs]- ++ [" ))"]- rejectFuncs <- case uninterpretedReject of- Nothing -> return Nothing- Just fs -> do mapM_ (send True) $ mergeSExpr uninterpretedFuns- defineRejector fs- return $ Just uiFunRejector+ -- Send function disequalities, if any:+ if not needMoreIterations+ then go (cnt+1) resultsSoFar+ else do let uiFunRejector = "uiFunRejector_model_" ++ show cnt+ header = "define-fun " ++ uiFunRejector ++ " () Bool " - -- send the disallow clause and the uninterpreted rejector:- case (disallow, rejectFuncs) of- (Nothing, Nothing) -> return (False, False, resultsSoFar)- (Just d, Nothing) -> do constrain d- go (cnt+1) resultsSoFar- (Nothing, Just f) -> do send True $ "(assert " ++ f ++ ")"- go (cnt+1) resultsSoFar- (Just d, Just f) -> -- This is where it gets ugly. We have an SBV and a string and we need to "or" them.- -- But we need a way to force 'd' to be produced. So, go ahead and force it:- do constrain $ d .=> d -- NB: Redundant, but it makes sure the corresponding constraint gets shown- svd <- io $ svToSV topState (unSBV d)- send True $ "(assert (or " ++ f ++ " " ++ show svd ++ "))"- go (cnt+1) resultsSoFar+ defineRejector [] = return ()+ defineRejector [x] = send True $ "(" ++ header ++ x ++ ")"+ defineRejector (x:xs) = mapM_ (send True) $ mergeSExpr $ ("(" ++ header)+ : (" (or " ++ x)+ : [" " ++ e | e <- xs]+ ++ [" ))"]+ rejectFuncs <- case uninterpretedReject of+ Nothing -> return Nothing+ Just fs -> do mapM_ (send True) $ mergeSExpr uninterpretedFuns+ defineRejector fs+ return $ Just uiFunRejector + -- send the disallow clause and the uninterpreted rejector:+ case (disallow, rejectFuncs) of+ (Nothing, Nothing) -> pure resultsSoFar+ (Just d, Nothing) -> do constrain d+ go (cnt+1) resultsSoFar+ (Nothing, Just f) -> do send True $ "(assert " ++ f ++ ")"+ go (cnt+1) resultsSoFar+ (Just d, Just f) -> -- This is where it gets ugly. We have an SBV and a string and we need to "or" them.+ -- But we need a way to force 'd' to be produced. So, go ahead and force it:+ do constrain $ d .=> d -- NB: Redundant, but it makes sure the corresponding constraint gets shown+ svd <- io $ svToSV topState (unSBV d)+ send True $ "(assert (or " ++ f ++ " " ++ show svd ++ "))"+ go (cnt+1) resultsSoFar+ -- | Generalization of 'Data.SBV.Control.getUnsatAssumptions' getUnsatAssumptions :: (MonadIO m, MonadQuery m) => [String] -> [(String, a)] -> m [a] getUnsatAssumptions originals proxyMap = do@@ -1473,19 +1512,31 @@ -- Transitioning from setup SMTMode qc stage isSAT cfg | not (isRunIStage stage) -> do - let backend = engine (solver cfg)+ let slvr = solver cfg+ backend = engine slvr - res <- liftIO $ extractSymbolicSimulationState st- setOpts <- liftIO $ reverse <$> readIORef (rSMTOptions st)+ -- make sure if we have dsat precision, then solver supports it+ let dsatOK = isNothing (dsatPrecision cfg)+ || isJust (supportsDeltaSat (capabilities slvr)) - let SMTProblem{smtLibPgm} = runProofOn rm queryContext [] res- cfg' = cfg { solverSetOptions = solverSetOptions cfg ++ setOpts }- pgm = smtLibPgm cfg'+ unless dsatOK $ error $ unlines+ [ ""+ , "*** Data.SBV: Delta-sat precision is specified."+ , "*** But the chosen solver (" ++ show (name slvr) ++ ") does not support"+ , "*** delta-satisfiability."+ ] - liftIO $ writeIORef (runMode st) $ SMTMode qc IRun isSAT cfg+ res <- liftIO $ extractSymbolicSimulationState st+ setOpts <- liftIO $ reverse <$> readIORef (rSMTOptions st) - lift $ join $ liftIO $ backend cfg' st (show pgm) $ extractIO . runReaderT userQuery+ let SMTProblem{smtLibPgm} = runProofOn rm queryContext [] res+ cfg' = cfg { solverSetOptions = solverSetOptions cfg ++ setOpts }+ pgm = smtLibPgm cfg' + liftIO $ writeIORef (runMode st) $ SMTMode qc IRun isSAT cfg++ lift $ join $ liftIO $ backend cfg' st (show pgm) $ extractIO . runReaderT userQuery+ -- Already in a query, in theory we can just continue, but that causes use-case issues -- so we reject it. TODO: Review if we should actually support this. The issue arises with -- expressions like this:@@ -1541,7 +1592,8 @@ , "***" , "*** Current mode: " ++ show rm , "***"- , "*** Query calls are only valid within runSMT/runSMTWith calls"+ , "*** Query calls are only valid within runSMT/runSMTWith calls,"+ , "*** and each call to runSMT should have only one query call inside." ] {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
Data/SBV/Core/AlgReals.hs view
@@ -6,7 +6,7 @@ -- Maintainer: erkokl@gmail.com -- Stability : experimental ----- Algrebraic reals in Haskell.+-- Algebraic reals in Haskell. ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleInstances #-}@@ -16,6 +16,8 @@ module Data.SBV.Core.AlgReals ( AlgReal(..) , AlgRealPoly(..)+ , RationalCV(..)+ , RealPoint(..), realPoint , mkPolyReal , algRealToSMTLib2 , algRealToHaskell@@ -27,6 +29,8 @@ ) where +import Data.Char (isDigit)+ import Data.List (sortBy, isPrefixOf, partition) import Data.Ratio ((%), numerator, denominator) import Data.Function (on)@@ -35,13 +39,24 @@ import Numeric (readSigned, readFloat) +-- | Is the endpoint included in the interval?+data RealPoint a = OpenPoint a -- ^ open: i.e., doesn't include the point+ | ClosedPoint a -- ^ closed: i.e., includes the point+ deriving (Show, Eq, Ord)++-- | Extract the point associated with the open-closed point+realPoint :: RealPoint a -> a+realPoint (OpenPoint a) = a+realPoint (ClosedPoint a) = a+ -- | Algebraic reals. Note that the representation is left abstract. We represent -- rational results explicitly, while the roots-of-polynomials are represented -- implicitly by their defining equation-data AlgReal = AlgRational Bool Rational -- ^ bool says it's exact (i.e., SMT-solver did not return it with ? at the end.)- | AlgPolyRoot (Integer, AlgRealPoly) (Maybe String) -- ^ which root of this polynomial and an approximate decimal representation with given precision, if available+data AlgReal = AlgRational Bool Rational -- ^ bool says it's exact (i.e., SMT-solver did not return it with ? at the end.)+ | AlgPolyRoot (Integer, AlgRealPoly) (Maybe String) -- ^ which root of this polynomial and an approximate decimal representation with given precision, if available+ | AlgInterval (RealPoint Rational) (RealPoint Rational) -- ^ interval, with low and high bounds --- | Check wheter a given argument is an exact rational+-- | Check whether a given argument is an exact rational isExactRational :: AlgReal -> Bool isExactRational (AlgRational True _) = True isExactRational _ = False@@ -56,9 +71,15 @@ mkPolyReal :: Either (Bool, String) (Integer, [(Integer, Integer)]) -> AlgReal mkPolyReal (Left (exact, str)) = case (str, break (== '.') str) of- ("", (_, _)) -> AlgRational exact 0- (_, (x, '.':y)) -> AlgRational exact (read (x++y) % (10 ^ length y))- (_, (x, _)) -> AlgRational exact (read x % 1)+ ("", _) -> AlgRational exact 0+ (_, (x, '.':y)) | all isDigit (x ++ y) -> AlgRational exact (read (x++y) % (10 ^ length y))+ (_, (x, "")) | all isDigit x -> AlgRational exact (read x % 1)+ _ -> error $ unlines [ "*** Data.SBV.mkPolyReal: Unable to read a number from:"+ , "***"+ , "*** " ++ str+ , "***"+ , "*** Please report this as a bug."+ ] mkPolyReal (Right (k, coeffs)) = AlgPolyRoot (k, AlgRealPoly (normalize coeffs)) Nothing where normalize :: [(Integer, Integer)] -> [(Integer, Integer)]@@ -93,6 +114,11 @@ show (AlgPolyRoot (i, p) mbApprox) = "root(" ++ show i ++ ", " ++ show p ++ ")" ++ maybe "" app mbApprox where app v | last v == '?' = " = " ++ init v ++ "..." | True = " = " ++ v+ show (AlgInterval a b) = case (a, b) of+ (OpenPoint l, OpenPoint h) -> "(" ++ show l ++ ", " ++ show h ++ ")"+ (OpenPoint l, ClosedPoint h) -> "(" ++ show l ++ ", " ++ show h ++ "]"+ (ClosedPoint l, OpenPoint h) -> "[" ++ show l ++ ", " ++ show h ++ ")"+ (ClosedPoint l, ClosedPoint h) -> "[" ++ show l ++ ", " ++ show h ++ "]" -- lift unary op through an exact rational, otherwise bail lift1 :: String -> (Rational -> Rational) -> AlgReal -> AlgReal@@ -126,8 +152,13 @@ algRealStructuralCompare :: AlgReal -> AlgReal -> Ordering AlgRational a b `algRealStructuralCompare` AlgRational c d = (a, b) `compare` (c, d) AlgRational _ _ `algRealStructuralCompare` AlgPolyRoot _ _ = LT+AlgRational _ _ `algRealStructuralCompare` AlgInterval _ _ = LT AlgPolyRoot _ _ `algRealStructuralCompare` AlgRational _ _ = GT AlgPolyRoot a b `algRealStructuralCompare` AlgPolyRoot c d = (a, b) `compare` (c, d)+AlgPolyRoot _ _ `algRealStructuralCompare` AlgInterval _ _ = LT+AlgInterval _ _ `algRealStructuralCompare` AlgRational _ _ = GT+AlgInterval _ _ `algRealStructuralCompare` AlgPolyRoot _ _ = GT+AlgInterval a b `algRealStructuralCompare` AlgInterval c d = (a, b) `compare` (c, d) instance Num AlgReal where (+) = lift2 "+" (+)@@ -185,6 +216,8 @@ term (k, p) = ["(* " ++ coeff k ++ " (^ x " ++ show p ++ "))"] coeff n | n < 0 = "(- " ++ show (abs n) ++ ")" | True = show n+algRealToSMTLib2 r@AlgInterval{}+ = error $ "SBV: Unexpected inexact rational to be converted to SMTLib2: " ++ show r -- | Render an 'AlgReal' as a Haskell value. Only supports rationals, since there is no corresponding -- standard Haskell type that can represent root-of-polynomial variety.@@ -198,26 +231,34 @@ , "represents an irrational number, and cannot be converted to a Haskell value." ] +-- | Conversion from internal rationals to Haskell values+data RationalCV = RatIrreducible AlgReal -- ^ Root of a polynomial, cannot be reduced+ | RatExact Rational -- ^ An exact rational+ | RatApprox Rational -- ^ An approximated value+ | RatInterval (RealPoint Rational) (RealPoint Rational) -- ^ Interval. If bool is 'True' then closed, otherwise open.+ deriving Show+ -- | Convert an 'AlgReal' to a 'Rational'. If the 'AlgReal' is exact, then you get a 'Left' value. Otherwise, -- you get a 'Right' value which is simply an approximation.-algRealToRational :: AlgReal -> Either Rational Rational+algRealToRational :: AlgReal -> RationalCV algRealToRational a = case a of- AlgRational True r -> Left r- AlgRational False r -> Left r- AlgPolyRoot _ Nothing -> bad+ AlgRational True r -> RatExact r+ AlgRational False r -> RatExact r+ AlgPolyRoot _ Nothing -> RatIrreducible a AlgPolyRoot _ (Just s) -> let trimmed = case reverse s of '.':'.':'.':rest -> reverse rest _ -> s in case readSigned readFloat trimmed of- [(v, "")] -> Right v- _ -> bad- where bad = error $ unlines [ ""- , "SBV.algRealToRational: Unsupported argument:"- , ""- , " " ++ show a- , ""- , "represents an irrational number that cannot be approximated."- ]+ [(v, "")] -> RatApprox v+ _ -> bad "represents a value that cannot be converted to a rational"+ AlgInterval lo hi -> RatInterval lo hi+ where bad w = error $ unlines [ ""+ , "SBV.algRealToRational: Unsupported argument:"+ , ""+ , " " ++ show a+ , ""+ , w+ ] -- Try to show a rational precisely if we can, with finite number of -- digits. Otherwise, show it as a rational value.
Data/SBV/Core/Concrete.hs view
@@ -82,7 +82,7 @@ | CMaybe !(Maybe CVal) -- ^ Maybe | CEither !(Either CVal CVal) -- ^ Disjoint union --- | Assing a rank to constant values, this is structural and helps with ordering+-- | Assign a rank to constant values, this is structural and helps with ordering cvRank :: CVal -> Int cvRank CAlgReal {} = 0 cvRank CInteger {} = 1@@ -160,7 +160,7 @@ data GeneralizedCV = ExtendedCV ExtCV | RegularCV CV --- | A simple expression type over extendent values, covering infinity, epsilon and intervals.+-- | A simple expression type over extended values, covering infinity, epsilon and intervals. data ExtCV = Infinite Kind -- infinity | Epsilon Kind -- epsilon | Interval ExtCV ExtCV -- closed interval@@ -241,13 +241,22 @@ normCV :: CV -> CV normCV c@(CV (KBounded signed sz) (CInteger v)) = c { cvVal = CInteger norm } where norm | sz == 0 = 0+ | signed = let rg = 2 ^ (sz - 1) in case divMod v rg of (a, b) | even a -> b (_, b) -> b - rg- | True = v `mod` (2 ^ sz)++ | True = {- We really want to do:++ v `mod` (2 ^ sz)++ Below is equivalent, and hopefully faster!+ -}+ v .&. (((1 :: Integer) `shiftL` sz) - 1) normCV c@(CV KBool (CInteger v)) = c { cvVal = CInteger (v .&. 1) } normCV c = c+{-# INLINE normCV #-} -- | Constant False as a 'CV'. We represent it using the integer value 0. falseCV :: CV@@ -424,20 +433,20 @@ -- | Create a constant word from an integral. mkConstCV :: Integral a => Kind -> a -> CV-mkConstCV KBool a = normCV $ CV KBool (CInteger (toInteger a))-mkConstCV k@KBounded{} a = normCV $ CV k (CInteger (toInteger a))-mkConstCV KUnbounded a = normCV $ CV KUnbounded (CInteger (toInteger a))-mkConstCV KReal a = normCV $ CV KReal (CAlgReal (fromInteger (toInteger a)))-mkConstCV KFloat a = normCV $ CV KFloat (CFloat (fromInteger (toInteger a)))-mkConstCV KDouble a = normCV $ CV KDouble (CDouble (fromInteger (toInteger a)))-mkConstCV KChar a = error $ "Unexpected call to mkConstCV (Char) with value: " ++ show (toInteger a)-mkConstCV KString a = error $ "Unexpected call to mkConstCV (String) with value: " ++ show (toInteger a)-mkConstCV (KUninterpreted s _) a = error $ "Unexpected call to mkConstCV with uninterpreted kind: " ++ s ++ " with value: " ++ show (toInteger a)-mkConstCV k@KList{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)-mkConstCV k@KSet{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)-mkConstCV k@KTuple{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)-mkConstCV k@KMaybe{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)-mkConstCV k@KEither{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)+mkConstCV KBool a = normCV $ CV KBool (CInteger (toInteger a))+mkConstCV k@KBounded{} a = normCV $ CV k (CInteger (toInteger a))+mkConstCV KUnbounded a = normCV $ CV KUnbounded (CInteger (toInteger a))+mkConstCV KReal a = normCV $ CV KReal (CAlgReal (fromInteger (toInteger a)))+mkConstCV KFloat a = normCV $ CV KFloat (CFloat (fromInteger (toInteger a)))+mkConstCV KDouble a = normCV $ CV KDouble (CDouble (fromInteger (toInteger a)))+mkConstCV KChar a = error $ "Unexpected call to mkConstCV (Char) with value: " ++ show (toInteger a)+mkConstCV KString a = error $ "Unexpected call to mkConstCV (String) with value: " ++ show (toInteger a)+mkConstCV (KUserSort s _) a = error $ "Unexpected call to mkConstCV with user kind: " ++ s ++ " with value: " ++ show (toInteger a)+mkConstCV k@KList{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)+mkConstCV k@KSet{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)+mkConstCV k@KTuple{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)+mkConstCV k@KMaybe{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a)+mkConstCV k@KEither{} a = error $ "Unexpected call to mkConstCV (" ++ show k ++ ") with value: " ++ show (toInteger a) -- | Generate a random constant value ('CVal') of the correct kind. randomCVal :: Kind -> IO CVal@@ -453,7 +462,7 @@ KString -> do l <- randomRIO (0, 100) CString <$> replicateM l (chr <$> randomRIO (0, 255)) KChar -> CChar . chr <$> randomRIO (0, 255)- KUninterpreted s _ -> error $ "Unexpected call to randomCVal with uninterpreted kind: " ++ s+ KUserSort s _ -> error $ "Unexpected call to randomCVal with user kind: " ++ s KList ek -> do l <- randomRIO (0, 100) CList <$> replicateM l (randomCVal ek) KSet ek -> do i <- randomIO -- regular or complement
Data/SBV/Core/Data.hs view
@@ -73,6 +73,9 @@ import qualified Data.Generics as G (Data(..)) +import qualified Data.IORef as R (readIORef, newIORef)+import qualified Data.IntMap.Strict as IMap (size, insert, empty)+ import System.Random import Data.SBV.Core.AlgReals@@ -368,8 +371,8 @@ ------------------------------------------------------------------------- -- | Generalization of 'Data.SBV.mkSymSBV'-mkSymSBV :: forall a m. MonadSymbolic m => Maybe Quantifier -> Kind -> Maybe String -> m (SBV a)-mkSymSBV mbQ k mbNm = SBV <$> (symbolicEnv >>= liftIO . svMkSymVar mbQ k mbNm)+mkSymSBV :: forall a m. MonadSymbolic m => VarContext -> Kind -> Maybe String -> m (SBV a)+mkSymSBV vc k mbNm = SBV <$> (symbolicEnv >>= liftIO . svMkSymVar vc k mbNm) -- | Generalization of 'Data.SBV.sbvToSymSW' sbvToSymSV :: MonadSymbolic m => SBV a -> m SV@@ -399,7 +402,7 @@ -- | Add a user specified axiom to the generated SMT-Lib file. The first argument is a mere -- string, use for commenting purposes. The second argument is intended to hold the multiple-lines -- of the axiom text as expressed in SMT-Lib notation. Note that we perform no checks on the axiom- -- itself, to see whether it's actually well-formed or is sensical by any means.+ -- itself, to see whether it's actually well-formed or is sensible by any means. -- A separate formalization of SMT-Lib would be very useful here. addAxiom :: String -> [String] -> m () -- | Set a solver time-out value, in milli-seconds. This function@@ -461,7 +464,7 @@ -- | A 'SymVal' is a potential symbolic value that can be created instances of to be fed to a symbolic program. class (HasKind a, Typeable a) => SymVal a where -- | Generalization of 'Data.SBV.mkSymVal'- mkSymVal :: MonadSymbolic m => Maybe Quantifier -> Maybe String -> m (SBV a)+ mkSymVal :: MonadSymbolic m => VarContext -> Maybe String -> m (SBV a) -- | Turn a literal constant to symbolic literal :: a -> SBV a -- | Extract a literal, from a CV representation@@ -473,8 +476,8 @@ -- Giving no instances is okay when defining an uninterpreted/enumerated sort, but otherwise you really -- want to define: literal, fromCV, mkSymVal - default mkSymVal :: (MonadSymbolic m, Read a, G.Data a) => Maybe Quantifier -> Maybe String -> m (SBV a)- mkSymVal mbQ mbNm = SBV <$> (symbolicEnv >>= liftIO . svMkSymVar mbQ k mbNm)+ default mkSymVal :: (MonadSymbolic m, Read a, G.Data a) => VarContext -> Maybe String -> m (SBV a)+ mkSymVal vc mbNm = SBV <$> (symbolicEnv >>= liftIO . svMkSymVar vc k mbNm) where -- NB.A call of the form -- constructUKind (Proxy @a) -- would be wrong here, as it would uninterpret the Proxy datatype!@@ -482,11 +485,11 @@ k = constructUKind (undefined :: a) default literal :: Show a => a -> SBV a- literal x = let k@(KUninterpreted _ conts) = kindOf x- sx = show x+ literal x = let k@(KUserSort _ conts) = kindOf x+ sx = show x mbIdx = case conts of- Right xs -> sx `elemIndex` xs- _ -> Nothing+ Just xs -> sx `elemIndex` xs+ Nothing -> Nothing in SBV $ SVal k (Left (CV k (CUserSort (mbIdx, sx)))) default fromCV :: Read a => CV -> a@@ -499,11 +502,11 @@ -- | Generalization of 'Data.SBV.forall' forall :: MonadSymbolic m => String -> m (SBV a)- forall = mkSymVal (Just ALL) . Just+ forall = mkSymVal (NonQueryVar (Just ALL)) . Just -- | Generalization of 'Data.SBV.forall_' forall_ :: MonadSymbolic m => m (SBV a)- forall_ = mkSymVal (Just ALL) Nothing+ forall_ = mkSymVal (NonQueryVar (Just ALL)) Nothing -- | Generalization of 'Data.SBV.mkForallVars' mkForallVars :: MonadSymbolic m => Int -> m [SBV a]@@ -511,11 +514,11 @@ -- | Generalization of 'Data.SBV.exists' exists :: MonadSymbolic m => String -> m (SBV a)- exists = mkSymVal (Just EX) . Just+ exists = mkSymVal (NonQueryVar (Just EX)) . Just -- | Generalization of 'Data.SBV.exists_' exists_ :: MonadSymbolic m => m (SBV a)- exists_ = mkSymVal (Just EX) Nothing+ exists_ = mkSymVal (NonQueryVar (Just EX)) Nothing -- | Generalization of 'Data.SBV.mkExistVars' mkExistVars :: MonadSymbolic m => Int -> m [SBV a]@@ -523,11 +526,11 @@ -- | Generalization of 'Data.SBV.free' free :: MonadSymbolic m => String -> m (SBV a)- free = mkSymVal Nothing . Just+ free = mkSymVal (NonQueryVar Nothing) . Just -- | Generalization of 'Data.SBV.free_' free_ :: MonadSymbolic m => m (SBV a)- free_ = mkSymVal Nothing Nothing+ free_ = mkSymVal (NonQueryVar Nothing) Nothing -- | Generalization of 'Data.SBV.mkFreeVars' mkFreeVars :: MonadSymbolic m => Int -> m [SBV a]@@ -608,11 +611,16 @@ -- As a rule of thumb, try 'SArray' first. These should generate compact code. However, if -- the backend solver has hard time solving the generated problems, switch to -- 'SFunArray'. If you still have issues, please report so we can see what the problem might be!+--+-- NB. 'sListArray' insists on a concrete initializer, because not having one would break+-- referential transparency. See https://github.com/LeventErkok/sbv/issues/553 for details. class SymArray array where -- | Generalization of 'Data.SBV.newArray_' newArray_ :: (MonadSymbolic m, HasKind a, HasKind b) => Maybe (SBV b) -> m (array a b) -- | Generalization of 'Data.SBV.newArray' newArray :: (MonadSymbolic m, HasKind a, HasKind b) => String -> Maybe (SBV b) -> m (array a b)+ -- | Create a literal array+ sListArray :: (HasKind a, SymVal b) => b -> [(SBV a, SBV b)] -> array a b -- | Read the array element at @a@ readArray :: array a b -> SBV a -> SBV b -- | Update the element at @a@ to be @b@@@ -624,7 +632,7 @@ -- | Internal function, not exported to the user newArrayInState :: (HasKind a, HasKind b) => Maybe String -> Maybe (SBV b) -> State -> IO (array a b) - {-# MINIMAL readArray, writeArray, mergeArrays, ((newArray_, newArray) | newArrayInState) #-}+ {-# MINIMAL readArray, writeArray, mergeArrays, ((newArray_, newArray) | newArrayInState), sListArray #-} newArray_ mbVal = symbolicEnv >>= liftIO . newArrayInState Nothing mbVal newArray nm mbVal = symbolicEnv >>= liftIO . newArrayInState (Just nm) mbVal @@ -656,6 +664,22 @@ writeArray (SArray arr) (SBV a) (SBV b) = SArray (writeSArr arr a b) mergeArrays (SBV t) (SArray a) (SArray b) = SArray (mergeSArr t a b) + sListArray :: forall a b. (HasKind a, SymVal b) => b -> [(SBV a, SBV b)] -> SArray a b+ sListArray initializer = foldl (uncurry . writeArray) arr+ where arr = SArray $ SArr ks $ cache r+ where ks = (kindOf (Proxy @a), kindOf (Proxy @b))+ r st = do amap <- R.readIORef (rArrayMap st)++ let k = ArrayIndex $ IMap.size amap+ iVal = literal initializer++ iSV <- sbvToSV st iVal++ let upd = IMap.insert (unArrayIndex k) ("array_" ++ show k, ks, ArrayFree (Just iSV))++ k `seq` modifyState st rArrayMap upd $ modifyIncState st rNewArrs upd+ return k+ newArrayInState :: forall a b. (HasKind a, HasKind b) => Maybe String -> Maybe (SBV b) -> State -> IO (SArray a b) newArrayInState mbNm mbVal st = do mapM_ (registerKind st) [aknd, bknd] SArray <$> newSArr st (aknd, bknd) (mkNm mbNm) (unSBV <$> mbVal)@@ -688,6 +712,23 @@ readArray (SFunArray arr) (SBV a) = SBV (readSFunArr arr a) writeArray (SFunArray arr) (SBV a) (SBV b) = SFunArray (writeSFunArr arr a b) mergeArrays (SBV t) (SFunArray a) (SFunArray b) = SFunArray (mergeSFunArr t a b)++ sListArray :: forall a b. (HasKind a, SymVal b) => b -> [(SBV a, SBV b)] -> SFunArray a b+ sListArray initializer = foldl (uncurry . writeArray) arr+ where arr = SFunArray $ SFunArr ks $ cache r+ where ks = (kindOf (Proxy @a), kindOf (Proxy @b))++ r st = do amap <- R.readIORef (rFArrayMap st)++ memoTable <- R.newIORef IMap.empty++ let k = FArrayIndex $ IMap.size amap+ iVal = literal initializer+ mkUninitialized = const (unSBV iVal)+ upd = IMap.insert (unFArrayIndex k) (mkUninitialized, memoTable)++ k `seq` modifyState st rFArrayMap upd (return ())+ return k newArrayInState :: forall a b. (HasKind a, HasKind b) => Maybe String -> Maybe (SBV b) -> State -> IO (SFunArray a b) newArrayInState mbNm mbVal st = do mapM_ (registerKind st) [aknd, bknd]
Data/SBV/Core/Floating.hs view
@@ -223,14 +223,14 @@ -- >>> prove $ roundTrip @Int32 -- Falsifiable. Counter-example: -- s0 = RoundNearestTiesToEven :: RoundingMode- -- s1 = -264306721 :: Int32+ -- s1 = -206897400 :: Int32 -- -- Note how we get a failure on `Int32`. The counter-example value is not representable exactly as a single precision float: --- -- >>> toRational (-264306721 :: Float)- -- (-264306720) % 1+ -- >>> toRational (-206897400 :: Float)+ -- (-206897408) % 1 --- -- Note how the numerator is different, it is off by 1. This is hardly surprising, since floats become sparser as+ -- Note how the numerator is different, it is off by 8. This is hardly surprising, since floats become sparser as -- the magnitude increases to be able to cover all the integer values representable. toSFloat :: SRoundingMode -> SBV a -> SFloat @@ -263,16 +263,16 @@ -- Q.E.D. -- >>> prove $ roundTrip @Int64 -- Falsifiable. Counter-example:- -- s0 = RoundTowardNegative :: RoundingMode- -- s1 = -8069753317450726624 :: Int64+ -- s0 = RoundTowardNegative :: RoundingMode+ -- s1 = -18014398509481983 :: Int64 -- -- Just like in the `SFloat` case, once we reach 64-bits, we no longer can exactly represent the -- integer value for all possible values: --- -- >>> toRational ( -8069753317450726624 :: Double)- -- (-8069753317450726400) % 1+ -- >>> toRational (-18014398509481983 :: Double)+ -- (-18014398509481984) % 1 --- -- In this case the numerator is off by 224!+ -- In this case the numerator is off by 1. toSDouble :: SRoundingMode -> SBV a -> SDouble -- default definition if we have an integral like
Data/SBV/Core/Kind.hs view
@@ -41,7 +41,7 @@ | KBounded !Bool !Int | KUnbounded | KReal- | KUninterpreted String (Either String [String]) -- name. Left: uninterpreted. Right: enum constructors.+ | KUserSort String (Maybe [String]) -- name. Uninterpreted, or enumeration constants. | KFloat | KDouble | KChar@@ -54,43 +54,43 @@ deriving (Eq, Ord) -- | The interesting about the show instance is that it can tell apart two kinds nicely; since it conveniently--- ignores the enumeration constructors. Also, when we construct a 'KUninterpreted', we make sure we don't use any of+-- ignores the enumeration constructors. Also, when we construct a 'KUserSort', we make sure we don't use any of -- the reserved names; see 'constructUKind' for details. instance Show Kind where- show KBool = "SBool"- show (KBounded False n) = pickType n "SWord" "SWord " ++ show n- show (KBounded True n) = pickType n "SInt" "SInt " ++ show n- show KUnbounded = "SInteger"- show KReal = "SReal"- show (KUninterpreted s _) = s- show KFloat = "SFloat"- show KDouble = "SDouble"- show KString = "SString"- show KChar = "SChar"- show (KList e) = "[" ++ show e ++ "]"- show (KSet e) = "{" ++ show e ++ "}"- show (KTuple m) = "(" ++ intercalate ", " (show <$> m) ++ ")"- show (KMaybe k) = "SMaybe " ++ kindParen (showBaseKind k)- show (KEither k1 k2) = "SEither " ++ kindParen (showBaseKind k1) ++ " " ++ kindParen (showBaseKind k2)+ show KBool = "SBool"+ show (KBounded False n) = pickType n "SWord" "SWord " ++ show n+ show (KBounded True n) = pickType n "SInt" "SInt " ++ show n+ show KUnbounded = "SInteger"+ show KReal = "SReal"+ show (KUserSort s _) = s+ show KFloat = "SFloat"+ show KDouble = "SDouble"+ show KString = "SString"+ show KChar = "SChar"+ show (KList e) = "[" ++ show e ++ "]"+ show (KSet e) = "{" ++ show e ++ "}"+ show (KTuple m) = "(" ++ intercalate ", " (show <$> m) ++ ")"+ show (KMaybe k) = "SMaybe " ++ kindParen (showBaseKind k)+ show (KEither k1 k2) = "SEither " ++ kindParen (showBaseKind k1) ++ " " ++ kindParen (showBaseKind k2) -- | A version of show for kinds that says Bool instead of SBool showBaseKind :: Kind -> String showBaseKind = sh- where sh k@KBool = noS (show k)- sh (KBounded False n) = pickType n "Word" "WordN " ++ show n- sh (KBounded True n) = pickType n "Int" "IntN " ++ show n- sh k@KUnbounded = noS (show k)- sh k@KReal = noS (show k)- sh k@KUninterpreted{} = show k -- Leave user-sorts untouched!- sh k@KFloat = noS (show k)- sh k@KDouble = noS (show k)- sh k@KChar = noS (show k)- sh k@KString = noS (show k)- sh (KList k) = "[" ++ sh k ++ "]"- sh (KSet k) = "{" ++ sh k ++ "}"- sh (KTuple ks) = "(" ++ intercalate ", " (map sh ks) ++ ")"- sh (KMaybe k) = "Maybe " ++ kindParen (sh k)- sh (KEither k1 k2) = "Either " ++ kindParen (sh k1) ++ " " ++ kindParen (sh k2)+ where sh k@KBool = noS (show k)+ sh (KBounded False n) = pickType n "Word" "WordN " ++ show n+ sh (KBounded True n) = pickType n "Int" "IntN " ++ show n+ sh k@KUnbounded = noS (show k)+ sh k@KReal = noS (show k)+ sh k@KUserSort{} = show k -- Leave user-sorts untouched!+ sh k@KFloat = noS (show k)+ sh k@KDouble = noS (show k)+ sh k@KChar = noS (show k)+ sh k@KString = noS (show k)+ sh (KList k) = "[" ++ sh k ++ "]"+ sh (KSet k) = "{" ++ sh k ++ "}"+ sh (KTuple ks) = "(" ++ intercalate ", " (map sh ks) ++ ")"+ sh (KMaybe k) = "Maybe " ++ kindParen (sh k)+ sh (KEither k1 k2) = "Either " ++ kindParen (sh k1) ++ " " ++ kindParen (sh k2) -- Drop the initial S if it's there noS ('S':s) = s@@ -111,21 +111,21 @@ -- | How the type maps to SMT land smtType :: Kind -> String-smtType KBool = "Bool"-smtType (KBounded _ sz) = "(_ BitVec " ++ show sz ++ ")"-smtType KUnbounded = "Int"-smtType KReal = "Real"-smtType KFloat = "(_ FloatingPoint 8 24)"-smtType KDouble = "(_ FloatingPoint 11 53)"-smtType KString = "String"-smtType KChar = "(_ BitVec 8)"-smtType (KList k) = "(Seq " ++ smtType k ++ ")"-smtType (KSet k) = "(Array " ++ smtType k ++ " Bool)"-smtType (KUninterpreted s _) = s-smtType (KTuple []) = "SBVTuple0"-smtType (KTuple kinds) = "(SBVTuple" ++ show (length kinds) ++ " " ++ unwords (smtType <$> kinds) ++ ")"-smtType (KMaybe k) = "(SBVMaybe " ++ smtType k ++ ")"-smtType (KEither k1 k2) = "(SBVEither " ++ smtType k1 ++ " " ++ smtType k2 ++ ")"+smtType KBool = "Bool"+smtType (KBounded _ sz) = "(_ BitVec " ++ show sz ++ ")"+smtType KUnbounded = "Int"+smtType KReal = "Real"+smtType KFloat = "(_ FloatingPoint 8 24)"+smtType KDouble = "(_ FloatingPoint 11 53)"+smtType KString = "String"+smtType KChar = "(_ BitVec 8)"+smtType (KList k) = "(Seq " ++ smtType k ++ ")"+smtType (KSet k) = "(Array " ++ smtType k ++ " Bool)"+smtType (KUserSort s _) = s+smtType (KTuple []) = "SBVTuple0"+smtType (KTuple kinds) = "(SBVTuple" ++ show (length kinds) ++ " " ++ unwords (smtType <$> kinds) ++ ")"+smtType (KMaybe k) = "(SBVMaybe " ++ smtType k ++ ")"+smtType (KEither k1 k2) = "(SBVEither " ++ smtType k1 ++ " " ++ smtType k2 ++ ")" instance Eq G.DataType where a == b = G.tyconUQname (G.dataTypeName a) == G.tyconUQname (G.dataTypeName b)@@ -135,46 +135,51 @@ -- | Does this kind represent a signed quantity? kindHasSign :: Kind -> Bool-kindHasSign = \case KBool -> False- KBounded b _ -> b- KUnbounded -> True- KReal -> True- KFloat -> True- KDouble -> True- KUninterpreted{} -> False- KString -> False- KChar -> False- KList{} -> False- KSet{} -> False- KTuple{} -> False- KMaybe{} -> False- KEither{} -> False+kindHasSign = \case KBool -> False+ KBounded b _ -> b+ KUnbounded -> True+ KReal -> True+ KFloat -> True+ KDouble -> True+ KUserSort{} -> False+ KString -> False+ KChar -> False+ KList{} -> False+ KSet{} -> False+ KTuple{} -> False+ KMaybe{} -> False+ KEither{} -> False -- | Construct an uninterpreted/enumerated kind from a piece of data; we distinguish simple enumerations as those -- are mapped to proper SMT-Lib2 data-types; while others go completely uninterpreted constructUKind :: forall a. (Read a, G.Data a) => a -> Kind constructUKind a | any (`isPrefixOf` sortName) badPrefixes- = error $ "Data.SBV: Cannot construct user-sort with name: " ++ show sortName ++ ": Must not start with any of " ++ intercalate ", " badPrefixes+ = error $ unlines [ "*** Data.SBV: Cannot construct user-sort with name: " ++ show sortName+ , "***"+ , "*** Must not start with any of: " ++ intercalate ", " badPrefixes+ ] | True- = KUninterpreted sortName mbEnumFields+ = case (constrs, concatMap G.constrFields constrs) of+ ([], _) -> KUserSort sortName Nothing+ (cs, []) -> KUserSort sortName $ Just (map show cs)+ _ -> error $ unlines [ "*** Data.SBV: " ++ sortName ++ " is not an enumeration."+ , "***"+ , "*** To declare an enumeration, constructors should not have any fields."+ , "*** To declare an uninterpreted sort, use a datatype with no constructors."+ ]+ where -- make sure we don't step on ourselves:- badPrefixes = ["SBool", "SWord", "SInt", "SInteger", "SReal", "SFloat", "SDouble", "SString", "SChar", "["]+ -- NB. The sort "RoundingMode" is special. It's treated by SBV as a user-defined+ -- sort, even though it's internally handled differently. So, that name doesn't appear+ -- below.+ badPrefixes = [ "SBool", "SWord", "SInt", "SInteger", "SReal", "SFloat", "SDouble"+ , "SString", "SChar", "[", "SSet", "STuple", "SMaybe", "SEither"+ ] - dataType = G.dataTypeOf a- sortName = G.tyconUQname . G.dataTypeName $ dataType- constrs = G.dataTypeConstrs dataType- isEnumeration = not (null constrs) && all (null . G.constrFields) constrs- mbEnumFields- | isEnumeration = check constrs []- | True = Left $ sortName ++ " is not a finite non-empty enumeration"- check [] sofar = Right $ reverse sofar- check (c:cs) sofar = case checkConstr c of- Nothing -> check cs (show c : sofar)- Just s -> Left $ sortName ++ "." ++ show c ++ ": " ++ s- checkConstr c = case (reads (show c) :: [(a, String)]) of- ((_, "") : _) -> Nothing- _ -> Just "not a nullary constructor"+ dataType = G.dataTypeOf a+ sortName = G.tyconUQname . G.dataTypeName $ dataType+ constrs = G.dataTypeConstrs dataType -- | A class for capturing values that have a sign and a size (finite or infinite) -- minimal complete definition: kindOf, unless you can take advantage of the default@@ -182,84 +187,84 @@ -- a 'G.Data' instance; this is useful for creating uninterpreted sorts. So, in -- reality, end users should almost never need to define any methods. class HasKind a where- kindOf :: a -> Kind- hasSign :: a -> Bool- intSizeOf :: a -> Int- isBoolean :: a -> Bool- isBounded :: a -> Bool -- NB. This really means word/int; i.e., Real/Float will test False- isReal :: a -> Bool- isFloat :: a -> Bool- isDouble :: a -> Bool- isUnbounded :: a -> Bool- isUninterpreted :: a -> Bool- isChar :: a -> Bool- isString :: a -> Bool- isList :: a -> Bool- isSet :: a -> Bool- isTuple :: a -> Bool- isMaybe :: a -> Bool- isEither :: a -> Bool- showType :: a -> String+ kindOf :: a -> Kind+ hasSign :: a -> Bool+ intSizeOf :: a -> Int+ isBoolean :: a -> Bool+ isBounded :: a -> Bool -- NB. This really means word/int; i.e., Real/Float will test False+ isReal :: a -> Bool+ isFloat :: a -> Bool+ isDouble :: a -> Bool+ isUnbounded :: a -> Bool+ isUserSort :: a -> Bool+ isChar :: a -> Bool+ isString :: a -> Bool+ isList :: a -> Bool+ isSet :: a -> Bool+ isTuple :: a -> Bool+ isMaybe :: a -> Bool+ isEither :: a -> Bool+ showType :: a -> String -- defaults hasSign x = kindHasSign (kindOf x) intSizeOf x = case kindOf x of- KBool -> error "SBV.HasKind.intSizeOf((S)Bool)"- KBounded _ s -> s- KUnbounded -> error "SBV.HasKind.intSizeOf((S)Integer)"- KReal -> error "SBV.HasKind.intSizeOf((S)Real)"- KFloat -> error "SBV.HasKind.intSizeOf((S)Float)"- KDouble -> error "SBV.HasKind.intSizeOf((S)Double)"- KUninterpreted s _ -> error $ "SBV.HasKind.intSizeOf: Uninterpreted sort: " ++ s- KString -> error "SBV.HasKind.intSizeOf((S)Double)"- KChar -> error "SBV.HasKind.intSizeOf((S)Char)"- KList ek -> error $ "SBV.HasKind.intSizeOf((S)List)" ++ show ek- KSet ek -> error $ "SBV.HasKind.intSizeOf((S)Set)" ++ show ek- KTuple tys -> error $ "SBV.HasKind.intSizeOf((S)Tuple)" ++ show tys- KMaybe k -> error $ "SBV.HasKind.intSizeOf((S)Maybe)" ++ show k- KEither k1 k2 -> error $ "SBV.HasKind.intSizeOf((S)Either)" ++ show (k1, k2)+ KBool -> error "SBV.HasKind.intSizeOf((S)Bool)"+ KBounded _ s -> s+ KUnbounded -> error "SBV.HasKind.intSizeOf((S)Integer)"+ KReal -> error "SBV.HasKind.intSizeOf((S)Real)"+ KFloat -> error "SBV.HasKind.intSizeOf((S)Float)"+ KDouble -> error "SBV.HasKind.intSizeOf((S)Double)"+ KUserSort s _ -> error $ "SBV.HasKind.intSizeOf: Uninterpreted sort: " ++ s+ KString -> error "SBV.HasKind.intSizeOf((S)Double)"+ KChar -> error "SBV.HasKind.intSizeOf((S)Char)"+ KList ek -> error $ "SBV.HasKind.intSizeOf((S)List)" ++ show ek+ KSet ek -> error $ "SBV.HasKind.intSizeOf((S)Set)" ++ show ek+ KTuple tys -> error $ "SBV.HasKind.intSizeOf((S)Tuple)" ++ show tys+ KMaybe k -> error $ "SBV.HasKind.intSizeOf((S)Maybe)" ++ show k+ KEither k1 k2 -> error $ "SBV.HasKind.intSizeOf((S)Either)" ++ show (k1, k2) - isBoolean (kindOf -> KBool{}) = True- isBoolean _ = False+ isBoolean (kindOf -> KBool{}) = True+ isBoolean _ = False - isBounded (kindOf -> KBounded{}) = True- isBounded _ = False+ isBounded (kindOf -> KBounded{}) = True+ isBounded _ = False - isReal (kindOf -> KReal{}) = True- isReal _ = False+ isReal (kindOf -> KReal{}) = True+ isReal _ = False - isFloat (kindOf -> KFloat{}) = True- isFloat _ = False+ isFloat (kindOf -> KFloat{}) = True+ isFloat _ = False - isDouble (kindOf -> KDouble{}) = True- isDouble _ = False+ isDouble (kindOf -> KDouble{}) = True+ isDouble _ = False - isUnbounded (kindOf -> KUnbounded{}) = True- isUnbounded _ = False+ isUnbounded (kindOf -> KUnbounded{}) = True+ isUnbounded _ = False - isUninterpreted (kindOf -> KUninterpreted{}) = True- isUninterpreted _ = False+ isUserSort (kindOf -> KUserSort{}) = True+ isUserSort _ = False - isChar (kindOf -> KChar{}) = True- isChar _ = False+ isChar (kindOf -> KChar{}) = True+ isChar _ = False - isString (kindOf -> KString{}) = True- isString _ = False+ isString (kindOf -> KString{}) = True+ isString _ = False - isList (kindOf -> KList{}) = True- isList _ = False+ isList (kindOf -> KList{}) = True+ isList _ = False - isSet (kindOf -> KSet{}) = True- isSet _ = False+ isSet (kindOf -> KSet{}) = True+ isSet _ = False - isTuple (kindOf -> KTuple{}) = True- isTuple _ = False+ isTuple (kindOf -> KTuple{}) = True+ isTuple _ = False - isMaybe (kindOf -> KMaybe{}) = True- isMaybe _ = False+ isMaybe (kindOf -> KMaybe{}) = True+ isMaybe _ = False - isEither (kindOf -> KEither{}) = True- isEither _ = False+ isEither (kindOf -> KEither{}) = True+ isEither _ = False showType = show . kindOf @@ -289,21 +294,21 @@ -- | Do we have a completely uninterpreted sort lying around anywhere? hasUninterpretedSorts :: Kind -> Bool-hasUninterpretedSorts KBool = False-hasUninterpretedSorts KBounded{} = False-hasUninterpretedSorts KUnbounded = False-hasUninterpretedSorts KReal = False-hasUninterpretedSorts (KUninterpreted _ (Right _)) = False -- These are the enumerated sorts, and they are perfectly fine-hasUninterpretedSorts (KUninterpreted _ (Left _)) = True -- These are the completely uninterpreted sorts, which we are looking for here-hasUninterpretedSorts KFloat = False-hasUninterpretedSorts KDouble = False-hasUninterpretedSorts KChar = False-hasUninterpretedSorts KString = False-hasUninterpretedSorts (KList k) = hasUninterpretedSorts k-hasUninterpretedSorts (KSet k) = hasUninterpretedSorts k-hasUninterpretedSorts (KTuple ks) = any hasUninterpretedSorts ks-hasUninterpretedSorts (KMaybe k) = hasUninterpretedSorts k-hasUninterpretedSorts (KEither k1 k2) = any hasUninterpretedSorts [k1, k2]+hasUninterpretedSorts KBool = False+hasUninterpretedSorts KBounded{} = False+hasUninterpretedSorts KUnbounded = False+hasUninterpretedSorts KReal = False+hasUninterpretedSorts (KUserSort _ (Just _)) = False -- These are the enumerated sorts, and they are perfectly fine+hasUninterpretedSorts (KUserSort _ Nothing) = True -- These are the completely uninterpreted sorts, which we are looking for here+hasUninterpretedSorts KFloat = False+hasUninterpretedSorts KDouble = False+hasUninterpretedSorts KChar = False+hasUninterpretedSorts KString = False+hasUninterpretedSorts (KList k) = hasUninterpretedSorts k+hasUninterpretedSorts (KSet k) = hasUninterpretedSorts k+hasUninterpretedSorts (KTuple ks) = any hasUninterpretedSorts ks+hasUninterpretedSorts (KMaybe k) = hasUninterpretedSorts k+hasUninterpretedSorts (KEither k1 k2) = any hasUninterpretedSorts [k1, k2] instance (Typeable a, HasKind a) => HasKind [a] where kindOf x | isKString @[a] x = KString@@ -346,17 +351,17 @@ -- Essentially, we're being conservative here and simply requesting flattening anything that has -- some structure to it. needsFlattening :: Kind -> Bool-needsFlattening KBool = False-needsFlattening KBounded{} = False-needsFlattening KUnbounded = False-needsFlattening KReal = False-needsFlattening KUninterpreted{} = False-needsFlattening KFloat = False-needsFlattening KDouble = False-needsFlattening KChar = False-needsFlattening KString = False-needsFlattening KList{} = True-needsFlattening KSet{} = True-needsFlattening KTuple{} = True-needsFlattening KMaybe{} = True-needsFlattening KEither{} = True+needsFlattening KBool = False+needsFlattening KBounded{} = False+needsFlattening KUnbounded = False+needsFlattening KReal = False+needsFlattening KUserSort{} = False+needsFlattening KFloat = False+needsFlattening KDouble = False+needsFlattening KChar = False+needsFlattening KString = False+needsFlattening KList{} = True+needsFlattening KSet{} = True+needsFlattening KTuple{} = True+needsFlattening KMaybe{} = True+needsFlattening KEither{} = True
Data/SBV/Core/Model.hs view
@@ -87,11 +87,11 @@ -- Symbolic-Word class instances -- | Generate a finite symbolic bitvector, named-genVar :: MonadSymbolic m => Maybe Quantifier -> Kind -> String -> m (SBV a)+genVar :: MonadSymbolic m => VarContext -> Kind -> String -> m (SBV a) genVar q k = mkSymSBV q k . Just -- | Generate a finite symbolic bitvector, unnamed-genVar_ :: MonadSymbolic m => Maybe Quantifier -> Kind -> m (SBV a)+genVar_ :: MonadSymbolic m => VarContext -> Kind -> m (SBV a) genVar_ q k = mkSymSBV q k Nothing -- | Generate a finite constant bitvector@@ -104,7 +104,7 @@ genFromCV c = error $ "genFromCV: Unsupported non-integral value: " ++ show c -- | Generalization of 'Data.SBV.genMkSymVar'-genMkSymVar :: MonadSymbolic m => Kind -> Maybe Quantifier -> Maybe String -> m (SBV a)+genMkSymVar :: MonadSymbolic m => Kind -> VarContext -> Maybe String -> m (SBV a) genMkSymVar k mbq Nothing = genVar_ mbq k genMkSymVar k mbq (Just s) = genVar mbq k s @@ -654,7 +654,7 @@ recordObservable st m (cond . fromCV) xsv return xsv --- | Observe the value of an expression, uncoditionally. See 'observeIf' for a generalized version.+-- | Observe the value of an expression, unconditionally. See 'observeIf' for a generalized version. observe :: SymVal a => String -> SBV a -> SBV a observe = observeIf (const True) @@ -881,20 +881,20 @@ = True | True = case k of- KBool -> True- KBounded {} -> True- KUnbounded {} -> True- KReal {} -> True- KUninterpreted {} -> True- KFloat -> True- KDouble -> True- KChar -> True- KString -> True- KList {} -> nope -- Unfortunately, no way for us to desugar this- KSet {} -> nope -- Ditto here..- KTuple {} -> False- KMaybe {} -> False- KEither {} -> False+ KBool -> True+ KBounded {} -> True+ KUnbounded {} -> True+ KReal {} -> True+ KUserSort {} -> True+ KFloat -> True+ KDouble -> True+ KChar -> True+ KString -> True+ KList {} -> nope -- Unfortunately, no way for us to desugar this+ KSet {} -> nope -- Ditto here..+ KTuple {} -> False+ KMaybe {} -> False+ KEither {} -> False where k = kindOf x nope = error $ "Data.SBV.OrdSymbolic: SMTLib does not support " ++ op ++ " for " ++ show k @@ -1034,7 +1034,7 @@ setBitTo :: SBV a -> Int -> SBool -> SBV a -- | Full adder, returns carry-out from the addition. Only for unsigned quantities. fullAdder :: SBV a -> SBV a -> (SBool, SBV a)- -- | Full multipler, returns both high and low-order bits. Only for unsigned quantities.+ -- | Full multiplier, returns both high and low-order bits. Only for unsigned quantities. fullMultiplier :: SBV a -> SBV a -> (SBV a, SBV a) -- | Count leading zeros in a word, big-endian interpretation. sCountLeadingZeros :: SBV a -> SWord8@@ -1290,40 +1290,41 @@ KDouble -> False KReal -> True -- Following cases should not happen since these types should *not* be instances of Fractional- k@KBounded{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KUnbounded -> error $ "Unexpected Fractional case for: " ++ show k- k@KBool -> error $ "Unexpected Fractional case for: " ++ show k- k@KString -> error $ "Unexpected Fractional case for: " ++ show k- k@KChar -> error $ "Unexpected Fractional case for: " ++ show k- k@KList{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KSet{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KUninterpreted{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KTuple{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KMaybe{} -> error $ "Unexpected Fractional case for: " ++ show k- k@KEither{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KBounded{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KUnbounded -> error $ "Unexpected Fractional case for: " ++ show k+ k@KBool -> error $ "Unexpected Fractional case for: " ++ show k+ k@KString -> error $ "Unexpected Fractional case for: " ++ show k+ k@KChar -> error $ "Unexpected Fractional case for: " ++ show k+ k@KList{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KSet{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KUserSort{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KTuple{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KMaybe{} -> error $ "Unexpected Fractional case for: " ++ show k+ k@KEither{} -> error $ "Unexpected Fractional case for: " ++ show k --- | Define Floating instance on SBV's; only for base types that are already floating; i.e., SFloat and SDouble--- Note that most of the fields are "undefined" for symbolic values, we add methods as they are supported by SMTLib.--- Currently, the only symbolicly available function in this class is sqrt.+-- | Define Floating instance on SBV's; only for base types that are already floating; i.e., SFloat, SDouble, and SReal.+-- Note that unless you use delta-sat via dReal on SReal, most of the fields are "undefined" for symbolic values. We will+-- add methods as they are supported by SMTLib. Currently, the only symbolically available function in this class is sqrt+-- for SFloat and SDouble. instance (Ord a, SymVal a, Fractional a, Floating a) => Floating (SBV a) where- pi = literal pi- exp = lift1FNS "exp" exp- log = lift1FNS "log" log- sqrt = lift1F FP_Sqrt sqrt- sin = lift1FNS "sin" sin- cos = lift1FNS "cos" cos- tan = lift1FNS "tan" tan- asin = lift1FNS "asin" asin- acos = lift1FNS "acos" acos- atan = lift1FNS "atan" atan- sinh = lift1FNS "sinh" sinh- cosh = lift1FNS "cosh" cosh- tanh = lift1FNS "tanh" tanh- asinh = lift1FNS "asinh" asinh- acosh = lift1FNS "acosh" acosh- atanh = lift1FNS "atanh" atanh- (**) = lift2FNS "**" (**)- logBase = lift2FNS "logBase" logBase+ pi = literal pi+ exp = lift1FNS "exp" exp+ log = lift1FNS "log" log+ sqrt = lift1F FP_Sqrt sqrt+ sin = lift1FNS "sin" sin+ cos = lift1FNS "cos" cos+ tan = lift1FNS "tan" tan+ asin = lift1FNS "asin" asin+ acos = lift1FNS "acos" acos+ atan = lift1FNS "atan" atan+ sinh = lift1FNS "sinh" sinh+ cosh = lift1FNS "cosh" cosh+ tanh = lift1FNS "tanh" tanh+ asinh = lift1FNS "asinh" asinh+ acosh = lift1FNS "acosh" acosh+ atanh = lift1FNS "atanh" atanh+ (**) = lift2FNS "**" (**)+ logBase = lift2FNS "logBase" logBase -- | Lift a 1 arg FP-op, using sRNE default lift1F :: SymVal a => FPOp -> (a -> a) -> SBV a -> SBV a@@ -1350,6 +1351,45 @@ , Just v2 <- unliteral sv2 = literal $ f v1 v2 | True = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv1) +-- | SReal Floating instance, used in conjunction with the dReal solver for delta-satisfiability. Note that+-- we do not constant fold these values (except for pi), as Haskell doesn't really have any means of computing+-- them for arbitrary rationals.+instance {-# OVERLAPPING #-} Floating SReal where+ pi = fromRational . toRational $ (pi :: Double)+ exp = lift1SReal NR_Exp+ log = lift1SReal NR_Log+ sqrt = lift1SReal NR_Sqrt+ sin = lift1SReal NR_Sin+ cos = lift1SReal NR_Cos+ tan = lift1SReal NR_Tan+ asin = lift1SReal NR_ASin+ acos = lift1SReal NR_ACos+ atan = lift1SReal NR_ATan+ sinh = lift1SReal NR_Sinh+ cosh = lift1SReal NR_Cosh+ tanh = lift1SReal NR_Tanh+ asinh = error "Data.SBV.SReal: asinh is currently not supported. Please request this as a feature!"+ acosh = error "Data.SBV.SReal: acosh is currently not supported. Please request this as a feature!"+ atanh = error "Data.SBV.SReal: atanh is currently not supported. Please request this as a feature!"+ (**) = lift2SReal NR_Pow++ logBase x y = log y / log x++-- | Lift an sreal unary function+lift1SReal :: NROp -> SReal -> SReal+lift1SReal w a = SBV $ SVal k $ Right $ cache r+ where k = kindOf a+ r st = do swa <- sbvToSV st a+ newExpr st k (SBVApp (NonLinear w) [swa])++-- | Lift an sreal binary function+lift2SReal :: NROp -> SReal -> SReal -> SReal+lift2SReal w a b = SBV $ SVal k $ Right $ cache r+ where k = kindOf a+ r st = do swa <- sbvToSV st a+ swb <- sbvToSV st b+ newExpr st k (SBVApp (NonLinear w) [swa, swb])+ -- NB. In the optimizations below, use of -1 is valid as -- -1 has all bits set to True for both signed and unsigned values -- | Using 'popCount' or 'testBit' on non-concrete values will result in an@@ -2464,7 +2504,7 @@ return (SBV s :: SBool) -- | Explicit sharing combinator. The SBV library has internal caching/hash-consing mechanisms--- built in, based on Andy Gill's type-safe obervable sharing technique (see: <http://ku-fpg.github.io/files/Gill-09-TypeSafeReification.pdf>).+-- built in, based on Andy Gill's type-safe observable sharing technique (see: <http://ku-fpg.github.io/files/Gill-09-TypeSafeReification.pdf>). -- However, there might be times where being explicit on the sharing can help, especially in experimental code. The 'slet' combinator -- ensures that its first argument is computed once and passed on to its continuation, explicitly indicating the intent of sharing. Most -- use cases of the SBV library should simply use Haskell's @let@ construct for this purpose.
Data/SBV/Core/Operations.hs view
@@ -42,7 +42,7 @@ , svBlastLE, svBlastBE , svAddConstant, svIncrement, svDecrement -- ** Basic array operations- , SArr, readSArr, writeSArr, mergeSArr, newSArr, eqSArr+ , SArr(..), readSArr, writeSArr, mergeSArr, newSArr, eqSArr , SFunArr(..), readSFunArr, writeSFunArr, mergeSFunArr, newSFunArr -- Utils , mkSymOp@@ -54,7 +54,7 @@ import qualified Data.IORef as R (modifyIORef', newIORef, readIORef) import qualified Data.Map.Strict as Map (toList, fromList, lookup)-import qualified Data.IntMap.Strict as IMap (IntMap, empty, toAscList, fromAscList, lookup, size, insert)+import qualified Data.IntMap.Strict as IMap (IntMap, empty, toAscList, fromAscList, lookup, size, insert, delete) import Data.SBV.Core.AlgReals import Data.SBV.Core.Kind@@ -511,7 +511,7 @@ newExpr st k (SBVApp (Extract i j) [sv]) svExtract _ _ _ = error "extract: non-bitvector type" --- | Join two words, by concataneting+-- | Join two words, by concatenating svJoin :: SVal -> SVal -> SVal svJoin x@(SVal (KBounded s i) a) y@(SVal (KBounded _ j) b) | i == 0 = y@@ -577,7 +577,7 @@ where k = x+5 If we tracked the assumptions, we would recompute @k@ twice, since the branch assumptions would differ. Clearly, there is no need to- re-compute @k@ in this case since its value is independent of @y@. Note that the whole SBV performance story is based on agressive sharing,+ re-compute @k@ in this case since its value is independent of @y@. Note that the whole SBV performance story is based on aggressive sharing, and losing that would have other significant ramifications. The "proper" solution would be to track, with each shared computation, precisely which assumptions it actually *depends* on, rather@@ -605,7 +605,7 @@ ite e1 (f e2 e4) (f e3 e5) --> f (ite e1 e2 e3) (ite e1 e4 e5) especially if this expression happens to be inside 'f's body itself (i.e., when f is recursive), since it reduces the number of- recursive calls. Clearly, programming with symbolic simulation in mind is another kind of beast alltogether.+ recursive calls. Clearly, programming with symbolic simulation in mind is another kind of beast altogether. -} let sta = st `extendSValPathCondition` svAnd t let stb = st `extendSValPathCondition` svAnd (svNot t)@@ -1005,7 +1005,7 @@ swToSVal sv@(SV k _) = SVal k $ Right $ cache $ const $ return sv -- | A variant of SVal equality, but taking into account of constants--- NB. The rationalCheck is paranid perhaps, but is necessary in case+-- NB. The rationalCheck is paranoid perhaps, but is necessary in case -- we have some funky polynomial roots in there. We do allow for -- floating-points here though. Why? Because the Eq instance of 'CV' -- does the right thing by using object equality. (i.e., it does@@ -1088,21 +1088,19 @@ SV _ (NodeId addressNodeId) <- svToSV st address val <- svToSV st b - -- There are three cases:+ -- There are two cases: -- -- (1) We hit the cache, and old value is the same as new: No write necessary, just return the array- -- (2) We hit the cache, values are different. Simply insert, overriding the old-memo table location- -- (3) We miss the cache: Now we have to walk through all accesses and update the memo table accordingly.- -- Why? Just because we missed the cache doesn't mean that it's not there with a different "symbolic"- -- address. So, we have to walk through and update each entry in case the address matches.+ -- (2) We hit the cache, values are different OR we miss the cache. We need to insert this value into+ -- the cache, overriding the original if it was there. Note that we also have to walk the cache+ -- to update each element, as this write can symbolically be the same as some other addresses. -- -- Below, we determine which case we're in and then insert the value at the end and continue cont <- case addressNodeId `IMap.lookup` memoTable of Just oldVal -- Cache hit | val == oldVal -> return $ Left fArrayIndex -- Case 1- | True -> return $ Right memoTable -- Case 2 - Nothing -> do -- Cache miss+ _ -> do -- Cache miss, or value is different. let aInfo = (address, addressNodeId `Map.lookup` consts) @@ -1117,7 +1115,7 @@ modify :: Int -> SV -> IO SV modify i s = svToSV st $ svIte (svEqualWithConsts (nodeIdToSVal ak i, i `Map.lookup` consts) aInfo) b (swToSVal s) - Right . IMap.fromAscList <$> walk (IMap.toAscList memoTable) []+ Right . IMap.fromAscList <$> walk (IMap.toAscList (IMap.delete addressNodeId memoTable)) [] case cont of Left j -> return j -- There was a hit, and value was unchanged, nothing to do@@ -1304,7 +1302,7 @@ (with obvious modifications to call sites to get the proper arguments.) -But this means that we have to grab the constant list for every symbolicly lifted operation, also do the+But this means that we have to grab the constant list for every symbolically lifted operation, also do the same for other places, etc.; for the rare opportunity of catching a @x .== x@ optimization. Even then, the constants for the branches would still be generated. (i.e., in the above example we would still generate @s1@ and @s2@, but would skip @s3@.)
Data/SBV/Core/Symbolic.hs view
@@ -30,8 +30,8 @@ module Data.SBV.Core.Symbolic ( NodeId(..) , SV(..), swKind, trueSV, falseSV- , Op(..), PBOp(..), OvOp(..), FPOp(..), StrOp(..), SeqOp(..), SetOp(..), RegExp(..)- , Quantifier(..), needsExistentials+ , Op(..), PBOp(..), OvOp(..), FPOp(..), NROp(..), StrOp(..), SeqOp(..), SetOp(..), RegExp(..)+ , Quantifier(..), needsExistentials, VarContext(..) , RoundingMode(..) , SBVType(..), svUninterpreted, newUninterpreted , SVal(..)@@ -176,8 +176,9 @@ | Uninterpreted String | Label String -- Essentially no-op; useful for code generation to emit comments. | IEEEFP FPOp -- Floating-point ops, categorized separately- | PseudoBoolean PBOp -- Pseudo-boolean ops, categorized separately+ | NonLinear NROp -- Non-linear ops (mostly trigonometric), categorized separately | OverflowOp OvOp -- Overflow-ops, categorized separately+ | PseudoBoolean PBOp -- Pseudo-boolean ops, categorized separately | StrOp StrOp -- String ops, categorized separately | SeqOp SeqOp -- Sequence ops, categorized separately | SetOp SetOp -- Set operations, categorized separately@@ -246,6 +247,38 @@ show FP_IsNegative = "fp.isNegative" show FP_IsPositive = "fp.isPositive" +-- | Non-linear operations+data NROp = NR_Sin+ | NR_Cos+ | NR_Tan+ | NR_ASin+ | NR_ACos+ | NR_ATan+ | NR_Sqrt+ | NR_Sinh+ | NR_Cosh+ | NR_Tanh+ | NR_Exp+ | NR_Log+ | NR_Pow+ deriving (Eq, Ord)++-- | The show instance carefully arranges for these to be printed as it can be understood by dreal+instance Show NROp where+ show NR_Sin = "sin"+ show NR_Cos = "cos"+ show NR_Tan = "tan"+ show NR_ASin = "asin"+ show NR_ACos = "acos"+ show NR_ATan = "atan"+ show NR_Sinh = "sinh"+ show NR_Cosh = "cosh"+ show NR_Tanh = "tanh"+ show NR_Sqrt = "sqrt"+ show NR_Exp = "exp"+ show NR_Log = "log"+ show NR_Pow = "pow"+ -- | Pseudo-boolean operations data PBOp = PB_AtMost Int -- ^ At most k | PB_AtLeast Int -- ^ At least k@@ -447,6 +480,8 @@ show (IEEEFP w) = show w + show (NonLinear w) = show w+ show (PseudoBoolean p) = show p show (OverflowOp o) = show o@@ -459,18 +494,20 @@ show (TupleConstructor n) = "mkSBVTuple" ++ show n show (TupleAccess i n) = "proj_" ++ show i ++ "_SBVTuple" ++ show n + -- Remember, while we try to maintain SMTLib compabitibility here, these output+ -- is merely for debugging purposes. For how we actually render these in SMTLib,+ -- look at the file SBV/SMT/SMTLib2.hs for these constructors. show (EitherConstructor k1 k2 False) = "(_ left_SBVEither " ++ show (KEither k1 k2) ++ ")" show (EitherConstructor k1 k2 True ) = "(_ right_SBVEither " ++ show (KEither k1 k2) ++ ")" show (EitherIs k1 k2 False) = "(_ is (left_SBVEither (" ++ show k1 ++ ") " ++ show (KEither k1 k2) ++ "))" show (EitherIs k1 k2 True ) = "(_ is (right_SBVEither (" ++ show k2 ++ ") " ++ show (KEither k1 k2) ++ "))" show (EitherAccess False) = "get_left_SBVEither" show (EitherAccess True ) = "get_right_SBVEither"-- show (MaybeConstructor k False) = "(_ nothing_SBVMaybe " ++ show (KMaybe k) ++ ")"- show (MaybeConstructor k True) = "(_ just_SBVMaybe " ++ show (KMaybe k) ++ ")"- show (MaybeIs k False) = "(_ is (nothing_SBVMaybe () " ++ show (KMaybe k) ++ "))"- show (MaybeIs k True ) = "(_ is (just_SBVMaybe (" ++ show k ++ ") " ++ show (KMaybe k) ++ "))"- show MaybeAccess = "get_just_SBVMaybe"+ show (MaybeConstructor k False) = "(_ nothing_SBVMaybe " ++ show (KMaybe k) ++ ")"+ show (MaybeConstructor k True) = "(_ just_SBVMaybe " ++ show (KMaybe k) ++ ")"+ show (MaybeIs k False) = "(_ is (nothing_SBVMaybe () " ++ show (KMaybe k) ++ "))"+ show (MaybeIs k True ) = "(_ is (just_SBVMaybe (" ++ show k ++ ") " ++ show (KMaybe k) ++ "))"+ show MaybeAccess = "get_just_SBVMaybe" show op | Just s <- op `lookup` syms = s@@ -494,6 +531,10 @@ show ALL = "Forall" show EX = "Exists" +-- | Which context is this variable being created?+data VarContext = NonQueryVar (Maybe Quantifier) -- in this case, it can be quantified+ | QueryVar -- in this case, it is always existential+ -- | Are there any existential quantifiers? needsExistentials :: [Quantifier] -> Bool needsExistentials = (EX `elem`)@@ -701,9 +742,9 @@ where sh2 :: Show a => [a] -> [String] sh2 = map ((" "++) . show) - usorts = [sh s t | KUninterpreted s t <- Set.toList kinds]- where sh s (Left _) = s- sh s (Right es) = s ++ " (" ++ intercalate ", " es ++ ")"+ usorts = [sh s t | KUserSort s t <- Set.toList kinds]+ where sh s Nothing = s+ sh s (Just es) = s ++ " (" ++ intercalate ", " es ++ ")" shs sv = show sv ++ " :: " ++ show (swKind sv) @@ -983,6 +1024,12 @@ : map ("*** " ++) ss ++ ["*** Data.SBV: Please report this as a feature request!"] +-- | Things we do not support in interactive mode, nor we ever intend to+noInteractiveEver :: [String] -> a+noInteractiveEver ss = error $ unlines $ ""+ : "*** Data.SBV: Unsupported interactive/query mode feature."+ : map ("*** " ++) ss+ -- | Modification of the state, but carefully handling the interactive tasks. -- Note that the state is always updated regardless of the mode, but we get -- to also perform extra operation in interactive mode. (Typically error out, but also simply@@ -1102,7 +1149,7 @@ -- allow for this. registerKind :: State -> Kind -> IO () registerKind st k- | KUninterpreted sortName _ <- k, map toLower sortName `elem` smtLibReservedNames+ | KUserSort sortName _ <- k, map toLower sortName `elem` smtLibReservedNames = error $ "SBV: " ++ show sortName ++ " is a reserved sort; please use a different name." | True = do -- Adding a kind to the incState is tricky; we only need to add it@@ -1118,31 +1165,31 @@ -- order: In particular, if an uninterpreted kind is already in there, we don't -- want to re-add because double-declaration would be wrong. See 'cvtInc' for details. let needsAdding = case k of- KUninterpreted{} -> k `notElem` existingKinds- KList{} -> k `notElem` existingKinds- KTuple nks -> length nks `notElem` [length oks | KTuple oks <- Set.toList existingKinds]- KMaybe{} -> k `notElem` existingKinds- KEither{} -> k `notElem` existingKinds- _ -> False+ KUserSort{} -> k `notElem` existingKinds+ KList{} -> k `notElem` existingKinds+ KTuple nks -> length nks `notElem` [length oks | KTuple oks <- Set.toList existingKinds]+ KMaybe{} -> k `notElem` existingKinds+ KEither{} -> k `notElem` existingKinds+ _ -> False when needsAdding $ modifyIncState st rNewKinds (Set.insert k) -- Don't forget to register subkinds! case k of- KBool {} -> return ()- KBounded {} -> return ()- KUnbounded {} -> return ()- KReal {} -> return ()- KUninterpreted {} -> return ()- KFloat {} -> return ()- KDouble {} -> return ()- KChar {} -> return ()- KString {} -> return ()- KList ek -> registerKind st ek- KSet ek -> registerKind st ek- KTuple eks -> mapM_ (registerKind st) eks- KMaybe ke -> registerKind st ke- KEither k1 k2 -> mapM_ (registerKind st) [k1, k2]+ KBool {} -> return ()+ KBounded {} -> return ()+ KUnbounded{} -> return ()+ KReal {} -> return ()+ KUserSort {} -> return ()+ KFloat {} -> return ()+ KDouble {} -> return ()+ KChar {} -> return ()+ KString {} -> return ()+ KList ek -> registerKind st ek+ KSet ek -> registerKind st ek+ KTuple eks -> mapM_ (registerKind st) eks+ KMaybe ke -> registerKind st ke+ KEither k1 k2 -> mapM_ (registerKind st) [k1, k2] -- | Register a new label with the system, making sure they are unique and have no '|'s in them registerLabel :: String -> State -> String -> IO ()@@ -1271,36 +1318,36 @@ -- pick the quantifier appropriately based on the run-mode. -- @randomCV@ is used for generating random values for this variable -- when used for @quickCheck@ or 'Data.SBV.Tools.GenTest.genTest' purposes.-svMkSymVar :: Maybe Quantifier -> Kind -> Maybe String -> State -> IO SVal+svMkSymVar :: VarContext -> Kind -> Maybe String -> State -> IO SVal svMkSymVar = svMkSymVarGen False -- | Create an existentially quantified tracker variable svMkTrackerVar :: Kind -> String -> State -> IO SVal-svMkTrackerVar k nm = svMkSymVarGen True (Just EX) k (Just nm)+svMkTrackerVar k nm = svMkSymVarGen True (NonQueryVar (Just EX)) k (Just nm) -- | Generalization of 'Data.SBV.sWordN' sWordN :: MonadSymbolic m => Int -> String -> m SVal-sWordN w nm = symbolicEnv >>= liftIO . svMkSymVar Nothing (KBounded False w) (Just nm)+sWordN w nm = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded False w) (Just nm) -- | Generalization of 'Data.SBV.sWordN_' sWordN_ :: MonadSymbolic m => Int -> m SVal-sWordN_ w = symbolicEnv >>= liftIO . svMkSymVar Nothing (KBounded False w) Nothing+sWordN_ w = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded False w) Nothing -- | Generalization of 'Data.SBV.sIntN' sIntN :: MonadSymbolic m => Int -> String -> m SVal-sIntN w nm = symbolicEnv >>= liftIO . svMkSymVar Nothing (KBounded True w) (Just nm)+sIntN w nm = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded True w) (Just nm) -- | Generalization of 'Data.SBV.sIntN_' sIntN_ :: MonadSymbolic m => Int -> m SVal-sIntN_ w = symbolicEnv >>= liftIO . svMkSymVar Nothing (KBounded True w) Nothing+sIntN_ w = symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar Nothing) (KBounded True w) Nothing -- | Create a symbolic value, based on the quantifier we have. If an -- explicit quantifier is given, we just use that. If not, then we -- pick the quantifier appropriately based on the run-mode. -- @randomCV@ is used for generating random values for this variable -- when used for @quickCheck@ or 'Data.SBV.Tools.GenTest.genTest' purposes.-svMkSymVarGen :: Bool -> Maybe Quantifier -> Kind -> Maybe String -> State -> IO SVal-svMkSymVarGen isTracker mbQ k mbNm st = do+svMkSymVarGen :: Bool -> VarContext -> Kind -> Maybe String -> State -> IO SVal+svMkSymVarGen isTracker varContext k mbNm st = do rm <- readIORef (runMode st) let varInfo = case mbNm of@@ -1310,12 +1357,16 @@ disallow what = error $ "Data.SBV: Unsupported: " ++ what ++ varInfo ++ " in mode: " ++ show rm noUI cont- | isUninterpreted k = disallow "Uninterpreted sorts"- | True = cont+ | isUserSort k = disallow "User defined sorts"+ | True = cont + (isQueryVar, mbQ) = case varContext of+ NonQueryVar mq -> (False, mq)+ QueryVar -> (True, Just EX)+ mkS q = do (sv, internalName) <- newSV st k let nm = fromMaybe internalName mbNm- introduceUserName st isTracker nm k q sv+ introduceUserName st (isQueryVar, isTracker) nm k q sv mkC cv = do registerKind st k modifyState st rCInfo ((fromMaybe "_" mbNm, cv):) (return ())@@ -1344,8 +1395,8 @@ cant = "Validation engine is not capable of handling this case. Failed to validate." report = "Please report this as a bug in SBV!" - in if isUninterpreted k- then bad ("Cannot validate models in the presence of uninterpeted kinds, saw: " ++ show k) cant+ in if isUserSort k+ then bad ("Cannot validate models in the presence of user defined kinds, saw: " ++ show k) cant else do (sv, internalName) <- newSV st k let nm = fromMaybe internalName mbNm@@ -1372,12 +1423,26 @@ mkC cv -- | Introduce a new user name. We simply append a suffix if we have seen this variable before.-introduceUserName :: State -> Bool -> String -> Kind -> Quantifier -> SV -> IO SVal-introduceUserName st isTracker nmOrig k q sv = do+introduceUserName :: State -> (Bool, Bool) -> String -> Kind -> Quantifier -> SV -> IO SVal+introduceUserName st@State{runMode} (isQueryVar, isTracker) nmOrig k q sv = do (_, old) <- readIORef (rinps st) let nm = mkUnique nmOrig old + -- If this is not a query variable and we're in a query, reject it.+ -- See https://github.com/LeventErkok/sbv/issues/554 for the rationale.+ -- In theory, it should be possible to support this, but fixing it is+ -- rather costly as we'd have to track the regular updates and sync the+ -- incremental state appropriately. Instead, we issue an error message+ -- and ask the user to obey the query mode rules.+ rm <- readIORef runMode+ case rm of+ SMTMode _ IRun _ _ | not isQueryVar -> noInteractiveEver [ "Adding a new input variable in query mode: " ++ show nm+ , ""+ , "Hint: Use freshVar/freshVar_ for introducing new inputs in query mode."+ ]+ _ -> pure ()+ if isTracker && q == ALL then error $ "SBV: Impossible happened! A universally quantified tracker variable is being introduced: " ++ show nm else do let newInp olds = case q of@@ -1459,7 +1524,7 @@ , rSMTOptions = smtOpts , rOptGoals = optGoals , rAsserts = asserts- , rQueryState = qstate+ , rQueryState = qstate } _ <- liftIO $ newConst st falseCV -- s(-2) == falseSV _ <- liftIO $ newConst st trueCV -- s(-1) == trueSV@@ -1584,7 +1649,7 @@ -- level. This is similar to the "type-safe observable sharing" work, but also -- takes into the account of how symbolic simulation executes. ----- See Andy Gill's type-safe obervable sharing trick for the inspiration behind+-- See Andy Gill's type-safe observable sharing trick for the inspiration behind -- this technique: <http://ku-fpg.github.io/files/Gill-09-TypeSafeReification.pdf> -- -- Note that this is *not* a general memo utility!@@ -1685,11 +1750,12 @@ instance NFData SVal where rnf (SVal x y) = rnf x `seq` rnf y instance NFData SMTResult where- rnf (Unsatisfiable _ xs ) = rnf xs- rnf (Satisfiable _ xs ) = rnf xs- rnf (SatExtField _ xs ) = rnf xs- rnf (Unknown _ xs ) = rnf xs- rnf (ProofError _ xs mr) = rnf xs `seq` rnf mr+ rnf (Unsatisfiable _ m ) = rnf m+ rnf (Satisfiable _ m ) = rnf m+ rnf (DeltaSat _ p m ) = rnf m `seq` rnf p+ rnf (SatExtField _ m ) = rnf m+ rnf (Unknown _ m ) = rnf m+ rnf (ProofError _ m mr) = rnf m `seq` rnf mr instance NFData SMTModel where rnf (SMTModel objs bndgs assocs uifuns) = rnf objs `seq` rnf bndgs `seq` rnf assocs `seq` rnf uifuns@@ -1700,10 +1766,14 @@ -- | Translation tricks needed for specific capabilities afforded by each solver data SolverCapabilities = SolverCapabilities { supportsQuantifiers :: Bool -- ^ Supports SMT-Lib2 style quantifiers?+ , supportsDefineFun :: Bool -- ^ Supports define-fun construct?+ , supportsDistinct :: Bool -- ^ Supports calls to distinct?+ , supportsBitVectors :: Bool -- ^ Supports bit-vectors? , supportsUninterpretedSorts :: Bool -- ^ Supports SMT-Lib2 style uninterpreted-sorts , supportsUnboundedInts :: Bool -- ^ Supports unbounded integers? , supportsReals :: Bool -- ^ Supports reals? , supportsApproxReals :: Bool -- ^ Supports printing of approximations of reals?+ , supportsDeltaSat :: Maybe String -- ^ Supports delta-satisfiability? (With given precision query) , supportsIEEE754 :: Bool -- ^ Supports floating point numbers? , supportsSets :: Bool -- ^ Supports set operations? , supportsOptimization :: Bool -- ^ Supports optimization routines?@@ -1711,6 +1781,7 @@ , supportsCustomQueries :: Bool -- ^ Supports interactive queries per SMT-Lib? , supportsGlobalDecls :: Bool -- ^ Supports global declarations? (Needed for push-pop.) , supportsDataTypes :: Bool -- ^ Supports datatypes?+ , supportsDirectAccessors :: Bool -- ^ Supports data-type accessors without full ascription? , supportsFlattenedModels :: Maybe [String] -- ^ Supports flattened model output? (With given config lines.) } @@ -1763,7 +1834,9 @@ , optimizeValidateConstraints :: Bool -- ^ Validate optimization results. NB: Does NOT make sure the model is optimal, just checks they satisfy the constraints. , transcript :: Maybe FilePath -- ^ If Just, the entire interaction will be recorded as a playable file (for debugging purposes mostly) , smtLibVersion :: SMTLibVersion -- ^ What version of SMT-lib we use for the tool+ , dsatPrecision :: Maybe Double -- ^ Delta-sat precision , solver :: SMTSolver -- ^ The actual SMT solver.+ , extraArgs :: [String] -- ^ Extra command line arguments to pass to the solver. , allowQuantifiedQueries :: Bool -- ^ Should we permit use of quantifiers in the query mode? (Default: False. See <http://github.com/LeventErkok/sbv/issues/459> for why.) , roundingMode :: RoundingMode -- ^ Rounding mode to use for floating-point conversions , solverSetOptions :: [SMTOption] -- ^ Options to set as we start the solver@@ -1797,6 +1870,7 @@ -- it. (Custom Show instances and model extractors.) data SMTResult = Unsatisfiable SMTConfig (Maybe [String]) -- ^ Unsatisfiable. If unsat-cores are enabled, they will be returned in the second parameter. | Satisfiable SMTConfig SMTModel -- ^ Satisfiable with model+ | DeltaSat SMTConfig (Maybe String) SMTModel -- ^ Delta satisfiable with queried string if available and model | SatExtField SMTConfig SMTModel -- ^ Prover returned a model, but in an extension field containing Infinite/epsilon | Unknown SMTConfig SMTReasonUnknown -- ^ Prover returned unknown, with the given reason | ProofError SMTConfig [String] (Maybe SMTResult) -- ^ Prover errored out, with possibly a bogus result@@ -1818,6 +1892,7 @@ -- | Solvers that SBV is aware of data Solver = Z3 | Yices+ | DReal | Boolector | CVC4 | MathSAT@@ -1846,3 +1921,4 @@ {-# ANN type FPOp ("HLint: ignore Use camelCase" :: String) #-} {-# ANN type PBOp ("HLint: ignore Use camelCase" :: String) #-} {-# ANN type OvOp ("HLint: ignore Use camelCase" :: String) #-}+{-# ANN type NROp ("HLint: ignore Use camelCase" :: String) #-}
Data/SBV/Internals.hs view
@@ -21,7 +21,7 @@ module Data.SBV.Internals ( -- * Running symbolic programs /manually/- Result(..), SBVRunMode(..), IStage(..), QueryContext(..)+ Result(..), SBVRunMode(..), IStage(..), QueryContext(..), VarContext(..) -- * Solver capabilities , SolverCapabilities(..)@@ -59,7 +59,7 @@ import Data.SBV.Core.Data import Data.SBV.Core.Model (genLiteral, genFromCV, genMkSymVar, liftQRem, liftDMod)-import Data.SBV.Core.Symbolic (IStage(..), QueryContext(..), MonadQuery, addSValOptGoal, registerKind)+import Data.SBV.Core.Symbolic (IStage(..), QueryContext(..), MonadQuery, addSValOptGoal, registerKind, VarContext(..)) import Data.SBV.Core.Floating (sFloatAsComparableSWord32, sDoubleAsComparableSWord64)
Data/SBV/Provers/ABC.hs view
@@ -30,10 +30,14 @@ , engine = standardEngine "SBV_ABC" "SBV_ABC_OPTIONS" , capabilities = SolverCapabilities { supportsQuantifiers = False+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True , supportsUninterpretedSorts = False , supportsUnboundedInts = False , supportsReals = False , supportsApproxReals = False+ , supportsDeltaSat = Nothing , supportsIEEE754 = False , supportsSets = False , supportsOptimization = False@@ -41,6 +45,7 @@ , supportsCustomQueries = False , supportsGlobalDecls = False , supportsDataTypes = False+ , supportsDirectAccessors = False , supportsFlattenedModels = Nothing } }
Data/SBV/Provers/Boolector.hs view
@@ -28,10 +28,14 @@ , engine = standardEngine "SBV_BOOLECTOR" "SBV_BOOLECTOR_OPTIONS" , capabilities = SolverCapabilities { supportsQuantifiers = False+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True , supportsUninterpretedSorts = False , supportsUnboundedInts = False , supportsReals = False , supportsApproxReals = False+ , supportsDeltaSat = Nothing , supportsIEEE754 = False , supportsSets = False , supportsOptimization = False@@ -39,6 +43,7 @@ , supportsCustomQueries = True , supportsGlobalDecls = False , supportsDataTypes = False+ , supportsDirectAccessors = False , supportsFlattenedModels = Nothing } }
Data/SBV/Provers/CVC4.hs view
@@ -32,10 +32,14 @@ , engine = standardEngine "SBV_CVC4" "SBV_CVC4_OPTIONS" , capabilities = SolverCapabilities { supportsQuantifiers = True+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True , supportsUninterpretedSorts = True , supportsUnboundedInts = True , supportsReals = True -- Not quite the same capability as Z3; but works more or less.. , supportsApproxReals = False+ , supportsDeltaSat = Nothing , supportsIEEE754 = True , supportsSets = False , supportsOptimization = False@@ -43,6 +47,7 @@ , supportsCustomQueries = True , supportsGlobalDecls = True , supportsDataTypes = True+ , supportsDirectAccessors = True , supportsFlattenedModels = Nothing } }
+ Data/SBV/Provers/DReal.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.SBV.Provers.DReal+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- The connection to the dReal SMT solver+-----------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Data.SBV.Provers.DReal(dReal) where++import Data.SBV.Core.Data+import Data.SBV.SMT.SMT++import Numeric++-- | The description of the dReal SMT solver+-- The default executable is @\"dReal\"@, which must be in your path. You can use the @SBV_DREAL@ environment variable to point to the executable on your system.+-- You can use the @SBV_DREAL_OPTIONS@ environment variable to override the options.+dReal :: SMTSolver+dReal = SMTSolver {+ name = DReal+ , executable = "dReal"+ , preprocess = id+ , options = modConfig ["--in", "--format", "smt2"]+ , engine = standardEngine "SBV_DREAL" "SBV_DREAL_OPTIONS"+ , capabilities = SolverCapabilities {+ supportsQuantifiers = False+ , supportsDefineFun = True+ , supportsDistinct = False+ , supportsBitVectors = False+ , supportsUninterpretedSorts = False+ , supportsUnboundedInts = True+ , supportsReals = True+ , supportsApproxReals = False+ , supportsDeltaSat = Just "(get-option :precision)"+ , supportsIEEE754 = False+ , supportsSets = False+ , supportsOptimization = False+ , supportsPseudoBooleans = False+ , supportsCustomQueries = False+ , supportsGlobalDecls = False+ , supportsDataTypes = False+ , supportsDirectAccessors = False+ , supportsFlattenedModels = Nothing+ }+ }+ where -- If dsat precision is given, pass that as an argument+ modConfig :: [String] -> SMTConfig -> [String]+ modConfig opts cfg = case dsatPrecision cfg of+ Nothing -> opts+ Just d -> let sd = showFFloat Nothing d ""+ in if d > 0+ then opts ++ ["--precision", sd]+ else error $ unlines [ ""+ , "*** Data.SBV: Invalid precision to dReal: " ++ sd+ , "*** Precision must be non-negative."+ ]
Data/SBV/Provers/MathSAT.hs view
@@ -32,10 +32,14 @@ , engine = standardEngine "SBV_MATHSAT" "SBV_MATHSAT_OPTIONS" , capabilities = SolverCapabilities { supportsQuantifiers = True+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True , supportsUninterpretedSorts = True , supportsUnboundedInts = True , supportsReals = True , supportsApproxReals = False+ , supportsDeltaSat = Nothing , supportsIEEE754 = True , supportsSets = False , supportsOptimization = False@@ -43,6 +47,7 @@ , supportsCustomQueries = True , supportsGlobalDecls = True , supportsDataTypes = True+ , supportsDirectAccessors = True , supportsFlattenedModels = Nothing } }
Data/SBV/Provers/Prover.hs view
@@ -31,7 +31,7 @@ , runSMT, runSMTWith , SatModel(..), Modelable(..), displayModels, extractModels , getModelDictionaries, getModelValues, getModelUninterpretedValues- , boolector, cvc4, yices, z3, mathSAT, abc, defaultSMTCfg+ , boolector, cvc4, yices, dReal, z3, mathSAT, abc, defaultSMTCfg, defaultDeltaSMTCfg ) where @@ -71,6 +71,7 @@ import qualified Data.SBV.Provers.Boolector as Boolector import qualified Data.SBV.Provers.CVC4 as CVC4 import qualified Data.SBV.Provers.Yices as Yices+import qualified Data.SBV.Provers.DReal as DReal import qualified Data.SBV.Provers.Z3 as Z3 import qualified Data.SBV.Provers.MathSAT as MathSAT import qualified Data.SBV.Provers.ABC as ABC@@ -83,6 +84,8 @@ , transcript = Nothing , solver = s , smtLibVersion = smtVersion+ , dsatPrecision = Nothing+ , extraArgs = [] , satCmd = "(check-sat)" , satTrackUFs = True -- i.e., yes, do extract UI function values , allSatMaxModelCount = Nothing -- i.e., return all satisfying models@@ -100,7 +103,7 @@ -- | If supported, this makes all output go to stdout, which works better with SBV -- Alas, not all solvers support it.. allOnStdOut :: Control.SMTOption-allOnStdOut = Control.OptionKeyword ":diagnostic-output-channel" [show "stdout"]+allOnStdOut = Control.DiagnosticOutputChannel "stdout" -- | Default configuration for the Boolector SMT solver boolector :: SMTConfig@@ -114,6 +117,11 @@ yices :: SMTConfig yices = mkConfig Yices.yices SMTLib2 [] +-- | Default configuration for the Yices SMT Solver.+dReal :: SMTConfig+dReal = mkConfig DReal.dReal SMTLib2 [ Control.OptionKeyword ":smtlib2_compliant" ["true"]+ ]+ -- | Default configuration for the Z3 SMT solver z3 :: SMTConfig z3 = mkConfig Z3.z3 SMTLib2 [ Control.OptionKeyword ":smtlib2_compliant" ["true"]@@ -132,6 +140,11 @@ defaultSMTCfg :: SMTConfig defaultSMTCfg = z3 +-- | The default solver used by SBV for delta-satisfiability problems. This is currently set to dReal,+-- which is also the only solver that supports delta-satisfiability.+defaultDeltaSMTCfg :: SMTConfig+defaultDeltaSMTCfg = dReal+ -- | A predicate is a symbolic program that returns a (symbolic) boolean value. For all intents and -- purposes, it can be treated as an n-ary function from symbolic-values to a boolean. The 'Symbolic' -- monad captures the underlying representation, and can/should be ignored by the users of the library,@@ -172,6 +185,17 @@ then validate False cfg a r else return r + -- | Generalization of 'Data.SBV.dprove'+ dprove :: a -> m ThmResult+ dprove = dproveWith defaultDeltaSMTCfg++ -- | Generalization of 'Data.SBV.dproveWith'+ dproveWith :: SMTConfig -> a -> m ThmResult+ dproveWith cfg a = do r <- runWithQuery False (checkNoOptimizations >> Control.getSMTResult) cfg a+ ThmResult <$> if validationRequested cfg+ then validate False cfg a r+ else return r+ -- | Generalization of 'Data.SBV.sat' sat :: a -> m SatResult sat = satWith defaultSMTCfg@@ -183,17 +207,28 @@ then validate True cfg a r else return r + -- | Generalization of 'Data.SBV.sat'+ dsat :: a -> m SatResult+ dsat = dsatWith defaultDeltaSMTCfg++ -- | Generalization of 'Data.SBV.satWith'+ dsatWith :: SMTConfig -> a -> m SatResult+ dsatWith cfg a = do r <- runWithQuery True (checkNoOptimizations >> Control.getSMTResult) cfg a+ SatResult <$> if validationRequested cfg+ then validate True cfg a r+ else return r+ -- | Generalization of 'Data.SBV.allSat' allSat :: a -> m AllSatResult allSat = allSatWith defaultSMTCfg -- | Generalization of 'Data.SBV.allSatWith' allSatWith :: SMTConfig -> a -> m AllSatResult- allSatWith cfg a = do f@(mm, pe, un, rs) <- runWithQuery True (checkNoOptimizations >> Control.getAllSatResult) cfg a- AllSatResult <$> if validationRequested cfg- then do rs' <- mapM (validate True cfg a) rs- return (mm, pe, un, rs')- else return f+ allSatWith cfg a = do asr <- runWithQuery True (checkNoOptimizations >> Control.getAllSatResult) cfg a+ if validationRequested cfg+ then do rs' <- mapM (validate True cfg a) (allSatResults asr)+ return asr{allSatResults = rs'}+ else return asr -- | Generalization of 'Data.SBV.optimize' optimize :: OptimizeStyle -> a -> m OptimizeResult@@ -324,9 +359,10 @@ check :: QueryT m Bool check = do cs <- Control.checkSat case cs of- Control.Unsat -> return True- Control.Sat -> return False- Control.Unk -> error "SBV: isVacuous: Solver returned unknown!"+ Control.Unsat -> return True+ Control.Sat -> return False+ Control.DSat{} -> return False+ Control.Unk -> error "SBV: isVacuous: Solver returned unknown!" -- | Generalization of 'Data.SBV.isTheorem' isTheorem :: a -> m Bool@@ -335,11 +371,14 @@ -- | Generalization of 'Data.SBV.isTheoremWith' isTheoremWith :: SMTConfig -> a -> m Bool isTheoremWith cfg p = do r <- proveWith cfg p+ let bad = error $ "SBV.isTheorem: Received:\n" ++ show r case r of ThmResult Unsatisfiable{} -> return True ThmResult Satisfiable{} -> return False- _ -> error $ "SBV.isTheorem: Received:\n" ++ show r-+ ThmResult DeltaSat{} -> return False+ ThmResult SatExtField{} -> return False+ ThmResult Unknown{} -> bad+ ThmResult ProofError{} -> bad -- | Generalization of 'Data.SBV.isSatisfiable' isSatisfiable :: a -> m Bool@@ -358,20 +397,27 @@ validate isSAT cfg p res = case res of Unsatisfiable{} -> return res Satisfiable _ m -> case modelBindings m of- Nothing -> error "Data.SBV.validate: Impossible happaned; no bindings generated during model validation."+ Nothing -> error "Data.SBV.validate: Impossible happened; no bindings generated during model validation." Just env -> check env- SatExtField{} -> return $ ProofError cfg [ "The model requires an extension field value."- , "Cannot validate models with infinities/epsilons produced during optimization."- , ""- , "To turn validation off, use `cfg{optimizeValidateConstraints = False}`"- , ""- , "Unable to validate the produced model."- ]- (Just res)++ DeltaSat {} -> cant [ "The model is delta-satisfiable."+ , "Cannot validate delta-satisfiable models."+ ]++ SatExtField{} -> cant [ "The model requires an extension field value."+ , "Cannot validate models with infinities/epsilons produced during optimization."+ , ""+ , "To turn validation off, use `cfg{optimizeValidateConstraints = False}`"+ ]+ Unknown{} -> return res ProofError{} -> return res - where check env = do let univs = [n | ((ALL, (_, n)), _) <- env]+ where cant msg = return $ ProofError cfg (msg ++ [ ""+ , "Unable to validate the produced model."+ ]) (Just res)++ check env = do let univs = [n | ((ALL, (_, n)), _) <- env] envShown = showModelDictionary True True cfg modelBinds where modelBinds = [(n, fake q s v) | ((q, (s, n)), v) <- env] fake q s Nothing@@ -630,19 +676,21 @@ -- SFunArrays (memory, functional representation), only supported universally for the time being instance (HasKind a, HasKind b, MProvable m p) => MProvable m (SArray a b -> p) where- forAll_ k = newArray_ Nothing >>= \a -> forAll_ $ k a- forAll (s:ss) k = newArray s Nothing >>= \a -> forAll ss $ k a- forAll [] k = forAll_ k- forSome_ _ = error "SBV.forSome.SFunArray: Existential arrays are not currently supported."- forSome _ _ = error "SBV.forSome.SFunArray: Existential arrays are not currently supported."+ forAll_ k = newArray_ Nothing >>= \a -> forAll_ $ k a+ forAll (s:ss) k = newArray s Nothing >>= \a -> forAll ss $ k a+ forAll [] k = forAll_ k+ forSome_ k = newArray_ Nothing >>= \a -> forSome_ $ k a+ forSome (s:ss) k = newArray s Nothing >>= \a -> forSome ss $ k a+ forSome [] k = forSome_ k -- SArrays (memory, SMT-Lib notion of arrays), only supported universally for the time being instance (HasKind a, HasKind b, MProvable m p) => MProvable m (SFunArray a b -> p) where- forAll_ k = newArray_ Nothing >>= \a -> forAll_ $ k a- forAll (s:ss) k = newArray s Nothing >>= \a -> forAll ss $ k a- forAll [] k = forAll_ k- forSome_ _ = error "SBV.forSome.SArray: Existential arrays are not currently supported."- forSome _ _ = error "SBV.forSome.SArray: Existential arrays are not currently supported."+ forAll_ k = newArray_ Nothing >>= \a -> forAll_ $ k a+ forAll (s:ss) k = newArray s Nothing >>= \a -> forAll ss $ k a+ forAll [] k = forAll_ k+ forSome_ k = newArray_ Nothing >>= \a -> forSome_ $ k a+ forSome (s:ss) k = newArray s Nothing >>= \a -> forSome ss $ k a+ forSome [] k = forSome_ k -- 2 Tuple instance (SymVal a, SymVal b, MProvable m p) => MProvable m ((SBV a, SBV b) -> p) where@@ -717,6 +765,7 @@ isSafe (SafeResult (_, _, result)) = case result of Unsatisfiable{} -> True Satisfiable{} -> False+ DeltaSat{} -> False -- conservative SatExtField{} -> False -- conservative Unknown{} -> False -- conservative ProofError{} -> False -- conservative@@ -779,7 +828,7 @@ rs <- unsafeInterleaveIO $ go (filter (/= d) as) return (r : rs) --- | Symbolically executable program fragments. This class is mainly used for 'safe' calls, and is sufficently populated internally to cover most use+-- | Symbolically executable program fragments. This class is mainly used for 'safe' calls, and is sufficiently populated internally to cover most use -- cases. Users can extend it as they wish to allow 'safe' checks for SBV programs that return/take types that are user-defined. class ExtractIO m => SExecutable m a where -- | Generalization of 'Data.SBV.sName_'
Data/SBV/Provers/Yices.hs view
@@ -30,10 +30,14 @@ , engine = standardEngine "SBV_YICES" "SBV_YICES_OPTIONS" , capabilities = SolverCapabilities { supportsQuantifiers = False+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True , supportsUninterpretedSorts = True , supportsUnboundedInts = True , supportsReals = True , supportsApproxReals = False+ , supportsDeltaSat = Nothing , supportsIEEE754 = False , supportsSets = False , supportsOptimization = False@@ -41,6 +45,7 @@ , supportsCustomQueries = True , supportsGlobalDecls = False , supportsDataTypes = False+ , supportsDirectAccessors = False , supportsFlattenedModels = Nothing } }
Data/SBV/Provers/Z3.hs view
@@ -30,10 +30,14 @@ , engine = standardEngine "SBV_Z3" "SBV_Z3_OPTIONS" , capabilities = SolverCapabilities { supportsQuantifiers = True+ , supportsDefineFun = True+ , supportsDistinct = True+ , supportsBitVectors = True , supportsUninterpretedSorts = True , supportsUnboundedInts = True , supportsReals = True , supportsApproxReals = True+ , supportsDeltaSat = Nothing , supportsIEEE754 = True , supportsSets = True , supportsOptimization = True@@ -41,6 +45,7 @@ , supportsCustomQueries = True , supportsGlobalDecls = True , supportsDataTypes = True+ , supportsDirectAccessors = False -- Needs ascriptions. (See the CVC4 version of this) , supportsFlattenedModels = Just [ "(set-option :pp.max_depth 4294967295)" , "(set-option :pp.min_alias_size 4294967295)" , "(set-option :model.inline_def true )"
Data/SBV/RegExp.hs view
@@ -8,7 +8,7 @@ -- -- A collection of regular-expression related utilities. The recommended -- workflow is to import this module qualified as the names of the functions--- are specificly chosen to be common identifiers. Also, it is recommended+-- are specifically chosen to be common identifiers. Also, it is recommended -- you use the @OverloadedStrings@ extension to allow literal strings to be -- used as symbolic-strings and regular-expressions when working with -- this module.@@ -87,7 +87,7 @@ -- >>> let phone = pre * "-" * post -- >>> sat $ \s -> (s :: SString) `match` phone -- Satisfiable. Model:--- s0 = "100-1000" :: String+-- s0 = "840-4224" :: String class RegExpMatchable a where -- | @`match` s r@ checks whether @s@ is in the language generated by @r@. match :: a -> RegExp -> SBool
Data/SBV/SMT/SMT.hs view
@@ -75,10 +75,13 @@ import qualified System.Timeout as Timeout (timeout) +import Numeric+ -- | Extract the final configuration from a result resultConfig :: SMTResult -> SMTConfig resultConfig (Unsatisfiable c _ ) = c resultConfig (Satisfiable c _ ) = c+resultConfig (DeltaSat c _ _) = c resultConfig (SatExtField c _ ) = c resultConfig (Unknown c _ ) = c resultConfig (ProofError c _ _) = c@@ -92,11 +95,13 @@ newtype SatResult = SatResult SMTResult deriving NFData --- | An 'Data.SBV.allSat' call results in a 'AllSatResult'. The first boolean says whether we--- hit the max-model limit as we searched. The second boolean says whether--- there were prefix-existentials. The third boolean says whether we stopped because--- the solver returned 'Unknown'.-newtype AllSatResult = AllSatResult (Bool, Bool, Bool, [SMTResult])+-- | An 'Data.SBV.allSat' call results in a 'AllSatResult'+data AllSatResult = AllSatResult { allSatMaxModelCountReached :: Bool -- ^ Did we reach the user given model count limit?+ , allSatHasPrefixExistentials :: Bool -- ^ Were there quantifiers in the problem (unique upto prefix existentials)+ , allSatSolverReturnedUnknown :: Bool -- ^ Did the solver report unknown at the end?+ , allSatSolverReturnedDSat :: Bool -- ^ Did the solver report delta-satisfiable at the end?+ , allSatResults :: [SMTResult] -- ^ All satisfying models+ } -- | A 'Data.SBV.safe' call results in a 'SafeResult' newtype SafeResult = SafeResult (Maybe String, String, SMTResult)@@ -108,30 +113,53 @@ | ParetoResult (Bool, [SMTResult]) | IndependentResult [(String, SMTResult)] +-- | What's the precision of a delta-sat query?+getPrecision :: SMTResult -> Maybe String -> String+getPrecision r queriedPrecision = case (queriedPrecision, dsatPrecision (resultConfig r)) of+ (Just s, _ ) -> s+ (_, Just d) -> showFFloat Nothing d ""+ _ -> "tool default"+ -- User friendly way of printing theorem results instance Show ThmResult where show (ThmResult r) = showSMTResult "Q.E.D." "Unknown"- "Falsifiable" "Falsifiable. Counter-example:\n" "Falsifiable in an extension field:\n" r+ "Falsifiable"+ "Falsifiable. Counter-example:\n"+ (\mbP -> "Delta falsifiable, precision: " ++ getPrecision r mbP ++ ". Counter-example:\n")+ "Falsifiable in an extension field:\n"+ r -- User friendly way of printing satisfiablity results instance Show SatResult where show (SatResult r) = showSMTResult "Unsatisfiable" "Unknown"- "Satisfiable" "Satisfiable. Model:\n" "Satisfiable in an extension field. Model:\n" r+ "Satisfiable"+ "Satisfiable. Model:\n"+ (\mbP -> "Delta satisfiable, precision: " ++ getPrecision r mbP ++ ". Model:\n")+ "Satisfiable in an extension field. Model:\n"+ r -- User friendly way of printing safety results instance Show SafeResult where show (SafeResult (mbLoc, msg, r)) = showSMTResult (tag "No violations detected") (tag "Unknown")- (tag "Violated") (tag "Violated. Model:\n") (tag "Violated in an extension field:\n") r+ (tag "Violated")+ (tag "Violated. Model:\n")+ (\mbP -> tag "Violated in a delta-satisfiable context, precision: " ++ getPrecision r mbP ++ ". Model:\n")+ (tag "Violated in an extension field:\n")+ r where loc = maybe "" (++ ": ") mbLoc tag s = loc ++ msg ++ ": " ++ s --- The Show instance of AllSatResults. Note that we have to be careful in being lazy enough--- as the typical use case is to pull results out as they become available.+-- The Show instance of AllSatResults. instance Show AllSatResult where- show (AllSatResult (l, e, u, xs)) = go (0::Int) xs+ show AllSatResult { allSatMaxModelCountReached = l+ , allSatHasPrefixExistentials = e+ , allSatSolverReturnedUnknown = u+ , allSatSolverReturnedDSat = d+ , allSatResults = xs+ } = go (0::Int) xs where warnings = case (e, u) of (False, False) -> "" (False, True) -> " (Search stopped since solver has returned unknown.)"@@ -141,15 +169,17 @@ go c (s:ss) = let c' = c+1 (ok, o) = sh c' s in c' `seq` if ok then o ++ "\n" ++ go c' ss else o- go c [] = case (l, c) of- (True, _) -> "Search stopped since model count request was reached." ++ warnings- (False, 0) -> "No solutions found."- (False, 1) -> "This is the only solution." ++ warnings- (False, _) -> "Found " ++ show c ++ " different solutions." ++ warnings+ go c [] = case (l, d, c) of+ (True, _ , _) -> "Search stopped since model count request was reached." ++ warnings+ (_ , True, _) -> "Search stopped since the result was delta-satisfiable." ++ warnings+ (False, _ , 0) -> "No solutions found."+ (False, _ , 1) -> "This is the only solution." ++ warnings+ (False, _ , _) -> "Found " ++ show c ++ " different solutions." ++ warnings sh i c = (ok, showSMTResult "Unsatisfiable" "Unknown" ("Solution #" ++ show i ++ ":\nSatisfiable") ("Solution #" ++ show i ++ ":\n")+ (\mbP -> "Solution $" ++ show i ++ " with delta-satisfiability, precision: " ++ getPrecision c mbP ++ ":\n") ("Solution $" ++ show i ++ " in an extension field:\n") c) where ok = case c of@@ -175,11 +205,13 @@ shI n = sh (\s -> "Objective " ++ show n ++ ": " ++ s) shP i = sh (\s -> "Pareto front #" ++ show i ++ ": " ++ s) - sh tag = showSMTResult (tag "Unsatisfiable.")- (tag "Unknown.")- (tag "Optimal with no assignments.")- (tag "Optimal model:" ++ "\n")- (tag "Optimal in an extension field:" ++ "\n")+ sh tag r = showSMTResult (tag "Unsatisfiable.")+ (tag "Unknown.")+ (tag "Optimal with no assignments.")+ (tag "Optimal model:" ++ "\n")+ (\mbP -> tag "Optimal model with delta-satisfiability, precision: " ++ getPrecision r mbP ++ ":" ++ "\n")+ (tag "Optimal in an extension field:" ++ "\n")+ r -- | Instances of 'SatModel' can be automatically extracted from models returned by the -- solvers. The idea is that the sbv infrastructure provides a stream of CV's (constant values)@@ -369,19 +401,19 @@ -- | Return all the models from an 'Data.SBV.allSat' call, similar to 'extractModel' but -- is suitable for the case of multiple results. extractModels :: SatModel a => AllSatResult -> [a]-extractModels (AllSatResult (_, _, _, xs)) = [ms | Right (_, ms) <- map getModelAssignment xs]+extractModels AllSatResult{allSatResults = xs} = [ms | Right (_, ms) <- map getModelAssignment xs] -- | Get dictionaries from an all-sat call. Similar to `getModelDictionary`. getModelDictionaries :: AllSatResult -> [M.Map String CV]-getModelDictionaries (AllSatResult (_, _, _, xs)) = map getModelDictionary xs+getModelDictionaries AllSatResult{allSatResults = xs} = map getModelDictionary xs -- | Extract value of a variable from an all-sat call. Similar to `getModelValue`. getModelValues :: SymVal b => String -> AllSatResult -> [Maybe b]-getModelValues s (AllSatResult (_, _, _, xs)) = map (s `getModelValue`) xs+getModelValues s AllSatResult{allSatResults = xs} = map (s `getModelValue`) xs -- | Extract value of an uninterpreted variable from an all-sat call. Similar to `getModelUninterpretedValue`. getModelUninterpretedValues :: String -> AllSatResult -> [Maybe String]-getModelUninterpretedValues s (AllSatResult (_, _, _, xs)) = map (s `getModelUninterpretedValue`) xs+getModelUninterpretedValues s AllSatResult{allSatResults = xs} = map (s `getModelUninterpretedValue`) xs -- | 'ThmResult' as a generic model provider instance Modelable ThmResult where@@ -402,7 +434,8 @@ -- | 'SMTResult' as a generic model provider instance Modelable SMTResult where getModelAssignment (Unsatisfiable _ _ ) = Left "SBV.getModelAssignment: Unsatisfiable result"- getModelAssignment (Satisfiable _ m ) = Right (False, parseModelOut m)+ getModelAssignment (Satisfiable _ m) = Right (False, parseModelOut m)+ getModelAssignment (DeltaSat _ _ m) = Right (False, parseModelOut m) getModelAssignment (SatExtField _ _ ) = Left "SBV.getModelAssignment: The model is in an extension field" getModelAssignment (Unknown _ m ) = Left $ "SBV.getModelAssignment: Solver state is unknown: " ++ show m getModelAssignment (ProofError _ s _) = error $ unlines $ "SBV.getModelAssignment: Failed to produce a model: " : s@@ -411,23 +444,26 @@ modelExists Unknown{} = False -- don't risk it modelExists _ = False - getModelDictionary Unsatisfiable{} = M.empty- getModelDictionary (Satisfiable _ m) = M.fromList (modelAssocs m)- getModelDictionary SatExtField{} = M.empty- getModelDictionary Unknown{} = M.empty- getModelDictionary ProofError{} = M.empty+ getModelDictionary Unsatisfiable{} = M.empty+ getModelDictionary (Satisfiable _ m) = M.fromList (modelAssocs m)+ getModelDictionary (DeltaSat _ _ m) = M.fromList (modelAssocs m)+ getModelDictionary SatExtField{} = M.empty+ getModelDictionary Unknown{} = M.empty+ getModelDictionary ProofError{} = M.empty - getModelObjectives Unsatisfiable{} = M.empty- getModelObjectives (Satisfiable _ m) = M.fromList (modelObjectives m)- getModelObjectives (SatExtField _ m) = M.fromList (modelObjectives m)- getModelObjectives Unknown{} = M.empty- getModelObjectives ProofError{} = M.empty+ getModelObjectives Unsatisfiable{} = M.empty+ getModelObjectives (Satisfiable _ m ) = M.fromList (modelObjectives m)+ getModelObjectives (DeltaSat _ _ m) = M.fromList (modelObjectives m)+ getModelObjectives (SatExtField _ m ) = M.fromList (modelObjectives m)+ getModelObjectives Unknown{} = M.empty+ getModelObjectives ProofError{} = M.empty - getModelUIFuns Unsatisfiable{} = M.empty- getModelUIFuns (Satisfiable _ m) = M.fromList (modelUIFuns m)- getModelUIFuns (SatExtField _ m) = M.fromList (modelUIFuns m)- getModelUIFuns Unknown{} = M.empty- getModelUIFuns ProofError{} = M.empty+ getModelUIFuns Unsatisfiable{} = M.empty+ getModelUIFuns (Satisfiable _ m ) = M.fromList (modelUIFuns m)+ getModelUIFuns (DeltaSat _ _ m) = M.fromList (modelUIFuns m)+ getModelUIFuns (SatExtField _ m ) = M.fromList (modelUIFuns m)+ getModelUIFuns Unknown{} = M.empty+ getModelUIFuns ProofError{} = M.empty -- | Extract a model out, will throw error if parsing is unsuccessful parseModelOut :: SatModel a => SMTModel -> a@@ -439,21 +475,22 @@ -- | Given an 'Data.SBV.allSat' call, we typically want to iterate over it and print the results in sequence. The -- 'displayModels' function automates this task by calling @disp@ on each result, consecutively. The first -- 'Int' argument to @disp@ 'is the current model number. The second argument is a tuple, where the first--- element indicates whether the model is alleged (i.e., if the solver is not sure, returing Unknown).+-- element indicates whether the model is alleged (i.e., if the solver is not sure, returning Unknown). -- The arrange argument can sort the results in any way you like, if necessary. displayModels :: SatModel a => ([(Bool, a)] -> [(Bool, a)]) -> (Int -> (Bool, a) -> IO ()) -> AllSatResult -> IO Int-displayModels arrange disp (AllSatResult (_, _, _, ms)) = do+displayModels arrange disp AllSatResult{allSatResults = ms} = do let models = [a | Right a <- map (getModelAssignment . SatResult) ms] inds <- zipWithM display (arrange models) [(1::Int)..] return $ last (0:inds) where display r i = disp i r >> return i -- | Show an SMTResult; generic version-showSMTResult :: String -> String -> String -> String -> String -> SMTResult -> String-showSMTResult unsatMsg unkMsg satMsg satMsgModel satExtMsg result = case result of+showSMTResult :: String -> String -> String -> String -> (Maybe String -> String) -> String -> SMTResult -> String+showSMTResult unsatMsg unkMsg satMsg satMsgModel dSatMsgModel satExtMsg result = case result of Unsatisfiable _ uc -> unsatMsg ++ showUnsatCore uc Satisfiable _ (SMTModel _ _ [] []) -> satMsg- Satisfiable _ m -> satMsgModel ++ showModel cfg m+ Satisfiable _ m -> satMsgModel ++ showModel cfg m+ DeltaSat _ p m -> dSatMsgModel p ++ showModel cfg m SatExtField _ (SMTModel b _ _ _) -> satExtMsg ++ showModelDictionary True False cfg b Unknown _ r -> unkMsg ++ ".\n" ++ " Reason: " `alignPlain` show r ProofError _ [] Nothing -> "*** An error occurred. No additional information available. Try running in verbose mode."@@ -463,7 +500,7 @@ , "*** Alleged model:" , "***" ]- ++ ["*** " ++ l | l <- lines (showSMTResult unsatMsg unkMsg satMsg satMsgModel satExtMsg r)]+ ++ ["*** " ++ l | l <- lines (showSMTResult unsatMsg unkMsg satMsg satMsgModel dSatMsgModel satExtMsg r)] where cfg = resultConfig result showUnsatCore Nothing = ""@@ -608,7 +645,7 @@ let msg s = debug config ["** " ++ s] smtSolver= solver config exec = executable smtSolver- opts = options smtSolver config+ opts = options smtSolver config ++ extraArgs config msg $ "Calling: " ++ (exec ++ (if null opts then "" else " ") ++ joinArgs opts) rnf pgm `seq` pipeProcess config ctx exec opts pgm continuation @@ -785,7 +822,7 @@ let executeSolver = do let sendAndGetSuccess :: Maybe Int -> String -> IO () sendAndGetSuccess mbTimeOut l -- The pathetic case when the solver doesn't support queries, so we pretend it responded "success"- -- Currently ABC is the only such solver. Filed a request for ABC at: http://bitbucket.org/alanmi/abc/issues/70/+ -- Currently ABC is the only such solver. | not (supportsCustomQueries (capabilities (solver cfg))) = do send mbTimeOut l debug cfg ["[ISSUE] " `alignPlain` l]
Data/SBV/SMT/SMTLib.hs view
@@ -52,7 +52,7 @@ = unsupported "uninterpreted sorts" | True = SMTLibPgm v pgm- where sorts = [s | KUninterpreted s _ <- Set.toList kindInfo]+ where sorts = [s | KUserSort s _ <- Set.toList kindInfo] solverCaps = capabilities (solver config) unsupported w = error $ unlines [ "SBV: Given problem needs " ++ w , "*** Which is not supported by SBV for the chosen solver: " ++ show (name (solver config))
Data/SBV/SMT/SMTLib2.hs view
@@ -47,7 +47,7 @@ hasDouble = KDouble `Set.member` kindInfo hasRounding = not $ null [s | (s, _) <- usorts, s == "RoundingMode"] hasBVs = hasChar || not (null [() | KBounded{} <- Set.toList kindInfo]) -- Remember, characters map to Word8- usorts = [(s, dt) | KUninterpreted s dt <- Set.toList kindInfo]+ usorts = [(s, dt) | KUserSort s dt <- Set.toList kindInfo] trueUSorts = [s | (s, _) <- usorts, s /= "RoundingMode"] tupleArities = findTupleArities kindInfo hasNonBVArrays = (not . null) [() | (_, (_, (k1, k2), _)) <- arrs, not (isBounded k1 && isBounded k2)]@@ -63,8 +63,9 @@ -- Is there a reason why we can't handle this problem? -- NB. There's probably a lot more checking we can do here, but this is a start: doesntHandle = listToMaybe [nope w | (w, have, need) <- checks, need && not have]- where checks = [ ("data types", supportsDataTypes solverCaps, hasTuples || hasEither || hasMaybe)- , ("set operations", supportsSets solverCaps, hasSets)+ where checks = [ ("data types", supportsDataTypes solverCaps, hasTuples || hasEither || hasMaybe)+ , ("set operations", supportsSets solverCaps, hasSets)+ , ("bit vectors", supportsBitVectors solverCaps, hasBVs) ] nope w = [ "*** Given problem requires support for " ++ w@@ -129,7 +130,9 @@ | True = case ctx of QueryExternal -> ["(set-logic ALL) ; external query, using all logics."]- QueryInternal -> ["(set-logic " ++ qs ++ as ++ ufs ++ "BV)"]+ QueryInternal -> if supportsBitVectors solverCaps+ then ["(set-logic " ++ qs ++ as ++ ufs ++ "BV)"]+ else ["(set-logic ALL)"] -- fall-thru where qs | null foralls && null axs = "QF_" -- axioms are likely to contain quantifiers | True = "" as | null arrs = ""@@ -141,11 +144,21 @@ getModels = "(set-option :produce-models true)" : concat [flattenConfig | any needsFlattening kindInfo, Just flattenConfig <- [supportsFlattenedModels solverCaps]] - -- process all other settings we're given- userSettings = concatMap opts $ solverSetOptions cfg- where opts SetLogic{} = [] -- processed already- opts o = [setSMTOption o]+ -- process all other settings we're given. If an option cannot be repeated, we only take the last one.+ userSettings = map setSMTOption $ filter (not . isLogic) $ foldr comb [] $ solverSetOptions cfg+ where -- Logic is already processed, so drop it:+ isLogic SetLogic{} = True+ isLogic _ = False + -- SBV sets diagnostic-output channel on some solvers. If the user also gives it, let's just+ -- take it by only taking the last one+ isDiagOutput DiagnosticOutputChannel{} = True+ isDiagOutput _ = False++ comb o rest+ | isDiagOutput o && any isDiagOutput rest = rest+ | True = o : rest+ settings = userSettings -- NB. Make sure this comes first! ++ getModels ++ logic@@ -166,7 +179,7 @@ ++ [ "; --- optimization tracker variables ---" | not (null trackerVars) ] ++ [ "(declare-fun " ++ show s ++ " " ++ svFunType [] s ++ ") ; tracks " ++ nm | (s, nm) <- trackerVars] ++ [ "; --- constant tables ---" ]- ++ concatMap constTable constTables+ ++ concatMap (uncurry (:) . constTable) constTables ++ [ "; --- skolemized tables ---" ] ++ map (skolemTable (unwords (map svType foralls))) skolemTables ++ [ "; --- arrays ---" ]@@ -177,12 +190,12 @@ ++ map declAx axs ++ [ "; --- formula ---" ] - ++ map (declDef cfg skolemMap tableMap) preQuantifierAssigns+ ++ concatMap (declDef cfg skolemMap tableMap) preQuantifierAssigns ++ ["(assert (forall (" ++ intercalate "\n " ["(" ++ show s ++ " " ++ svType s ++ ")" | s <- foralls] ++ ")" | not (null foralls) ]- ++ map mkAssign postQuantifierAssigns+ ++ concatMap mkAssign postQuantifierAssigns ++ concat arrayDelayeds @@ -299,7 +312,7 @@ mkAssign a | null foralls = declDef cfg skolemMap tableMap a- | True = letShift (mkLet a)+ | True = [letShift (mkLet a)] mkLet (s, SBVApp (Label m) [e]) = "(let ((" ++ show s ++ " " ++ cvtSV skolemMap e ++ ")) ; " ++ m mkLet (s, e) = "(let ((" ++ show s ++ " " ++ cvtExp solverCaps rm skolemMap tableMap e ++ "))"@@ -310,14 +323,14 @@ _ -> "" -- | Declare new sorts-declSort :: (String, Either String [String]) -> [String]+declSort :: (String, Maybe [String]) -> [String] declSort (s, _) | s == "RoundingMode" -- built-in-sort; so don't declare. = []-declSort (s, Left r ) = ["(declare-sort " ++ s ++ " 0) ; N.B. Uninterpreted: " ++ r]-declSort (s, Right fs) = [ "(declare-datatypes ((" ++ s ++ " 0)) ((" ++ unwords (map (\c -> "(" ++ c ++ ")") fs) ++ ")))"- , "(define-fun " ++ s ++ "_constrIndex ((x " ++ s ++ ")) Int"- ] ++ [" " ++ body fs (0::Int)] ++ [")"]+declSort (s, Nothing) = ["(declare-sort " ++ s ++ " 0) ; N.B. Uninterpreted sort." ]+declSort (s, Just fs) = [ "(declare-datatypes ((" ++ s ++ " 0)) ((" ++ unwords (map (\c -> "(" ++ c ++ ")") fs) ++ ")))"+ , "(define-fun " ++ s ++ "_constrIndex ((x " ++ s ++ ")) Int"+ ] ++ [" " ++ body fs (0::Int)] ++ [")"] where body [] _ = "" body [_] i = show i body (c:cs) i = "(ite (= x " ++ c ++ ") " ++ show i ++ " " ++ body cs (i+1) ++ ")"@@ -389,7 +402,7 @@ -- any new settings? settings -- sorts- ++ concatMap declSort [(s, dt) | KUninterpreted s dt <- newKinds]+ ++ concatMap declSort [(s, dt) | KUserSort s dt <- newKinds] -- tuples. NB. Only declare the new sizes, old sizes persist. ++ concatMap declTuple (findTupleArities newKs) -- sums@@ -403,12 +416,14 @@ ++ concat arrayConstants -- uninterpreteds ++ concatMap declUI uis- -- tables- ++ concatMap constTable allTables+ -- table declarations+ ++ tableDecls -- expressions- ++ map (declDef cfg skolemMap tableMap) (F.toList asgnsSeq)+ ++ concatMap (declDef cfg skolemMap tableMap) (F.toList asgnsSeq) -- delayed equalities ++ concat arrayDelayeds+ -- table setups+ ++ concat tableAssigns -- array setups ++ concat arraySetups -- extra constraints@@ -426,6 +441,8 @@ (arrayConstants, arrayDelayeds, arraySetups) = unzip3 $ map (declArray cfg False consts skolemMap) arrs allTables = [(t, either id id (genTableData rm skolemMap (False, []) (map fst consts) t)) | t <- tbls]+ (tableDecls, tableAssigns) = unzip $ map constTable allTables+ tableMap = IM.fromList $ map mkTable allTables where mkTable (((t, _, _), _), _) = (t, "table" ++ show t) @@ -437,26 +454,33 @@ = [] where solverCaps = capabilities (solver cfg) -declDef :: SMTConfig -> SkolemMap -> TableMap -> (SV, SBVExpr) -> String+declDef :: SMTConfig -> SkolemMap -> TableMap -> (SV, SBVExpr) -> [String] declDef cfg skolemMap tableMap (s, expr) = case expr of- SBVApp (Label m) [e] -> defineFun (s, cvtSV skolemMap e) (Just m)- e -> defineFun (s, cvtExp caps rm skolemMap tableMap e) Nothing+ SBVApp (Label m) [e] -> defineFun cfg (s, cvtSV skolemMap e) (Just m)+ e -> defineFun cfg (s, cvtExp caps rm skolemMap tableMap e) Nothing where caps = capabilities (solver cfg) rm = roundingMode cfg -defineFun :: (SV, String) -> Maybe String -> String-defineFun (s, def) mbComment = "(define-fun " ++ varT ++ " " ++ def ++ ")" ++ cmnt- where varT = show s ++ " " ++ svFunType [] s- cmnt = maybe "" (" ; " ++) mbComment+defineFun :: SMTConfig -> (SV, String) -> Maybe String -> [String]+defineFun cfg (s, def) mbComment+ | hasDefFun = ["(define-fun " ++ varT ++ " " ++ def ++ ")" ++ cmnt]+ | True = [ "(declare-fun " ++ varT ++ ")" ++ cmnt+ , "(assert (= " ++ var ++ " " ++ def ++ "))"+ ]+ where var = show s+ varT = var ++ " " ++ svFunType [] s+ cmnt = maybe "" (" ; " ++) mbComment + hasDefFun = supportsDefineFun $ capabilities (solver cfg)+ -- Declare constants. NB. We don't declare true/false; but just inline those as necessary declConst :: SMTConfig -> (SV, CV) -> [String] declConst cfg (s, c) | s == falseSV || s == trueSV = [] | True- = [defineFun (s, cvtCV (roundingMode cfg) c) Nothing]+ = defineFun cfg (s, cvtCV (roundingMode cfg) c) Nothing declUI :: (String, SBVType) -> [String] declUI (i, t) = ["(declare-fun " ++ i ++ " " ++ cvtType t ++ ")"]@@ -465,8 +489,8 @@ declAx :: (String, [String]) -> String declAx (nm, ls) = (";; -- user given axiom: " ++ nm ++ "\n") ++ intercalate "\n" ls -constTable :: (((Int, Kind, Kind), [SV]), [String]) -> [String]-constTable (((i, ak, rk), _elts), is) = decl : zipWith wrap [(0::Int)..] is ++ setup+constTable :: (((Int, Kind, Kind), [SV]), [String]) -> (String, [String])+constTable (((i, ak, rk), _elts), is) = (decl, zipWith wrap [(0::Int)..] is ++ setup) where t = "table" ++ show i decl = "(declare-fun " ++ t ++ " (" ++ smtType ak ++ ") " ++ smtType rk ++ ")" @@ -607,6 +631,8 @@ supportsPB = supportsPseudoBooleans caps + hasDistinct = supportsDistinct caps+ bvOp = all isBounded arguments intOp = any isUnbounded arguments realOp = any isReal arguments@@ -666,16 +692,13 @@ | True = lift2 "=" sgn sbvs notEqual sgn sbvs- | doubleOp = liftP sbvs- | floatOp = liftP sbvs- | True = liftN "distinct" sgn sbvs+ | doubleOp || floatOp || not hasDistinct = liftP sbvs+ | True = liftN "distinct" sgn sbvs where liftP [_, _] = "(not " ++ equal sgn sbvs ++ ")" liftP args = "(and " ++ unwords (walk args) ++ ")" walk [] = []- walk (e:es) = map (pair e) es ++ walk es-- pair e1 e2 = "(not (fp.eq " ++ e1 ++ " " ++ e2 ++ "))"+ walk (e:es) = map (\e' -> liftP [e, e']) es ++ walk es lift2S oU oS sgn = lift2 (if sgn then oS else oU) sgn liftNS oU oS sgn = liftN (if sgn then oS else oU) sgn@@ -684,7 +707,7 @@ | True = lift2 o unintComp o [a, b]- | KUninterpreted s (Right _) <- kindOf (head arguments)+ | KUserSort s (Just _) <- kindOf (head arguments) = let idx v = "(" ++ s ++ "_constrIndex " ++ v ++ ")" in "(" ++ o ++ " " ++ idx a ++ " " ++ idx b ++ ")" unintComp o sbvs = error $ "SBV.SMT.SMTLib2.sh.unintComp: Unexpected arguments: " ++ show (o, sbvs, map kindOf arguments) @@ -719,9 +742,13 @@ dtConstructor fld args res = "((as " ++ fld ++ " " ++ smtType res ++ ") " ++ unwords (map ssv args) ++ ")" -- Similarly, we fully qualify the accessors with their types to work around type checking issues- dtAccessor fld params res = result- where ps = " (" ++ unwords (map smtType params) ++ ") "- result = "(_ is (" ++ fld ++ ps ++ smtType res ++ "))"+ -- Unfortunately, z3 and CVC4 are behaving differently, so we tie this ascription to a solver capability.+ dtAccessor fld params res+ | supportsDirectAccessors caps = dResult+ | True = aResult+ where dResult = "(_ is " ++ fld ++ ")"+ ps = " (" ++ unwords (map smtType params) ++ ") "+ aResult = "(_ is (" ++ fld ++ ps ++ smtType res ++ "))" sh (SBVApp Ite [a, b, c]) = "(ite " ++ ssv a ++ " " ++ ssv b ++ " " ++ ssv c ++ ")" @@ -729,20 +756,20 @@ | needsCheck = "(ite " ++ cond ++ ssv e ++ " " ++ lkUp ++ ")" | True = lkUp where needsCheck = case aKnd of- KBool -> (2::Integer) > fromIntegral l- KBounded _ n -> (2::Integer)^n > fromIntegral l- KUnbounded -> True- KReal -> error "SBV.SMT.SMTLib2.cvtExp: unexpected real valued index"- KFloat -> error "SBV.SMT.SMTLib2.cvtExp: unexpected float valued index"- KDouble -> error "SBV.SMT.SMTLib2.cvtExp: unexpected double valued index"- KChar -> error "SBV.SMT.SMTLib2.cvtExp: unexpected char valued index"- KString -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"- KList k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected list valued: " ++ show k- KSet k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected set valued: " ++ show k- KTuple k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected tuple valued: " ++ show k- KMaybe k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected maybe valued: " ++ show k- KEither k1 k2 -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected sum valued: " ++ show (k1, k2)- KUninterpreted s _ -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected uninterpreted valued index: " ++ s+ KBool -> (2::Integer) > fromIntegral l+ KBounded _ n -> (2::Integer)^n > fromIntegral l+ KUnbounded -> True+ KReal -> error "SBV.SMT.SMTLib2.cvtExp: unexpected real valued index"+ KFloat -> error "SBV.SMT.SMTLib2.cvtExp: unexpected float valued index"+ KDouble -> error "SBV.SMT.SMTLib2.cvtExp: unexpected double valued index"+ KChar -> error "SBV.SMT.SMTLib2.cvtExp: unexpected char valued index"+ KString -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"+ KList k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected list valued: " ++ show k+ KSet k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected set valued: " ++ show k+ KTuple k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected tuple valued: " ++ show k+ KMaybe k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected maybe valued: " ++ show k+ KEither k1 k2 -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected sum valued: " ++ show (k1, k2)+ KUserSort s _ -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected uninterpreted valued index: " ++ s lkUp = "(" ++ getTable tableMap t ++ " " ++ ssv i ++ ")" @@ -751,20 +778,20 @@ | True = gtl ++ " " (less, leq) = case aKnd of- KBool -> error "SBV.SMT.SMTLib2.cvtExp: unexpected boolean valued index"- KBounded{} -> if hasSign i then ("bvslt", "bvsle") else ("bvult", "bvule")- KUnbounded -> ("<", "<=")- KReal -> ("<", "<=")- KFloat -> ("fp.lt", "fp.leq")- KDouble -> ("fp.lt", "fp.geq")- KChar -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"- KString -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"- KList k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected sequence valued index: " ++ show k- KSet k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected set valued index: " ++ show k- KTuple k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected tuple valued index: " ++ show k- KMaybe k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected maybe valued index: " ++ show k- KEither k1 k2 -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected sum valued index: " ++ show (k1, k2)- KUninterpreted s _ -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected uninterpreted valued index: " ++ s+ KBool -> error "SBV.SMT.SMTLib2.cvtExp: unexpected boolean valued index"+ KBounded{} -> if hasSign i then ("bvslt", "bvsle") else ("bvult", "bvule")+ KUnbounded -> ("<", "<=")+ KReal -> ("<", "<=")+ KFloat -> ("fp.lt", "fp.leq")+ KDouble -> ("fp.lt", "fp.geq")+ KChar -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"+ KString -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"+ KList k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected sequence valued index: " ++ show k+ KSet k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected set valued index: " ++ show k+ KTuple k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected tuple valued index: " ++ show k+ KMaybe k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected maybe valued index: " ++ show k+ KEither k1 k2 -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected sum valued index: " ++ show (k1, k2)+ KUserSort s _ -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected uninterpreted valued index: " ++ s mkCnst = cvtCV rm . mkConstCV (kindOf i) le0 = "(" ++ less ++ " " ++ ssv i ++ " " ++ mkCnst 0 ++ ")"@@ -814,6 +841,8 @@ sh (SBVApp (IEEEFP (FP_Cast kFrom kTo m)) args) = handleFPCast kFrom kTo (ssv m) (unwords (map ssv args)) sh (SBVApp (IEEEFP w ) args) = "(" ++ show w ++ " " ++ unwords (map ssv args) ++ ")" + sh (SBVApp (NonLinear w) args) = "(" ++ show w ++ " " ++ unwords (map ssv args) ++ ")"+ sh (SBVApp (PseudoBoolean pb) args) | supportsPB = handlePB pb args' | True = reducePB pb args'@@ -876,7 +905,7 @@ | Just f <- lookup op uninterpretedTable = f (map ssv args) | True- = if not (null args) && isUninterpreted (head args)+ = if not (null args) && isUserSort (head args) then error $ unlines [ "" , "*** Cannot translate operator : " ++ show op , "*** When applied to arguments of kind: " ++ intercalate ", " (nub (map (show . kindOf) args))@@ -900,6 +929,7 @@ , (LessEq, lift2S "bvule" "bvsle") , (GreaterEq, lift2S "bvuge" "bvsge") ]+ -- Boolean comparisons.. SMTLib's bool type doesn't do comparisons, but Haskell does.. Sigh boolComps = [ (LessThan, blt) , (GreaterThan, blt . swp)@@ -912,15 +942,19 @@ blq xs = error $ "SBV.SMT.SMTLib2.boolComps.blq: Impossible happened, incorrect arity (expected 2): " ++ show xs swp [x, y] = [y, x] swp xs = error $ "SBV.SMT.SMTLib2.boolComps.swp: Impossible happened, incorrect arity (expected 2): " ++ show xs+ smtOpRealTable = smtIntRealShared ++ [ (Quot, lift2WM "/" "fp.div") ]+ smtOpIntTable = smtIntRealShared ++ [ (Quot, lift2 "div") , (Rem, lift2 "mod") ]+ smtOpFloatDoubleTable = smtIntRealShared ++ [(Quot, lift2WM "/" "fp.div")]+ smtIntRealShared = [ (Plus, lift2WM "+" "fp.add") , (Minus, lift2WM "-" "fp.sub") , (Times, lift2WM "*" "fp.mul")@@ -933,6 +967,7 @@ , (LessEq, lift2Cmp "<=" "fp.leq") , (GreaterEq, lift2Cmp ">=" "fp.geq") ]+ -- equality and comparisons are the only thing that works on uninterpreted sorts and pretty much everything else uninterpretedTable = [ (Equal, lift2S "=" "=" True) , (NotEqual, liftNS "distinct" "distinct" True)@@ -941,6 +976,7 @@ , (LessEq, unintComp "<=") , (GreaterEq, unintComp ">=") ]+ -- For chars, the underlying type is currently SWord8, so we go with the regular bit-vector operations -- TODO: This will change when we move to unicode! smtCharTable = [ (Equal, eqBV)@@ -950,6 +986,7 @@ , (LessEq, lift2S "bvule" (error "smtChar.<=: did-not expect signed char here!")) , (GreaterEq, lift2S "bvuge" (error "smtChar.>=: did-not expect signed char here!")) ]+ -- For strings, equality and comparisons are the only operators -- TODO: The string comparison operators will most likely change with the new theory! smtStringTable = [ (Equal, lift2S "=" "=" True)@@ -959,6 +996,7 @@ , (LessEq, stringCmp False "str.<=") , (GreaterEq, stringCmp True "str.<=") ]+ -- For lists, equality is really the only operator -- Likewise here, things might change for comparisons smtListTable = [ (Equal, lift2S "=" "=" True)
Data/SBV/Tools/BMC.hs view
@@ -61,12 +61,13 @@ constrain $ goal curState cs <- checkSat case cs of- Sat -> do when chatty $ io $ putStrLn $ "BMC: Solution found at iteration " ++ show i- ms <- mapM project (curState : sofar)- return $ Right (i, reverse ms)- Unk -> do when chatty $ io $ putStrLn $ "BMC: Backend solver said unknown at iteration " ++ show i- return $ Left $ "BMC: Solver said unknown in iteration " ++ show i- Unsat -> do pop 1- nextState <- create- constrain $ sAny (nextState .==) (trans curState)- go (i+1) nextState (curState : sofar)+ DSat{} -> error "BMC: Solver returned an unexpected delta-sat result."+ Sat -> do when chatty $ io $ putStrLn $ "BMC: Solution found at iteration " ++ show i+ ms <- mapM project (curState : sofar)+ return $ Right (i, reverse ms)+ Unk -> do when chatty $ io $ putStrLn $ "BMC: Backend solver said unknown at iteration " ++ show i+ return $ Left $ "BMC: Solver said unknown in iteration " ++ show i+ Unsat -> do pop 1+ nextState <- create+ constrain $ sAny (nextState .==) (trans curState)+ go (i+1) nextState (curState : sofar)
Data/SBV/Tools/GenTest.hs view
@@ -118,41 +118,41 @@ valOf xs = "[" ++ intercalate ", " (map s xs) ++ "]" t cv = case kindOf cv of- KBool -> "Bool"- KBounded False 8 -> "Word8"- KBounded False 16 -> "Word16"- KBounded False 32 -> "Word32"- KBounded False 64 -> "Word64"- KBounded True 8 -> "Int8"- KBounded True 16 -> "Int16"- KBounded True 32 -> "Int32"- KBounded True 64 -> "Int64"- KUnbounded -> "Integer"- KFloat -> "Float"- KDouble -> "Double"- KChar -> error "SBV.renderTest: Unsupported char"- KString -> error "SBV.renderTest: Unsupported string"- KReal -> error $ "SBV.renderTest: Unsupported real valued test value: " ++ show cv- KList es -> error $ "SBV.renderTest: Unsupported list valued test: [" ++ show es ++ "]"- KSet es -> error $ "SBV.renderTest: Unsupported set valued test: {" ++ show es ++ "}"- KUninterpreted us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us- _ -> error $ "SBV.renderTest: Unexpected CV: " ++ show cv+ KBool -> "Bool"+ KBounded False 8 -> "Word8"+ KBounded False 16 -> "Word16"+ KBounded False 32 -> "Word32"+ KBounded False 64 -> "Word64"+ KBounded True 8 -> "Int8"+ KBounded True 16 -> "Int16"+ KBounded True 32 -> "Int32"+ KBounded True 64 -> "Int64"+ KUnbounded -> "Integer"+ KFloat -> "Float"+ KDouble -> "Double"+ KChar -> error "SBV.renderTest: Unsupported char"+ KString -> error "SBV.renderTest: Unsupported string"+ KReal -> error $ "SBV.renderTest: Unsupported real valued test value: " ++ show cv+ KList es -> error $ "SBV.renderTest: Unsupported list valued test: [" ++ show es ++ "]"+ KSet es -> error $ "SBV.renderTest: Unsupported set valued test: {" ++ show es ++ "}"+ KUserSort us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us+ _ -> error $ "SBV.renderTest: Unexpected CV: " ++ show cv s cv = case kindOf cv of- KBool -> take 5 (show (cvToBool cv) ++ repeat ' ')- KBounded sgn sz -> let CInteger w = cvVal cv in shex False True (sgn, sz) w- KUnbounded -> let CInteger w = cvVal cv in shexI False True w- KFloat -> let CFloat w = cvVal cv in showHFloat w- KDouble -> let CDouble w = cvVal cv in showHDouble w- KChar -> error "SBV.renderTest: Unsupported char"- KString -> error "SBV.renderTest: Unsupported string"- KReal -> let CAlgReal w = cvVal cv in algRealToHaskell w- KList es -> error $ "SBV.renderTest: Unsupported list valued sort: [" ++ show es ++ "]"- KSet es -> error $ "SBV.renderTest: Unsupported set valued sort: {" ++ show es ++ "}"- KUninterpreted us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us- k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple: " ++ show k- k@KMaybe{} -> error $ "SBV.renderTest: Unsupported maybe: " ++ show k- k@KEither{} -> error $ "SBV.renderTest: Unsupported sum: " ++ show k+ KBool -> take 5 (show (cvToBool cv) ++ repeat ' ')+ KBounded sgn sz -> let CInteger w = cvVal cv in shex False True (sgn, sz) w+ KUnbounded -> let CInteger w = cvVal cv in shexI False True w+ KFloat -> let CFloat w = cvVal cv in showHFloat w+ KDouble -> let CDouble w = cvVal cv in showHDouble w+ KChar -> error "SBV.renderTest: Unsupported char"+ KString -> error "SBV.renderTest: Unsupported string"+ KReal -> let CAlgReal w = cvVal cv in algRealToHaskell w+ KList es -> error $ "SBV.renderTest: Unsupported list valued sort: [" ++ show es ++ "]"+ KSet es -> error $ "SBV.renderTest: Unsupported set valued sort: {" ++ show es ++ "}"+ KUserSort us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us+ k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple: " ++ show k+ k@KMaybe{} -> error $ "SBV.renderTest: Unsupported maybe: " ++ show k+ k@KEither{} -> error $ "SBV.renderTest: Unsupported sum: " ++ show k c :: String -> [([CV], [CV])] -> String c n vs = intercalate "\n" $@@ -218,47 +218,47 @@ ] where mkField p cv i = " " ++ t ++ " " ++ p ++ show i ++ ";" where t = case kindOf cv of- KBool -> "SBool"- KBounded False 8 -> "SWord8"- KBounded False 16 -> "SWord16"- KBounded False 32 -> "SWord32"- KBounded False 64 -> "SWord64"- KBounded True 8 -> "SInt8"- KBounded True 16 -> "SInt16"- KBounded True 32 -> "SInt32"- KBounded True 64 -> "SInt64"- k@KBounded{} -> error $ "SBV.renderTest: Unsupported kind: " ++ show k- KFloat -> "SFloat"- KDouble -> "SDouble"- KChar -> error "SBV.renderTest: Unsupported char"- KString -> error "SBV.renderTest: Unsupported string"- KUnbounded -> error "SBV.renderTest: Unbounded integers are not supported when generating C test-cases."- KReal -> error "SBV.renderTest: Real values are not supported when generating C test-cases."- KUninterpreted us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us- k@KList{} -> error $ "SBV.renderTest: Unsupported list sort: " ++ show k- k@KSet{} -> error $ "SBV.renderTest: Unsupported set sort: " ++ show k- k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple sort: " ++ show k- k@KMaybe{} -> error $ "SBV.renderTest: Unsupported maybe sort: " ++ show k- k@KEither{} -> error $ "SBV.renderTest: Unsupported either sort: " ++ show k+ KBool -> "SBool"+ KBounded False 8 -> "SWord8"+ KBounded False 16 -> "SWord16"+ KBounded False 32 -> "SWord32"+ KBounded False 64 -> "SWord64"+ KBounded True 8 -> "SInt8"+ KBounded True 16 -> "SInt16"+ KBounded True 32 -> "SInt32"+ KBounded True 64 -> "SInt64"+ k@KBounded{} -> error $ "SBV.renderTest: Unsupported kind: " ++ show k+ KFloat -> "SFloat"+ KDouble -> "SDouble"+ KChar -> error "SBV.renderTest: Unsupported char"+ KString -> error "SBV.renderTest: Unsupported string"+ KUnbounded -> error "SBV.renderTest: Unbounded integers are not supported when generating C test-cases."+ KReal -> error "SBV.renderTest: Real values are not supported when generating C test-cases."+ KUserSort us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us+ k@KList{} -> error $ "SBV.renderTest: Unsupported list sort: " ++ show k+ k@KSet{} -> error $ "SBV.renderTest: Unsupported set sort: " ++ show k+ k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple sort: " ++ show k+ k@KMaybe{} -> error $ "SBV.renderTest: Unsupported maybe sort: " ++ show k+ k@KEither{} -> error $ "SBV.renderTest: Unsupported either sort: " ++ show k mkLine (is, os) = "{{" ++ intercalate ", " (map v is) ++ "}, {" ++ intercalate ", " (map v os) ++ "}}" v cv = case kindOf cv of- KBool -> if cvToBool cv then "true " else "false"- KBounded sgn sz -> let CInteger w = cvVal cv in chex False True (sgn, sz) w- KUnbounded -> let CInteger w = cvVal cv in shexI False True w- KFloat -> let CFloat w = cvVal cv in showCFloat w- KDouble -> let CDouble w = cvVal cv in showCDouble w- KChar -> error "SBV.renderTest: Unsupported char"- KString -> error "SBV.renderTest: Unsupported string"- k@KList{} -> error $ "SBV.renderTest: Unsupported list sort!" ++ show k- k@KSet{} -> error $ "SBV.renderTest: Unsupported set sort!" ++ show k- KUninterpreted us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us- KReal -> error "SBV.renderTest: Real values are not supported when generating C test-cases."- k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple sort!" ++ show k- k@KMaybe{} -> error $ "SBV.renderTest: Unsupported maybe sort!" ++ show k- k@KEither{} -> error $ "SBV.renderTest: Unsupported sum sort!" ++ show k+ KBool -> if cvToBool cv then "true " else "false"+ KBounded sgn sz -> let CInteger w = cvVal cv in chex False True (sgn, sz) w+ KUnbounded -> let CInteger w = cvVal cv in shexI False True w+ KFloat -> let CFloat w = cvVal cv in showCFloat w+ KDouble -> let CDouble w = cvVal cv in showCDouble w+ KChar -> error "SBV.renderTest: Unsupported char"+ KString -> error "SBV.renderTest: Unsupported string"+ k@KList{} -> error $ "SBV.renderTest: Unsupported list sort!" ++ show k+ k@KSet{} -> error $ "SBV.renderTest: Unsupported set sort!" ++ show k+ KUserSort us _ -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us+ KReal -> error "SBV.renderTest: Real values are not supported when generating C test-cases."+ k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple sort!" ++ show k+ k@KMaybe{} -> error $ "SBV.renderTest: Unsupported maybe sort!" ++ show k+ k@KEither{} -> error $ "SBV.renderTest: Unsupported sum sort!" ++ show k outLine | null vs = "printf(\"\");"@@ -309,25 +309,25 @@ toF False = '0' blast cv = let noForte w = error "SBV.renderTest: " ++ w ++ " values are not supported when generating Forte test-cases." in case kindOf cv of- KBool -> [toF (cvToBool cv)]- KBounded False 8 -> xlt 8 (cvVal cv)- KBounded False 16 -> xlt 16 (cvVal cv)- KBounded False 32 -> xlt 32 (cvVal cv)- KBounded False 64 -> xlt 64 (cvVal cv)- KBounded True 8 -> xlt 8 (cvVal cv)- KBounded True 16 -> xlt 16 (cvVal cv)- KBounded True 32 -> xlt 32 (cvVal cv)- KBounded True 64 -> xlt 64 (cvVal cv)- KFloat -> noForte "Float"- KDouble -> noForte "Double"- KChar -> noForte "Char"- KString -> noForte "String"- KReal -> noForte "Real"- KList ek -> noForte $ "List of " ++ show ek- KSet ek -> noForte $ "Set of " ++ show ek- KUnbounded -> noForte "Unbounded integers"- KUninterpreted s _ -> noForte $ "Uninterpreted kind " ++ show s- _ -> error $ "SBV.renderTest: Unexpected CV: " ++ show cv+ KBool -> [toF (cvToBool cv)]+ KBounded False 8 -> xlt 8 (cvVal cv)+ KBounded False 16 -> xlt 16 (cvVal cv)+ KBounded False 32 -> xlt 32 (cvVal cv)+ KBounded False 64 -> xlt 64 (cvVal cv)+ KBounded True 8 -> xlt 8 (cvVal cv)+ KBounded True 16 -> xlt 16 (cvVal cv)+ KBounded True 32 -> xlt 32 (cvVal cv)+ KBounded True 64 -> xlt 64 (cvVal cv)+ KFloat -> noForte "Float"+ KDouble -> noForte "Double"+ KChar -> noForte "Char"+ KString -> noForte "String"+ KReal -> noForte "Real"+ KList ek -> noForte $ "List of " ++ show ek+ KSet ek -> noForte $ "Set of " ++ show ek+ KUnbounded -> noForte "Unbounded integers"+ KUserSort s _ -> noForte $ "Uninterpreted kind " ++ show s+ _ -> error $ "SBV.renderTest: Unexpected CV: " ++ show cv xlt s (CInteger v) = [toF (testBit v i) | i <- [s-1, s-2 .. 0]] xlt _ (CFloat r) = error $ "SBV.renderTest.Forte: Unexpected float value: " ++ show r
Data/SBV/Tools/Induction.hs view
@@ -130,12 +130,13 @@ cs <- checkSat case cs of- Unk -> error "Solver said unknown"- Unsat -> return Nothing- Sat -> do io $ msg "Failed:"- ex <- project st- io $ msg $ show ex- return $ Just ex+ Unk -> error "Solver said unknown"+ DSat{} -> error "Solver returned a delta-sat result"+ Unsat -> return Nothing+ Sat -> do io $ msg "Failed:"+ ex <- project st+ io $ msg $ show ex+ return $ Just ex strengthen [] cont = cont strengthen ((nm, st):sts) cont = try ("Proving strengthening initation : " ++ nm)
Data/SBV/Tools/Overflow.hs view
@@ -51,7 +51,7 @@ class ArithOverflow a where -- | Bit-vector addition. Unsigned addition can only overflow. Signed addition can underflow and overflow. --- -- A tell tale sign of unsigned addition overflow is when the sum is less than minumum of the arguments.+ -- A tell tale sign of unsigned addition overflow is when the sum is less than minimum of the arguments. -- -- >>> prove $ \x y -> snd (bvAddO x (y::SWord16)) .<=> x + y .< x `smin` y -- Q.E.D.
Data/SBV/Tools/Polynomial.hs view
@@ -48,14 +48,14 @@ -- -- @polynomial [0, 1, 3] :: SWord8@ -- - -- will evaluate to @11@, since it sets the bits @0@, @1@, and @3@. Mathematicans would write this polynomial+ -- will evaluate to @11@, since it sets the bits @0@, @1@, and @3@. Mathematicians would write this polynomial -- as @x^3 + x + 1@. And in fact, 'showPoly' will show it like that. polynomial :: [Int] -> a -- | Add two polynomials in GF(2^n). pAdd :: a -> a -> a -- | Multiply two polynomials in GF(2^n), and reduce it by the irreducible specified by -- the polynomial as specified by coefficients of the third argument. Note that the third- -- argument is specifically left in this form as it is usally in GF(2^(n+1)), which is not available in our+ -- argument is specifically left in this form as it is usually in GF(2^(n+1)), which is not available in our -- formalism. (That is, we would need SWord9 for SWord8 multiplication, etc.) Also note that we do not -- support symbolic irreducibles, which is a minor shortcoming. (Most GF's will come with fixed irreducibles, -- so this should not be a problem in practice.)
Data/SBV/Tools/Range.hs view
@@ -175,9 +175,10 @@ query $ do cs <- checkSat case cs of- Unsat -> return False- Unk -> error "Data.SBV.interval.isFeasible: Solver said unknown!"- Sat -> return True+ Unsat -> return False+ DSat{} -> error "Data.SBV.interval.isFeasible: Solver returned a delta-satisfiable result!"+ Unk -> error "Data.SBV.interval.isFeasible: Solver said unknown!"+ Sat -> return True bisect :: Range a -> IO (Maybe [Range a]) bisect r@(Range lo hi) = runSMTWith cfg $ do x <- witness r@@ -186,10 +187,11 @@ query $ do cs <- checkSat case cs of- Unsat -> return Nothing- Unk -> error "Data.SBV.interval.bisect: Solver said unknown!"- Sat -> do midV <- Open <$> getValue x- return $ Just [Range lo midV, Range midV hi]+ Unsat -> return Nothing+ DSat{} -> error "Data.SBV.interval.bisect: Solver returned a delta-satisfiable result!"+ Unk -> error "Data.SBV.interval.bisect: Solver said unknown!"+ Sat -> do midV <- Open <$> getValue x+ return $ Just [Range lo midV, Range midV hi] search :: [Range a] -> [Range a] -> IO [Range a] search [] sofar = return $ reverse sofar
Data/SBV/Tools/WeakestPreconditions.hs view
@@ -173,7 +173,7 @@ ] show (InvariantPre nm s) = dispVC ("Invariant for loop " ++ show nm ++ " fails upon entry") [("", show s)]- show (InvariantMaintain nm s1 s2) = dispVC ("Invariant for loop " ++ show nm ++ " is not maintaned by the body")+ show (InvariantMaintain nm s1 s2) = dispVC ("Invariant for loop " ++ show nm ++ " is not maintained by the body") [ ("Before", show s1) , ("After ", show s2) ]@@ -220,52 +220,54 @@ cs <- checkSat case cs of- Unk -> Indeterminate . show <$> getUnknownReason+ Unk -> Indeterminate . show <$> getUnknownReason - Unsat -> do let t = isTotal program+ Unsat -> do let t = isTotal program - if t then msg "Total correctness is established."- else msg "Partial correctness is established."+ if t then msg "Total correctness is established."+ else msg "Partial correctness is established." - return $ Proven t+ pure $ Proven t - Sat -> do let checkVC :: (SBool, VC st SInteger) -> Query [VC res Integer]- checkVC (cond, vc) = do c <- getValue cond- if c- then return [] -- The VC was OK- else do vc' <- case vc of- BadPrecondition s -> BadPrecondition <$> project s- BadPostcondition s1 s2 -> BadPostcondition <$> project s1 <*> project s2- Unstable l s1 s2 -> Unstable l <$> project s1 <*> project s2- AbortReachable l s1 s2 -> AbortReachable l <$> project s1 <*> project s2- InvariantPre l s -> InvariantPre l <$> project s- InvariantMaintain l s1 s2 -> InvariantMaintain l <$> project s1 <*> project s2- MeasureBound l (s, m) -> do r <- project s- v <- mapM getValue m- return $ MeasureBound l (r, v)- MeasureDecrease l (s1, i1) (s2, i2) -> do r1 <- project s1- v1 <- mapM getValue i1- r2 <- project s2- v2 <- mapM getValue i2- return $ MeasureDecrease l (r1, v1) (r2, v2)- return [vc']+ DSat{} -> pure $ Indeterminate "Unsupported: Solver returned a delta-satisfiable answer." - badVCs <- concat <$> mapM checkVC vcs+ Sat -> do let checkVC :: (SBool, VC st SInteger) -> Query [VC res Integer]+ checkVC (cond, vc) = do c <- getValue cond+ if c+ then return [] -- The VC was OK+ else do vc' <- case vc of+ BadPrecondition s -> BadPrecondition <$> project s+ BadPostcondition s1 s2 -> BadPostcondition <$> project s1 <*> project s2+ Unstable l s1 s2 -> Unstable l <$> project s1 <*> project s2+ AbortReachable l s1 s2 -> AbortReachable l <$> project s1 <*> project s2+ InvariantPre l s -> InvariantPre l <$> project s+ InvariantMaintain l s1 s2 -> InvariantMaintain l <$> project s1 <*> project s2+ MeasureBound l (s, m) -> do r <- project s+ v <- mapM getValue m+ return $ MeasureBound l (r, v)+ MeasureDecrease l (s1, i1) (s2, i2) -> do r1 <- project s1+ v1 <- mapM getValue i1+ r2 <- project s2+ v2 <- mapM getValue i2+ return $ MeasureDecrease l (r1, v1) (r2, v2)+ return [vc'] - when (null badVCs) $ error "Data.SBV.proveWP: Impossible happened. Proof failed, but no failing VC found!"+ badVCs <- concat <$> mapM checkVC vcs - let plu w (_:_:_) = w ++ "s"- plu w _ = w+ when (null badVCs) $ error "Data.SBV.proveWP: Impossible happened. Proof failed, but no failing VC found!" - m = "Following proof " ++ plu "obligation" badVCs ++ " failed:"+ let plu w (_:_:_) = w ++ "s"+ plu w _ = w - msg m- msg $ replicate (length m) '='+ m = "Following proof " ++ plu "obligation" badVCs ++ " failed:" - let disp c = mapM_ msg [" " ++ l | l <- lines (show c)]- mapM_ disp badVCs+ msg m+ msg $ replicate (length m) '=' - return $ Failed badVCs+ let disp c = mapM_ msg [" " ++ l | l <- lines (show c)]+ mapM_ disp badVCs++ return $ Failed badVCs msg = io . when wpVerbose . putStrLn
Data/SBV/Trans.hs view
@@ -81,7 +81,7 @@ , mkSymbolicEnumeration -- * Uninterpreted sorts, axioms, constants, and functions- , Uninterpreted(..), addAxiom+ , mkUninterpretedSort, Uninterpreted(..), addAxiom -- * Properties, proofs, and satisfiability , Predicate, Goal, MProvable(..), Provable, proveWithAll, proveWithAny , satWithAll
Data/SBV/Utils/PrettyNum.hs view
@@ -163,7 +163,7 @@ bin = sbinI False False instance PrettyNum CV where- hexS cv | isUninterpreted cv = show cv ++ " :: " ++ show (kindOf cv)+ hexS cv | isUserSort cv = show cv ++ " :: " ++ show (kindOf cv) | isBoolean cv = hexS (cvToBool cv) ++ " :: Bool" | isFloat cv = let CFloat f = cvVal cv in show f ++ " :: Float\n" ++ show (floatToFP f) | isDouble cv = let CDouble d = cvVal cv in show d ++ " :: Double\n" ++ show (doubleToFP d)@@ -172,7 +172,7 @@ | not (isBounded cv) = let CInteger i = cvVal cv in shexI True True i | True = let CInteger i = cvVal cv in shex True True (hasSign cv, intSizeOf cv) i - binS cv | isUninterpreted cv = show cv ++ " :: " ++ show (kindOf cv)+ binS cv | isUserSort cv = show cv ++ " :: " ++ show (kindOf cv) | isBoolean cv = binS (cvToBool cv) ++ " :: Bool" | isFloat cv = let CFloat f = cvVal cv in show f ++ " :: Float\n" ++ show (floatToFP f) | isDouble cv = let CDouble d = cvVal cv in show d ++ " :: Double\n" ++ show (doubleToFP d)@@ -181,7 +181,7 @@ | not (isBounded cv) = let CInteger i = cvVal cv in sbinI True True i | True = let CInteger i = cvVal cv in sbin True True (hasSign cv, intSizeOf cv) i - hexP cv | isUninterpreted cv = show cv+ hexP cv | isUserSort cv = show cv | isBoolean cv = hexS (cvToBool cv) | isFloat cv = let CFloat f = cvVal cv in show f | isDouble cv = let CDouble d = cvVal cv in show d@@ -190,7 +190,7 @@ | not (isBounded cv) = let CInteger i = cvVal cv in shexI False True i | True = let CInteger i = cvVal cv in shex False True (hasSign cv, intSizeOf cv) i - binP cv | isUninterpreted cv = show cv+ binP cv | isUserSort cv = show cv | isBoolean cv = binS (cvToBool cv) | isFloat cv = let CFloat f = cvVal cv in show f | isDouble cv = let CDouble d = cvVal cv in show d@@ -199,7 +199,7 @@ | not (isBounded cv) = let CInteger i = cvVal cv in sbinI False True i | True = let CInteger i = cvVal cv in sbin False True (hasSign cv, intSizeOf cv) i - hex cv | isUninterpreted cv = show cv+ hex cv | isUserSort cv = show cv | isBoolean cv = hexS (cvToBool cv) | isFloat cv = let CFloat f = cvVal cv in show f | isDouble cv = let CDouble d = cvVal cv in show d@@ -208,7 +208,7 @@ | not (isBounded cv) = let CInteger i = cvVal cv in shexI False False i | True = let CInteger i = cvVal cv in shex False False (hasSign cv, intSizeOf cv) i - bin cv | isUninterpreted cv = show cv+ bin cv | isUserSort cv = show cv | isBoolean cv = binS (cvToBool cv) | isFloat cv = let CFloat f = cvVal cv in show f | isDouble cv = let CDouble d = cvVal cv in show d@@ -407,7 +407,7 @@ cvToSMTLib :: RoundingMode -> CV -> String cvToSMTLib rm x | isBoolean x, CInteger w <- cvVal x = if w == 0 then "false" else "true"- | isUninterpreted x, CUserSort (_, s) <- cvVal x = roundModeConvert s+ | isUserSort x, CUserSort (_, s) <- cvVal x = roundModeConvert s | isReal x, CAlgReal r <- cvVal x = algRealToSMTLib2 r | isFloat x, CFloat f <- cvVal x = showSMTFloat rm f | isDouble x, CDouble d <- cvVal x = showSMTDouble rm d@@ -487,6 +487,6 @@ -- | Create a skolem 0 for the kind mkSkolemZero :: RoundingMode -> Kind -> String-mkSkolemZero _ (KUninterpreted _ (Right (f:_))) = f-mkSkolemZero _ (KUninterpreted s _) = error $ "SBV.mkSkolemZero: Unexpected uninterpreted sort: " ++ s-mkSkolemZero rm k = cvToSMTLib rm (mkConstCV k (0::Integer))+mkSkolemZero _ (KUserSort _ (Just (f:_))) = f+mkSkolemZero _ (KUserSort s _) = error $ "SBV.mkSkolemZero: Unexpected user sort: " ++ s+mkSkolemZero rm k = cvToSMTLib rm (mkConstCV k (0::Integer))
Data/SBV/Utils/SExpr.hs view
@@ -124,11 +124,16 @@ pTok ('#':'b':r) = mkNum (Just (length r)) $ readInt 2 (`elem` "01") (\c -> ord c - ord '0') r pTok ('#':'x':r) = mkNum (Just (4 * length r)) $ readHex r - pTok n- | not (null n) && isDigit (head n)- = if '.' `elem` n then getReal n- else mkNum Nothing $ readDec n+ pTok n | possiblyNum n = if all intChar n then mkNum Nothing $ readDec n else getReal n pTok n = return $ ECon (constantMap n)++ -- crude, but effective!+ possiblyNum s = case s of+ "" -> False+ ('-':c:_) -> isDigit c+ (c:_) -> isDigit c++ intChar c = c == '-' || isDigit c mkNum l [(n, "")] = return $ ENum (n, l) mkNum _ _ = die "cannot read number"
Documentation/SBV/Examples/BitPrecise/Legato.hs view
@@ -122,7 +122,7 @@ poke :: Location -> Value -> Program poke a v m = m {memory = memory m // [(a, v)]} --- | Checking overflow. In Legato's multipler the @ADC@ instruction+-- | Checking overflow. In Legato's multiplier the @ADC@ instruction -- needs to see if the expression x + y + c overflowed, as checked -- by this function. Note that we verify the correctness of this check -- separately below in `checkOverflowCorrect`.
Documentation/SBV/Examples/BitPrecise/MergeSort.hs view
@@ -30,7 +30,7 @@ merge xs@(x:xr) ys@(y:yr) = ite (x .< y) (x : merge xr ys) (y : merge xs yr) -- | Simple merge-sort implementation. We simply divide the input list--- in two two halves so long as it has at least two elements, sort+-- in two halves so long as it has at least two elements, sort -- each half on its own, and then merge. mergeSort :: [E] -> [E] mergeSort [] = []
Documentation/SBV/Examples/BitPrecise/MultMask.hs view
@@ -40,17 +40,14 @@ -- mask = 0x8080808080808080 :: Word64 -- mult = 0x0002040810204081 :: Word64 ----- That is, any 64 bit value masked by the first and multipled by the second+-- That is, any 64 bit value masked by the first and multiplied by the second -- value above will have its bits at positions @[7,15,23,31,39,47,55,63]@ moved -- to positions @[56,57,58,59,60,61,62,63]@ respectively. -- -- NB. Depending on your z3 version, you might also get the following -- multiplier as the result: 0x8202040810204081. That value works just fine as well!------ Note that we have to use a custom SAT command for this problem, as otherwise it takes too--- long. See <https://github.com/Z3Prover/z3/issues/2587> for details. maskAndMult :: IO ()-maskAndMult = print =<< satWith z3{printBase=16, satCmd = "(check-sat-using (and-then simplify smtfd))"} find+maskAndMult = print =<< satWith z3{printBase=16} find where find = do mask <- exists "mask" mult <- exists "mult" inp <- forall "inp"
Documentation/SBV/Examples/CodeGeneration/CRC_USB5.hs view
@@ -80,7 +80,7 @@ cgOutput "crc" (crcUSB msg) -- | Generate a C function to compute the USB CRC, using the mathematical--- definition of the CRCs. While this version generates functionally eqivalent+-- definition of the CRCs. While this version generates functionally equivalent -- C code, it's less efficient; it has about 30% more code. So, the above -- version is preferable for code generation purposes. cg2 :: IO ()
Documentation/SBV/Examples/Crypto/AES.hs view
@@ -16,7 +16,7 @@ -- as possible in Haskell, and have SBV's code-generator generate fast C code automatically. -- Therefore, we merely use ordinary Haskell lists as our data-structures, and do not -- bother with any unboxing or strictness annotations. Thus, we achieve the separation--- of concerns: Correctness via clairty and simplicity and proofs on the Haskell side,+-- of concerns: Correctness via clarity and simplicity and proofs on the Haskell side, -- performance by relying on SBV's code generator. If necessary, the generated code -- can be FFI'd back into Haskell to complete the loop. --@@ -51,7 +51,7 @@ -- maximum degree 7. They are conveniently represented as values between 0 and 255. type GF28 = SWord 8 --- | Multiplication in GF(2^8). This is simple polynomial multipliation, followed+-- | Multiplication in GF(2^8). This is simple polynomial multiplication, followed -- by the irreducible polynomial @x^8+x^4+x^3+x^1+1@. We simply use the 'pMult' -- function exported by SBV to do the operation. gf28Mult :: GF28 -> GF28 -> GF28@@ -471,7 +471,7 @@ For the purposes of illustration, we only show here how to generate code for a 128-bit AES block-encrypt function, that takes 8 32-bit words as an argument. The first 4 are the 128-bit input, and the final four are the 128-bit key. The impact of this is that the generated function would expand the key for- each block of encryption, a needless task unless we change the key in every block. In a more serios application,+ each block of encryption, a needless task unless we change the key in every block. In a more serious application, we would instead generate code for both the 'aesKeySchedule' and the 'aesEncrypt' functions, thus reusing the key-schedule over many applications of the encryption call. (Unfortunately doing this is rather cumbersome right now, since Haskell does not support fixed-size lists.)
Documentation/SBV/Examples/Crypto/SHA.hs view
@@ -62,7 +62,7 @@ maj x y z = (x .&. y) `xor` (x .&. z) `xor` (y .&. z) -- | The sum-0 function. We parameterize over the rotation amounts as different--- variants of SHA use different rotation amnounts.+-- variants of SHA use different rotation amounts. sum0 :: Bits a => SHA w -> a -> a sum0 SHA{sum0Coefficients = (a, b, c)} x = (x `rotateR` a) `xor` (x `rotateR` b) `xor` (x `rotateR` c)
+ Documentation/SBV/Examples/DeltaSat/DeltaSat.hs view
@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.SBV.Examples.DeltaSat.DeltaSat+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- The encoding of the Flyspec example from the dReal web page+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wall -Werror #-}++module Documentation.SBV.Examples.DeltaSat.DeltaSat where++import Data.SBV++-- | Encode the delta-sat problem as given in <http://dreal.github.io/>+-- We have:+--+-- >>> flyspeck+-- Unsatisfiable+flyspeck :: IO SatResult+flyspeck = dsat $ do+ x1 <- sReal "x1"+ x2 <- sReal "x2"++ constrain $ x1 `inRange` ( 3, 3.14)+ constrain $ x2 `inRange` (-7, 5)++ let pi' = 3.14159265+ lhs = 2 * pi' - 2 * x1 * asin (cos 0.979 * sin (pi' / x1))+ rhs = -0.591 - 0.0331 * x2 + 0.506 + 1++ pure $ lhs .<= rhs
Documentation/SBV/Examples/Existentials/CRCPolynomial.hs view
@@ -75,7 +75,7 @@ -- Polynomial #3. x^16 + x^3 + x + 1 -- Polynomial #4. x^16 + x^15 + x^2 + 1 -- Polynomial #5. x^16 + x^15 + x^2 + x + 1--- Found: 5 polynomail(s).+-- Found: 5 polynomial(s). -- @ -- -- Note that different runs can produce different results, depending on the random
Documentation/SBV/Examples/Lists/BoundedMutex.hs view
@@ -36,25 +36,10 @@ -- | Make 'State' a symbolic enumeration mkSymbolicEnumeration ''State --- | The type synonym 'SState' is mnemonic for symbolic state.-type SState = SBV State---- | Symbolic version of 'Idle'-idle :: SState-idle = literal Idle---- | Symbolic version of 'Ready'-ready :: SState-ready = literal Ready---- | Symbolic version of 'Critical'-critical :: SState-critical = literal Critical- -- | A bounded mutex property holds for two sequences of state transitions, if they are not in -- their critical section at the same time up to that given bound. mutex :: Int -> SList State -> SList State -> SBool-mutex i p1s p2s = L.band i $ L.bzipWith i (\p1 p2 -> p1 ./= critical .|| p2 ./= critical) p1s p2s+mutex i p1s p2s = L.band i $ L.bzipWith i (\p1 p2 -> p1 ./= sCritical .|| p2 ./= sCritical) p1s p2s -- | A sequence is valid upto a bound if it starts at 'Idle', and follows the mutex rules. That is: --@@ -65,19 +50,19 @@ -- The variable @me@ identifies the agent id. validSequence :: Int -> Integer -> SList Integer -> SList State -> SBool validSequence b me pturns proc = sAnd [ L.length proc .== fromIntegral b- , idle .== L.head proc- , check b pturns proc idle+ , sIdle .== L.head proc+ , check b pturns proc sIdle ] where check 0 _ _ _ = sTrue check i ts ps prev = let (cur, rest) = L.uncons ps (turn, turns) = L.uncons ts- ok = ite (prev .== idle) (cur `sElem` [idle, ready])- $ ite (prev .== ready .&& turn .== literal me) (cur `sElem` [critical])- $ ite (prev .== critical) (cur `sElem` [critical, idle])- (cur `sElem` [prev])+ ok = ite (prev .== sIdle) (cur `sElem` [sIdle, sReady])+ $ ite (prev .== sReady .&& turn .== literal me) (cur `sElem` [sCritical])+ $ ite (prev .== sCritical) (cur `sElem` [sCritical, sIdle])+ (cur `sElem` [prev]) in ok .&& check (i-1) turns rest cur --- | The mutex algorithm, coded implicity as an assignment to turns. Turns start at @1@, and at each stage is either+-- | The mutex algorithm, coded implicitly as an assignment to turns. Turns start at @1@, and at each stage is either -- @1@ or @2@; giving preference to that process. The only condition is that if either process is in its critical -- section, then the turn value stays the same. Note that this is sufficient to satisfy safety (i.e., mutual -- exclusion), though it does not guarantee liveness.@@ -88,7 +73,7 @@ ] where check 0 _ _ _ _ = sTrue check i ts proc1 proc2 prev = cur `sElem` [1, 2]- .&& (p1 .== critical .|| p2 .== critical .=> cur .== prev)+ .&& (p1 .== sCritical .|| p2 .== sCritical .=> cur .== prev) .&& check (i-1) rest p1s p2s cur where (cur, rest) = L.uncons ts (p1, p1s) = L.uncons proc1@@ -117,16 +102,17 @@ query $ do cs <- checkSat case cs of- Unk -> error "Solver said Unknown!"- Unsat -> io . putStrLn $ "All is good!"- Sat -> do io . putStrLn $ "Violation detected!"- do p1V <- getValue p1- p2V <- getValue p2- ts <- getValue turns+ Unk -> error "Solver said Unknown!"+ DSat{} -> error "Solver said delta-satisfiable!"+ Unsat -> io . putStrLn $ "All is good!"+ Sat -> do io . putStrLn $ "Violation detected!"+ do p1V <- getValue p1+ p2V <- getValue p2+ ts <- getValue turns - io . putStrLn $ "P1: " ++ show p1V- io . putStrLn $ "P2: " ++ show p2V- io . putStrLn $ "Ts: " ++ show ts+ io . putStrLn $ "P1: " ++ show p1V+ io . putStrLn $ "P2: " ++ show p2V+ io . putStrLn $ "Ts: " ++ show ts -- | Our algorithm is correct, but it is not fair. It does not guarantee that a process that -- wants to enter its critical-section will always do so eventually. Demonstrate this by@@ -156,23 +142,24 @@ constrain $ validTurns b turns p1 p2 -- Ensure that the second process becomes ready in the second cycle:- constrain $ p2 .!! 1 .== ready+ constrain $ p2 .!! 1 .== sReady -- Find a trace where p2 never goes critical -- counter example, we would've found a violation!- constrain $ sNot $ L.belem b critical p2+ constrain $ sNot $ L.belem b sCritical p2 query $ do cs <- checkSat case cs of- Unk -> error "Solver said Unknown!"- Unsat -> error "Solver couldn't find a violating trace!"- Sat -> do io . putStrLn $ "Fairness is violated at bound: " ++ show b- do p1V <- getValue p1- p2V <- getValue p2- ts <- getValue turns+ Unk -> error "Solver said Unknown!"+ DSat{} -> error "Solver said delta-satisfiable!"+ Unsat -> error "Solver couldn't find a violating trace!"+ Sat -> do io . putStrLn $ "Fairness is violated at bound: " ++ show b+ do p1V <- getValue p1+ p2V <- getValue p2+ ts <- getValue turns - io . putStrLn $ "P1: " ++ show p1V- io . putStrLn $ "P2: " ++ show p2V- io . putStrLn $ "Ts: " ++ show ts+ io . putStrLn $ "P1: " ++ show p1V+ io . putStrLn $ "P2: " ++ show p2V+ io . putStrLn $ "Ts: " ++ show ts {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
Documentation/SBV/Examples/Lists/Fibonacci.hs view
@@ -47,6 +47,7 @@ query $ do cs <- checkSat case cs of- Unk -> error "Solver returned unknown!"- Unsat -> error "Solver couldn't generate the fibonacci sequence!"- Sat -> getValue fibs+ Unk -> error "Solver returned unknown!"+ DSat{} -> error "Unexpected dsat result!"+ Unsat -> error "Solver couldn't generate the fibonacci sequence!"+ Sat -> getValue fibs
Documentation/SBV/Examples/Lists/Nested.hs view
@@ -37,7 +37,8 @@ query $ do cs <- checkSat case cs of- Unk -> error "Solver said unknown!"- Unsat -> io $ putStrLn "Unsat"- Sat -> do v <- getValue a- io $ print v+ Unk -> error "Solver said unknown!"+ DSat{} -> error "Unexpected dsat result.."+ Unsat -> io $ putStrLn "Unsat"+ Sat -> do v <- getValue a+ io $ print v
Documentation/SBV/Examples/Misc/Enumerate.hs view
@@ -36,9 +36,6 @@ -- | Make 'E' a symbolic value. mkSymbolicEnumeration ''E --- | Give a name to the symbolic variants of 'E', for convenience-type SE = SBV E- -- | Have the SMT solver enumerate the elements of the domain. We have: -- -- >>> elts@@ -63,7 +60,7 @@ -- | Enumerations are automatically ordered, so we can ask for the maximum -- element. Note the use of quantification. We have: ----- >>> maxE+-- maxE -- Satisfiable. Model: -- maxE = C :: E maxE :: IO SatResult@@ -71,7 +68,7 @@ e <- forall "e" return $ mx .>= (e::SE) --- | Similarly, we get the minumum element. We have:+-- | Similarly, we get the minimum element. We have: -- -- >>> minE -- Satisfiable. Model:
Documentation/SBV/Examples/Misc/Floating.hs view
@@ -58,19 +58,19 @@ -- -- >>> assocPlusRegular -- Falsifiable. Counter-example:--- x = 128.00029 :: Float--- y = -7.27236e-4 :: Float--- z = -6.875994e-3 :: Float+-- x = -4.73427e15 :: Float+-- y = 3.718088e19 :: Float+-- z = 4.500073e20 :: Float -- -- Indeed, we have: ----- >>> let x = 128.00029 :: Float--- >>> let y = -7.27236e-4 :: Float--- >>> let z = -6.875994e-3 :: Float+-- >>> let x = -4.73427e15 :: Float+-- >>> let y = 3.718088e19 :: Float+-- >>> let z = 4.500073e20 :: Float -- >>> x + (y + z)--- 127.99268+-- 4.8718343e20 -- >>> (x + y) + z--- 127.99269+-- 4.8718347e20 -- -- Note the difference in the results! assocPlusRegular :: IO ThmResult@@ -92,13 +92,13 @@ -- -- >>> nonZeroAddition -- Falsifiable. Counter-example:--- a = 5.060287e28 :: Float--- b = 3.6780381e19 :: Float+-- a = 1.3408534e37 :: Float+-- b = 6.977023e21 :: Float -- -- Indeed, we have: ----- >>> let a = 5.060287e28 :: Float--- >>> let b = 3.6780381e19 :: Float+-- >>> let a = 1.3408534e37 :: Float+-- >>> let b = 6.977023e21 :: Float -- >>> a + b == a -- True -- >>> b == 0@@ -121,13 +121,13 @@ -- -- >>> multInverse -- Falsifiable. Counter-example:--- a = 2.4907063e38 :: Float+-- a = 7.660899e-39 :: Float -- -- Indeed, we have: ----- >>> let a = 2.4907063e38 :: Float+-- >>> let a = 7.660899e-39 :: Float -- >>> a * (1/a)--- 1.0000001+-- 0.99999994 multInverse :: IO ThmResult multInverse = prove $ do a <- sFloat "a" constrain $ fpIsPoint a@@ -148,29 +148,29 @@ -- >>> roundingAdd -- Satisfiable. Model: -- rm = RoundTowardPositive :: RoundingMode--- x = -2.3509886e-38 :: Float--- y = -6.0e-45 :: Float+-- x = -2.240786e-38 :: Float+-- y = -1.10355e-39 :: Float -- -- (Note that depending on your version of Z3, you might get a different result.) -- Unfortunately we can't directly validate this result at the Haskell level, as Haskell only supports -- 'RoundNearestTiesToEven'. We have: ----- >>> -2.3509886e-38 + (-6.0e-45) :: Float--- -2.3509893e-38+-- >>> -2.240786e-38 + (-1.10355e-39) :: Float+-- -2.3511412e-38 -- -- While we cannot directly see the result when the mode is 'RoundTowardPositive' in Haskell, we can use -- SBV to provide us with that result thusly: ----- >>> sat $ \z -> z .== fpAdd sRoundTowardPositive (-2.3509886e-38) (-6.0e-45 :: SFloat)+-- >>> sat $ \z -> z .== fpAdd sRoundTowardPositive (-2.240786e-38) (-1.10355e-39 :: SFloat) -- Satisfiable. Model:--- s0 = -2.350989e-38 :: Float+-- s0 = -2.351141e-38 :: Float ----- We can see why these two resuls are indeed different: The 'RoundTowardPositive'+-- We can see why these two results are indeed different: The 'RoundTowardPositive' -- (which rounds towards positive infinity from zero) produces a larger result. Indeed, if we treat these numbers -- as 'Double' values, we get: ----- >> -2.3509886e-38 + (-6.0e-45) :: Double--- -2.3509892e-38+-- >> -2.240786e-38 + (-1.10355e-39) :: Double+-- -2.351141e-38 -- -- we see that the "more precise" result is larger than what the 'Float' value is, justifying the -- larger value with 'RoundTowardPositive'. A more detailed study is beyond our current scope, so we'll
Documentation/SBV/Examples/Optimization/Enumerate.hs view
@@ -29,35 +29,32 @@ -- | Make 'Day' a symbolic value. mkSymbolicEnumeration ''Day --- | Give a name to the symbolic variants of 'Day', for convenience-type SDay = SBV Day- -- | Make day an optimizable value, by mapping it to 'Word8' in the most -- obvious way. We can map it to any value the underlying solver can optimize, -- but 'Word8' is the simplest and it'll fit the bill. instance Metric Day where type MetricSpace Day = Word8 - toMetricSpace x = ite (x .== literal Mon) 0- $ ite (x .== literal Tue) 1- $ ite (x .== literal Wed) 2- $ ite (x .== literal Thu) 3- $ ite (x .== literal Fri) 4- $ ite (x .== literal Sat) 5- 6+ toMetricSpace x = ite (x .== sMon) 0+ $ ite (x .== sTue) 1+ $ ite (x .== sWed) 2+ $ ite (x .== sThu) 3+ $ ite (x .== sFri) 4+ $ ite (x .== sSat) 5+ 6 - fromMetricSpace x = ite (x .== 0) (literal Mon)- $ ite (x .== 1) (literal Tue)- $ ite (x .== 2) (literal Wed)- $ ite (x .== 3) (literal Thu)- $ ite (x .== 4) (literal Fri)- $ ite (x .== 5) (literal Sat)- (literal Sun)+ fromMetricSpace x = ite (x .== 0) sMon+ $ ite (x .== 1) sTue+ $ ite (x .== 2) sWed+ $ ite (x .== 3) sThu+ $ ite (x .== 4) sFri+ $ ite (x .== 5) sSat+ sSun -- | Identify weekend days isWeekend :: SDay -> SBool isWeekend = (`sElem` weekend)- where weekend = map literal [Sat, Sun]+ where weekend = [sSat, sSun] -- | Using optimization, find the latest day that is not a weekend. -- We have:
Documentation/SBV/Examples/Optimization/ExtField.hs view
@@ -16,8 +16,8 @@ import Data.SBV -- | Optimization goals where min/max values might require assignments--- to values that are infinite (integer case), or infinite/epsion (real case).--- This simple example demostrates how SBV can be used to extract such values.+-- to values that are infinite (integer case), or infinite/epsilon (real case).+-- This simple example demonstrates how SBV can be used to extract such values. -- -- We have: --
Documentation/SBV/Examples/Puzzles/Garden.hs view
@@ -70,7 +70,7 @@ let valid = validPick n - -- Declare three existential flowers. We declar these with+ -- Declare three existential flowers. We declare these with -- _modelIgnore suffix, because we don't care different assignments -- to them to be a different model. See 'isNonModelVar' below. ef1 <- exists "ef1_modelIgnore"@@ -85,7 +85,7 @@ -- Each color is represented: constrain $ valid ef1 ef2 ef3- constrain $ map col [ef1, ef2, ef3] .== map literal [Red, Yellow, Blue]+ constrain $ map col [ef1, ef2, ef3] .== [sRed, sYellow, sBlue] -- Pick any three, at least one is Red constrain $ valid af1 af2 af3 .=> count Red [af1, af2, af3] .>= 1
Documentation/SBV/Examples/Puzzles/HexPuzzle.hs view
@@ -58,9 +58,6 @@ -- | Make 'Color' a symbolic value. mkSymbolicEnumeration ''Color --- | Give symbolic colors a name for convenience.-type SColor = SBV Color- -- | Use 8-bit words for button numbers, even though we only have 1 to 19. type Button = Word8 @@ -74,7 +71,7 @@ -- If the button is "unpressable", i.e., if it is not one of the center -- buttons or it is currently colored black, we return the grid unchanged. next :: SButton -> Grid -> Grid-next b g = ite (readArray g b .== literal Black) g+next b g = ite (readArray g b .== sBlack) g $ ite (b .== 5) (rot [ 1, 2, 6, 10, 9, 4]) $ ite (b .== 6) (rot [ 2, 3, 7, 11, 10, 5]) $ ite (b .== 9) (rot [ 4, 5, 10, 14, 13, 8])@@ -89,7 +86,7 @@ -- | Iteratively search at increasing depths of button-presses to see if we can -- transform from the initial board position to a final board position. search :: [Color] -> [Color] -> IO ()-search initial final = runSMT $ do emptyGrid :: Grid <- newArray "emptyGrid" (Just (literal Black))+search initial final = runSMT $ do emptyGrid :: Grid <- newArray "emptyGrid" (Just sBlack) let initGrid = foldr (\(i, c) a -> writeArray a (literal i) (literal c)) emptyGrid (zip [1..] initial) query $ loop (0 :: Int) initGrid [] @@ -101,27 +98,30 @@ cs <- checkSat case cs of- Unk -> error $ "Solver said Unknown, depth: " ++ show i+ Unk -> error $ "Solver said Unknown, depth: " ++ show i - Unsat -> do -- It didn't work out. Pop and try again with one more move:- pop 1- b <- freshVar ("press_" ++ show i)- constrain $ b `sElem` map literal [5, 6, 9, 10, 11, 14, 15]- loop (i+1) (next b g) (sofar ++ [b])+ DSat{} -> error $ "Solver returned a delta-satisfiable result, depth: " ++ show i - Sat -> do vs <- mapM getValue sofar- io $ putStrLn $ "Found: " ++ show vs- findOthers sofar vs+ Unsat -> do -- It didn't work out. Pop and try again with one more move:+ pop 1+ b <- freshVar ("press_" ++ show i)+ constrain $ b `sElem` map literal [5, 6, 9, 10, 11, 14, 15]+ loop (i+1) (next b g) (sofar ++ [b]) + Sat -> do vs <- mapM getValue sofar+ io $ putStrLn $ "Found: " ++ show vs+ findOthers sofar vs+ findOthers vs = go where go curVals = do constrain $ sOr $ zipWith (\v c -> v ./= literal c) vs curVals cs <- checkSat case cs of- Unk -> error "Unknown!"- Unsat -> io $ putStrLn "There are no more solutions."- Sat -> do newVals <- mapM getValue vs- io $ putStrLn $ "Found: " ++ show newVals- go newVals+ Unk -> error "Unknown!"+ DSat{} -> error "Delta-sat!"+ Unsat -> io $ putStrLn "There are no more solutions."+ Sat -> do newVals <- mapM getValue vs+ io $ putStrLn $ "Found: " ++ show newVals+ go newVals -- | A particular example run. We have: --@@ -133,8 +133,8 @@ -- Searching at depth: 4 -- Searching at depth: 5 -- Searching at depth: 6--- Found: [10,10,11,9,14,6] -- Found: [10,10,9,11,14,6]+-- Found: [10,10,11,9,14,6] -- There are no more solutions. example :: IO () example = search initBoard finalBoard
Documentation/SBV/Examples/Puzzles/U2Bridge.hs view
@@ -40,13 +40,6 @@ -- | Make 'U2Member' a symbolic value. mkSymbolicEnumeration ''U2Member --- | Symbolic shorthand for a 'U2Member'-type SU2Member = SBV U2Member---- | Shorthands for symbolic versions of the members-bono, edge, adam, larry :: SU2Member-[bono, edge, adam, larry] = map literal [Bono, Edge, Adam, Larry]- -- | Model time using 32 bits type Time = Word32 @@ -62,10 +55,10 @@ -- | The symbolic variant.. The duplication is unfortunate. sCrossTime :: SU2Member -> STime-sCrossTime m = ite (m .== bono) (literal (crossTime Bono))- $ ite (m .== edge) (literal (crossTime Edge))- $ ite (m .== adam) (literal (crossTime Adam))- (literal (crossTime Larry)) -- Must be Larry+sCrossTime m = ite (m .== sBono) (literal (crossTime Bono))+ $ ite (m .== sEdge) (literal (crossTime Edge))+ $ ite (m .== sAdam) (literal (crossTime Adam))+ (literal (crossTime Larry)) -- Must be Larry -- | Location of the flash data Location = Here | There@@ -73,13 +66,6 @@ -- | Make 'Location' a symbolic value. mkSymbolicEnumeration ''Location --- | Symbolic variant of 'Location'-type SLocation = SBV Location---- | Shorthands for symbolic versions of locations-here, there :: SLocation-[here, there] = map literal [Here, There]- -- | The status of the puzzle after each move -- -- This type is equipped with an automatically derived 'Mergeable' instance@@ -107,14 +93,14 @@ -- , lLarry = symbolicMerge f t (lLarry s1) (lLarry s2) -- } --- | Start configuration, time elapsed is 0 and everybody is 'here'+-- | Start configuration, time elapsed is 0 and everybody is here start :: Status start = Status { time = 0- , flash = here- , lBono = here- , lEdge = here- , lAdam = here- , lLarry = here+ , flash = sHere+ , lBono = sHere+ , lEdge = sHere+ , lAdam = sHere+ , lLarry = sHere } -- | A puzzle move is modeled as a state-transformer@@ -136,23 +122,23 @@ -- | Given an arbitrary member, return his location whereIs :: SU2Member -> Move SLocation-whereIs p = ite (p .== bono) (peek lBono)- $ ite (p .== edge) (peek lEdge)- $ ite (p .== adam) (peek lAdam)- (peek lLarry)+whereIs p = ite (p .== sBono) (peek lBono)+ $ ite (p .== sEdge) (peek lEdge)+ $ ite (p .== sAdam) (peek lAdam)+ (peek lLarry) -- | Transferring the flash to the other side xferFlash :: Move ()-xferFlash = modify $ \s -> s{flash = ite (flash s .== here) there here}+xferFlash = modify $ \s -> s{flash = ite (flash s .== sHere) sThere sHere} -- | Transferring a person to the other side xferPerson :: SU2Member -> Move () xferPerson p = do ~[lb, le, la, ll] <- mapM peek [lBono, lEdge, lAdam, lLarry]- let move l = ite (l .== here) there here- lb' = ite (p .== bono) (move lb) lb- le' = ite (p .== edge) (move le) le- la' = ite (p .== adam) (move la) la- ll' = ite (p .== larry) (move ll) ll+ let move l = ite (l .== sHere) sThere sHere+ lb' = ite (p .== sBono) (move lb) lb+ le' = ite (p .== sEdge) (move le) le+ la' = ite (p .== sAdam) (move la) la+ ll' = ite (p .== sLarry) (move ll) ll modify $ \s -> s{lBono = lb', lEdge = le', lAdam = la', lLarry = ll'} -- | Increment the time, when only one person crosses@@ -209,9 +195,9 @@ -- | Check if a given sequence of actions is valid, i.e., they must all -- cross the bridge according to the rules and in less than 17 seconds isValid :: Actions -> SBool-isValid as = time end .<= 17 .&& sAll check as .&& zigZag (cycle [there, here]) (map flash states) .&& sAll (.== there) [lBono end, lEdge end, lAdam end, lLarry end]- where check (s, p1, p2) = (sNot s .=> p1 .> p2) -- for two person moves, ensure first person is "larger"- .&& (s .=> p2 .== bono) -- for one person moves, ensure second person is always "bono"+isValid as = time end .<= 17 .&& sAll check as .&& zigZag (cycle [sThere, sHere]) (map flash states) .&& sAll (.== sThere) [lBono end, lEdge end, lAdam end, lLarry end]+ where check (s, p1, p2) = (sNot s .=> p1 .> p2) -- for two person moves, ensure first person is "larger"+ .&& (s .=> p2 .== sBono) -- for one person moves, ensure second person is always "bono" states = evalState (run as) start end = last states zigZag reqs locs = sAnd $ zipWith (.==) locs reqs
Documentation/SBV/Examples/Queries/AllSat.hs view
@@ -42,23 +42,24 @@ cs <- checkSatAssuming [x .== literal (i-1)] case cs of- Unk -> error "Too bad, solver said unknown.." -- Won't happen- Unsat -> do io $ putStrLn "No other solution!"- return $ reverse sofar+ Unk -> error "Too bad, solver said unknown.." -- Won't happen+ DSat{} -> error "Unexpected dsat result.." -- Won't happen+ Unsat -> do io $ putStrLn "No other solution!"+ return $ reverse sofar - Sat -> do xv <- getValue x- yv <- getValue y+ Sat -> do xv <- getValue x+ yv <- getValue y - io $ putStrLn $ "Current solution is: " ++ show (xv, yv)+ io $ putStrLn $ "Current solution is: " ++ show (xv, yv) - -- For next iteration: Put in constraints outlawing the current one:- -- Note that we do *not* put these separately, as we do want- -- to allow repetition on one value if the other is different!- constrain $ x ./= literal xv- .|| y ./= literal yv+ -- For next iteration: Put in constraints outlawing the current one:+ -- Note that we do *not* put these separately, as we do want+ -- to allow repetition on one value if the other is different!+ constrain $ x ./= literal xv+ .|| y ./= literal yv - -- loop around!- next (i+1) ((xv, yv) : sofar)+ -- loop around!+ next (i+1) ((xv, yv) : sofar) -- Go into query mode and execute the loop: query $ do io $ putStrLn "Starting the all-sat engine!"
Documentation/SBV/Examples/Queries/Concurrency.hs view
@@ -58,14 +58,15 @@ cs <- checkSat case cs of- Unk -> error "Too bad, solver said unknown.." -- Won't happen- Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ Unk -> error "Too bad, solver said unknown.." -- Won't happen+ DSat{} -> error "Unexpected dsat result.." -- Won't happen+ Unsat -> do io $ putStrLn "No other solution!"+ return Nothing - Sat -> do xv <- getValue x- yv <- getValue y- io $ putStrLn $ "[One]: Current solution is: " ++ show (xv, yv)- return $ Just (xv + yv)+ Sat -> do xv <- getValue x+ yv <- getValue y+ io $ putStrLn $ "[One]: Current solution is: " ++ show (xv, yv)+ return $ Just (xv + yv) -- | In the second query we constrain for an answer where y is smaller than x, -- and then return the product of the found values.@@ -77,14 +78,15 @@ cs <- checkSat case cs of- Unk -> error "Too bad, solver said unknown.." -- Won't happen- Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ Unk -> error "Too bad, solver said unknown.." -- Won't happen+ DSat{} -> error "Unexpected dsat result.." -- Won't happen+ Unsat -> do io $ putStrLn "No other solution!"+ return Nothing - Sat -> do yv <- getValue y- xv <- getValue x- io $ putStrLn $ "[Two]: Current solution is: " ++ show (xv, yv)- return $ Just (xv * yv)+ Sat -> do yv <- getValue y+ xv <- getValue x+ io $ putStrLn $ "[Two]: Current solution is: " ++ show (xv, yv)+ return $ Just (xv * yv) -- | Run the demo several times to see that the children threads will change ordering. demo :: IO ()@@ -120,16 +122,17 @@ cs <- checkSat case cs of- Unk -> error "Too bad, solver said unknown.." -- Won't happen- Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ Unk -> error "Too bad, solver said unknown.." -- Won't happen+ DSat{} -> error "Unexpected dsat result.." -- Won't happen+ Unsat -> do io $ putStrLn "No other solution!"+ return Nothing - Sat -> do xv <- getValue x- yv <- getValue y- io $ putStrLn $ "[One]: Current solution is: " ++ show (xv, yv)- io $ putStrLn $ "[One]: Place vars for [Two]"- liftIO $ putMVar v2 (literal (xv + yv), literal (xv * yv))- return $ Just (xv + yv)+ Sat -> do xv <- getValue x+ yv <- getValue y+ io $ putStrLn $ "[One]: Current solution is: " ++ show (xv, yv)+ io $ putStrLn $ "[One]: Place vars for [Two]"+ liftIO $ putMVar v2 (literal (xv + yv), literal (xv * yv))+ return $ Just (xv + yv) -- | In the second query we create a new variable z, and then a symbolic query -- using information from the first query and return a solution that uses the@@ -147,15 +150,16 @@ cs <- checkSat case cs of- Unk -> error "Too bad, solver said unknown.." -- Won't happen- Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ Unk -> error "Too bad, solver said unknown.." -- Won't happen+ DSat{} -> error "Unexpected dsat result.." -- Won't happen+ Unsat -> do io $ putStrLn "No other solution!"+ return Nothing - Sat -> do yv <- getValue y- xv <- getValue x- zv <- getValue z- io $ putStrLn $ "[Two]: My solution is: " ++ show (zv + xv, zv + yv)- return $ Just (zv * xv * yv)+ Sat -> do yv <- getValue y+ xv <- getValue x+ zv <- getValue z+ io $ putStrLn $ "[Two]: My solution is: " ++ show (zv + xv, zv + yv)+ return $ Just (zv * xv * yv) -- | In our second demonstration we show how through the use of concurrency -- constructs the user can have children queries communicate with one another.
Documentation/SBV/Examples/Queries/Enums.hs view
@@ -28,10 +28,6 @@ -- | Make 'Day' a symbolic value. mkSymbolicEnumeration ''Day --- | The type synonym 'SDay' is the symbolic variant of 'Day'. (Similar to 'SInteger'/'Integer'--- and others.)-type SDay = SBV Day- -- | A trivial query to find three consecutive days that's all before 'Thursday'. The point -- here is that we can perform queries on such enumerated values and use 'getValue' on them -- and return their values from queries just like any other value. We have:@@ -48,7 +44,7 @@ constrain $ d2 .<= d3 -- Assert that last day is before 'Thursday'- constrain $ d3 .< literal Thursday+ constrain $ d3 .< sThursday -- Constraints can be given before or after -- the query mode starts. We will assert that
Documentation/SBV/Examples/Queries/FourFours.hs view
@@ -51,12 +51,6 @@ -- | Make 'UnOp' a symbolic value. mkSymbolicEnumeration ''UnOp --- | Symbolic variant of 'BinOp'.-type SBinOp = SBV BinOp---- | Symbolic variant of 'UnOp'.-type SUnOp = SBV UnOp- -- | The shape of a tree, either a binary node, or a unary node, or the number @4@, represented hear by -- the constructor @F@. We parameterize by the operator type: When doing symbolic computations, we'll fill -- those with 'SBinOp' and 'SUnOp'. When finding the shapes, we will simply put unit values, i.e., holes.@@ -119,8 +113,8 @@ F -> return 4 where binOp :: SBinOp -> SInteger -> SInteger -> Symbolic SInteger- binOp o l r = do constrain $ o .== literal Divide .=> r .== 4 .|| r .== 2- constrain $ o .== literal Expt .=> r .== 0+ binOp o l r = do constrain $ o .== sDivide .=> r .== 4 .|| r .== 2+ constrain $ o .== sExpt .=> r .== 0 return $ sCase o [ (Plus, l+r) , (Minus, l-r)@@ -130,8 +124,8 @@ ] uOp :: SUnOp -> SInteger -> Symbolic SInteger- uOp o v = do constrain $ o .== literal Sqrt .=> v .== 4- constrain $ o .== literal Factorial .=> v .== 4+ uOp o v = do constrain $ o .== sSqrt .=> v .== 4+ constrain $ o .== sFactorial .=> v .== 4 return $ sCase o [ (Negate, -v) , (Sqrt, 2) -- argument is restricted to 4, so the value is 2
Documentation/SBV/Examples/Queries/GuessNumber.hs view
@@ -38,22 +38,23 @@ -- Issue a check-sat cs <- checkSat case cs of- Unk -> error "Too bad, solver said Unknown.." -- Won't really happen- Unsat ->- -- This cannot happen! If it does, the input was- -- not properly constrainted. Note that we found this- -- by getting an Unsat, not by checking the value!- error $ unlines [ "There's no solution!"- , "Guess sequence: " ++ show (reverse sofar)- ]- Sat -> do gv <- getValue g- case gv `compare` input of- EQ -> -- Got it, return:- return (reverse (gv : sofar))- LT -> -- Solver guess is too small, increase the lower bound:- loop ((lb+1) `max` (lb + (input - lb) `div` 2)) ub (gv : sofar)- GT -> -- Solver guess is too big, decrease the upper bound:- loop lb ((ub-1) `min` (ub - (ub - input) `div` 2)) (gv : sofar)+ Unk -> error "Too bad, solver said Unknown.." -- Won't really happen+ DSat{} -> error "Unexpected delta-sat result.." -- Won't really happen+ Unsat ->+ -- This cannot happen! If it does, the input was+ -- not properly constrainted. Note that we found this+ -- by getting an Unsat, not by checking the value!+ error $ unlines [ "There's no solution!"+ , "Guess sequence: " ++ show (reverse sofar)+ ]+ Sat -> do gv <- getValue g+ case gv `compare` input of+ EQ -> -- Got it, return:+ return (reverse (gv : sofar))+ LT -> -- Solver guess is too small, increase the lower bound:+ loop ((lb+1) `max` (lb + (input - lb) `div` 2)) ub (gv : sofar)+ GT -> -- Solver guess is too big, decrease the upper bound:+ loop lb ((ub-1) `min` (ub - (ub - input) `div` 2)) (gv : sofar) -- Start the search query $ loop 0 1000 []
Documentation/SBV/Examples/Queries/Interpolants.hs view
@@ -78,9 +78,10 @@ -- To obtain the interpolant, we run a query query $ do cs <- checkSat case cs of- Unsat -> getInterpolantMathSAT ["A"]- Sat -> error "Unexpected sat result!"- Unk -> error "Unexpected unknown result!"+ Unsat -> getInterpolantMathSAT ["A"]+ DSat{} -> error "Unexpected delta-sat result!"+ Sat -> error "Unexpected sat result!"+ Unk -> error "Unexpected unknown result!" -- | Z3 example. Compute the interpolant for formulas @y = 2x@ and @y = 2z+1@. --@@ -100,7 +101,7 @@ -- -- Notice that the only symbol is @y@, as required. To establish that this is -- indeed an interpolant, we should establish that when @y@ is even, this formula--- is @True@; and if @y@ is odd, then then it should be @False@. You can argue+-- is @True@; and if @y@ is odd, then it should be @False@. You can argue -- mathematically that this indeed the case, but let's just use SBV to prove these: -- -- >>> prove $ \y -> (y `sMod` 2 .== 0) .=> ((y .== 0) .|| (y .== 2 * (y `sDiv` (2::SInteger))))
Documentation/SBV/Examples/Strings/RegexCrossword.hs view
@@ -38,7 +38,7 @@ rows <- mapM mkRow rowRegExps - -- constrain colums+ -- constrain columns let mkCol colRegExp = do col <- free_ constrain $ col `R.match` colRegExp constrain $ S.length col .== literal numRows@@ -55,9 +55,10 @@ -- Now query to extract the solution query $ do cs <- checkSat case cs of- Unk -> error "Solver returned unknown!"- Unsat -> error "There are no solutions to this puzzle!"- Sat -> mapM getValue rows+ Unk -> error "Solver returned unknown!"+ DSat{} -> error "Solver returned delta-sat!"+ Unsat -> error "There are no solutions to this puzzle!"+ Sat -> mapM getValue rows -- | Solve <http://regexcrossword.com/challenges/intermediate/puzzles/1> --
Documentation/SBV/Examples/Strings/SQLInjection.hs view
@@ -143,11 +143,12 @@ (_, queries) <- runWriterT (evalStateT (eval expr) env) - -- For all the queries thus generated, ask that one of them be "explotiable"+ -- For all the queries thus generated, ask that one of them be "exploitable" constrain $ sAny (`R.match` exploitRe) queries query $ do cs <- checkSat case cs of- Unk -> error "Solver returned unknown!"- Unsat -> error "No exploits are found"- Sat -> getValue badTopic+ Unk -> error "Solver returned unknown!"+ DSat{} -> error "Solver returned delta-satisfiable!"+ Unsat -> error "No exploits are found"+ Sat -> getValue badTopic
Documentation/SBV/Examples/Transformers/SymbolicEval.hs view
@@ -161,10 +161,11 @@ mkQuery env = do satResult <- checkSat case satResult of- Sat -> Counterexample <$> getValue (envX env)- <*> getValue (envY env)- Unsat -> pure Proved- Unk -> throwError "unknown"+ Sat -> Counterexample <$> getValue (envX env)+ <*> getValue (envY env)+ Unsat -> pure Proved+ DSat{} -> throwError "delta-sat"+ Unk -> throwError "unknown" -- | Checks a 'Property' of a 'Program' (or fails). check :: Program a -> Property -> IO (Either String CheckResult)
Documentation/SBV/Examples/Uninterpreted/Deduce.hs view
@@ -13,12 +13,13 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Uninterpreted.Deduce where -import Data.Generics import Data.SBV -- we will have our own "uninterpreted" functions corresponding@@ -30,11 +31,11 @@ ----------------------------------------------------------------------------- -- | The uninterpreted sort 'B', corresponding to the carrier.--- To prevent SBV from translating it to an enumerated type, we simply attach an unused field-newtype B = B () deriving (Eq, Ord, Show, Read, Data, SymVal, HasKind)+data B --- | Handy shortcut for the type of symbolic values over 'B'-type SB = SBV B+-- | Make this sort uninterpreted. This splice will automatically introduce+-- the type 'SB' into the environment, as a synonym for 'SBV' 'B'.+mkUninterpretedSort ''B ----------------------------------------------------------------------------- -- * Uninterpreted connectives over 'B'
Documentation/SBV/Examples/Uninterpreted/Multiply.hs view
@@ -25,7 +25,7 @@ -- no computation going on here, aside from simply passing the arguments -- to the uninterpreted functions and stitching it back together. ----- NB. While definining @mul22_lo@ we used our domain knowledge that the+-- NB. While defining @mul22_lo@ we used our domain knowledge that the -- low-bit of the multiplication only depends on the low bits of the inputs. -- However, this is merely a simplifying assumption; we could have passed -- all the arguments as well.
Documentation/SBV/Examples/Uninterpreted/Sort.hs view
@@ -11,22 +11,26 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Uninterpreted.Sort where -import Data.Generics import Data.SBV -- | A new data-type that we expect to use in an uninterpreted fashion--- in the backend SMT solver. Note the custom @deriving@ clause, which--- takes care of most of the boilerplate. The () field is needed so--- SBV will not translate it to an enumerated data-type-newtype Q = Q () deriving (Eq, Ord, Data, Read, Show, SymVal, HasKind)+-- in the backend SMT solver.+data Q +-- | Make 'Q' an uinterpreted sort. This will automatically introduce the+-- type 'SQ' into our environment, which is the symbolic version of the+-- carrier type 'Q'.+mkUninterpretedSort ''Q+ -- | Declare an uninterpreted function that works over Q's-f :: SBV Q -> SBV Q+f :: SQ -> SQ f = uninterpret "f" -- | A satisfiable example, stating that there is an element of the domain
Documentation/SBV/Examples/Uninterpreted/UISortAllSat.hs view
@@ -10,34 +10,28 @@ -- Thanks to Eric Seidel for the idea. ----------------------------------------------------------------------------- +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Uninterpreted.UISortAllSat where -import Data.Generics import Data.SBV -- | A "list-like" data type, but one we plan to uninterpret at the SMT level.--- The actual shape is really immaterial for us, but could be used as a proxy--- to generate test cases or explore data-space in some other part of a program.--- Note that we neither rely on the shape of this data, nor need the actual--- constructors.-data L = Nil- | Cons Int L- deriving (Eq, Ord, Show, Read, Data)---- | Declare instances to make 'L' a usable uninterpreted sort. First we need the--- 'SymVal' instance, with the default definition sufficing.-instance SymVal L+-- The actual shape is really immaterial for us.+data L --- | Similarly, 'HasKind's default implementation is sufficient.-instance HasKind L+-- | Make 'L' into an uninterpreted sort, automatically introducing 'SL'+-- as a synonym for 'SBV' 'L'.+mkUninterpretedSort ''L -- | An uninterpreted "classify" function. Really, we only care about -- the fact that such a function exists, not what it does.-classify :: SBV L -> SInteger+classify :: SL -> SInteger classify = uninterpret "classify" -- | Formulate a query that essentially asserts a cardinality constraint on
Documentation/SBV/Examples/WeakestPreconditions/Basics.hs view
@@ -6,7 +6,7 @@ -- Maintainer: erkokl@gmail.com -- Stability : experimental ----- Some basic aspects of weakest preconditions, demostrating programs+-- Some basic aspects of weakest preconditions, demonstrating programs -- that do not use while loops. We use a simple increment program as -- an example. -----------------------------------------------------------------------------
Documentation/SBV/Examples/WeakestPreconditions/Sum.hs view
@@ -203,7 +203,7 @@ >>> void $ correctness invariant Nothing Following proof obligation failed: ==================================- Invariant for loop "i < n" is not maintaned by the body:+ Invariant for loop "i < n" is not maintained by the body: Before: SumS {n = 2, i = 1, s = 1} After : SumS {n = 2, i = 2, s = 3}
README.md view
@@ -7,12 +7,12 @@ ### Build Status - Linux:- - GHC 8.6.5 [![Build1][3]][1]- - GHC 8.6.4 [![Build1][4]][1]+ - GHC 8.10.2 [![Build1][3]][1]+ - GHC 8.8.4 [![Build1][4]][1] - Mac OSX:- - GHC 8.6.5 [![Build1][5]][1]+ - GHC 8.10.2 [![Build1][5]][1] - Windows:- - GHC 8.6.5 [![Build5][6]][2]+ - GHC 8.10.1 [![Build5][6]][2] [1]: https://travis-ci.org/LeventErkok/sbv [2]: https://ci.appveyor.com/project/LeventErkok/sbv
SBVBenchSuite/BenchSuite/Bench/Bench.hs view
@@ -28,8 +28,8 @@ , runIO , runPure , rGroup- , runOverheadBenchMark- , runBenchMark+ , runOverheadBenchmark+ , runBenchmark , onConfig , onDesc , runner@@ -43,7 +43,7 @@ import System.IO import System.IO.Silently (silence) -import Gauge.Main+import qualified Gauge.Main as G import qualified System.Process as P import qualified Utils.SBVBenchFramework as U@@ -79,13 +79,14 @@ -- so that we don't have to separate out runners that run a single benchmark -- from runners that need to run several benchmarks data Runner where- RBenchmark :: Benchmark -> Runner -- ^ a wrapper around gauge benchmarks- Runner :: RunnerI -> Runner -- ^ a single run- RunnerGroup :: [Runner] -> Runner -- ^ a group of runs+ RBenchmark :: G.Benchmark -> Runner -- ^ a wrapper around gauge benchmarks+ Runner :: RunnerI -> Runner -- ^ a single run+ RunnerGroup :: [Runner] -> Runner -- ^ a group of runs -- | Convenience boilerplate functions, simply avoiding a lens dependency using :: Runner -> (Runner -> Runner) -> Runner using = flip ($)+{-# INLINE using #-} -- | Set the runner function runner :: (Show c, NFData c) =>@@ -93,6 +94,7 @@ runner r' (Runner r@RunnerI{..}) = Runner $ r{runI = toRun r'} runner r' (RunnerGroup rs) = RunnerGroup $ runner r' <$> rs runner _ x = x+{-# INLINE runner #-} toRun :: (Show c, NFData c) => (forall a. U.Provable a => U.SMTConfig -> a -> IO c)@@ -104,12 +106,15 @@ -- curry with a config, then change the runner function from (a -> IO c), to -- (Problem -> IO c) where helper (Problem a) = f c a+{-# INLINE toRun #-} onConfig :: (U.SMTConfig -> U.SMTConfig) -> RunnerI -> RunnerI onConfig f r@RunnerI{..} = r{config = f config}+{-# INLINE onConfig #-} onDesc :: (String -> String) -> RunnerI -> RunnerI onDesc f r@RunnerI{..} = r{description = f description}+{-# INLINE onDesc #-} onProblem :: (forall a. a -> a) -> RunnerI -> RunnerI onProblem f r@RunnerI{..} = r{problem = (helper problem)}@@ -118,14 +123,15 @@ -- rmap for profunctor land helper :: Problem -> Problem helper (Problem p) = Problem $ f p+{-# INLINE onProblem #-} -- | Filepath to /dev/null devNull :: FilePath-#ifndef WINDOWS-devNull = "/dev/null"-#else+#ifdef mingw32_HOST_OS devNull = "NUL"+#else+devNull = "/dev/null" #endif -- | to bench a solver without interfacing through SBV we call transcript to@@ -139,7 +145,9 @@ _ <- P.waitForProcess ph return ()) where command = U.mkExecString slvr fname+{-# INLINE runStandaloneSolver #-} + -- | Given a file name, a solver config, and a problem to solve, create an -- environment for the gauge benchmark by generating a transcript file standaloneEnv :: RunnerI -> IO FilePath -> IO BenchUnit@@ -150,11 +158,13 @@ let fPath = mconcat [pwd,"/",file] _ <- runI config{U.transcript = Just fPath} p >> return () return (config,fPath)+{-# INLINE standaloneEnv #-} -- | Cleanup the environment created by gauge by removing the transcript file -- used to run the standalone solver standaloneCleanup :: BenchUnit -> IO () standaloneCleanup (_,fPath) = P.callCommand $ "rm " ++ fPath+{-# INLINE standaloneCleanup #-} -- | To construct a benchmark to test SBV's overhead we setup an environment -- with gauge where a symbolic computation is emitted to a transcript file.@@ -165,37 +175,40 @@ -- like to benchmark with something other than 'Data.SBV.z3' and so that we can -- benchmark all solving variants, e.g., 'Data.SBV.proveWith', -- 'Data.SBV.satWith', 'Data.SBV.allProveWith' etc.-mkOverheadBenchMark' :: RunnerI -> Benchmark+mkOverheadBenchMark' :: RunnerI -> G.Benchmark mkOverheadBenchMark' r@RunnerI{..} =- envWithCleanup+ G.envWithCleanup (standaloneEnv r U.mkFileName) standaloneCleanup $ \ ~unit ->- bgroup description [ bench "standalone" $ nfIO $ runStandaloneSolver unit- -- notice for sbv benchmark; we pull the solver out of unit and- -- use the input problem not the transcript in the unit- , bench "sbv" $ nfIO $ runI (fst unit) problem- ]--runOverheadBenchMark :: Runner -> Benchmark-runOverheadBenchMark (Runner r@RunnerI{..}) = mkOverheadBenchMark' r-runOverheadBenchMark (RunnerGroup rs) = bgroup "" $ -- leave the description close to the benchmark/problem definition- runOverheadBenchMark <$> rs-runOverheadBenchMark (RBenchmark b) = b+ G.bgroup description [ G.bench "standalone" $! G.nfIO $ runStandaloneSolver unit+ -- notice for sbv benchmark; we pull the solver out of unit and+ -- use the input problem not the transcript in the unit+ , G.bench "sbv" $! G.nfIO $ runI (fst unit) problem+ ]+{-# INLINE mkOverheadBenchMark' #-} +runOverheadBenchmark :: Runner -> G.Benchmark+runOverheadBenchmark (Runner r@RunnerI{..}) = mkOverheadBenchMark' r+runOverheadBenchmark (RunnerGroup rs) = G.bgroup "" $ -- leave the description close to the benchmark/problem definition+ runOverheadBenchmark <$> rs+runOverheadBenchmark (RBenchmark b) = b+{-# INLINE runOverheadBenchmark #-} --- | make a normal benchmark without the overhead comparision. Notice this is+-- | make a normal benchmark without the overhead comparison. Notice this is -- just unpacking the Runner record-mkBenchMark :: RunnerI -> Benchmark-mkBenchMark RunnerI{..} = bgroup description [bench "" . nfIO $! runI config problem]+mkBenchmark :: RunnerI -> G.Benchmark+mkBenchmark RunnerI{..} = G.bench description . G.nfIO $! runI config problem+{-# INLINE mkBenchmark #-} -- | Convert a Runner or a group of Runners to Benchmarks, this is an api level -- function to convert the runners defined in each file to benchmarks which can -- be run by gauge-runBenchMark :: Runner -> Benchmark-runBenchMark (Runner r@RunnerI{..}) = mkBenchMark r-runBenchMark (RunnerGroup rs) = bgroup "" $ runBenchMark <$> rs-runBenchMark (RBenchmark b) = b+runBenchmark :: Runner -> G.Benchmark+runBenchmark (Runner r@RunnerI{..}) = mkBenchmark r+runBenchmark (RunnerGroup rs) = G.bgroup "" $ runBenchmark <$> rs+runBenchmark (RBenchmark b) = b+{-# INLINE runBenchmark #-} -- | This is just a wrapper around the RunnerI constructor and serves as the main -- entry point to make a runner for a user in case they need something custom.@@ -207,41 +220,48 @@ -> Runner run' r config description problem = Runner $ RunnerI{..} where runI = toRun r+{-# INLINE run' #-} -- | Convenience function for creating benchmarks that exposes a configuration runWith :: U.Provable a => U.SMTConfig -> String -> a -> Runner runWith c d p = run' U.satWith c d (Problem p)+{-# INLINE runWith #-} -- | Main entry point for simple benchmarks. See 'mkRunner'' or 'mkRunnerWith' -- for versions of this function that allows custom inputs. If you have some use -- case that is not considered then you can simply overload the record fields. run :: U.Provable a => String -> a -> Runner run d p = runWith U.z3 d p `using` runner U.satWith+{-# INLINE run #-} -- | Entry point for problems that return IO or to benchmark IO results-runIOWith :: NFData a => (a -> Benchmarkable) -> String -> a -> Runner-runIOWith f d = RBenchmark . bench d . f+runIOWith :: NFData a => (a -> G.Benchmarkable) -> String -> a -> Runner+runIOWith f d = RBenchmark . G.bench d . f+{-# INLINE runIOWith #-} -- | Benchmark an IO result of sbv, this could be codegen, return models, etc.. -- See @runIOWith@ for a version which allows the consumer to select the -- Benchmarkable injection function runIO :: NFData a => String -> IO a -> Runner-runIO d = RBenchmark . bench d . nfIO . silence+runIO d = RBenchmark . G.bench d . G.nfIO . silence+{-# INLINE runIO #-} -- | Benchmark an pure result runPure :: NFData a => String -> (a -> b) -> a -> Runner-runPure d = (RBenchmark . bench d) .: whnf+runPure d = (RBenchmark . G.bench d) .: G.whnf where (.:) = (.).(.)+{-# INLINE runPure #-} -- | create a runner group. Useful for benchmarks that need to run several -- benchmarks. See 'BenchSuite.Puzzles.NQueens' for an example. rGroup :: [Runner] -> Runner rGroup = RunnerGroup+{-# INLINE rGroup #-} -- | Orphaned instances just for benchmarking instance NFData U.AllSatResult where- rnf (U.AllSatResult (a, b, c, results)) =- rnf a `seq` rnf b `seq` rnf c `seq` rwhnf results+ rnf (U.AllSatResult a b c d results) =+ rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rwhnf results -- | Unwrap the existential type to make gauge happy instance NFData BenchResult where rnf (BenchResult a) = rnf a
SBVBenchSuite/BenchSuite/BitPrecise/BrokenSearch.hs view
@@ -22,7 +22,7 @@ -- benchmark suite benchmarks :: Runner benchmarks = rGroup- [ B.run "Arith.MidPointFixed" (checkCorrect midPointFixed) `using` runner Data.SBV.proveWith+ [ B.run "Arith.MidPointFixed" (checkCorrect midPointFixed) `using` runner Data.SBV.proveWith , B.run "Arith-Overflow" (checkCorrect midPointAlternative) `using` runner Data.SBV.proveWith ]
SBVBenchSuite/BenchSuite/BitPrecise/MergeSort.hs view
@@ -22,12 +22,10 @@ -- benchmark suite benchmarks :: Runner benchmarks = rGroup- [ B.run "Correctness.MergeSort 10" (correctness' 10) `using` runner Data.SBV.proveWith- , B.run "Correctness.MergeSort 100" (correctness' 100) `using` runner Data.SBV.proveWith- , B.run "Correctness.MergeSort 1000" (correctness' 1000) `using` runner Data.SBV.proveWith- , B.runIO "CodeGen.MergeSort 10" $ codeGen 10- , B.runIO "CodeGen.MergeSort 100" $ codeGen 100- , B.runIO "CodeGen.MergeSort 1000" $ codeGen 1000+ [ B.run "Correctness.MergeSort 3" (correctness' 3) `using` runner Data.SBV.proveWith+ , B.run "Correctness.MergeSort 4" (correctness' 4) `using` runner Data.SBV.proveWith+ , B.runIO "CodeGen.MergeSort 3" $ codeGen 3+ , B.runIO "CodeGen.MergeSort 4" $ codeGen 4 ] where correctness' n = do xs <- mkFreeVars n let ys = mergeSort xs
SBVBenchSuite/BenchSuite/Lists/BoundedMutex.hs view
@@ -22,9 +22,9 @@ benchmarks :: Runner benchmarks = rGroup [ runIO "CheckMutex.1" $ checkMutex 1- , runIO "CheckMutex.10" $ checkMutex 10- , runIO "CheckMutex.20" $ checkMutex 20+ , runIO "CheckMutex.3" $ checkMutex 3+ , runIO "CheckMutex.5" $ checkMutex 5 , runIO "NotFair.1" $ notFair 1- , runIO "NotFair.10" $ notFair 10- , runIO "NotFair.20" $ notFair 20+ , runIO "NotFair.3" $ notFair 3+ , runIO "NotFair.5" $ notFair 5 ]
SBVBenchSuite/BenchSuite/Misc/SoftConstrain.hs view
@@ -22,7 +22,7 @@ -- benchmark suite benchmarks :: Runner-benchmarks = run "SoftConstrain" softC+benchmarks = rGroup [ run "SoftConstrain" softC ] where softC = do x <- sString "x" y <- sString "y"
SBVBenchSuite/BenchSuite/Misc/Tuple.hs view
@@ -21,4 +21,4 @@ -- benchmark suite benchmarks :: Runner-benchmarks = runIO "Tuple" example+benchmarks = rGroup [ runIO "Tuple" example ]
SBVBenchSuite/BenchSuite/Optimization/ExtField.hs view
@@ -23,4 +23,6 @@ -- benchmark suite benchmarks :: Runner-benchmarks = run "ExtField.problem" problem `using` runner (flip optimizeWith Lexicographic)+benchmarks = rGroup+ [ run "ExtField.problem" problem `using` runner (flip optimizeWith Lexicographic)+ ]
SBVBenchSuite/BenchSuite/ProofTools/BMC.hs view
@@ -22,8 +22,8 @@ -- benchmark suite benchmarks :: Runner benchmarks = rGroup- [ runIO "ex1" ex1- , runIO "ex2" ex2+ [ runIO "BMC.ex1" ex1+ , runIO "BMC.ex2" ex2 ]
SBVBenchSuite/BenchSuite/ProofTools/Fibonacci.hs view
@@ -23,7 +23,7 @@ -- benchmark suite benchmarks :: Runner-benchmarks = runIO "Correctness" fibCorrect+benchmarks = runIO "Fibonacci.Correctness" fibCorrect instance NFData a => NFData (S a) where rnf a = seq a ()
SBVBenchSuite/BenchSuite/ProofTools/Strengthen.hs view
@@ -24,12 +24,12 @@ -- benchmark suite benchmarks :: Runner benchmarks = rGroup- [ runIO "ex1" ex1- , runIO "ex2" ex2- , runIO "ex3" ex3- , runIO "ex4" ex4- , runIO "ex5" ex5- , runIO "ex6" ex6+ [ runIO "Strengthen.ex1" ex1+ , runIO "Strengthen.ex2" ex2+ , runIO "Strengthen.ex3" ex3+ , runIO "Strengthen.ex4" ex4+ , runIO "Strengthen.ex5" ex5+ , runIO "Strengthen.ex6" ex6 ] instance NFData a => NFData (S a) where rnf a = seq a ()
SBVBenchSuite/BenchSuite/ProofTools/Sum.hs view
@@ -23,7 +23,7 @@ -- benchmark suite benchmarks :: Runner-benchmarks = runIO "Correctness" sumCorrect+benchmarks = runIO "Sum.Correctness" sumCorrect instance NFData a => NFData (S a) instance NFData a => NFData (InductionResult a) where rnf a = seq a ()
SBVBenchSuite/BenchSuite/Puzzles/Birthday.hs view
@@ -22,4 +22,6 @@ -- benchmark suite benchmarks :: Runner-benchmarks = S.run "Birthday" puzzle `using` runner allSatWith+benchmarks = rGroup+ [ S.run "Birthday" puzzle `using` runner allSatWith+ ]
SBVBenchSuite/BenchSuite/Puzzles/Coins.hs view
@@ -22,13 +22,13 @@ -- benchmark suite benchmarks :: Runner-benchmarks = S.run "Coins" coinsPgm+benchmarks = rGroup [ S.run "Coins" coinsPgm ] where coinsPgm = do cs <- mapM mkCoin [1..6] mapM_ constrain [c s | s <- combinations cs, length s >= 2, c <- [c1, c2, c3, c4, c5, c6]] constrain $ sAnd $ zipWith (.>=) cs (tail cs) -- normally we would call output here, but returning -- several outputs from a symbolic computation doesn't- -- play nice with either the transcript generation or the benchmarking apparantly+ -- play nice with either the transcript generation or the benchmarking apparently -- output $ sum cs .== 115
SBVBenchSuite/BenchSuite/Puzzles/Counts.hs view
@@ -22,6 +22,6 @@ -- benchmark suite benchmarks :: Runner-benchmarks = S.run "Counts" countPgm `using` runner allSatWith- where countPgm = forAll_ puzzle' >>= return -- avoiding 'output' here again- puzzle' d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 = puzzle [d0, d1, d2, d3, d4, d5, d6, d7, d8, d9]+benchmarks = rGroup [ S.run "Counts" countPgm ]+ where countPgm = puzzle `fmap` mkExistVars 10+ -- puzzle' d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 = puzzle [d0, d1, d2, d3, d4, d5, d6, d7, d8, d9]
SBVBenchSuite/BenchSuite/Puzzles/DogCatMouse.hs view
@@ -20,7 +20,7 @@ -- benchmark suite benchmarks :: Runner-benchmarks = S.run "DogCatMouse" p `using` runner allSatWith+benchmarks = rGroup [ S.run "DogCatMouse" p `using` runner allSatWith ] where p = do [dog, cat, mouse] <- sIntegers ["dog", "cat", "mouse"] solve [ dog .>= 1 -- at least one dog , cat .>= 1 -- at least one cat
SBVBenchSuite/BenchSuite/Puzzles/Euler185.hs view
@@ -22,4 +22,4 @@ -- benchmark suite benchmarks :: Runner-benchmarks = S.run "Euler185" euler185 `using` runner allSatWith+benchmarks = rGroup [ S.run "Euler185" euler185 `using` runner satWith ]
SBVBenchSuite/BenchSuite/Puzzles/Garden.hs view
@@ -24,5 +24,5 @@ -- benchmark suite benchmarks :: Runner-benchmarks = S.runWith s "Garden" puzzle `using` runner allSatWith+benchmarks = rGroup [ S.runWith s "Garden" puzzle `using` runner allSatWith ] where s = z3{satTrackUFs = False, isNonModelVar = ("_modelIgnore" `isSuffixOf`)}
SBVBenchSuite/BenchSuite/Puzzles/LadyAndTigers.hs view
@@ -21,7 +21,7 @@ -- benchmark suite benchmarks :: Runner-benchmarks = S.run "Puzzles.LadyAndTigers" p `using` runner allSatWith+benchmarks = rGroup [ S.run "LadyAndTigers" p `using` runner allSatWith ] where p = do -- One boolean for each of the correctness of the signs
SBVBenchSuite/BenchSuite/Puzzles/SendMoreMoney.hs view
@@ -21,7 +21,7 @@ -- benchmark suite benchmarks :: Runner-benchmarks = S.run "Puzzles.SendMoreMoney" p `using` runner allSatWith+benchmarks = rGroup [ S.run "Puzzles.SendMoreMoney" p `using` runner allSatWith ] where p = do ds@[s,e,n,d,m,o,r,y] <- mapM sInteger ["s", "e", "n", "d", "m", "o", "r", "y"] let isDigit x = x .>= 0 .&& x .<= 9
SBVBenchSuite/BenchSuite/Puzzles/Sudoku.hs view
@@ -23,7 +23,7 @@ -- benchmark suite benchmarks :: Runner benchmarks = rGroup- [ S.run ("sudoku " ++ show n) (checkPuzzle s) `using` runner allSatWith+ [ S.run ("sudoku " ++ show n) (checkPuzzle s) `using` runner satWith | (n, s) <- zip [(0::Int)..]
SBVBenchSuite/BenchSuite/Puzzles/U2Bridge.hs view
@@ -23,11 +23,11 @@ -- benchmark suite benchmarks :: Runner benchmarks = rGroup- [ S.run "U2Bridge_cnt1" (count 1) `using` runner allSatWith- , S.run "U2Bridge_cnt2" (count 2) `using` runner allSatWith- , S.run "U2Bridge_cnt3" (count 3) `using` runner allSatWith- , S.run "U2Bridge_cnt4" (count 4) `using` runner allSatWith- , S.run "U2Bridge_cnt6" (count 6) `using` runner allSatWith+ [ S.run "U2Bridge_cnt1" (count 1) `using` runner satWith+ , S.run "U2Bridge_cnt2" (count 2) `using` runner satWith+ , S.run "U2Bridge_cnt3" (count 3) `using` runner satWith+ , S.run "U2Bridge_cnt4" (count 4) `using` runner satWith+ , S.run "U2Bridge_cnt6" (count 6) `using` runner satWith ] where act = do b <- exists_; p1 <- exists_; p2 <- exists_; return (b, p1, p2)
SBVBenchSuite/BenchSuite/Strings/SQLInjection.hs view
@@ -21,4 +21,6 @@ -- benchmark suite benchmarks :: Runner-benchmarks = runIO "FindInjection" $ ("'; DROP TABLE 'users" `Data.List.isSuffixOf`) <$> findInjection exampleProgram+benchmarks = rGroup+ [ runIO "FindInjection" $ ("'; DROP TABLE 'users" `Data.List.isSuffixOf`) <$> findInjection exampleProgram+ ]
SBVBenchSuite/BenchSuite/Uninterpreted/UISortAllSat.hs view
@@ -20,4 +20,6 @@ import BenchSuite.Bench.Bench benchmarks :: Runner-benchmarks = run "genLs" genLs `using` runner allSatWith -- could be expensive+benchmarks = rGroup+ [ run "genLs" genLs `using` runner allSatWith -- could be expensive+ ]
SBVBenchSuite/BenchSuite/WeakestPreconditions/Basics.hs view
@@ -28,11 +28,11 @@ benchmarks :: Runner benchmarks = rGroup- [ runIO "Correctness.Basics skip" (correctness Skip Skip)- , runIO "Correctness.Basics y+1" (correctness Skip $ Assign $ \st@IncS{y} -> st{y = y+1})- , runIO "Correctness.Basics x>0" $ correctness (assert "x > 0" (\st@IncS{x} -> x .> 0)) Skip- , runIO "Correctness.Basics x>-5" $ correctness (assert "x > -5" (\st@IncS{x} -> x .> -5)) Skip- , runIO "Correctness.Basics y is even" $ correctness Skip (assert "y is even" (\st@IncS{y} -> y `sMod` 2 .== 0))- , runIO "Correctness.Basics y > x" $ correctness Skip (assert "y > x" (\st@IncS{x, y} -> y .> x))+ [ runIO "Correctness.Basics skip" $ correctness Skip Skip+ , runIO "Correctness.Basics y+1" $ correctness Skip $ Assign $ \st@IncS{y} -> st{y = y+1}+ , runIO "Correctness.Basics x>0" $ correctness (assert "x > 0" (\IncS{x} -> x .> 0)) Skip+ , runIO "Correctness.Basics x>-5" $ correctness (assert "x > -5" (\IncS{x} -> x .> -5)) Skip+ , runIO "Correctness.Basics y is even" $ correctness Skip (assert "y is even" (\IncS{y} -> y `sMod` 2 .== 0))+ , runIO "Correctness.Basics y > x" $ correctness Skip (assert "y > x" (\IncS{x, y} -> y .> x)) , runIO "Correctness.Basics skip-assign" $ correctness Skip (Assign $ \st -> st{x = 10, y = 11}) ]
SBVBenchSuite/SBVBench.hs view
@@ -7,301 +7,54 @@ -- Maintainer: erkokl@gmail.com -- Stability : experimental ----- Main entry point to the bench suite.+-- We define this entry point to the benchsuite for use in fine-tuning SBV's+-- performance. It may be the case that a user wants to benchmark only one+-- particular feature or aspect of SBV and this entry point facilitates such a+-- "deep dive". ----------------------------------------------------------------------------- module Main where -import Gauge.Main import Gauge.Main.Options (defaultConfig, Config(..)) -import Utils.SBVBenchFramework--import BenchSuite.Bench.Bench---- | Puzzles-import qualified BenchSuite.Puzzles.Birthday-import qualified BenchSuite.Puzzles.Coins-import qualified BenchSuite.Puzzles.Counts-import qualified BenchSuite.Puzzles.DogCatMouse-import qualified BenchSuite.Puzzles.Euler185-import qualified BenchSuite.Puzzles.Garden-import qualified BenchSuite.Puzzles.LadyAndTigers-import qualified BenchSuite.Puzzles.MagicSquare-import qualified BenchSuite.Puzzles.NQueens-import qualified BenchSuite.Puzzles.SendMoreMoney-import qualified BenchSuite.Puzzles.Sudoku-import qualified BenchSuite.Puzzles.U2Bridge---- | BitPrecise-import qualified BenchSuite.BitPrecise.BitTricks-import qualified BenchSuite.BitPrecise.BrokenSearch-import qualified BenchSuite.BitPrecise.Legato-import qualified BenchSuite.BitPrecise.MergeSort-import qualified BenchSuite.BitPrecise.MultMask-import qualified BenchSuite.BitPrecise.PrefixSum---- | Queries-import qualified BenchSuite.Queries.AllSat-import qualified BenchSuite.Queries.CaseSplit-import qualified BenchSuite.Queries.Concurrency-import qualified BenchSuite.Queries.Enums-import qualified BenchSuite.Queries.FourFours-import qualified BenchSuite.Queries.GuessNumber-import qualified BenchSuite.Queries.Interpolants-import qualified BenchSuite.Queries.UnsatCore---- | Weakest Preconditions-import qualified BenchSuite.WeakestPreconditions.Append-import qualified BenchSuite.WeakestPreconditions.Basics-import qualified BenchSuite.WeakestPreconditions.Fib-import qualified BenchSuite.WeakestPreconditions.GCD-import qualified BenchSuite.WeakestPreconditions.IntDiv-import qualified BenchSuite.WeakestPreconditions.IntSqrt-import qualified BenchSuite.WeakestPreconditions.Length-import qualified BenchSuite.WeakestPreconditions.Sum---- | Optimization-import qualified BenchSuite.Optimization.Enumerate-import qualified BenchSuite.Optimization.ExtField-import qualified BenchSuite.Optimization.LinearOpt-import qualified BenchSuite.Optimization.Production-import qualified BenchSuite.Optimization.VM---- | Uninterpreted-import qualified BenchSuite.Uninterpreted.AUF-import qualified BenchSuite.Uninterpreted.Deduce-import qualified BenchSuite.Uninterpreted.Function-import qualified BenchSuite.Uninterpreted.Multiply-import qualified BenchSuite.Uninterpreted.Shannon-import qualified BenchSuite.Uninterpreted.Sort-import qualified BenchSuite.Uninterpreted.UISortAllSat---- | Proof Tools-import qualified BenchSuite.ProofTools.BMC-import qualified BenchSuite.ProofTools.Fibonacci-import qualified BenchSuite.ProofTools.Strengthen-import qualified BenchSuite.ProofTools.Sum---- | Code Generation-import qualified BenchSuite.CodeGeneration.AddSub-import qualified BenchSuite.CodeGeneration.CRC_USB5-import qualified BenchSuite.CodeGeneration.Fibonacci-import qualified BenchSuite.CodeGeneration.GCD-import qualified BenchSuite.CodeGeneration.PopulationCount-import qualified BenchSuite.CodeGeneration.Uninterpreted---- | Crypto-import qualified BenchSuite.Crypto.AES-import qualified BenchSuite.Crypto.RC4-import qualified BenchSuite.Crypto.SHA---- | Miscellaneous-import qualified BenchSuite.Misc.Auxiliary-import qualified BenchSuite.Misc.Enumerate-import qualified BenchSuite.Misc.Floating-import qualified BenchSuite.Misc.ModelExtract-import qualified BenchSuite.Misc.Newtypes-import qualified BenchSuite.Misc.NoDiv0-import qualified BenchSuite.Misc.Polynomials-import qualified BenchSuite.Misc.SetAlgebra-import qualified BenchSuite.Misc.SoftConstrain-import qualified BenchSuite.Misc.Tuple---- | Lists-import qualified BenchSuite.Lists.BoundedMutex-import qualified BenchSuite.Lists.Fibonacci-import qualified BenchSuite.Lists.Nested---- | Strings-import qualified BenchSuite.Strings.RegexCrossword-import qualified BenchSuite.Strings.SQLInjection---- | Existentials-import qualified BenchSuite.Existentials.CRCPolynomial-import qualified BenchSuite.Existentials.Diophantine---- | Transformers-import qualified BenchSuite.Transformers.SymbolicEval+-- import Utils.SBVBenchFramework +import Documentation.SBV.Examples.Puzzles.Counts -- | Custom config to limit benchmarks to 5 minutes of runtime. This is required -- because we can easily generate benchmarks that take a lot of wall time to -- solve, especially with 'Data.SBV.allSatWith' calls benchConfig :: Config-benchConfig = defaultConfig {timeLimit = Just 300.00}---- The bench harness-main :: IO ()-main = defaultMainWith benchConfig $- [ puzzles- , bitPrecise- , queries- , weakestPreconditions- , optimizations- , uninterpreted- , proofTools- , codeGeneration- , crypto- , misc- , lists- , strings- , transformers- ]---- | Benchmarks for 'Documentation.SBV.Examples.Puzzles'. Each benchmark file--- defines a 'benchmarks' function which returns a--- 'BenchSuite.Bench.Bench.Runner'. We want to allow benchmarks to be defined as--- closely as possible to the problems being solved. But for practical reasons--- we may desire to prevent benchmarking 'Data.SBV.allSat' calls because they--- could timeout. Thus by using 'BenchSuite.Bench.Bench.Runner' we can define--- the benchmark mirroring the logic of the symbolic program and change solver--- details _without_ redefining the benchmark, as I have done below by--- converting all examples to use 'Data.SBV.satWith'. For benchmarks which do--- not need to run with different solver configurations, such as queries we run--- with `BenchSuite.Bench.Bench.Runner.runIO`-puzzles :: Benchmark-puzzles = bgroup "Puzzles" $ runBenchMark <$>- [ BenchSuite.Puzzles.Coins.benchmarks- , BenchSuite.Puzzles.Counts.benchmarks- , BenchSuite.Puzzles.Birthday.benchmarks- , BenchSuite.Puzzles.DogCatMouse.benchmarks- , BenchSuite.Puzzles.Euler185.benchmarks- , BenchSuite.Puzzles.Garden.benchmarks- , BenchSuite.Puzzles.LadyAndTigers.benchmarks- , BenchSuite.Puzzles.SendMoreMoney.benchmarks- , BenchSuite.Puzzles.NQueens.benchmarks- , BenchSuite.Puzzles.MagicSquare.benchmarks- , BenchSuite.Puzzles.Sudoku.benchmarks- , BenchSuite.Puzzles.U2Bridge.benchmarks- ]---bitPrecise :: Benchmark-bitPrecise = bgroup "BitPrecise" $ runBenchMark <$>- [ BenchSuite.BitPrecise.BitTricks.benchmarks- , BenchSuite.BitPrecise.BrokenSearch.benchmarks- , BenchSuite.BitPrecise.Legato.benchmarks- , BenchSuite.BitPrecise.MergeSort.benchmarks- , BenchSuite.BitPrecise.MultMask.benchmarks- , BenchSuite.BitPrecise.PrefixSum.benchmarks- ]---queries :: Benchmark-queries = bgroup "Queries" $ runBenchMark <$>- [ BenchSuite.Queries.AllSat.benchmarks- , BenchSuite.Queries.CaseSplit.benchmarks- , BenchSuite.Queries.Concurrency.benchmarks- , BenchSuite.Queries.Enums.benchmarks- , BenchSuite.Queries.FourFours.benchmarks- , BenchSuite.Queries.GuessNumber.benchmarks- , BenchSuite.Queries.Interpolants.benchmarks- , BenchSuite.Queries.UnsatCore.benchmarks- ]---weakestPreconditions :: Benchmark-weakestPreconditions = bgroup "WeakestPreconditions" $ runBenchMark <$>- [ BenchSuite.WeakestPreconditions.Append.benchmarks- , BenchSuite.WeakestPreconditions.Basics.benchmarks- , BenchSuite.WeakestPreconditions.Fib.benchmarks- , BenchSuite.WeakestPreconditions.GCD.benchmarks- , BenchSuite.WeakestPreconditions.IntDiv.benchmarks- , BenchSuite.WeakestPreconditions.IntSqrt.benchmarks- , BenchSuite.WeakestPreconditions.Length.benchmarks- , BenchSuite.WeakestPreconditions.Sum.benchmarks- ]---optimizations :: Benchmark-optimizations = bgroup "Optimizations" $ runBenchMark <$>- [ BenchSuite.Optimization.Enumerate.benchmarks- , BenchSuite.Optimization.ExtField.benchmarks- , BenchSuite.Optimization.LinearOpt.benchmarks- , BenchSuite.Optimization.Production.benchmarks- , BenchSuite.Optimization.VM.benchmarks- ]---uninterpreted :: Benchmark-uninterpreted = bgroup "Uninterpreted" $ runBenchMark <$>- [ BenchSuite.Uninterpreted.AUF.benchmarks- , BenchSuite.Uninterpreted.Deduce.benchmarks- , BenchSuite.Uninterpreted.Function.benchmarks- , BenchSuite.Uninterpreted.Multiply.benchmarks- , BenchSuite.Uninterpreted.Shannon.benchmarks- , BenchSuite.Uninterpreted.Sort.benchmarks- , BenchSuite.Uninterpreted.UISortAllSat.benchmarks- ]---proofTools :: Benchmark-proofTools = bgroup "ProofTools" $ runBenchMark <$>- [ BenchSuite.ProofTools.BMC.benchmarks- , BenchSuite.ProofTools.Fibonacci.benchmarks- , BenchSuite.ProofTools.Strengthen.benchmarks- , BenchSuite.ProofTools.Sum.benchmarks- ]---codeGeneration :: Benchmark-codeGeneration = bgroup "CodeGeneration" $ runBenchMark <$>- [ BenchSuite.CodeGeneration.AddSub.benchmarks- , BenchSuite.CodeGeneration.CRC_USB5.benchmarks- , BenchSuite.CodeGeneration.Fibonacci.benchmarks- , BenchSuite.CodeGeneration.GCD.benchmarks- , BenchSuite.CodeGeneration.PopulationCount.benchmarks- , BenchSuite.CodeGeneration.Uninterpreted.benchmarks- ]---crypto :: Benchmark-crypto = bgroup "Crypto" $ runBenchMark <$>- [ BenchSuite.Crypto.AES.benchmarks- , BenchSuite.Crypto.RC4.benchmarks- , BenchSuite.Crypto.SHA.benchmarks- ]---misc :: Benchmark-misc = bgroup "Miscellaneous" $ runBenchMark <$>- [ BenchSuite.Misc.Auxiliary.benchmarks- , BenchSuite.Misc.Enumerate.benchmarks- , BenchSuite.Misc.Floating.benchmarks- , BenchSuite.Misc.ModelExtract.benchmarks- , BenchSuite.Misc.Newtypes.benchmarks- , BenchSuite.Misc.NoDiv0.benchmarks- , BenchSuite.Misc.Polynomials.benchmarks- , BenchSuite.Misc.SetAlgebra.benchmarks- , BenchSuite.Misc.SoftConstrain.benchmarks- , BenchSuite.Misc.Tuple.benchmarks- ]---lists :: Benchmark-lists = bgroup "Lists" $ runBenchMark <$>- [ BenchSuite.Lists.BoundedMutex.benchmarks- , BenchSuite.Lists.Fibonacci.benchmarks- , BenchSuite.Lists.Nested.benchmarks- ]+benchConfig = defaultConfig { timeLimit = Just 300.00 } +{-+This is the sister module to SBVBenchmark. Where SBVBenchmark provides the+continuous integration use case this module is reserved for deep dives into+particular aspects of SBV. One might use this entry point to only run a+particular benchmark of interest, or load and run a symbolic program to profile,+generate core code, or anything else. The workflow should be: -strings :: Benchmark-strings = bgroup "Strings" $ runBenchMark <$>- [ BenchSuite.Strings.RegexCrossword.benchmarks- , BenchSuite.Strings.SQLInjection.benchmarks- ]+------------------------------+1. benchmark the code of interest+2. profile the code if you are looking for performance improvements+3. make your changes+4. repeat benchmark and profiling to confirm the effect of your changes+------------------------------ +We recommend using a special file name, e.g., `filename <- benchResultsFile+"mergeableTuning"` to hold the benchmarks so that the before and after results+can be compared in the usual way with BenchShow: `cabal repl SBVBench;+compareBenchMarksCli "SBVBenchSuite/BenchFiles/mergeableTuning.csv"`+-} -existentials :: Benchmark-existentials = bgroup "Existentials" $ runBenchMark <$>- [ BenchSuite.Existentials.CRCPolynomial.benchmarks- , BenchSuite.Existentials.Diophantine.benchmarks- ]+main :: IO ()+main = do+ -- generate the benchmark file name+ -- let f = benchResultsFile "<your-test-name-here>" + -- Your code on interest here+ putStrLn "running"+ counts -transformers :: Benchmark-transformers = bgroup "Transformers" $ runBenchMark <$>- [ BenchSuite.Transformers.SymbolicEval.benchmarks- ]+ -- satisfying the type system+ -- return ()
+ SBVBenchSuite/SBVBenchmark.hs view
@@ -0,0 +1,394 @@+-----------------------------------------------------------------------------+-- |+-- Module : SBVBench+-- Copyright : (c) Jeffrey Young+-- Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Entry point to benchmark SBV. We define this as a separate cabal target so+-- that performance regressions can continue to occur as other fine-tuning+-- happens in parallel+-----------------------------------------------------------------------------++module Main where++import qualified Gauge.Main as G+import Gauge.Main.Options (defaultConfig, Config(..))++import Utils.SBVBenchFramework++import BenchSuite.Bench.Bench++-- Puzzles+import qualified BenchSuite.Puzzles.Birthday+import qualified BenchSuite.Puzzles.Coins+-- import qualified BenchSuite.Puzzles.Counts -- see comment below+import qualified BenchSuite.Puzzles.DogCatMouse+-- import qualified BenchSuite.Puzzles.Euler185+import qualified BenchSuite.Puzzles.Garden+import qualified BenchSuite.Puzzles.LadyAndTigers+import qualified BenchSuite.Puzzles.MagicSquare+import qualified BenchSuite.Puzzles.NQueens+import qualified BenchSuite.Puzzles.SendMoreMoney+import qualified BenchSuite.Puzzles.Sudoku+-- import qualified BenchSuite.Puzzles.U2Bridge++-- BitPrecise+import qualified BenchSuite.BitPrecise.BitTricks+-- import qualified BenchSuite.BitPrecise.BrokenSearch+-- import qualified BenchSuite.BitPrecise.Legato+-- import qualified BenchSuite.BitPrecise.MergeSort+import qualified BenchSuite.BitPrecise.MultMask+-- import qualified BenchSuite.BitPrecise.PrefixSum++-- Queries+import qualified BenchSuite.Queries.AllSat+import qualified BenchSuite.Queries.CaseSplit+-- import qualified BenchSuite.Queries.Concurrency+import qualified BenchSuite.Queries.Enums+import qualified BenchSuite.Queries.FourFours+import qualified BenchSuite.Queries.GuessNumber+import qualified BenchSuite.Queries.Interpolants+import qualified BenchSuite.Queries.UnsatCore++-- Weakest Preconditions+import qualified BenchSuite.WeakestPreconditions.Append+import qualified BenchSuite.WeakestPreconditions.Basics+import qualified BenchSuite.WeakestPreconditions.Fib+import qualified BenchSuite.WeakestPreconditions.GCD+import qualified BenchSuite.WeakestPreconditions.IntDiv+import qualified BenchSuite.WeakestPreconditions.IntSqrt+import qualified BenchSuite.WeakestPreconditions.Length+import qualified BenchSuite.WeakestPreconditions.Sum++-- Optimization+import qualified BenchSuite.Optimization.Enumerate+import qualified BenchSuite.Optimization.ExtField+import qualified BenchSuite.Optimization.LinearOpt+import qualified BenchSuite.Optimization.Production+import qualified BenchSuite.Optimization.VM++-- Uninterpreted+import qualified BenchSuite.Uninterpreted.AUF+import qualified BenchSuite.Uninterpreted.Deduce+import qualified BenchSuite.Uninterpreted.Function+import qualified BenchSuite.Uninterpreted.Multiply+import qualified BenchSuite.Uninterpreted.Shannon+import qualified BenchSuite.Uninterpreted.Sort+import qualified BenchSuite.Uninterpreted.UISortAllSat++-- Proof Tools+import qualified BenchSuite.ProofTools.BMC+import qualified BenchSuite.ProofTools.Fibonacci+import qualified BenchSuite.ProofTools.Strengthen+import qualified BenchSuite.ProofTools.Sum++-- Code Generation+import qualified BenchSuite.CodeGeneration.AddSub+import qualified BenchSuite.CodeGeneration.CRC_USB5+import qualified BenchSuite.CodeGeneration.Fibonacci+import qualified BenchSuite.CodeGeneration.GCD+import qualified BenchSuite.CodeGeneration.PopulationCount+import qualified BenchSuite.CodeGeneration.Uninterpreted++-- Crypto+import qualified BenchSuite.Crypto.AES+import qualified BenchSuite.Crypto.RC4+import qualified BenchSuite.Crypto.SHA++-- Miscellaneous+import qualified BenchSuite.Misc.Auxiliary+import qualified BenchSuite.Misc.Enumerate+-- import qualified BenchSuite.Misc.Floating+import qualified BenchSuite.Misc.ModelExtract+import qualified BenchSuite.Misc.Newtypes+import qualified BenchSuite.Misc.NoDiv0+-- import qualified BenchSuite.Misc.Polynomials+import qualified BenchSuite.Misc.SetAlgebra+import qualified BenchSuite.Misc.SoftConstrain+import qualified BenchSuite.Misc.Tuple++-- Lists+import qualified BenchSuite.Lists.BoundedMutex+import qualified BenchSuite.Lists.Fibonacci+import qualified BenchSuite.Lists.Nested++-- Strings+import qualified BenchSuite.Strings.RegexCrossword+import qualified BenchSuite.Strings.SQLInjection++-- Existentials+import qualified BenchSuite.Existentials.CRCPolynomial+import qualified BenchSuite.Existentials.Diophantine++-- Transformers+import qualified BenchSuite.Transformers.SymbolicEval++-- | Custom config to limit benchmarks to 2 minutes of runtime. This is required+-- because we can easily generate benchmarks that take a lot of wall time to+-- solve, especially with 'Data.SBV.allSatWith' calls+benchConfig :: Config+benchConfig = defaultConfig { timeLimit = Just 1.00 }++{-+To benchmark sbv we require two use cases: For continuous integration we want a+snapshot of all benchmarks at a given point in time and we want to be able to+compare benchmarks over time for performance tuning. For this module we default+to the continuous integration flow, thus 'cabal bench' this will get a timestamp+for the file, e.g., '2020-06-27-15:54:05.447753608-UTC.csv', run the benchmarks+and output the statistics to that file in 'sbv/BenchSuite/BenchFiles\/'. The+workflow for fine grained performance analysis is to run a benchmark, make your+changes, then rerun the benchmark. We analyze these results using the+<http://hackage.haskell.org/package/bench-show-0.3.1 bench-show> package, we+provide a few wrappers to ease the details in Utils.SBVBenchFramework.hs. So to+generate a report call compareBenchmarks <file-before-change>+<file-after-change> for example: > compareBenchmarks+"SBVBenchSuite/BenchResults/2020-07-27-17:04:04.261168259-UTC.csv"+"SBVBenchSuite/BenchResults/2020-07-27-17:23:53.048061816-UTC.csv". If you have+the results already aggregated to a single file then use the ticked versions,+e.g., compareBenchmarks'. To only run one or a few benchmarks we use the+'--match' command from the <https://hackage.haskell.org/package/gauge-0.2.5+gauge> library. For example to run only NQueens you would do the following:+`cabal build SBVBench; ./SBVBench --match=pattern -- 'NQueens'`. Note that+comparisons with benchmarks run on different machines will be spurious so use+your best judgment.+-}+main :: IO ()+main = do+ -- generate the benchmark file name+ f <- benchResultsFile <$> timeStamp++ -- run the benchmarks+ G.defaultMainWith benchConfig {csvFile = Just f} $+ [ puzzles+ , bitPrecise+ -- , queries :TODO queries are not running with overHead+ , weakestPreconditions+ , optimizations+ , uninterpreted+ , proofTools+ -- , codeGeneration :NOTE code generation takes too much time and memory+ -- crypto :NOTE crypto also is too expensive+ , misc+ , lists+ , strings+ , transformers+ ]++-- | Benchmarks for 'Documentation.SBV.Examples.Puzzles'. Each benchmark file+-- defines a 'benchmarks' function which returns a+-- 'BenchSuite.Bench.Bench.Runner'. We want to allow benchmarks to be defined as+-- closely as possible to the problems being solved. But for practical reasons+-- we may desire to prevent benchmarking 'Data.SBV.allSat' calls because they+-- could timeout. Thus by using 'BenchSuite.Bench.Bench.Runner' we can define+-- the benchmark mirroring the logic of the symbolic program and change solver+-- details _without_ redefining the benchmark, as I have done below by+-- converting all examples to use 'Data.SBV.satWith'. For benchmarks which do+-- not need to run with different solver configurations, such as queries we run+-- with `BenchSuite.Bench.Bench.Runner.runIO`++--------------------------- Puzzles ---------------------------------------------+puzzleBenchmarks :: [Runner]+puzzleBenchmarks = [ BenchSuite.Puzzles.Coins.benchmarks+ -- disable Counts for now, there is some issue with the counts function+ -- in a repl it works fine, when compiled it does not terminate+ -- , BenchSuite.Puzzles.Counts.benchmarks+ , BenchSuite.Puzzles.Birthday.benchmarks+ , BenchSuite.Puzzles.DogCatMouse.benchmarks+ -- expensive+ -- , BenchSuite.Puzzles.Euler185.benchmarks+ , BenchSuite.Puzzles.Garden.benchmarks+ , BenchSuite.Puzzles.LadyAndTigers.benchmarks+ , BenchSuite.Puzzles.SendMoreMoney.benchmarks+ , BenchSuite.Puzzles.NQueens.benchmarks+ , BenchSuite.Puzzles.MagicSquare.benchmarks+ , BenchSuite.Puzzles.Sudoku.benchmarks+ -- TODO: sbv finishes cnt3 in 100s but z3 does so in 83 ms,+ -- probably an issue with z3 here ,+ -- BenchSuite.Puzzles.U2Bridge.benchmarks+ ]++-- | We call `runOverheadBenchmark` run the benchmarks with both sbv and z3+-- native on the same program. To construct a benchmark for only sbv one would+-- call `runBenchmark`+puzzles :: Benchmark+puzzles = bgroup "Puzzles" $ runBenchmark <$> puzzleBenchmarks+++--------------------------- BitPrecise ------------------------------------------+bitPreciseBenchmarks :: [Runner]+bitPreciseBenchmarks = [ BenchSuite.BitPrecise.BitTricks.benchmarks+ -- These benchmarks blow the stack :TODO fix them+ -- , BenchSuite.BitPrecise.BrokenSearch.benchmarks+ -- , BenchSuite.BitPrecise.Legato.benchmarks+ -- , BenchSuite.BitPrecise.MergeSort.benchmarks+ , BenchSuite.BitPrecise.MultMask.benchmarks+ -- expensive+ -- , BenchSuite.BitPrecise.PrefixSum.benchmarks+ ]++bitPrecise :: Benchmark+bitPrecise = bgroup "BitPrecise" $ runBenchmark <$> bitPreciseBenchmarks+++--------------------------- Query -----------------------------------------------+queryBenchmarks :: [Runner]+queryBenchmarks = [ BenchSuite.Queries.AllSat.benchmarks+ , BenchSuite.Queries.CaseSplit.benchmarks+ -- The concurrency demo has STM blocking when benchmarking+ -- , BenchSuite.Queries.Concurrency.benchmarks+ , BenchSuite.Queries.Enums.benchmarks+ , BenchSuite.Queries.FourFours.benchmarks+ , BenchSuite.Queries.GuessNumber.benchmarks+ , BenchSuite.Queries.Interpolants.benchmarks+ , BenchSuite.Queries.UnsatCore.benchmarks+ ]++queries :: Benchmark+queries = bgroup "Queries" $ runBenchmark <$> queryBenchmarks+++--------------------------- WeakestPreconditions --------------------------------+weakestPreconditionBenchmarks :: [Runner]+weakestPreconditionBenchmarks =+ [ BenchSuite.WeakestPreconditions.Append.benchmarks+ , BenchSuite.WeakestPreconditions.Basics.benchmarks+ , BenchSuite.WeakestPreconditions.Fib.benchmarks+ , BenchSuite.WeakestPreconditions.GCD.benchmarks+ , BenchSuite.WeakestPreconditions.IntDiv.benchmarks+ , BenchSuite.WeakestPreconditions.IntSqrt.benchmarks+ , BenchSuite.WeakestPreconditions.Length.benchmarks+ , BenchSuite.WeakestPreconditions.Sum.benchmarks+ ]++weakestPreconditions :: Benchmark+weakestPreconditions = bgroup "WeakestPreconditions" $+ runOverheadBenchmark <$> weakestPreconditionBenchmarks+++--------------------------- Optimizations ---------------------------------------+optimizationBenchmarks :: [Runner]+optimizationBenchmarks = [ BenchSuite.Optimization.Enumerate.benchmarks+ , BenchSuite.Optimization.ExtField.benchmarks+ , BenchSuite.Optimization.LinearOpt.benchmarks+ , BenchSuite.Optimization.Production.benchmarks+ , BenchSuite.Optimization.VM.benchmarks+ ]++optimizations :: Benchmark+optimizations = bgroup "Optimizations" $ runBenchmark <$> optimizationBenchmarks+++--------------------------- Uninterpreted ---------------------------------------+uninterpretedBenchmarks :: [Runner]+uninterpretedBenchmarks = [ BenchSuite.Uninterpreted.AUF.benchmarks+ , BenchSuite.Uninterpreted.Deduce.benchmarks+ , BenchSuite.Uninterpreted.Function.benchmarks+ , BenchSuite.Uninterpreted.Multiply.benchmarks+ , BenchSuite.Uninterpreted.Shannon.benchmarks+ , BenchSuite.Uninterpreted.Sort.benchmarks+ , BenchSuite.Uninterpreted.UISortAllSat.benchmarks+ ]++uninterpreted :: Benchmark+uninterpreted = bgroup "Uninterpreted" $ runBenchmark <$> uninterpretedBenchmarks+++--------------------------- ProofTools -----------------------------------------+proofToolBenchmarks :: [Runner]+proofToolBenchmarks = [ BenchSuite.ProofTools.BMC.benchmarks+ , BenchSuite.ProofTools.Fibonacci.benchmarks+ , BenchSuite.ProofTools.Strengthen.benchmarks+ , BenchSuite.ProofTools.Sum.benchmarks+ ]++proofTools :: Benchmark+proofTools = bgroup "ProofTools" $ runBenchmark <$> proofToolBenchmarks+++--------------------------- Code Generation -------------------------------------+codeGenerationBenchmarks :: [Runner]+codeGenerationBenchmarks = [ BenchSuite.CodeGeneration.AddSub.benchmarks+ , BenchSuite.CodeGeneration.CRC_USB5.benchmarks+ , BenchSuite.CodeGeneration.Fibonacci.benchmarks+ , BenchSuite.CodeGeneration.GCD.benchmarks+ , BenchSuite.CodeGeneration.PopulationCount.benchmarks+ , BenchSuite.CodeGeneration.Uninterpreted.benchmarks+ ]++codeGeneration :: Benchmark+codeGeneration = bgroup "CodeGeneration" $+ runBenchmark <$> codeGenerationBenchmarks+++--------------------------- Crypto ----------------------------------------------+cryptoBenchmarks :: [Runner]+cryptoBenchmarks = [ BenchSuite.Crypto.AES.benchmarks+ , BenchSuite.Crypto.RC4.benchmarks+ , BenchSuite.Crypto.SHA.benchmarks+ ]++crypto :: Benchmark+crypto = bgroup "Crypto" $ runBenchmark <$> cryptoBenchmarks+++--------------------------- Miscellaneous ---------------------------------------+miscBenchmarks :: [Runner]+miscBenchmarks = [ BenchSuite.Misc.Auxiliary.benchmarks+ , BenchSuite.Misc.Enumerate.benchmarks+ -- expensive+ -- , BenchSuite.Misc.Floating.benchmarks+ , BenchSuite.Misc.ModelExtract.benchmarks+ , BenchSuite.Misc.Newtypes.benchmarks+ , BenchSuite.Misc.NoDiv0.benchmarks+ -- killed by OS, TODO: Investigate+ -- , BenchSuite.Misc.Polynomials.benchmarks+ , BenchSuite.Misc.SetAlgebra.benchmarks+ , BenchSuite.Misc.SoftConstrain.benchmarks+ , BenchSuite.Misc.Tuple.benchmarks+ ]++misc :: Benchmark+misc = bgroup "Miscellaneous" $ runBenchmark <$> miscBenchmarks+++--------------------------- Lists -----------------------------------------------+listBenchmarks :: [Runner]+listBenchmarks = [ BenchSuite.Lists.BoundedMutex.benchmarks+ , BenchSuite.Lists.Fibonacci.benchmarks+ , BenchSuite.Lists.Nested.benchmarks+ ]++lists :: Benchmark+lists = bgroup "Lists" $ runBenchmark <$> listBenchmarks+++--------------------------- Strings ---------------------------------------------+stringBenchmarks :: [Runner]+stringBenchmarks = [ BenchSuite.Strings.RegexCrossword.benchmarks+ , BenchSuite.Strings.SQLInjection.benchmarks+ ]++strings :: Benchmark+strings = bgroup "Strings" $ runBenchmark <$> stringBenchmarks+++--------------------------- Existentials ----------------------------------------+existentialBenchmarks :: [Runner]+existentialBenchmarks = [ BenchSuite.Existentials.CRCPolynomial.benchmarks+ , BenchSuite.Existentials.Diophantine.benchmarks+ ]++existentials :: Benchmark+existentials = bgroup "Existentials" $ runBenchmark <$> existentialBenchmarks+++--------------------------- Transformers ----------------------------------------+transformerBenchmarks :: [Runner]+transformerBenchmarks = [ BenchSuite.Transformers.SymbolicEval.benchmarks+ ]++transformers :: Benchmark+transformers = bgroup "Transformers" $ runBenchmark <$> transformerBenchmarks
SBVBenchSuite/Utils/SBVBenchFramework.hs view
@@ -10,18 +10,46 @@ -- Various goodies for benchmarking SBV ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+ module Utils.SBVBenchFramework ( mkExecString , mkFileName- , module Gauge.Main+ , Benchmark+ , bgroup , module Data.SBV+ , timeStamp+ , getDate+ , dateStamp+ , benchResultsFile+ , compareBenchmarks+ , compareBenchmarks'+ , compareBenchmarksOvHd+ , compareBenchmarksWith+ , compareBenchmarksWith'+ , classifier+ , overheadClassifier+ , filterOverhead+ , regressionConf+ , overheadConf ) where import qualified Data.List as L import System.Process (showCommandForUser) import System.Random+import Data.Char (isSpace)+import System.FilePath ((</>), (<.>))+import System.FilePath.Posix (takeBaseName)+import System.IO (appendFile, readFile)+import System.Process (callCommand)+import Data.Ord (comparing)+import Data.Time.Clock+import Data.Time.Calendar import Gauge.Main (Benchmark, bgroup)+import qualified BenchShow as BS hiding (verbose) import Data.SBV @@ -41,3 +69,124 @@ mkFileName :: IO String mkFileName = do gen <- newStdGen return . take 32 $ randomRs ('a','z') gen+++-- | Get (year, month, day)+getDate :: IO (Integer, Int, Int)+getDate = toGregorian . utctDay <$> getCurrentTime++dateStamp :: IO String+dateStamp = (\(y,m,d) -> show y ++ "-" +++ show m ++ "-" +++ show d) <$> getDate++-- | Construct a timestamp+timeStamp :: IO String+timeStamp = fmap (spaceTo '-') . show <$> getCurrentTime++spaceTo :: Char -> Char -> Char+spaceTo c x | isSpace x = c+ | otherwise = x++-- | Construct a benchmark file name. The input name should be a time stamp or+-- whatever you want to name the benchmark+benchResultsFile :: FilePath -> FilePath+benchResultsFile nm = "SBVBenchSuite" </> "BenchResults" </> nm <.> "csv"++-- | Run bench-show comparisons given an old-file, a newfile, and a config.+-- Bench show expects comparisons to be in a single file so we construct a file+-- by appending the input files and then remove it after the comparison.+-- bench-show differentiates the runs by a header generated from either @gauge@+-- or @criterion@. See <http://hackage.haskell.org/package/bench-show-0.3.1 bench-show>+-- for more details.+compareBenchmarksWith :: BS.Config -> FilePath -> FilePath -> IO ()+compareBenchmarksWith conf old new = do+ -- make the file name+ let fname = benchResultsFile $ (takeBaseName old) ++ "_vs_" ++ (takeBaseName new)+ -- this is lazy IO !!!+ readFile old >>= appendFile fname+ readFile new >>= appendFile fname+ -- run the report+ BS.report fname Nothing conf+ -- remove the file, this will likely fail on Windows+ callCommand $ "rm " ++ fname++-- | A simple wrapper for a single file case+compareBenchmarksWith' :: BS.Config -> FilePath -> IO ()+compareBenchmarksWith' c fp = BS.report fp Nothing c++compareBenchmarks' :: FilePath -> IO ()+compareBenchmarks' = compareBenchmarksWith' regressionConf++compareBenchmarks :: FilePath -> FilePath -> IO ()+compareBenchmarks = compareBenchmarksWith regressionConf+++compareBenchmarksOvHd :: FilePath -> FilePath -> IO ()+compareBenchmarksOvHd = compareBenchmarksWith overheadConf+++regressionConf :: BS.Config+regressionConf = BS.defaultConfig { BS.presentation = BS.Groups BS.PercentDiff -- report percent difference+ , BS.selectBenchmarks = \f -> -- sort from Improvement - Degradation+ map fst+ $ L.sortBy (comparing snd)+ $ either error id+ $ f (BS.ColumnIndex 1) Nothing+ }+++overheadConf :: BS.Config+overheadConf = BS.defaultConfig { BS.classifyBenchmark = overheadClassifier '/' -- separate groups assuming overhead results+ , BS.presentation = BS.Groups BS.PercentDiff+ , BS.selectBenchmarks = \f ->+ map fst+ $ L.sortBy (comparing snd)+ $ either error id+ $ f (BS.ColumnIndex 1) Nothing+ }+++-- | The classifier takes a line of text and chunks it into (group-name,+-- benchmark-name), for example:+-- >>> classifier '/' "Puzzles//Coins"+-- Just ("Puzzles/","Coins")+--+classifier :: Char -> String -> Maybe (String, String)+classifier e nm = Just $ last $ fmap (\(a,b) -> (a, tail b)) chunks+ where+ is :: [Int]+ is = L.elemIndices e nm++ chunks = fmap (flip L.splitAt nm) is++-- | We live with some code duplication due to the way overhead benchmarks apply+-- the "standalone" and "sbv" labels. By abstracting for overhead benchmarks+-- these labels will be appended to the description string. This is counter to+-- the assumptions of the bench-show package, thus we define a specialty+-- classifier to handle the overhead case+-- >>> overheadClassifier '/' "Puzzles//DogCatMouse/standalone"+-- Just ("standalone","Puzzles//DogCatMouse")+--+overheadClassifier :: Char -> String -> Maybe (String, String)+overheadClassifier e nm = Just $ last $ fmap (\(a,b) -> (tail b, a)) chunks+ where+ is :: [Int]+ is = L.elemIndices e nm++ chunks = fmap (flip L.splitAt nm) is++-- | a helper function to remove benchmarks where the over head benchmark+-- doesn't work or failed for some reason. This will write a filtered version+-- and return the file path to that filtered version.+filterOverhead :: Char -> FilePath -> IO FilePath+filterOverhead e fp = do (header:file) <- L.lines <$> readFile fp+ -- only keep instances of 3 or greater. This number+ -- comes from splitting benchmark output by '/'.+ -- Because our groups are separated by '//' and the+ -- overhead by '/' an overhead run will have >3 splits,+ -- but a normal benchmark will only have two from '//'+ let filteredContent = filter ((>=3) . length . L.elemIndices e) file+ filteredFilePath = (fp ++ "_filtered")+ writeFile filteredFilePath (concat $ header:filteredContent)+ return filteredFilePath
+ SBVTestSuite/GoldFiles/array_caching_01.gold view
@@ -0,0 +1,41 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Int 0)+[GOOD] (define-fun s3 () Int 2)+[GOOD] (define-fun s4 () Int 1)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () Int) ; tracks user variable "x"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s5 () Int (+ s0 s4))+[GOOD] (define-fun s6 () Bool (= s1 s5))+[GOOD] (define-fun s7 () Int (ite s6 s3 s1))+[GOOD] (define-fun s8 () Int (ite s6 s4 s3))+[GOOD] (define-fun s9 () Int (ite s2 s7 s8))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (assert s10)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (- 1)))+*** Solver : Z3+*** Exit code: ExitSuccess++FINAL OUTPUT:+Satisfiable. Model:+ x = -1 :: Integer
+ SBVTestSuite/GoldFiles/array_caching_02.gold view
@@ -0,0 +1,41 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s1 () Int 0)+[GOOD] (define-fun s3 () Int 2)+[GOOD] (define-fun s4 () Int 1)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () Int) ; tracks user variable "x"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s2 () Bool (distinct s0 s1))+[GOOD] (define-fun s5 () Int (+ s0 s4))+[GOOD] (define-fun s6 () Bool (= s1 s5))+[GOOD] (define-fun s7 () Int (ite s6 s4 s3))+[GOOD] (define-fun s8 () Int (ite s6 s3 s1))+[GOOD] (define-fun s9 () Int (ite s2 s7 s8))+[GOOD] (define-fun s10 () Bool (= s4 s9))+[GOOD] (assert s10)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 (- 1)))+*** Solver : Z3+*** Exit code: ExitSuccess++FINAL OUTPUT:+Satisfiable. Model:+ x = -1 :: Integer
+ SBVTestSuite/GoldFiles/constArr2_SArray.gold view
@@ -0,0 +1,73 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () Int 1)+[GOOD] (define-fun s5 () Int 2)+[GOOD] (define-fun s7 () Int 3)+[GOOD] (define-fun s9 () Int 75)+[GOOD] (define-fun s14 () Int 12)+[GOOD] (define-fun s15 () Int 5)+[GOOD] (define-fun s16 () Int 6)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () Int) ; tracks user variable "i"+[GOOD] (declare-fun s1 () Int) ; tracks user variable "j"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] (define-fun array_0 () (Array Int Int) ((as const (Array Int Int)) 2))+[GOOD] (declare-fun array_1 () (Array Int Int))+[GOOD] (define-fun array_1_initializer_0 () Bool (= array_1 (store array_0 s3 s14)))+[GOOD] (declare-fun array_2 () (Array Int Int))+[GOOD] (define-fun array_2_initializer_0 () Bool (= array_2 (store array_1 s5 s15)))+[GOOD] (declare-fun array_3 () (Array Int Int))+[GOOD] (define-fun array_3_initializer_0 () Bool (= array_3 (store array_2 s7 s16)))+[GOOD] (declare-fun array_4 () (Array Int Int))+[GOOD] (define-fun array_4_initializer_0 () Bool (= array_4 (store array_3 s9 s15)))+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s2 () Bool (distinct s0 s1))+[GOOD] (define-fun s4 () Bool (= s0 s3))+[GOOD] (define-fun s6 () Bool (= s0 s5))+[GOOD] (define-fun s8 () Bool (= s0 s7))+[GOOD] (define-fun s10 () Bool (= s0 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (or s6 s11))+[GOOD] (define-fun s13 () Bool (or s4 s12))+[GOOD] (define-fun s17 () Int (select array_4 s0))+[GOOD] (define-fun s18 () Int (select array_4 s1))+[GOOD] (define-fun s19 () Bool (= s17 s18))+[GOOD] (define-fun array_0_initializer () Bool true) ; no initializiation needed+[GOOD] (define-fun array_1_initializer () Bool array_1_initializer_0)+[GOOD] (assert array_1_initializer)+[GOOD] (define-fun array_2_initializer () Bool array_2_initializer_0)+[GOOD] (assert array_2_initializer)+[GOOD] (define-fun array_3_initializer () Bool array_3_initializer_0)+[GOOD] (assert array_3_initializer)+[GOOD] (define-fun array_4_initializer () Bool array_4_initializer_0)+[GOOD] (assert array_4_initializer)+[GOOD] (assert s2)+[GOOD] (assert s13)+[GOOD] (assert s19)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 2))+[SEND] (get-value (s1))+[RECV] ((s1 75))+*** Solver : Z3+*** Exit code: ExitSuccess++FINAL OUTPUT:+Satisfiable. Model:+ i = 2 :: Integer+ j = 75 :: Integer
+ SBVTestSuite/GoldFiles/constArr2_SFunArray.gold view
@@ -0,0 +1,67 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () Int 1)+[GOOD] (define-fun s5 () Int 2)+[GOOD] (define-fun s7 () Int 3)+[GOOD] (define-fun s9 () Int 75)+[GOOD] (define-fun s14 () Int 12)+[GOOD] (define-fun s15 () Int 5)+[GOOD] (define-fun s16 () Int 6)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () Int) ; tracks user variable "i"+[GOOD] (declare-fun s1 () Int) ; tracks user variable "j"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s2 () Bool (distinct s0 s1))+[GOOD] (define-fun s4 () Bool (= s0 s3))+[GOOD] (define-fun s6 () Bool (= s0 s5))+[GOOD] (define-fun s8 () Bool (= s0 s7))+[GOOD] (define-fun s10 () Bool (= s0 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (or s6 s11))+[GOOD] (define-fun s13 () Bool (or s4 s12))+[GOOD] (define-fun s17 () Int (ite s10 s15 s5))+[GOOD] (define-fun s18 () Int (ite s8 s16 s17))+[GOOD] (define-fun s19 () Int (ite s6 s15 s18))+[GOOD] (define-fun s20 () Int (ite s4 s14 s19))+[GOOD] (define-fun s21 () Bool (= s0 s1))+[GOOD] (define-fun s22 () Bool (= s1 s3))+[GOOD] (define-fun s23 () Bool (= s1 s5))+[GOOD] (define-fun s24 () Bool (= s1 s7))+[GOOD] (define-fun s25 () Bool (= s1 s9))+[GOOD] (define-fun s26 () Int (ite s25 s15 s5))+[GOOD] (define-fun s27 () Int (ite s24 s16 s26))+[GOOD] (define-fun s28 () Int (ite s23 s15 s27))+[GOOD] (define-fun s29 () Int (ite s22 s14 s28))+[GOOD] (define-fun s30 () Int (ite s21 s20 s29))+[GOOD] (define-fun s31 () Bool (= s20 s30))+[GOOD] (assert s2)+[GOOD] (assert s13)+[GOOD] (assert s31)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 2))+[SEND] (get-value (s1))+[RECV] ((s1 75))+*** Solver : Z3+*** Exit code: ExitSuccess++FINAL OUTPUT:+Satisfiable. Model:+ i = 2 :: Integer+ j = 75 :: Integer
+ SBVTestSuite/GoldFiles/constArr_SArray.gold view
@@ -0,0 +1,74 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () Int 1)+[GOOD] (define-fun s5 () Int 2)+[GOOD] (define-fun s7 () Int 3)+[GOOD] (define-fun s9 () Int 75)+[GOOD] (define-fun s14 () Int 7)+[GOOD] (define-fun s15 () Int 12)+[GOOD] (define-fun s16 () Int 5)+[GOOD] (define-fun s17 () Int 6)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () Int) ; tracks user variable "i"+[GOOD] (declare-fun s1 () Int) ; tracks user variable "j"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] (define-fun array_0 () (Array Int Int) ((as const (Array Int Int)) 7))+[GOOD] (declare-fun array_1 () (Array Int Int))+[GOOD] (define-fun array_1_initializer_0 () Bool (= array_1 (store array_0 s3 s15)))+[GOOD] (declare-fun array_2 () (Array Int Int))+[GOOD] (define-fun array_2_initializer_0 () Bool (= array_2 (store array_1 s5 s16)))+[GOOD] (declare-fun array_3 () (Array Int Int))+[GOOD] (define-fun array_3_initializer_0 () Bool (= array_3 (store array_2 s7 s17)))+[GOOD] (declare-fun array_4 () (Array Int Int))+[GOOD] (define-fun array_4_initializer_0 () Bool (= array_4 (store array_3 s9 s16)))+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s2 () Bool (distinct s0 s1))+[GOOD] (define-fun s4 () Bool (= s0 s3))+[GOOD] (define-fun s6 () Bool (= s0 s5))+[GOOD] (define-fun s8 () Bool (= s0 s7))+[GOOD] (define-fun s10 () Bool (= s0 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (or s6 s11))+[GOOD] (define-fun s13 () Bool (or s4 s12))+[GOOD] (define-fun s18 () Int (select array_4 s0))+[GOOD] (define-fun s19 () Int (select array_4 s1))+[GOOD] (define-fun s20 () Bool (= s18 s19))+[GOOD] (define-fun array_0_initializer () Bool true) ; no initializiation needed+[GOOD] (define-fun array_1_initializer () Bool array_1_initializer_0)+[GOOD] (assert array_1_initializer)+[GOOD] (define-fun array_2_initializer () Bool array_2_initializer_0)+[GOOD] (assert array_2_initializer)+[GOOD] (define-fun array_3_initializer () Bool array_3_initializer_0)+[GOOD] (assert array_3_initializer)+[GOOD] (define-fun array_4_initializer () Bool array_4_initializer_0)+[GOOD] (assert array_4_initializer)+[GOOD] (assert s2)+[GOOD] (assert s13)+[GOOD] (assert s20)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 2))+[SEND] (get-value (s1))+[RECV] ((s1 75))+*** Solver : Z3+*** Exit code: ExitSuccess++FINAL OUTPUT:+Satisfiable. Model:+ i = 2 :: Integer+ j = 75 :: Integer
+ SBVTestSuite/GoldFiles/constArr_SFunArray.gold view
@@ -0,0 +1,68 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s3 () Int 1)+[GOOD] (define-fun s5 () Int 2)+[GOOD] (define-fun s7 () Int 3)+[GOOD] (define-fun s9 () Int 75)+[GOOD] (define-fun s14 () Int 12)+[GOOD] (define-fun s15 () Int 5)+[GOOD] (define-fun s16 () Int 6)+[GOOD] (define-fun s17 () Int 7)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () Int) ; tracks user variable "i"+[GOOD] (declare-fun s1 () Int) ; tracks user variable "j"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s2 () Bool (distinct s0 s1))+[GOOD] (define-fun s4 () Bool (= s0 s3))+[GOOD] (define-fun s6 () Bool (= s0 s5))+[GOOD] (define-fun s8 () Bool (= s0 s7))+[GOOD] (define-fun s10 () Bool (= s0 s9))+[GOOD] (define-fun s11 () Bool (or s8 s10))+[GOOD] (define-fun s12 () Bool (or s6 s11))+[GOOD] (define-fun s13 () Bool (or s4 s12))+[GOOD] (define-fun s18 () Int (ite s10 s15 s17))+[GOOD] (define-fun s19 () Int (ite s8 s16 s18))+[GOOD] (define-fun s20 () Int (ite s6 s15 s19))+[GOOD] (define-fun s21 () Int (ite s4 s14 s20))+[GOOD] (define-fun s22 () Bool (= s0 s1))+[GOOD] (define-fun s23 () Bool (= s1 s3))+[GOOD] (define-fun s24 () Bool (= s1 s5))+[GOOD] (define-fun s25 () Bool (= s1 s7))+[GOOD] (define-fun s26 () Bool (= s1 s9))+[GOOD] (define-fun s27 () Int (ite s26 s15 s17))+[GOOD] (define-fun s28 () Int (ite s25 s16 s27))+[GOOD] (define-fun s29 () Int (ite s24 s15 s28))+[GOOD] (define-fun s30 () Int (ite s23 s14 s29))+[GOOD] (define-fun s31 () Int (ite s22 s21 s30))+[GOOD] (define-fun s32 () Bool (= s21 s31))+[GOOD] (assert s2)+[GOOD] (assert s13)+[GOOD] (assert s32)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 75))+[SEND] (get-value (s1))+[RECV] ((s1 2))+*** Solver : Z3+*** Exit code: ExitSuccess++FINAL OUTPUT:+Satisfiable. Model:+ i = 75 :: Integer+ j = 2 :: Integer
+ SBVTestSuite/GoldFiles/dsat01.gold view
@@ -0,0 +1,70 @@+** Calling: dReal --in --format smt2+[ISSUE] ; Automatically generated by SBV. Do not edit.+** Skipping heart-beat for the solver DReal+** Backend solver DReal does not support global decls.+** Some incremental calls, such as pop, will be limited.+[ISSUE] (set-option :smtlib2_compliant true)+[ISSUE] (set-option :produce-models true)+[ISSUE] (set-logic ALL) ; has unbounded values, using catch-all.+[ISSUE] ; --- uninterpreted sorts ---+[ISSUE] ; --- tuples ---+[ISSUE] ; --- sums ---+[ISSUE] ; --- literal constants ---+[ISSUE] (define-fun s3 () Real (/ 2.0 1.0))+[ISSUE] (define-fun s5 () Real (/ 5.0 1.0))+[ISSUE] ; --- skolem constants ---+[ISSUE] (declare-fun s0 () Real) ; tracks user variable "a0"+[ISSUE] (declare-fun s1 () Int) ; tracks user variable "i0"+[ISSUE] (declare-fun s2 () Bool) ; tracks user variable "b0"+[ISSUE] ; --- constant tables ---+[ISSUE] ; --- skolemized tables ---+[ISSUE] ; --- arrays ---+[ISSUE] ; --- uninterpreted constants ---+[ISSUE] ; --- user given axioms ---+[ISSUE] ; --- formula ---+[ISSUE] (define-fun s4 () Bool (> s0 s3))+[ISSUE] (define-fun s6 () Bool (<= s0 s5))+[ISSUE] (assert s4)+[ISSUE] (assert s6)+[FIRE] (declare-fun s7 () Real)+[FIRE] (declare-fun s8 () Int)+[FIRE] (declare-fun s9 () Bool)+[FIRE] (define-fun s10 () Real (/ 3.0 1.0))+[FIRE] (define-fun s11 () Bool (> s7 s10))+[FIRE] (assert s11)+[FIRE] (define-fun s12 () Real (/ 12.0 1.0))+[FIRE] (define-fun s13 () Bool (<= s7 s12))+[FIRE] (assert s13)+[SEND] (check-sat)+[RECV] delta-sat+[SEND] (get-option :precision)+[RECV] 0.001+[SEND] (get-value (s0))+[RECV] (+ (s0 (interval (closed (/ 7035748517859557 2251799813685248)) (closed (/ 7038000317673243 2251799813685248))))+ )+[SEND] (get-value (s7))+[RECV] (+ (s7 (interval (closed (/ 7177048956168307 1125899906842624)) (closed (/ 7178174856075149 1125899906842624))))+ )+[SEND] (get-value (s1))+[RECV] (+ (s1 0)+ )+[SEND] (get-value (s8))+[RECV] (+ (s8 0)+ )+[SEND] (get-value (s2))+[RECV] (+ (s2 true)+ )+[SEND] (get-value (s9))+[RECV] (+ (s9 true)+ )+*** Solver : DReal+*** Exit code: ExitSuccess++ FINAL:(Just "0.001",[[7035748517859557 % 2251799813685248, 7038000317673243 % 2251799813685248],[7177048956168307 % 1125899906842624, 7178174856075149 % 1125899906842624]],[RatInterval (ClosedPoint (7035748517859557 % 2251799813685248)) (ClosedPoint (7038000317673243 % 2251799813685248)),RatInterval (ClosedPoint (7177048956168307 % 1125899906842624)) (ClosedPoint (7178174856075149 % 1125899906842624))],[0,0],[True,True])+DONE!
SBVTestSuite/GoldFiles/qUninterp1.gold view
@@ -7,7 +7,10 @@ [GOOD] (set-option :produce-models true) [GOOD] (set-logic ALL) ; has user-defined sorts, using catch-all. [GOOD] ; --- uninterpreted sorts ----[GOOD] (declare-sort L 0) ; N.B. Uninterpreted: L.B: not a nullary constructor+[GOOD] (declare-datatypes ((L 0)) (((A) (B))))+[GOOD] (define-fun L_constrIndex ((x L)) Int+ (ite (= x A) 0 1)+ ) [GOOD] ; --- tuples --- [GOOD] ; --- sums --- [GOOD] ; --- literal constants ---@@ -22,9 +25,9 @@ [SEND] (check-sat) [RECV] sat [SEND] (get-value (s0))-[RECV] ((s0 L!val!0))+[RECV] ((s0 A)) *** Solver : Z3 *** Exit code: ExitSuccess - FINAL:L!val!0+ FINAL:A DONE!
SBVTestSuite/GoldFiles/queryArrays2.gold view
@@ -275,6 +275,8 @@ [GOOD] (define-fun s255 () (_ BitVec 8) #xfe) [GOOD] (define-fun s256 () (_ BitVec 8) #xff) [GOOD] (declare-fun table0 ((_ BitVec 8)) (_ BitVec 8))+[GOOD] (define-fun s257 () (_ BitVec 8) (table0 s0))+[GOOD] (define-fun s258 () Bool (= s0 s257)) [GOOD] (define-fun table0_initializer_0 () Bool (= (table0 #x00) s1)) [GOOD] (define-fun table0_initializer_1 () Bool (= (table0 #x01) s2)) [GOOD] (define-fun table0_initializer_2 () Bool (= (table0 #x02) s3))@@ -533,8 +535,6 @@ [GOOD] (define-fun table0_initializer_255 () Bool (= (table0 #xff) s256)) [GOOD] (define-fun table0_initializer () Bool (and table0_initializer_0 table0_initializer_1 table0_initializer_2 table0_initializer_3 table0_initializer_4 table0_initializer_5 table0_initializer_6 table0_initializer_7 table0_initializer_8 table0_initializer_9 table0_initializer_10 table0_initializer_11 table0_initializer_12 table0_initializer_13 table0_initializer_14 table0_initializer_15 table0_initializer_16 table0_initializer_17 table0_initializer_18 table0_initializer_19 table0_initializer_20 table0_initializer_21 table0_initializer_22 table0_initializer_23 table0_initializer_24 table0_initializer_25 table0_initializer_26 table0_initializer_27 table0_initializer_28 table0_initializer_29 table0_initializer_30 table0_initializer_31 table0_initializer_32 table0_initializer_33 table0_initializer_34 table0_initializer_35 table0_initializer_36 table0_initializer_37 table0_initializer_38 table0_initializer_39 table0_initializer_40 table0_initializer_41 table0_initializer_42 table0_initializer_43 table0_initializer_44 table0_initializer_45 table0_initializer_46 table0_initializer_47 table0_initializer_48 table0_initializer_49 table0_initializer_50 table0_initializer_51 table0_initializer_52 table0_initializer_53 table0_initializer_54 table0_initializer_55 table0_initializer_56 table0_initializer_57 table0_initializer_58 table0_initializer_59 table0_initializer_60 table0_initializer_61 table0_initializer_62 table0_initializer_63 table0_initializer_64 table0_initializer_65 table0_initializer_66 table0_initializer_67 table0_initializer_68 table0_initializer_69 table0_initializer_70 table0_initializer_71 table0_initializer_72 table0_initializer_73 table0_initializer_74 table0_initializer_75 table0_initializer_76 table0_initializer_77 table0_initializer_78 table0_initializer_79 table0_initializer_80 table0_initializer_81 table0_initializer_82 table0_initializer_83 table0_initializer_84 table0_initializer_85 table0_initializer_86 table0_initializer_87 table0_initializer_88 table0_initializer_89 table0_initializer_90 table0_initializer_91 table0_initializer_92 table0_initializer_93 table0_initializer_94 table0_initializer_95 table0_initializer_96 table0_initializer_97 table0_initializer_98 table0_initializer_99 table0_initializer_100 table0_initializer_101 table0_initializer_102 table0_initializer_103 table0_initializer_104 table0_initializer_105 table0_initializer_106 table0_initializer_107 table0_initializer_108 table0_initializer_109 table0_initializer_110 table0_initializer_111 table0_initializer_112 table0_initializer_113 table0_initializer_114 table0_initializer_115 table0_initializer_116 table0_initializer_117 table0_initializer_118 table0_initializer_119 table0_initializer_120 table0_initializer_121 table0_initializer_122 table0_initializer_123 table0_initializer_124 table0_initializer_125 table0_initializer_126 table0_initializer_127 table0_initializer_128 table0_initializer_129 table0_initializer_130 table0_initializer_131 table0_initializer_132 table0_initializer_133 table0_initializer_134 table0_initializer_135 table0_initializer_136 table0_initializer_137 table0_initializer_138 table0_initializer_139 table0_initializer_140 table0_initializer_141 table0_initializer_142 table0_initializer_143 table0_initializer_144 table0_initializer_145 table0_initializer_146 table0_initializer_147 table0_initializer_148 table0_initializer_149 table0_initializer_150 table0_initializer_151 table0_initializer_152 table0_initializer_153 table0_initializer_154 table0_initializer_155 table0_initializer_156 table0_initializer_157 table0_initializer_158 table0_initializer_159 table0_initializer_160 table0_initializer_161 table0_initializer_162 table0_initializer_163 table0_initializer_164 table0_initializer_165 table0_initializer_166 table0_initializer_167 table0_initializer_168 table0_initializer_169 table0_initializer_170 table0_initializer_171 table0_initializer_172 table0_initializer_173 table0_initializer_174 table0_initializer_175 table0_initializer_176 table0_initializer_177 table0_initializer_178 table0_initializer_179 table0_initializer_180 table0_initializer_181 table0_initializer_182 table0_initializer_183 table0_initializer_184 table0_initializer_185 table0_initializer_186 table0_initializer_187 table0_initializer_188 table0_initializer_189 table0_initializer_190 table0_initializer_191 table0_initializer_192 table0_initializer_193 table0_initializer_194 table0_initializer_195 table0_initializer_196 table0_initializer_197 table0_initializer_198 table0_initializer_199 table0_initializer_200 table0_initializer_201 table0_initializer_202 table0_initializer_203 table0_initializer_204 table0_initializer_205 table0_initializer_206 table0_initializer_207 table0_initializer_208 table0_initializer_209 table0_initializer_210 table0_initializer_211 table0_initializer_212 table0_initializer_213 table0_initializer_214 table0_initializer_215 table0_initializer_216 table0_initializer_217 table0_initializer_218 table0_initializer_219 table0_initializer_220 table0_initializer_221 table0_initializer_222 table0_initializer_223 table0_initializer_224 table0_initializer_225 table0_initializer_226 table0_initializer_227 table0_initializer_228 table0_initializer_229 table0_initializer_230 table0_initializer_231 table0_initializer_232 table0_initializer_233 table0_initializer_234 table0_initializer_235 table0_initializer_236 table0_initializer_237 table0_initializer_238 table0_initializer_239 table0_initializer_240 table0_initializer_241 table0_initializer_242 table0_initializer_243 table0_initializer_244 table0_initializer_245 table0_initializer_246 table0_initializer_247 table0_initializer_248 table0_initializer_249 table0_initializer_250 table0_initializer_251 table0_initializer_252 table0_initializer_253 table0_initializer_254 table0_initializer_255)) [GOOD] (assert table0_initializer)-[GOOD] (define-fun s257 () (_ BitVec 8) (table0 s0))-[GOOD] (define-fun s258 () Bool (= s0 s257)) [GOOD] (assert s258) [SEND] (check-sat) [RECV] sat
SBVTestSuite/GoldFiles/queryArrays3.gold view
@@ -20,6 +20,8 @@ [GOOD] ; --- formula --- [GOOD] (define-fun s1 () (_ BitVec 8) #x00) [GOOD] (declare-fun table0 ((_ BitVec 8)) (_ BitVec 8))+[GOOD] (define-fun s2 () (_ BitVec 8) (table0 s0))+[GOOD] (define-fun s3 () Bool (= s0 s2)) [GOOD] (define-fun table0_initializer_0 () Bool (= (table0 #x00) s0)) [GOOD] (define-fun table0_initializer_1 () Bool (= (table0 #x01) s0)) [GOOD] (define-fun table0_initializer_2 () Bool (= (table0 #x02) s0))@@ -278,8 +280,6 @@ [GOOD] (define-fun table0_initializer_255 () Bool (= (table0 #xff) s0)) [GOOD] (define-fun table0_initializer () Bool (and table0_initializer_0 table0_initializer_1 table0_initializer_2 table0_initializer_3 table0_initializer_4 table0_initializer_5 table0_initializer_6 table0_initializer_7 table0_initializer_8 table0_initializer_9 table0_initializer_10 table0_initializer_11 table0_initializer_12 table0_initializer_13 table0_initializer_14 table0_initializer_15 table0_initializer_16 table0_initializer_17 table0_initializer_18 table0_initializer_19 table0_initializer_20 table0_initializer_21 table0_initializer_22 table0_initializer_23 table0_initializer_24 table0_initializer_25 table0_initializer_26 table0_initializer_27 table0_initializer_28 table0_initializer_29 table0_initializer_30 table0_initializer_31 table0_initializer_32 table0_initializer_33 table0_initializer_34 table0_initializer_35 table0_initializer_36 table0_initializer_37 table0_initializer_38 table0_initializer_39 table0_initializer_40 table0_initializer_41 table0_initializer_42 table0_initializer_43 table0_initializer_44 table0_initializer_45 table0_initializer_46 table0_initializer_47 table0_initializer_48 table0_initializer_49 table0_initializer_50 table0_initializer_51 table0_initializer_52 table0_initializer_53 table0_initializer_54 table0_initializer_55 table0_initializer_56 table0_initializer_57 table0_initializer_58 table0_initializer_59 table0_initializer_60 table0_initializer_61 table0_initializer_62 table0_initializer_63 table0_initializer_64 table0_initializer_65 table0_initializer_66 table0_initializer_67 table0_initializer_68 table0_initializer_69 table0_initializer_70 table0_initializer_71 table0_initializer_72 table0_initializer_73 table0_initializer_74 table0_initializer_75 table0_initializer_76 table0_initializer_77 table0_initializer_78 table0_initializer_79 table0_initializer_80 table0_initializer_81 table0_initializer_82 table0_initializer_83 table0_initializer_84 table0_initializer_85 table0_initializer_86 table0_initializer_87 table0_initializer_88 table0_initializer_89 table0_initializer_90 table0_initializer_91 table0_initializer_92 table0_initializer_93 table0_initializer_94 table0_initializer_95 table0_initializer_96 table0_initializer_97 table0_initializer_98 table0_initializer_99 table0_initializer_100 table0_initializer_101 table0_initializer_102 table0_initializer_103 table0_initializer_104 table0_initializer_105 table0_initializer_106 table0_initializer_107 table0_initializer_108 table0_initializer_109 table0_initializer_110 table0_initializer_111 table0_initializer_112 table0_initializer_113 table0_initializer_114 table0_initializer_115 table0_initializer_116 table0_initializer_117 table0_initializer_118 table0_initializer_119 table0_initializer_120 table0_initializer_121 table0_initializer_122 table0_initializer_123 table0_initializer_124 table0_initializer_125 table0_initializer_126 table0_initializer_127 table0_initializer_128 table0_initializer_129 table0_initializer_130 table0_initializer_131 table0_initializer_132 table0_initializer_133 table0_initializer_134 table0_initializer_135 table0_initializer_136 table0_initializer_137 table0_initializer_138 table0_initializer_139 table0_initializer_140 table0_initializer_141 table0_initializer_142 table0_initializer_143 table0_initializer_144 table0_initializer_145 table0_initializer_146 table0_initializer_147 table0_initializer_148 table0_initializer_149 table0_initializer_150 table0_initializer_151 table0_initializer_152 table0_initializer_153 table0_initializer_154 table0_initializer_155 table0_initializer_156 table0_initializer_157 table0_initializer_158 table0_initializer_159 table0_initializer_160 table0_initializer_161 table0_initializer_162 table0_initializer_163 table0_initializer_164 table0_initializer_165 table0_initializer_166 table0_initializer_167 table0_initializer_168 table0_initializer_169 table0_initializer_170 table0_initializer_171 table0_initializer_172 table0_initializer_173 table0_initializer_174 table0_initializer_175 table0_initializer_176 table0_initializer_177 table0_initializer_178 table0_initializer_179 table0_initializer_180 table0_initializer_181 table0_initializer_182 table0_initializer_183 table0_initializer_184 table0_initializer_185 table0_initializer_186 table0_initializer_187 table0_initializer_188 table0_initializer_189 table0_initializer_190 table0_initializer_191 table0_initializer_192 table0_initializer_193 table0_initializer_194 table0_initializer_195 table0_initializer_196 table0_initializer_197 table0_initializer_198 table0_initializer_199 table0_initializer_200 table0_initializer_201 table0_initializer_202 table0_initializer_203 table0_initializer_204 table0_initializer_205 table0_initializer_206 table0_initializer_207 table0_initializer_208 table0_initializer_209 table0_initializer_210 table0_initializer_211 table0_initializer_212 table0_initializer_213 table0_initializer_214 table0_initializer_215 table0_initializer_216 table0_initializer_217 table0_initializer_218 table0_initializer_219 table0_initializer_220 table0_initializer_221 table0_initializer_222 table0_initializer_223 table0_initializer_224 table0_initializer_225 table0_initializer_226 table0_initializer_227 table0_initializer_228 table0_initializer_229 table0_initializer_230 table0_initializer_231 table0_initializer_232 table0_initializer_233 table0_initializer_234 table0_initializer_235 table0_initializer_236 table0_initializer_237 table0_initializer_238 table0_initializer_239 table0_initializer_240 table0_initializer_241 table0_initializer_242 table0_initializer_243 table0_initializer_244 table0_initializer_245 table0_initializer_246 table0_initializer_247 table0_initializer_248 table0_initializer_249 table0_initializer_250 table0_initializer_251 table0_initializer_252 table0_initializer_253 table0_initializer_254 table0_initializer_255)) [GOOD] (assert table0_initializer)-[GOOD] (define-fun s2 () (_ BitVec 8) (table0 s0))-[GOOD] (define-fun s3 () Bool (= s0 s2)) [GOOD] (assert s3) [SEND] (check-sat) [RECV] sat
SBVTestSuite/GoldFiles/queryArrays4.gold view
@@ -276,6 +276,8 @@ [GOOD] (define-fun s256 () (_ BitVec 8) #xfe) [GOOD] (define-fun s257 () (_ BitVec 8) #xff) [GOOD] (declare-fun table0 ((_ BitVec 8)) (_ BitVec 8))+[GOOD] (define-fun s258 () (_ BitVec 8) (table0 s0))+[GOOD] (define-fun s259 () Bool (= s0 s258)) [GOOD] (define-fun table0_initializer_0 () Bool (= (table0 #x00) s2)) [GOOD] (define-fun table0_initializer_1 () Bool (= (table0 #x01) s3)) [GOOD] (define-fun table0_initializer_2 () Bool (= (table0 #x02) s4))@@ -534,8 +536,6 @@ [GOOD] (define-fun table0_initializer_255 () Bool (= (table0 #xff) s257)) [GOOD] (define-fun table0_initializer () Bool (and table0_initializer_0 table0_initializer_1 table0_initializer_2 table0_initializer_3 table0_initializer_4 table0_initializer_5 table0_initializer_6 table0_initializer_7 table0_initializer_8 table0_initializer_9 table0_initializer_10 table0_initializer_11 table0_initializer_12 table0_initializer_13 table0_initializer_14 table0_initializer_15 table0_initializer_16 table0_initializer_17 table0_initializer_18 table0_initializer_19 table0_initializer_20 table0_initializer_21 table0_initializer_22 table0_initializer_23 table0_initializer_24 table0_initializer_25 table0_initializer_26 table0_initializer_27 table0_initializer_28 table0_initializer_29 table0_initializer_30 table0_initializer_31 table0_initializer_32 table0_initializer_33 table0_initializer_34 table0_initializer_35 table0_initializer_36 table0_initializer_37 table0_initializer_38 table0_initializer_39 table0_initializer_40 table0_initializer_41 table0_initializer_42 table0_initializer_43 table0_initializer_44 table0_initializer_45 table0_initializer_46 table0_initializer_47 table0_initializer_48 table0_initializer_49 table0_initializer_50 table0_initializer_51 table0_initializer_52 table0_initializer_53 table0_initializer_54 table0_initializer_55 table0_initializer_56 table0_initializer_57 table0_initializer_58 table0_initializer_59 table0_initializer_60 table0_initializer_61 table0_initializer_62 table0_initializer_63 table0_initializer_64 table0_initializer_65 table0_initializer_66 table0_initializer_67 table0_initializer_68 table0_initializer_69 table0_initializer_70 table0_initializer_71 table0_initializer_72 table0_initializer_73 table0_initializer_74 table0_initializer_75 table0_initializer_76 table0_initializer_77 table0_initializer_78 table0_initializer_79 table0_initializer_80 table0_initializer_81 table0_initializer_82 table0_initializer_83 table0_initializer_84 table0_initializer_85 table0_initializer_86 table0_initializer_87 table0_initializer_88 table0_initializer_89 table0_initializer_90 table0_initializer_91 table0_initializer_92 table0_initializer_93 table0_initializer_94 table0_initializer_95 table0_initializer_96 table0_initializer_97 table0_initializer_98 table0_initializer_99 table0_initializer_100 table0_initializer_101 table0_initializer_102 table0_initializer_103 table0_initializer_104 table0_initializer_105 table0_initializer_106 table0_initializer_107 table0_initializer_108 table0_initializer_109 table0_initializer_110 table0_initializer_111 table0_initializer_112 table0_initializer_113 table0_initializer_114 table0_initializer_115 table0_initializer_116 table0_initializer_117 table0_initializer_118 table0_initializer_119 table0_initializer_120 table0_initializer_121 table0_initializer_122 table0_initializer_123 table0_initializer_124 table0_initializer_125 table0_initializer_126 table0_initializer_127 table0_initializer_128 table0_initializer_129 table0_initializer_130 table0_initializer_131 table0_initializer_132 table0_initializer_133 table0_initializer_134 table0_initializer_135 table0_initializer_136 table0_initializer_137 table0_initializer_138 table0_initializer_139 table0_initializer_140 table0_initializer_141 table0_initializer_142 table0_initializer_143 table0_initializer_144 table0_initializer_145 table0_initializer_146 table0_initializer_147 table0_initializer_148 table0_initializer_149 table0_initializer_150 table0_initializer_151 table0_initializer_152 table0_initializer_153 table0_initializer_154 table0_initializer_155 table0_initializer_156 table0_initializer_157 table0_initializer_158 table0_initializer_159 table0_initializer_160 table0_initializer_161 table0_initializer_162 table0_initializer_163 table0_initializer_164 table0_initializer_165 table0_initializer_166 table0_initializer_167 table0_initializer_168 table0_initializer_169 table0_initializer_170 table0_initializer_171 table0_initializer_172 table0_initializer_173 table0_initializer_174 table0_initializer_175 table0_initializer_176 table0_initializer_177 table0_initializer_178 table0_initializer_179 table0_initializer_180 table0_initializer_181 table0_initializer_182 table0_initializer_183 table0_initializer_184 table0_initializer_185 table0_initializer_186 table0_initializer_187 table0_initializer_188 table0_initializer_189 table0_initializer_190 table0_initializer_191 table0_initializer_192 table0_initializer_193 table0_initializer_194 table0_initializer_195 table0_initializer_196 table0_initializer_197 table0_initializer_198 table0_initializer_199 table0_initializer_200 table0_initializer_201 table0_initializer_202 table0_initializer_203 table0_initializer_204 table0_initializer_205 table0_initializer_206 table0_initializer_207 table0_initializer_208 table0_initializer_209 table0_initializer_210 table0_initializer_211 table0_initializer_212 table0_initializer_213 table0_initializer_214 table0_initializer_215 table0_initializer_216 table0_initializer_217 table0_initializer_218 table0_initializer_219 table0_initializer_220 table0_initializer_221 table0_initializer_222 table0_initializer_223 table0_initializer_224 table0_initializer_225 table0_initializer_226 table0_initializer_227 table0_initializer_228 table0_initializer_229 table0_initializer_230 table0_initializer_231 table0_initializer_232 table0_initializer_233 table0_initializer_234 table0_initializer_235 table0_initializer_236 table0_initializer_237 table0_initializer_238 table0_initializer_239 table0_initializer_240 table0_initializer_241 table0_initializer_242 table0_initializer_243 table0_initializer_244 table0_initializer_245 table0_initializer_246 table0_initializer_247 table0_initializer_248 table0_initializer_249 table0_initializer_250 table0_initializer_251 table0_initializer_252 table0_initializer_253 table0_initializer_254 table0_initializer_255)) [GOOD] (assert table0_initializer)-[GOOD] (define-fun s258 () (_ BitVec 8) (table0 s0))-[GOOD] (define-fun s259 () Bool (= s0 s258)) [GOOD] (assert s259) [SEND] (check-sat) [RECV] sat
+ SBVTestSuite/GoldFiles/queryTables.gold view
@@ -0,0 +1,139 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL) ; external query, using all logics.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- tuples ---+[GOOD] ; --- sums ---+[GOOD] ; --- literal constants ---+[GOOD] ; --- skolem constants ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (declare-fun s0 () (_ BitVec 16))+[GOOD] (define-fun s1 () (_ BitVec 16) #x0000)+[GOOD] (define-fun s3 () (_ BitVec 16) #x0001)+[GOOD] (define-fun s2 () Bool (bvsle s1 s0))+[GOOD] (define-fun s4 () Bool (bvslt s0 s3))+[GOOD] (define-fun s5 () Bool (and s2 s4))+[GOOD] (assert s5)+[GOOD] (declare-fun s6 () (_ BitVec 16))+[GOOD] (define-fun s7 () Bool (bvsle s1 s6))+[GOOD] (define-fun s8 () Bool (bvslt s6 s3))+[GOOD] (define-fun s9 () Bool (and s7 s8))+[GOOD] (assert s9)+[GOOD] (push 1)+[GOOD] (set-option :pp.max_depth 4294967295)+[GOOD] (set-option :pp.min_alias_size 4294967295)+[GOOD] (set-option :model.inline_def true )+[GOOD] (declare-datatypes ((SBVTuple2 2)) ((par (T1 T2)+ ((mkSBVTuple2 (proj_1_SBVTuple2 T1)+ (proj_2_SBVTuple2 T2))))))+[GOOD] (declare-datatypes ((SBVMaybe 1)) ((par (T)+ ((nothing_SBVMaybe)+ (just_SBVMaybe (get_just_SBVMaybe T))))))+[GOOD] (define-fun s13 () (_ BitVec 16) #x000a)+[GOOD] (define-fun s15 () (_ BitVec 16) (bvneg #x0001))+[GOOD] (define-fun s17 () (_ BitVec 16) #x0007)+[GOOD] (define-fun s19 () (SBVMaybe (_ BitVec 16)) ((as just_SBVMaybe (SBVMaybe (_ BitVec 16))) #x0000))+[GOOD] (define-fun s20 () (SBVMaybe (_ BitVec 16)) (as nothing_SBVMaybe (SBVMaybe (_ BitVec 16))))+[GOOD] (define-fun s28 () (_ BitVec 16) #x00ff)+[GOOD] (declare-fun table0 ((_ BitVec 16)) (_ BitVec 16))+[GOOD] (define-fun s10 () (SBVTuple2 (_ BitVec 16) (_ BitVec 16)) (mkSBVTuple2 s0 s6))+[GOOD] (define-fun s11 () (_ BitVec 16) (proj_1_SBVTuple2 s10))+[GOOD] (define-fun s12 () Bool (= s3 s11))+[GOOD] (define-fun s14 () Bool (= s11 s13))+[GOOD] (define-fun s16 () (_ BitVec 16) (proj_2_SBVTuple2 s10))+[GOOD] (define-fun s18 () Bool (= s16 s17))+[GOOD] (define-fun s21 () (SBVMaybe (_ BitVec 16)) (ite s18 s19 s20))+[GOOD] (define-fun s22 () (_ BitVec 16) (get_just_SBVMaybe s21))+[GOOD] (define-fun s23 () Bool ((_ is (nothing_SBVMaybe () (SBVMaybe (_ BitVec 16)))) s21))+[GOOD] (define-fun s24 () (_ BitVec 16) (ite s23 s15 s22))+[GOOD] (define-fun s25 () (_ BitVec 16) (ite (or (bvslt s24 #x0000) (bvsle #x0001 s24)) s15 (table0 s24)))+[GOOD] (define-fun s26 () Bool (= s1 s25))+[GOOD] (define-fun s27 () Bool (= s1 s24))+[GOOD] (define-fun s29 () (_ BitVec 16) (ite s27 s28 s3))+[GOOD] (define-fun s30 () (_ BitVec 16) (ite s26 s29 s3))+[GOOD] (define-fun s31 () (_ BitVec 16) (ite s14 s30 s3))+[GOOD] (define-fun s32 () (_ BitVec 16) (ite s12 s3 s31))+[GOOD] (define-fun s33 () Bool (= s3 s32))+[GOOD] (define-fun s34 () Bool ((_ pbeq 1 1) s33))+[GOOD] (define-fun table0_initializer_0 () Bool (= (table0 #x0000) s3))+[GOOD] (define-fun table0_initializer () Bool table0_initializer_0)+[GOOD] (assert table0_initializer)+[GOOD] (assert s34)+[SEND] (check-sat)+[RECV] sat+[GOOD] (pop 1)+[GOOD] (assert table0_initializer)+[GOOD] (declare-fun s35 () (_ BitVec 16))+[GOOD] (define-fun s36 () Bool (bvsle s1 s35))+[GOOD] (define-fun s37 () Bool (bvslt s35 s3))+[GOOD] (define-fun s38 () Bool (and s36 s37))+[GOOD] (assert s38)+[GOOD] (declare-fun s39 () (_ BitVec 16))+[GOOD] (define-fun s40 () Bool (bvsle s1 s39))+[GOOD] (define-fun s41 () Bool (bvslt s39 s3))+[GOOD] (define-fun s42 () Bool (and s40 s41))+[GOOD] (assert s42)+[GOOD] (push 1)+[GOOD] (define-fun s48 () (_ BitVec 16) #x0006)+[GOOD] (define-fun s56 () (_ BitVec 16) #x0002)+[GOOD] (declare-fun table1 ((_ BitVec 16)) (_ BitVec 16))+[GOOD] (declare-fun table2 ((_ BitVec 16)) (_ BitVec 16))+[GOOD] (define-fun s43 () (SBVTuple2 (_ BitVec 16) (_ BitVec 16)) (mkSBVTuple2 s35 s39))+[GOOD] (define-fun s44 () (_ BitVec 16) (proj_1_SBVTuple2 s43))+[GOOD] (define-fun s45 () Bool (= s3 s44))+[GOOD] (define-fun s46 () (_ BitVec 16) (proj_2_SBVTuple2 s43))+[GOOD] (define-fun s47 () Bool (bvsle s3 s46))+[GOOD] (define-fun s49 () Bool (bvsle s46 s48))+[GOOD] (define-fun s50 () Bool (and s47 s49))+[GOOD] (define-fun s51 () Bool (bvsle s3 s16))+[GOOD] (define-fun s52 () Bool (bvsle s16 s48))+[GOOD] (define-fun s53 () Bool (and s51 s52))+[GOOD] (define-fun s54 () (_ BitVec 16) (bvsub s1 s3))+[GOOD] (define-fun s55 () Bool (= s1 s54))+[GOOD] (define-fun s57 () (_ BitVec 16) (ite s55 s56 s1))+[GOOD] (define-fun s58 () (_ BitVec 16) (bvsub s46 s3))+[GOOD] (define-fun s59 () (_ BitVec 16) (ite (or (bvslt s58 #x0000) (bvsle #x0001 s58)) s1 (table1 s58)))+[GOOD] (define-fun s60 () Bool (= s1 s59))+[GOOD] (define-fun s61 () Bool (= s13 s44))+[GOOD] (define-fun s62 () Bool (= s17 s46))+[GOOD] (define-fun s63 () (SBVMaybe (_ BitVec 16)) (ite s62 s19 s20))+[GOOD] (define-fun s64 () (_ BitVec 16) (get_just_SBVMaybe s63))+[GOOD] (define-fun s65 () Bool ((_ is (nothing_SBVMaybe () (SBVMaybe (_ BitVec 16)))) s63))+[GOOD] (define-fun s66 () (_ BitVec 16) (ite s65 s15 s64))+[GOOD] (define-fun s67 () (_ BitVec 16) (ite (or (bvslt s66 #x0000) (bvsle #x0001 s66)) s15 (table2 s66)))+[GOOD] (define-fun s68 () Bool (= s1 s67))+[GOOD] (define-fun s69 () Bool (= s1 s66))+[GOOD] (define-fun s70 () (_ BitVec 16) (ite s69 s28 s32))+[GOOD] (define-fun s71 () (_ BitVec 16) (ite s68 s70 s32))+[GOOD] (define-fun s72 () (_ BitVec 16) (ite s61 s71 s32))+[GOOD] (define-fun s73 () (_ BitVec 16) (ite s45 s32 s72))+[GOOD] (define-fun s74 () Bool (= s3 s73))+[GOOD] (define-fun s75 () Bool ((_ pbeq 1 1) s74))+[GOOD] (define-fun table1_initializer_0 () Bool (= (table1 #x0000) s57))+[GOOD] (define-fun table1_initializer () Bool table1_initializer_0)+[GOOD] (assert table1_initializer)+[GOOD] (define-fun table2_initializer_0 () Bool (= (table2 #x0000) s32))+[GOOD] (define-fun table2_initializer () Bool table2_initializer_0)+[GOOD] (assert table2_initializer)+[GOOD] (assert s75)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s10))+[RECV] ((s10 (mkSBVTuple2 #x0000 #x0000)))+[SEND] (get-value (s43))+[RECV] ((s43 (mkSBVTuple2 #x0000 #x0000)))+*** Solver : Z3+*** Exit code: ExitSuccess++ FINAL:[(0,0),(0,0)]+DONE!
SBVTestSuite/GoldFiles/query_cvc4.gold view
@@ -43,7 +43,7 @@ [SEND] (check-sat) [RECV] sat [SEND] (get-value (s0))-[RECV] ((s0 (_ bv1 32)))+[RECV] ((s0 #b00000000000000000000000000000001)) [GOOD] (pop 1) [GOOD] (define-fun s16 () (_ BitVec 32) #x00000001) [GOOD] (define-fun s17 () Bool (bvsgt s0 s16))@@ -52,9 +52,9 @@ [SEND] (check-sat) [RECV] sat [SEND] (get-value (s0))-[RECV] ((s0 (_ bv2 32)))+[RECV] ((s0 #b00000000000000000000000000000010)) [SEND] (get-value (s1))-[RECV] ((s1 (_ bv1 32)))+[RECV] ((s1 #b00000000000000000000000000000001)) *** Solver : CVC4 *** Exit code: ExitSuccess *** Std-out :
SBVTestSuite/GoldFiles/set_uninterp1.gold view
@@ -57,8 +57,8 @@ [SEND] (check-sat) [RECV] sat [SEND] (get-value (s0))-[RECV] ((s0 (store (store (store ((as const (Array E Bool)) false) C true) B true) A true)))-[GOOD] (define-fun s10 () (Array E Bool) (store (store (store ((as const (Array E Bool)) false) C true) B true) A true))+[RECV] ((s0 (store (store ((as const (Array E Bool)) false) C true) A true)))+[GOOD] (define-fun s10 () (Array E Bool) (store (store ((as const (Array E Bool)) false) C true) A true)) [GOOD] (define-fun s11 () Bool (= s0 s10)) [GOOD] (define-fun s12 () Bool (not s11)) [GOOD] (assert s12)@@ -66,8 +66,8 @@ [SEND] (check-sat) [RECV] sat [SEND] (get-value (s0))-[RECV] ((s0 (store (store ((as const (Array E Bool)) false) C true) A true)))-[GOOD] (define-fun s13 () (Array E Bool) (store (store ((as const (Array E Bool)) false) C true) A true))+[RECV] ((s0 (lambda ((x!1 E)) (= x!1 C))))+[GOOD] (define-fun s13 () (Array E Bool) (store ((as const (Array E Bool)) false) C true)) [GOOD] (define-fun s14 () Bool (= s0 s13)) [GOOD] (define-fun s15 () Bool (not s14)) [GOOD] (assert s15)@@ -75,8 +75,8 @@ [SEND] (check-sat) [RECV] sat [SEND] (get-value (s0))-[RECV] ((s0 (store (store ((as const (Array E Bool)) false) C true) B true)))-[GOOD] (define-fun s16 () (Array E Bool) (store (store ((as const (Array E Bool)) false) C true) B true))+[RECV] ((s0 (lambda ((x!1 E)) (= x!1 B))))+[GOOD] (define-fun s16 () (Array E Bool) (store ((as const (Array E Bool)) false) B true)) [GOOD] (define-fun s17 () Bool (= s0 s16)) [GOOD] (define-fun s18 () Bool (not s17)) [GOOD] (assert s18)@@ -84,8 +84,8 @@ [SEND] (check-sat) [RECV] sat [SEND] (get-value (s0))-[RECV] ((s0 (lambda ((x!1 E)) (= x!1 C))))-[GOOD] (define-fun s19 () (Array E Bool) (store ((as const (Array E Bool)) false) C true))+[RECV] ((s0 (store (store ((as const (Array E Bool)) false) C true) B true)))+[GOOD] (define-fun s19 () (Array E Bool) (store (store ((as const (Array E Bool)) false) C true) B true)) [GOOD] (define-fun s20 () Bool (= s0 s19)) [GOOD] (define-fun s21 () Bool (not s20)) [GOOD] (assert s21)@@ -93,8 +93,8 @@ [SEND] (check-sat) [RECV] sat [SEND] (get-value (s0))-[RECV] ((s0 (lambda ((x!1 E)) (= x!1 B))))-[GOOD] (define-fun s22 () (Array E Bool) (store ((as const (Array E Bool)) false) B true))+[RECV] ((s0 (store (store (store ((as const (Array E Bool)) false) C true) B true) A true)))+[GOOD] (define-fun s22 () (Array E Bool) (store (store (store ((as const (Array E Bool)) false) C true) B true) A true)) [GOOD] (define-fun s23 () Bool (= s0 s22)) [GOOD] (define-fun s24 () Bool (not s23)) [GOOD] (assert s24)@@ -112,14 +112,14 @@ Solution #3: s0 = {A,B} :: {E} Solution #4:- s0 = {A,B,C} :: {E}-Solution #5: s0 = {A,C} :: {E}+Solution #5:+ s0 = {C} :: {E} Solution #6:- s0 = {B,C} :: {E}+ s0 = {B} :: {E} Solution #7:- s0 = {C} :: {E}+ s0 = {B,C} :: {E} Solution #8:- s0 = {B} :: {E}+ s0 = {A,B,C} :: {E} Found 8 different solutions. DONE!
SBVTestSuite/GoldFiles/tgen_c.gold view
@@ -41,16 +41,16 @@ } CTestTestVector; CTestTestVector CTest[] = {- {{0xfcbe0fdbUL, 0xd321df04UL}, {0xcfdfeedfUL, 0x299c30d7UL, 0x0f03046cUL}}- , {{0x7e037b43UL, 0xf66d083bUL}, {0x7470837eUL, 0x87967308UL, 0x042e8071UL}}- , {{0xce482a70UL, 0x66b7c768UL}, {0x34fff1d8UL, 0x67906308UL, 0xdc5e4d80UL}}- , {{0xec1eda04UL, 0x465a32a9UL}, {0x32790cadUL, 0xa5c4a75bUL, 0xa45ab4a4UL}}- , {{0x61f89467UL, 0x00d8fb06UL}, {0x62d18f6dUL, 0x611f9961UL, 0x3c3c776aUL}}- , {{0x30e2d88cUL, 0x10ea31cdUL}, {0x41cd0a59UL, 0x1ff8a6bfUL, 0x4112341cUL}}- , {{0x4bf1b3fdUL, 0x2124dc8bUL}, {0x6d169088UL, 0x2accd772UL, 0xdf7e265fUL}}- , {{0x96885656UL, 0x60a8c5caUL}, {0xf7311c20UL, 0x35df908cUL, 0x9a744ddcUL}}- , {{0xc2bac856UL, 0xe5a9367cUL}, {0xa863fed2UL, 0xdd1191daUL, 0xe7812da8UL}}- , {{0x8b10b4f2UL, 0xf010d50fUL}, {0x7b218a01UL, 0x9affdfe3UL, 0x3ba7f42eUL}}+ {{0x06d79fd8UL, 0x96962508UL}, {0x9d6dc4e0UL, 0x70417ad0UL, 0x996736c0UL}}+ , {{0xf3dc6f98UL, 0xf76adb6bUL}, {0xeb474b03UL, 0xfc71942dUL, 0x5d89ac88UL}}+ , {{0xb4538396UL, 0x8f338d9cUL}, {0x43871132UL, 0x251ff5faUL, 0xe33fcd68UL}}+ , {{0xde90db7fUL, 0xe017f69fUL}, {0xbea8d21eUL, 0xfe78e4e0UL, 0x474d5de1UL}}+ , {{0xe7510cb7UL, 0x5e8efd6dUL}, {0x45e00a24UL, 0x88c20f4aUL, 0xd69544ebUL}}+ , {{0x9847fd68UL, 0x1e671b39UL}, {0xb6af18a1UL, 0x79e0e22fUL, 0xa4996428UL}}+ , {{0x3cba5737UL, 0xb9a2eb19UL}, {0xf65d4250UL, 0x83176c1eUL, 0xec10015fUL}}+ , {{0x6eedc674UL, 0x33a50d69UL}, {0xa292d3ddUL, 0x3b48b90bUL, 0x975e4994UL}}+ , {{0x4f576647UL, 0x0058226eUL}, {0x4faf88b5UL, 0x4eff43d9UL, 0xdb8b6082UL}}+ , {{0xa240be50UL, 0x24ff2cd8UL}, {0xc73feb28UL, 0x7d419178UL, 0xd9065380UL}} }; int CTestLength = 10;
SBVTestSuite/GoldFiles/tgen_forte.gold view
@@ -1,14 +1,14 @@ // Automatically generated by SBV. Do not edit! let ForteTest = let c s = val [_, r] = str_split s "'" in map (\s. s == "1") (explode (string_tl r))- in [ ((c "32'b11111100101111100000111111011011", c "32'b11010011001000011101111100000100"), (c "32'b11001111110111111110111011011111", c "32'b00101001100111000011000011010111", c "32'b00001111000000110000010001101100"))- , ((c "32'b01111110000000110111101101000011", c "32'b11110110011011010000100000111011"), (c "32'b01110100011100001000001101111110", c "32'b10000111100101100111001100001000", c "32'b00000100001011101000000001110001"))- , ((c "32'b11001110010010000010101001110000", c "32'b01100110101101111100011101101000"), (c "32'b00110100111111111111000111011000", c "32'b01100111100100000110001100001000", c "32'b11011100010111100100110110000000"))- , ((c "32'b11101100000111101101101000000100", c "32'b01000110010110100011001010101001"), (c "32'b00110010011110010000110010101101", c "32'b10100101110001001010011101011011", c "32'b10100100010110101011010010100100"))- , ((c "32'b01100001111110001001010001100111", c "32'b00000000110110001111101100000110"), (c "32'b01100010110100011000111101101101", c "32'b01100001000111111001100101100001", c "32'b00111100001111000111011101101010"))- , ((c "32'b00110000111000101101100010001100", c "32'b00010000111010100011000111001101"), (c "32'b01000001110011010000101001011001", c "32'b00011111111110001010011010111111", c "32'b01000001000100100011010000011100"))- , ((c "32'b01001011111100011011001111111101", c "32'b00100001001001001101110010001011"), (c "32'b01101101000101101001000010001000", c "32'b00101010110011001101011101110010", c "32'b11011111011111100010011001011111"))- , ((c "32'b10010110100010000101011001010110", c "32'b01100000101010001100010111001010"), (c "32'b11110111001100010001110000100000", c "32'b00110101110111111001000010001100", c "32'b10011010011101000100110111011100"))- , ((c "32'b11000010101110101100100001010110", c "32'b11100101101010010011011001111100"), (c "32'b10101000011000111111111011010010", c "32'b11011101000100011001000111011010", c "32'b11100111100000010010110110101000"))- , ((c "32'b10001011000100001011010011110010", c "32'b11110000000100001101010100001111"), (c "32'b01111011001000011000101000000001", c "32'b10011010111111111101111111100011", c "32'b00111011101001111111010000101110"))+ in [ ((c "32'b00000110110101111001111111011000", c "32'b10010110100101100010010100001000"), (c "32'b10011101011011011100010011100000", c "32'b01110000010000010111101011010000", c "32'b10011001011001110011011011000000"))+ , ((c "32'b11110011110111000110111110011000", c "32'b11110111011010101101101101101011"), (c "32'b11101011010001110100101100000011", c "32'b11111100011100011001010000101101", c "32'b01011101100010011010110010001000"))+ , ((c "32'b10110100010100111000001110010110", c "32'b10001111001100111000110110011100"), (c "32'b01000011100001110001000100110010", c "32'b00100101000111111111010111111010", c "32'b11100011001111111100110101101000"))+ , ((c "32'b11011110100100001101101101111111", c "32'b11100000000101111111011010011111"), (c "32'b10111110101010001101001000011110", c "32'b11111110011110001110010011100000", c "32'b01000111010011010101110111100001"))+ , ((c "32'b11100111010100010000110010110111", c "32'b01011110100011101111110101101101"), (c "32'b01000101111000000000101000100100", c "32'b10001000110000100000111101001010", c "32'b11010110100101010100010011101011"))+ , ((c "32'b10011000010001111111110101101000", c "32'b00011110011001110001101100111001"), (c "32'b10110110101011110001100010100001", c "32'b01111001111000001110001000101111", c "32'b10100100100110010110010000101000"))+ , ((c "32'b00111100101110100101011100110111", c "32'b10111001101000101110101100011001"), (c "32'b11110110010111010100001001010000", c "32'b10000011000101110110110000011110", c "32'b11101100000100000000000101011111"))+ , ((c "32'b01101110111011011100011001110100", c "32'b00110011101001010000110101101001"), (c "32'b10100010100100101101001111011101", c "32'b00111011010010001011100100001011", c "32'b10010111010111100100100110010100"))+ , ((c "32'b01001111010101110110011001000111", c "32'b00000000010110000010001001101110"), (c "32'b01001111101011111000100010110101", c "32'b01001110111111110100001111011001", c "32'b11011011100010110110000010000010"))+ , ((c "32'b10100010010000001011111001010000", c "32'b00100100111111110010110011011000"), (c "32'b11000111001111111110101100101000", c "32'b01111101010000011001000101111000", c "32'b11011001000001100101001110000000")) ];
SBVTestSuite/GoldFiles/tgen_haskell.gold view
@@ -5,14 +5,14 @@ import Data.Word haskTest :: [([Word32], [Word32])]-haskTest = [ ([0xfcbe0fdb, 0xd321df04], [0xcfdfeedf, 0x299c30d7, 0x0f03046c])- , ([0x7e037b43, 0xf66d083b], [0x7470837e, 0x87967308, 0x042e8071])- , ([0xce482a70, 0x66b7c768], [0x34fff1d8, 0x67906308, 0xdc5e4d80])- , ([0xec1eda04, 0x465a32a9], [0x32790cad, 0xa5c4a75b, 0xa45ab4a4])- , ([0x61f89467, 0x00d8fb06], [0x62d18f6d, 0x611f9961, 0x3c3c776a])- , ([0x30e2d88c, 0x10ea31cd], [0x41cd0a59, 0x1ff8a6bf, 0x4112341c])- , ([0x4bf1b3fd, 0x2124dc8b], [0x6d169088, 0x2accd772, 0xdf7e265f])- , ([0x96885656, 0x60a8c5ca], [0xf7311c20, 0x35df908c, 0x9a744ddc])- , ([0xc2bac856, 0xe5a9367c], [0xa863fed2, 0xdd1191da, 0xe7812da8])- , ([0x8b10b4f2, 0xf010d50f], [0x7b218a01, 0x9affdfe3, 0x3ba7f42e])+haskTest = [ ([0x06d79fd8, 0x96962508], [0x9d6dc4e0, 0x70417ad0, 0x996736c0])+ , ([0xf3dc6f98, 0xf76adb6b], [0xeb474b03, 0xfc71942d, 0x5d89ac88])+ , ([0xb4538396, 0x8f338d9c], [0x43871132, 0x251ff5fa, 0xe33fcd68])+ , ([0xde90db7f, 0xe017f69f], [0xbea8d21e, 0xfe78e4e0, 0x474d5de1])+ , ([0xe7510cb7, 0x5e8efd6d], [0x45e00a24, 0x88c20f4a, 0xd69544eb])+ , ([0x9847fd68, 0x1e671b39], [0xb6af18a1, 0x79e0e22f, 0xa4996428])+ , ([0x3cba5737, 0xb9a2eb19], [0xf65d4250, 0x83176c1e, 0xec10015f])+ , ([0x6eedc674, 0x33a50d69], [0xa292d3dd, 0x3b48b90b, 0x975e4994])+ , ([0x4f576647, 0x0058226e], [0x4faf88b5, 0x4eff43d9, 0xdb8b6082])+ , ([0xa240be50, 0x24ff2cd8], [0xc73feb28, 0x7d419178, 0xd9065380]) ]
SBVTestSuite/GoldFiles/unint-axioms-query.gold view
@@ -7,7 +7,7 @@ [GOOD] (set-option :produce-models true) [GOOD] (set-logic ALL) ; has user-defined sorts, using catch-all. [GOOD] ; --- uninterpreted sorts ----[GOOD] (declare-sort B 0) ; N.B. Uninterpreted: B.B: not a nullary constructor+[GOOD] (declare-sort B 0) ; N.B. Uninterpreted sort. [GOOD] ; --- tuples --- [GOOD] ; --- sums --- [GOOD] ; --- literal constants ---
SBVTestSuite/GoldFiles/validate_2.gold view
@@ -25,11 +25,11 @@ [SEND] (check-sat) [RECV] sat [SEND] (get-value (s0))-[RECV] ((s0 (fp #b0 #x03 #b11011110110000010001000)))+[RECV] ((s0 (fp #b0 #x03 #b11010011011011001000000))) *** Solver : Z3 *** Exit code: ExitSuccess [VALIDATE] Validating the model. Assignment:-[VALIDATE] x = 8.793325e-38 :: Float+[VALIDATE] x = 8.58522e-38 :: Float [VALIDATE] There are no constraints to check. [VALIDATE] Validating outputs. @@ -38,7 +38,7 @@ *** *** Assignment: *** -*** x = 8.793325e-38 :: Float+*** x = 8.58522e-38 :: Float *** *** Floating point FMA operation is not supported concretely. *** @@ -48,4 +48,4 @@ *** Alleged model: *** *** Satisfiable. Model:-*** x = 8.793325e-38 :: Float+*** x = 8.58522e-38 :: Float
+ SBVTestSuite/SBVConnectionTest.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module Main (main) where++import Data.SBV+import Data.List+import Control.Monad+import System.Exit+import System.Environment++-- Known solvers with bugs! Should really be empty!+badSolvers :: [SMTConfig]+badSolvers = []++solverName :: SMTConfig -> String+solverName = show . name . solver++main :: IO ()+main = do let allSolvers = map (\s -> (solverName s, s)) [abc, boolector, cvc4, mathSAT, yices, z3, dReal]++ args <- getArgs++ let chosenSolvers = case args of+ [] -> allSolvers+ _ -> let walk [] = []+ walk (c:cs) = case c `lookup` allSolvers of+ Nothing -> error $ "Unknown chosen solver: " ++ show c+ Just s -> (c, s) : walk cs+ in walk args++ (requiredBad, requiredPresent) = partition (\(n, _) -> n `elem` map solverName badSolvers) chosenSolvers++ pickTest s = case name (solver s) of+ DReal -> testI s+ _ -> test s++ mapM_ (pickTest . snd) requiredPresent++ let tested = sort $ map fst requiredPresent+ allKnown = sort $ map fst allSolvers++ skipped = filter (`notElem` tested) allKnown+++ putStrLn $ "Tested OK basic connection to: " ++ intercalate ", " (map fst requiredPresent)+ unless (null requiredBad) $ putStrLn $ "*** NB: The following solvers are declared bad: " ++ intercalate ", " (map (\(n, s)-> show (n, solverName s)) requiredBad)+ unless (null skipped) $ putStrLn $ "*** NB: The following solvers are skipped: " ++ intercalate ", " skipped++test :: SMTConfig -> IO ()+test s = do check s "t0" t0 (== False)+ check s "t1" t1 (== True)+ models "t2" t2 (== ([2,62,66,126,130,190,194,254]::[Word8]))+ models "t3" t3 (== ([]::[Word8]))+ models "t4" t4 (== [4::Word8])+ where models m p f = (extractModels <$> allSat p) >>= decide s m f . sort+ t0 x = x .== x+(1::SWord8)+ t1 x = x*2 .== x+(x::SWord8)+ t2 x = x*x .== (4::SWord8)+ t3 x = x*x .== (3::SWord8)+ t4 x = x*3 .== (12::SWord8)++-- integer only test, for dReal mostly+testI :: SMTConfig -> IO ()+testI s = do check s "t0" t0 (== True)+ check s "t1" t1 (== False)+ where t0 x = x .== (x :: SReal)+ t1 x = x .== (2 :: SReal) .&& (x .== 3)++check :: Provable a => SMTConfig -> String -> a -> (Bool -> Bool) -> IO ()+check s m p f = isTheoremWith s p >>= decide s m f++decide :: Show a => SMTConfig -> String -> (a -> Bool) -> a -> IO ()+decide s m f r+ | f r = return ()+ | True = do putStrLn $ m ++ "[" ++ solverName s ++ "] FAIL. Got: " ++ show r+ exitFailure
SBVTestSuite/SBVDocTest.hs view
@@ -45,11 +45,20 @@ let allFiles = srcFiles ++ docFiles testFiles = filter (\nm -> not (skipWindows nm || skipRemote nm || skipLocal nm)) allFiles - args = ["--fast", "--no-magic"]+ packages = [ "async"+ , "crackNum"+ , "mtl"+ , "QuickCheck"+ , "random"+ , "syb"+ ] + pargs = concatMap (\p -> ["-package", p]) packages+ args = ["--fast", "--no-magic"]+ tfs <- pickPercentage tp testFiles - doctest $ args ++ tfs+ doctest $ pargs ++ args ++ tfs where noGood nm = any $ (`isSuffixOf` map toLower nm) . map toLower
SBVTestSuite/SBVTest.hs view
@@ -24,6 +24,7 @@ import qualified TestSuite.Arrays.InitVals import qualified TestSuite.Arrays.Memory import qualified TestSuite.Arrays.Query+import qualified TestSuite.Arrays.Caching import qualified TestSuite.Basics.AllSat import qualified TestSuite.Basics.ArithNoSolver import qualified TestSuite.Basics.ArithSolver@@ -98,6 +99,7 @@ import qualified TestSuite.Puzzles.U2Bridge import qualified TestSuite.Queries.BasicQuery import qualified TestSuite.Queries.BadOption+import qualified TestSuite.Queries.DSat import qualified TestSuite.Queries.Enums import qualified TestSuite.Queries.FreshVars import qualified TestSuite.Queries.Int_ABC@@ -110,6 +112,7 @@ import qualified TestSuite.Queries.Lists import qualified TestSuite.Queries.Strings import qualified TestSuite.Queries.Sums+import qualified TestSuite.Queries.Tables import qualified TestSuite.Queries.Tuples import qualified TestSuite.Queries.UISat import qualified TestSuite.Queries.UISatEx@@ -158,6 +161,7 @@ , TestSuite.Basics.BarrelRotate.tests -- Requires CVC4 , TestSuite.Basics.ModelValidate.testsABC -- Requires ABC , TestSuite.Queries.BasicQuery.tests+ , TestSuite.Queries.DSat.tests -- Requires dReal , TestSuite.Queries.BadOption.tests , TestSuite.Queries.Int_ABC.tests , TestSuite.Queries.Int_Boolector.tests@@ -174,6 +178,7 @@ TestSuite.Arrays.InitVals.tests , TestSuite.Arrays.Memory.tests , TestSuite.Arrays.Query.tests+ , TestSuite.Arrays.Caching.tests , TestSuite.Basics.AllSat.tests , TestSuite.Basics.ArithNoSolver.tests , TestSuite.Basics.Assert.tests@@ -250,6 +255,7 @@ , TestSuite.Queries.Lists.tests , TestSuite.Queries.Strings.tests , TestSuite.Queries.Sums.tests+ , TestSuite.Queries.Tables.tests , TestSuite.Queries.Tuples.tests , TestSuite.Queries.UISat.tests , TestSuite.Queries.UISatEx.tests
+ SBVTestSuite/TestSuite/Arrays/Caching.hs view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module : TestSuite.Arrays.Caching+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Test case for https://github.com/LeventErkok/sbv/issues/541+-----------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module TestSuite.Arrays.Caching (tests) where++import Utils.SBVTestFramework++tests :: TestTree+tests = testGroup "Arrays.Caching" [+ goldenCapturedIO "array_caching_01" (run (test True))+ , goldenCapturedIO "array_caching_02" (run (test False))+ ]+ where run :: Symbolic SBool -> FilePath -> IO ()+ run tst goldFile = do r <- satWith defaultSMTCfg{verbose=True, redirectVerbose = Just goldFile} tst+ appendFile goldFile ("\nFINAL OUTPUT:\n" ++ show r ++ "\n")++test :: Bool -> Symbolic SBool+test swap = do+ arr :: SFunArray Integer Integer <- newArray "items" (Just 0)+ x <- sInteger "x"++ let ys = writeArray arr 0 2++ idx = x + 1++ ys1 = writeArray ys 0 (readArray ys idx)+ ys2 = writeArray ys idx 1++ v = if swap+ then ite (x .== 0) (readArray ys1 0) (readArray ys2 0)+ else ite (x ./= 0) (readArray ys2 0) (readArray ys1 0)++ pure $ v .== 1
SBVTestSuite/TestSuite/Arrays/InitVals.hs view
@@ -37,12 +37,42 @@ return $ readArray a i .== j +constArr :: forall m. SymArray m => m Integer Integer -> Predicate+constArr proxy = do i <- sInteger "i"+ j <- sInteger "j"++ constrain $ i ./= j+ constrain $ i `sElem` [1, 2, 3, 75]+ pure $ readArray myArray i .== readArray (myArray `asTypeOf` proxy) j+ where myArray = sListArray 7 [(1, 12), (2, 5) , (3, 6), (75, 5)]++constArr2 :: forall m. SymArray m => m Integer Integer -> Predicate+constArr2 proxy = do i <- sInteger "i"+ j <- sInteger "j"++ constrain $ i ./= j+ constrain $ i `sElem` [1, 2, 3, 75]+ pure $ readArray myArray i .== readArray (myArray `asTypeOf` proxy) j+ where myArray = sListArray 2 [(1, 12), (2, 5) , (3, 6), (75, 5)]+ tests :: TestTree tests = testGroup "Arrays.InitVals"- [ testCase "readDef_SArray" $ assertIsThm (readDef (undefined :: SArray Integer Integer))- , testCase "readDef_SFunArray" $ assertIsThm (readDef (undefined :: SFunArray Integer Integer))+ [ testCase "readDef_SArray" $ assertIsThm (readDef (undefined :: SArray Integer Integer))+ , testCase "readDef_SFunArray" $ assertIsThm (readDef (undefined :: SFunArray Integer Integer)) - , testCase "readDef_SArray" $ assertIsSat (readNoDef (undefined :: SArray Integer Integer))- , testCase "readDef_SFunArray" $ assertIsSat (readNoDef (undefined :: SFunArray Integer Integer))+ , testCase "readDef2_SArray2" $ assertIsSat (readNoDef (undefined :: SArray Integer Integer))+ , testCase "readDef2_SFunArray" $ assertIsSat (readNoDef (undefined :: SFunArray Integer Integer))++ , goldenCapturedIO "constArr_SArray" $ t (undefined :: SArray Integer Integer)+ , goldenCapturedIO "constArr_SFunArray" $ t (undefined :: SFunArray Integer Integer)++ , goldenCapturedIO "constArr2_SArray" $ t2 (undefined :: SArray Integer Integer)+ , goldenCapturedIO "constArr2_SFunArray" $ t2 (undefined :: SFunArray Integer Integer) ]+ where t p goldFile = do r <- satWith defaultSMTCfg{verbose=True, redirectVerbose = Just goldFile} (constArr p)+ appendFile goldFile ("\nFINAL OUTPUT:\n" ++ show r ++ "\n")+ t2 p goldFile = do r <- satWith defaultSMTCfg{verbose=True, redirectVerbose = Just goldFile} (constArr2 p)+ appendFile goldFile ("\nFINAL OUTPUT:\n" ++ show r ++ "\n")++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
SBVTestSuite/TestSuite/Arrays/Query.hs view
@@ -99,11 +99,12 @@ cs <- checkSat case cs of- Unsat -> return Nothing- Unk -> error "solver returned Unknown!"- Sat -> do av <- getValue a- vv <- getValue v- return $ Just (av, vv)+ Unsat -> return Nothing+ Unk -> error "solver returned Unknown!"+ DSat{} -> error "solver returned Delta-satisfiable!"+ Sat -> do av <- getValue a+ vv <- getValue v+ return $ Just (av, vv) q6 :: Symbolic [Integer] q6 = do (a :: SArray Integer Integer) <- newArray "a" Nothing@@ -114,12 +115,13 @@ constrain $ readArray a 1 .== 5 cs <- checkSat case cs of- Unk -> error "Unknown"- Unsat -> do pop 1- d <- freshVar $ "d" ++ show (length sofar)- constrain $ d .>= 1 .&& d .< 3- loop (writeArray a 1 (readArray a 1 + d)) (sofar ++ [d])- Sat -> mapM getValue sofar+ Unk -> error "Unknown"+ Unsat -> do pop 1+ d <- freshVar $ "d" ++ show (length sofar)+ constrain $ d .>= 1 .&& d .< 3+ loop (writeArray a 1 (readArray a 1 + d)) (sofar ++ [d])+ DSat{} -> error "solver returned Delta-satisfiable!"+ Sat -> mapM getValue sofar q7 :: Symbolic (CheckSatResult, CheckSatResult)
SBVTestSuite/TestSuite/Basics/AllSat.hs view
@@ -11,16 +11,20 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -Werror #-} module TestSuite.Basics.AllSat(tests) where -import Data.Generics import Utils.SBVTestFramework import Data.List (sortOn) +data Q+mkUninterpretedSort ''Q+ tests :: TestTree tests = testGroup "Basics.AllSat"@@ -33,10 +37,7 @@ ] srt :: AllSatResult -> AllSatResult-srt (AllSatResult (b1, b2, b3, rs)) = AllSatResult (b1, b2, b3, sortOn getModelDictionary rs)--newtype Q = Q () deriving (Eq, Ord, Data, Read, Show, SymVal, HasKind)-type SQ = SBV Q+srt r@AllSatResult{allSatResults = ms} = r { allSatResults = sortOn (show . SatResult) ms } t1 :: IO AllSatResult t1 = allSat $ do x <- free "x"
SBVTestSuite/TestSuite/Basics/BoundedList.hs view
@@ -77,9 +77,10 @@ query $ do cs <- checkSat unless (cs == csExpected) $ case cs of- Unsat -> error $ "Failed! Expected " ++ show csExpected ++ ", got Unsat"- Sat -> getModel >>= \r -> error $ "Failed! Expected " ++ show csExpected ++ ", got Sat:\n" ++ show (SatResult (Satisfiable cfg r))- Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected " ++ show csExpected ++ ", got Unk:\n" ++ show r+ Unsat -> error $ "Failed! Expected " ++ show csExpected ++ ", got Unsat"+ DSat{} -> error $ "Failed! Expected " ++ show csExpected ++ ", got delta-sat"+ Sat -> getModel >>= \r -> error $ "Failed! Expected " ++ show csExpected ++ ", got Sat:\n" ++ show (SatResult (Satisfiable cfg r))+ Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected " ++ show csExpected ++ ", got Unk:\n" ++ show r concreteFoldrSat :: Symbolic () concreteFoldrSat = constrain $ BL.bfoldr 3 (+) 0 [1..3] .== (6 :: SInteger)
SBVTestSuite/TestSuite/Basics/DynSign.hs view
@@ -16,10 +16,10 @@ import Utils.SBVTestFramework hiding (proveWith) import Data.SBV.Dynamic-import Data.SBV.Internals (genMkSymVar, unSBV)+import Data.SBV.Internals (genMkSymVar, unSBV, VarContext(..)) prop :: Symbolic SVal-prop = do x <- unSBV <$> genMkSymVar w8 Nothing (Just "x")+prop = do x <- unSBV <$> genMkSymVar w8 (NonQueryVar Nothing) (Just "x") let lhs = svUnsign (svSign x `svShiftRight` sfour) rhs = svExtract 7 0 x `svShiftRight` ufour return $ lhs `svEqual` rhs
SBVTestSuite/TestSuite/Basics/List.hs view
@@ -52,9 +52,10 @@ query $ do cs <- checkSat unless (cs == csExpected) $ case cs of- Unsat -> error "Failed! Expected Sat, got UNSAT"- Sat -> getModel >>= \r -> error $ "Failed! Expected Unsat, got SAT:\n" ++ show (SatResult (Satisfiable cfg r))- Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" ++ show r+ Unsat -> error "Failed! Expected Sat, got UNSAT"+ DSat{} -> error "Failed! Expected Sat, got delta-sat"+ Sat -> getModel >>= \r -> error $ "Failed! Expected Unsat, got SAT:\n" ++ show (SatResult (Satisfiable cfg r))+ Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" ++ show r seqConcatSat :: Symbolic () seqConcatSat = constrain $ [1..3] .++ [4..6] .== ([1..6] :: SList Integer)
SBVTestSuite/TestSuite/Basics/PseudoBoolean.hs view
@@ -40,9 +40,10 @@ constrain $ sNot (spec bs) query $ do cs <- checkSat case cs of- Unsat -> return ()- Sat -> getModel >>= \r -> error $ "Failed! Expected Unsat, got SAT:\n" ++ show (SatResult (Satisfiable cfg r))- Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" ++ show r+ Unsat -> return ()+ DSat{} -> error "Expected Unsat, got delta-sat"+ Sat -> getModel >>= \r -> error $ "Failed! Expected Unsat, got SAT:\n" ++ show (SatResult (Satisfiable cfg r))+ Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" ++ show r propPbAtMost :: [SBool] -> SBool propPbAtMost bs = pbAtMost bs 8 .== (sum (map oneIf bs) .<= (8::SWord32))
SBVTestSuite/TestSuite/Basics/Recursive.hs view
@@ -15,7 +15,7 @@ import Utils.SBVTestFramework -import Data.SBV.Internals (genMkSymVar, unSBV)+import Data.SBV.Internals (genMkSymVar, unSBV, VarContext(..)) import qualified Data.SBV.Dynamic as D @@ -29,7 +29,7 @@ mgcdDyn i = D.proveWith z3 $ do let var8 :: String -> Symbolic D.SVal- var8 nm = unSBV <$> genMkSymVar word8 (Just D.ALL) (Just nm)+ var8 nm = unSBV <$> genMkSymVar word8 (NonQueryVar (Just D.ALL)) (Just nm) word8 = KBounded False 8 zero8 = D.svInteger word8 0
SBVTestSuite/TestSuite/Basics/Set.hs view
@@ -31,6 +31,9 @@ data E = A | B | C mkSymbolicEnumeration ''E +__unused :: SE+__unused = error "stop GHC from complaining unused names" sA sB sC+ type SC = SSet Char type RC = RCSet Char
SBVTestSuite/TestSuite/Basics/SmallShifts.hs view
@@ -17,7 +17,7 @@ import Utils.SBVTestFramework hiding (proveWith) import Data.SBV.Dynamic-import Data.SBV.Internals (genMkSymVar, unSBV)+import Data.SBV.Internals (genMkSymVar, unSBV, VarContext(..)) k1, k32, k33 :: Kind k1 = KBounded False 1@@ -43,8 +43,8 @@ `svPlus` (x `svAnd` (y `svAnd` svInteger k32 1)) prop :: Symbolic SVal-prop = do x <- unSBV <$> genMkSymVar k32 Nothing (Just "x")- y <- unSBV <$> genMkSymVar k32 Nothing (Just "y")+prop = do x <- unSBV <$> genMkSymVar k32 (NonQueryVar Nothing) (Just "x")+ y <- unSBV <$> genMkSymVar k32 (NonQueryVar Nothing) (Just "y") return $ average33 x y `svEqual` average4 x y checkThm :: ThmResult -> Assertion
SBVTestSuite/TestSuite/Basics/String.hs view
@@ -60,9 +60,10 @@ query $ do cs <- checkSat unless (cs == csExpected) $ case cs of- Unsat -> error "Failed! Expected Sat, got UNSAT"- Sat -> getModel >>= \r -> error $ "Failed! Expected Unsat, got SAT:\n" ++ show (SatResult (Satisfiable cfg r))- Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" ++ show r+ Unsat -> error "Failed! Expected Sat, got UNSAT"+ DSat{} -> error "Failed! Expected Sat, got delta-sat"+ Sat -> getModel >>= \r -> error $ "Failed! Expected Unsat, got SAT:\n" ++ show (SatResult (Satisfiable cfg r))+ Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" ++ show r strConcatSat :: Symbolic () strConcatSat = constrain $ "abc" .++ "def" .== "abcdef"
SBVTestSuite/TestSuite/Basics/Sum.hs view
@@ -48,9 +48,10 @@ query $ do cs <- checkSat unless (cs == csExpected) $ case cs of- Unsat -> error "Failed! Expected Sat, got UNSAT"- Sat -> getModel >>= \r -> error $ "Failed! Expected Unsat, got SAT:\n" ++ show (SatResult (Satisfiable cfg r))- Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" ++ show r+ Unsat -> error "Failed! Expected Sat, got UNSAT"+ DSat{} -> error "Failed! Expected Sat, got delta-sat"+ Sat -> getModel >>= \r -> error $ "Failed! Expected Unsat, got SAT:\n" ++ show (SatResult (Satisfiable cfg r))+ Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" ++ show r when (cs == Sat) $ getModel >>= \m -> io $ appendFile rf $ "\nMODEL: " ++ show m ++ "\nDONE."
SBVTestSuite/TestSuite/Basics/Tuple.hs view
@@ -32,6 +32,9 @@ data E = A | B | C mkSymbolicEnumeration ''E +__unused :: SE+__unused = error "stop GHC from complaining unused names" sA sB sC+ -- Test suite tests :: TestTree tests = testGroup "Basics.Tuple" [@@ -102,7 +105,7 @@ constrain $ L.length vTup1 .== 3 case untuple (vTup1 .!! 2) of- (e, b) -> do constrain $ e .== literal C+ (e, b) -> do constrain $ e .== sC constrain $ L.length b .== 6 constrain $ b .!! 4 .== sTrue
SBVTestSuite/TestSuite/Puzzles/Temperature.hs view
@@ -28,13 +28,13 @@ type Temp = SInteger --- convert celcius to fahrenheit, rounding up/down properly+-- convert celsius to fahrenheit, rounding up/down properly -- we have to be careful here to make sure rounding is done properly.. d2f :: Temp -> Temp d2f d = 32 + ite (fr .>= 5) (1+fi) fi where (fi, fr) = (18 * d) `sQuotRem` 10 --- puzzle: What 2 digit fahrenheit/celcius values are reverses of each other?+-- puzzle: What 2 digit fahrenheit/celsius values are reverses of each other? revOf :: Temp -> SBool revOf c = swap (digits c) .== digits (d2f c) where digits x = x `sQuotRem` 10
SBVTestSuite/TestSuite/Puzzles/U2Bridge.hs view
@@ -33,4 +33,5 @@ where act = do b <- exists_; p1 <- exists_; p2 <- exists_; return (b, p1, p2) count n = numberOfModels $ isValid `fmap` mapM (const act) [1..(n::Int)] slv n = rearrange `fmap` allSat (isValid `fmap` mapM (const act) [1..(n::Int)])- rearrange (AllSatResult (b1, b2, b3, ms)) = AllSatResult (b1, b2, b3, sortOn (show . SatResult) ms)++ rearrange r@AllSatResult{allSatResults = ms} = r { allSatResults = sortOn (show . SatResult) ms }
+ SBVTestSuite/TestSuite/Queries/DSat.hs view
@@ -0,0 +1,69 @@+-----------------------------------------------------------------------------+-- |+-- Module : TestSuite.Queries.DSat+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Testing dsat value extraction+-----------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wall -Werror #-}++module TestSuite.Queries.DSat (tests) where++import Data.SBV.Control++import Utils.SBVTestFramework++-- Test suite+tests :: TestTree+tests =+ testGroup "Basics.Query.DSat"+ [ goldenCapturedIO "dsat01" testQuery+ ]++testQuery :: FilePath -> IO ()+testQuery rf = do r <- runSMTWith dReal{verbose=True, redirectVerbose=Just rf} fv+ appendFile rf ("\n FINAL:" ++ show r ++ "\nDONE!\n")++fv :: Symbolic (Maybe String, [AlgReal], [RationalCV], [Integer], [Bool])+fv = do a0 <- sReal "a0"+ i0 <- sInteger "i0"+ b0 <- sBool "b0"++ constrain $ a0 .> 2+ constrain $ a0 .<= 5++ query $ do a1 :: SReal <- freshVar "a1"+ i1 :: SInteger <- freshVar "i1"+ b1 :: SBool <- freshVar "b1"++ constrain $ a1 .> 3+ constrain $ a1 .<= 12++ cs <- checkSat++ case cs of+ DSat p -> do va0 <- getValue a0+ va1 <- getValue a1+ vi0 <- getValue i0+ vi1 <- getValue i1+ vb0 <- getValue b0+ vb1 <- getValue b1++ let rva0 = algRealToRational va0+ rva1 = algRealToRational va1++ check r = case r of+ RatInterval lo hi -> if realPoint lo <= realPoint hi+ then r+ else error $ "Bounds violated for: " ++ show r+ _ -> r++ pure (p, [va0, va1], map check [rva0, rva1], [vi0, vi1], [vb0, vb1])++ _ -> error "didn't expect non-DSat here!"
SBVTestSuite/TestSuite/Queries/Enums.hs view
@@ -33,7 +33,6 @@ [ goldenCapturedIO "qEnum1" $ \rf -> runSMTWith defaultSMTCfg{verbose=True, redirectVerbose=Just rf} test ] -type SBinOp = SBV BinOp test :: Symbolic () test = do p :: SBinOp <- free "p"
SBVTestSuite/TestSuite/Queries/FreshVars.hs view
@@ -28,6 +28,9 @@ data BinOp = Plus | Minus | Times mkSymbolicEnumeration ''BinOp +_unused :: a+_unused = error "stop GHC from complaining unused names" sPlus sMinus sTimes+ -- Test suite tests :: TestTree tests =@@ -39,8 +42,6 @@ testQuery rf = do r <- runSMTWith defaultSMTCfg{verbose=True, redirectVerbose=Just rf} fv appendFile rf ("\n FINAL:" ++ show (SatResult r) ++ "\nDONE!\n") -type SBinOp = SBV BinOp- fv :: Symbolic SMTResult fv = do a <- sInteger "a" @@ -77,7 +78,7 @@ constrain $ vDouble .== 10 constrain $ vReal .== 11 constrain $ vInteger .== 12- constrain $ vBinOp .== literal Plus+ constrain $ vBinOp .== sPlus vSArray :: SArray Integer Integer <- freshArray "vSArray" Nothing vFArray :: SFunArray Bool Char <- freshArray "vFArray" Nothing
SBVTestSuite/TestSuite/Queries/Int_ABC.hs view
@@ -45,8 +45,9 @@ cs <- checkSat case cs of- Unk -> getInfo ReasonUnknown >>= error . show- Unsat -> error "Got UNSAT!"- Sat -> do -- Query a/b- res <- (,) <$> getValue a <*> getValue b- unless (res == (1, 1)) $ error $ "Didn't get (1,1): " ++ show res+ Unk -> getInfo ReasonUnknown >>= error . show+ Unsat -> error "Got UNSAT!"+ DSat{} -> error "Got Delta-satisfiable!"+ Sat -> do -- Query a/b+ res <- (,) <$> getValue a <*> getValue b+ unless (res == (1, 1)) $ error $ "Didn't get (1,1): " ++ show res
+ SBVTestSuite/TestSuite/Queries/Tables.hs view
@@ -0,0 +1,170 @@+-----------------------------------------------------------------------------+-- |+-- Module : TestSuite.Queries.Tables+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer: erkokl@gmail.com+-- Stability : experimental+--+-- Test case for https://github.com/LeventErkok/sbv/issues/539+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}++module TestSuite.Queries.Tables (tests) where++import GHC.Generics hiding (S)+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.State++import qualified Data.SBV.Maybe as SBV+import qualified Data.SBV.Tuple as SBV++import Data.SBV.Control+import Utils.SBVTestFramework++-- Test suite+tests :: TestTree+tests =+ testGroup "Basics.Tables"+ [ goldenCapturedIO "queryTables" testTables+ ]++testTables :: FilePath -> IO ()+testTables rf = do r <- runSMTWith defaultSMTCfg{verbose=True, redirectVerbose=Just rf} tables+ appendFile rf ("\n FINAL:" ++ show r ++ "\nDONE!\n")++data S = S { currentRoom :: SInt16+ , itemLocations :: [SInt16]+ } deriving (Show, Generic, Mergeable)++tables :: Symbolic [(Int16, Int16)]+tables = do+ let theGame = Game+ { gameDictSize = 1+ , gameItems = [7]+ , gameRooms = [[0],[2]]+ }+++ let genWord = do+ word <- freshVar_+ constrain $ 0 .<= word .&& word .< literal (gameDictSize theGame)+ return word+ genCmd = do+ verb <- genWord+ noun <- genWord+ return $ SBV.tuple (verb, noun)+ query $ do+ let s0 = initState theGame++ let step cmd = do+ let (verb, noun) = SBV.untuple cmd+ runGame theGame $ stepPlayer (verb, noun)++ cmd1 <- genCmd+ push 1+ (f1, s1) <- return $ runState (step cmd1) s0+ constrain f1+ _cs <- checkSat+ pop 1++ cmd2 <- genCmd+ push 1+ (f2, _s2) <- return $ runState (step cmd2) s1+ constrain f2+ _cs <- checkSat++ mapM getValue [cmd1, cmd2]++instance forall a. Mergeable a => Mergeable (Identity a) where+ symbolicMerge force cond thn els = Identity $ symbolicMerge force cond (runIdentity thn) (runIdentity els)++instance (Mergeable a, forall b. Mergeable b => Mergeable (m b)) => Mergeable (ReaderT r m a) where+ symbolicMerge force cond thn els = ReaderT $ symbolicMerge force cond (runReaderT thn) (runReaderT els)++instance (Mergeable s, Mergeable a, forall b. Mergeable b => Mergeable (m b)) => Mergeable (StateT s m a) where+ symbolicMerge force cond thn els = StateT $ symbolicMerge force cond (runStateT thn) (runStateT els)++data Game = Game { gameDictSize :: Int16+ , gameItems :: [Int16]+ , gameRooms :: [[Int16]]+ } deriving Show++type SInput = (SInt16, SInt16)++type Engine = ReaderT Game (State S)++carried :: Int16+carried = 255++initState :: Game -> S+initState _game = S { currentRoom = 0+ , itemLocations = [1]+ }++runGame :: Game -> Engine a -> State S a+runGame game act = runReaderT act game++stepPlayer :: SInput -> Engine SBool+stepPlayer (v, n) = do+ perform (v, n)+ finished++finished :: Engine SBool+finished = do+ locs <- gets itemLocations+ return $ map (.== 1) locs `pbExactly` 1++perform :: SInput -> Engine ()+perform (verb, noun) = sCase verb (return ())+ [ (1, builtin_go)+ , (10, builtin_get)+ ]+ where+ builtin_go = sWhen (1 .<= noun .&& noun .<= 6) $ do+ let dir = noun - 1+ here <- gets currentRoom+ exits <- asks $ (.!! here) . map (map literal) . gameRooms+ let newRoom = select exits 0 dir+ sUnless (newRoom .== 0) $ modify $ \s ->+ s{ currentRoom = newRoom }++ builtin_get = do+ locs <- gets itemLocations+ here <- gets currentRoom+ items <- asks gameItems+ let item = SBV.fromMaybe (-1) $ sFindIndex (\nm -> noun .== literal nm) items+ sWhen (select locs (-1) item .== here) $ modify $ \s ->+ s{ itemLocations = replaceAt item (literal carried) (itemLocations s) }++(.!!) :: (Mergeable a) => [a] -> SInt16 -> a+xs .!! i = case xs of+ [] -> error "(.!) : empty array"+ lst@(x:_) -> select lst x i++replaceAt :: (Mergeable a) => SInt16 -> a -> [a] -> [a]+replaceAt i x' = zipWith (\j x -> ite (i .== literal j) x' x) [0..]++sCase :: (Mergeable a) => SInt16 -> a -> [(Int16, a)] -> a+sCase x def = go+ where+ go [] = def+ go ((k,v):kvs) = ite (x .== literal k) v (go kvs)++sUnless :: (Monad m, Mergeable (m ())) => SBool -> m () -> m ()+sUnless b = ite b (return ())++sWhen :: (Monad m, Mergeable (m ())) => SBool -> m () -> m ()+sWhen b act = ite b act (return ())++sFindIndex :: (a -> SBool) -> [a] -> SMaybe Int16+sFindIndex p = go 0+ where+ go _ [] = SBV.sNothing+ go i (x:xs) = ite (p x) (SBV.sJust i) (go (i + 1) xs)
SBVTestSuite/TestSuite/Queries/UISat.hs view
@@ -40,9 +40,10 @@ query $ do cs <- checkSat unless (cs == csExpected) $ case cs of- Unsat -> error "Failed! Expected Sat, got UNSAT"- Sat -> getModel >>= \r -> error $ "Failed! Expected Unsat, got SAT:\n" ++ show (SatResult (Satisfiable cfg r))- Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" ++ show r+ Unsat -> error "Failed! Expected Sat, got UNSAT"+ DSat{} -> error "Failed! Expected Sat, got delta-satisfiable!"+ Sat -> getModel >>= \r -> error $ "Failed! Expected Unsat, got SAT:\n" ++ show (SatResult (Satisfiable cfg r))+ Unk -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" ++ show r when (cs == Sat) $ getModel >>= \m -> io $ appendFile rf $ "\nMODEL: " ++ show m ++ "\nDONE."
SBVTestSuite/TestSuite/Queries/Uninterpreted.hs view
@@ -9,18 +9,22 @@ -- Testing uninterpreted value extraction ----------------------------------------------------------------------------- +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -Werror #-} module TestSuite.Queries.Uninterpreted where -import Data.Generics import Data.SBV.Control- import Utils.SBVTestFramework +data L = A | B+mkSymbolicEnumeration ''L+ -- Test suite tests :: TestTree tests =@@ -33,14 +37,8 @@ appendFile rf ("\n FINAL:" ++ r ++ "\nDONE!\n") -data L = A | B ()- deriving (Eq, Ord, Show, Read, Data)--instance SymVal L-instance HasKind L- unint1 :: Symbolic String unint1 = do (x :: SBV L) <- free_ query $ do _ <- checkSat- getUninterpretedValue x+ show <$> getValue x
SBVTestSuite/TestSuite/Uninterpreted/Axioms.hs view
@@ -11,16 +11,23 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -Werror #-} module TestSuite.Uninterpreted.Axioms(tests) where import Utils.SBVTestFramework-import Data.Generics import Data.SBV.Control +data Bitstring+mkUninterpretedSort ''Bitstring++data B+mkUninterpretedSort ''B+ tests :: TestTree tests = testGroup "Uninterpreted.Axioms"@@ -28,10 +35,6 @@ , goldenCapturedIO "unint-axioms-query" testQuery ] --- Example provided by Thomas DuBuisson:-newtype Bitstring = Bitstring () deriving (Eq, Ord, Show, Read, Data, SymVal, HasKind)-type SBitstring = SBV Bitstring- a :: SBitstring -> SBool a = uninterpret "a" @@ -51,9 +54,6 @@ constrain $ a p constrain $ a k return $ a (e k p)--newtype B = B () deriving (Eq, Ord, Show, Read, Data, SymVal, HasKind)-type SB = SBV B testQuery :: FilePath -> IO () testQuery rf = do r <- runSMTWith defaultSMTCfg{verbose=True, redirectVerbose=Just rf} t
SBVTestSuite/TestSuite/Uninterpreted/Sort.hs view
@@ -9,16 +9,21 @@ -- Test suite for uninterpreted sorts ----------------------------------------------------------------------------- +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall -Werror #-} module TestSuite.Uninterpreted.Sort(tests) where import Utils.SBVTestFramework-import Data.Generics +data L+mkUninterpretedSort ''L+ tests :: TestTree tests = testGroup "Uninterpreted.Sort"@@ -26,15 +31,7 @@ (assert . (==4) . length . (extractModels :: AllSatResult -> [L]) =<< allSat p0) ] -data L = Nil | Cons Int L deriving (Eq, Ord, Data, Read, Show)-instance SymVal L-instance HasKind L-instance SatModel L where- parseCVs = undefined -- make GHC shut up about the missing method, we won't actually call it--type UList = SBV L--len :: UList -> SInteger+len :: SL -> SInteger len = uninterpret "len" p0 :: Symbolic SBool
SBVTestSuite/Utils/SBVTestFramework.hs view
@@ -124,14 +124,19 @@ -- that was hit, or the search was stopped because the -- solver said 'Unknown' at some point. numberOfModels :: Provable a => a -> IO Int-numberOfModels p = do AllSatResult (maxHit, _, unk, rs) <- allSat p+numberOfModels p = do AllSatResult { allSatMaxModelCountReached = maxHit+ , allSatSolverReturnedUnknown = unk+ , allSatSolverReturnedDSat = ds+ , allSatResults = rs+ } <- allSat p let l = length rs- case (unk, maxHit) of- (True, _) -> error $ "Data.SBV.numberOfModels: Search was stopped because solver said 'Unknown'. At this point, we saw: " ++ show l ++ " model(s)."- (_, True) -> error $ "Data.SBV.numberOfModels: Search was stopped because the user-specified max-model count was hit at " ++ show l ++ " model(s)."- _ -> return l+ case (unk, ds, maxHit) of+ (True, _, _) -> error $ "Data.SBV.numberOfModels: Search was stopped because solver said 'Unknown'. At this point, we saw: " ++ show l ++ " model(s)."+ (_, True, _) -> error $ "Data.SBV.numberOfModels: Search was stopped because solver returned 'delta satisfiable'. At this point, we saw: " ++ show l ++ " model(s)."+ (_, _, True) -> error $ "Data.SBV.numberOfModels: Search was stopped because the user-specified max-model count was hit at " ++ show l ++ " model(s)."+ _ -> return l --- | Symbolicly run a SAT instance using the default config+-- | Symbolically run a SAT instance using the default config runSAT :: Symbolic a -> IO Result runSAT cmp = snd <$> runSymbolic (SMTMode QueryInternal ISetup True defaultSMTCfg) cmp @@ -180,10 +185,11 @@ query $ do cs <- checkSat case cs of- Unk -> return (pre, Left "Unexpected: Solver responded Unknown!")- Unsat -> return (pre, Left "Unexpected: Solver responded Unsatisfiable!")- Sat -> do r <- getValue res- return (pre, Right r)+ Unk -> return (pre, Left "Unexpected: Solver responded Unknown!")+ Unsat -> return (pre, Left "Unexpected: Solver responded Unsatisfiable!")+ DSat{} -> return (pre, Left "Unexpected: Solver responded Delta-satisfiable!")+ Sat -> do r <- getValue res+ return (pre, Right r) let getCV vnm (SBV (SVal _ (Left c))) = (vnm, c) getCV vnm (SBV (SVal k _ )) = error $ "qc2.getCV: Impossible happened, non-CV value while extracting: " ++ show (vnm, k)@@ -237,10 +243,11 @@ query $ do cs <- checkSat case cs of- Unk -> return (pre, Left "Unexpected: Solver responded Unknown!")- Unsat -> return (pre, Left "Unexpected: Solver responded Unsatisfiable!")- Sat -> do r <- getValue res- return (pre, Right r)+ Unk -> return (pre, Left "Unexpected: Solver responded Unknown!")+ Unsat -> return (pre, Left "Unexpected: Solver responded Unsatisfiable!")+ DSat{} -> return (pre, Left "Unexpected: Solver responded Delta-satisfiable!")+ Sat -> do r <- getValue res+ return (pre, Right r) let getCV vnm (SBV (SVal _ (Left c))) = (vnm, c) getCV vnm (SBV (SVal k _ )) = error $ "qc2.getCV: Impossible happened, non-CV value while extracting: " ++ show (vnm, k)
sbv.cabal view
@@ -1,25 +1,28 @@-Name: sbv-Version: 8.7-Category: Formal Methods, Theorem Provers, Bit vectors, Symbolic Computation, Math, SMT-Synopsis: SMT Based Verification: Symbolic Haskell theorem prover using SMT solving.-Description: Express properties about Haskell programs and automatically prove them using SMT+Cabal-Version: 2.2++Name : sbv+Version : 8.8+Category : Formal Methods, Theorem Provers, Bit vectors, Symbolic Computation, Math, SMT+Synopsis : SMT Based Verification: Symbolic Haskell theorem prover using SMT solving.+Description : Express properties about Haskell programs and automatically prove them using SMT (Satisfiability Modulo Theories) solvers. . For details, please see: <http://leventerkok.github.com/sbv/> -Copyright: Levent Erkok, 2010-2020-License: BSD3-License-file: LICENSE-Stability: Experimental-Author: Levent Erkok-Homepage: http://leventerkok.github.com/sbv/-Bug-reports: http://github.com/LeventErkok/sbv/issues-Maintainer: Levent Erkok (erkokl@gmail.com)-Build-Type: Simple-Cabal-Version: 1.14-Data-Files: SBVTestSuite/GoldFiles/*.gold-Extra-Source-Files: INSTALL, README.md, COPYRIGHT, CHANGES.md+Copyright : Levent Erkok, 2010-2020+License : BSD-3-Clause+License-file : LICENSE+Stability : Experimental+Author : Levent Erkok+Homepage : http://leventerkok.github.com/sbv/+Bug-reports : http://github.com/LeventErkok/sbv/issues+Maintainer : Levent Erkok (erkokl@gmail.com)+Build-Type : Simple+Data-Files : SBVTestSuite/GoldFiles/*.gold+Extra-Source-Files : INSTALL, README.md, COPYRIGHT, CHANGES.md +Tested-With : GHC==8.10.2, GHC==8.8.4+ source-repository head type: git location: git://github.com/LeventErkok/sbv.git@@ -28,13 +31,20 @@ -- we use this flag to skip that build. flag skipHLintTester description: Do not build the HLint tester- default: False- manual: True+ default : False+ manual : True +common common-settings+ default-language: Haskell2010+ ghc-options : -Wall -O2+ build-depends : base >= 4.11 && < 5++ if impl(ghc >= 8.10.1)+ ghc-options : -Wunused-packages+ Library- default-language: Haskell2010- ghc-options : -Wall -O2- other-extensions: BangPatterns+ import : common-settings+ other-extensions : BangPatterns CPP ConstraintKinds DataKinds@@ -70,12 +80,10 @@ TypeSynonymInstances UndecidableInstances ViewPatterns- Build-Depends : base >= 4.11 && < 5- , crackNum >= 2.3+ build-depends : crackNum , QuickCheck, template-haskell , array, async, containers, deepseq, directory, filepath, time , pretty, process, mtl, random, syb, transformers- , generic-deriving Exposed-modules : Data.SBV , Data.SBV.Control , Data.SBV.Dynamic@@ -116,6 +124,7 @@ , Documentation.SBV.Examples.Crypto.AES , Documentation.SBV.Examples.Crypto.RC4 , Documentation.SBV.Examples.Crypto.SHA+ , Documentation.SBV.Examples.DeltaSat.DeltaSat , Documentation.SBV.Examples.Existentials.CRCPolynomial , Documentation.SBV.Examples.Existentials.Diophantine , Documentation.SBV.Examples.Lists.Fibonacci@@ -180,7 +189,7 @@ , Documentation.SBV.Examples.Uninterpreted.Shannon , Documentation.SBV.Examples.Uninterpreted.Sort , Documentation.SBV.Examples.Uninterpreted.UISortAllSat- Other-modules : Data.SBV.Client+ other-modules : Data.SBV.Client , Data.SBV.Client.BaseIO , Data.SBV.Core.AlgReals , Data.SBV.Core.Concrete@@ -206,6 +215,7 @@ , Data.SBV.Provers.Boolector , Data.SBV.Provers.CVC4 , Data.SBV.Provers.Yices+ , Data.SBV.Provers.DReal , Data.SBV.Provers.Z3 , Data.SBV.Provers.MathSAT , Data.SBV.Provers.ABC@@ -217,10 +227,10 @@ , Data.SBV.Utils.SExpr Test-Suite SBVTest- type : exitcode-stdio-1.0- default-language: Haskell2010- ghc-options : -Wall -with-rtsopts=-K64m -O2- other-extensions: DataKinds+ import : common-settings+ type : exitcode-stdio-1.0+ ghc-options : -with-rtsopts=-K64m+ other-extensions : DataKinds DeriveAnyClass DeriveDataTypeable FlexibleContexts@@ -234,15 +244,16 @@ TemplateHaskell TupleSections TypeApplications- Build-depends : base >= 4.11, filepath, syb, crackNum >= 2.3- , sbv, directory, random, mtl, containers- , template-haskell, bytestring, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, QuickCheck- Hs-Source-Dirs : SBVTestSuite+ build-depends : filepath, crackNum+ , sbv, directory, random, mtl, containers+ , bytestring, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, QuickCheck+ hs-source-dirs : SBVTestSuite main-is : SBVTest.hs- Other-modules : Utils.SBVTestFramework+ other-modules : Utils.SBVTestFramework , TestSuite.Arrays.InitVals , TestSuite.Arrays.Memory , TestSuite.Arrays.Query+ , TestSuite.Arrays.Caching , TestSuite.Basics.AllSat , TestSuite.Basics.ArithNoSolver , TestSuite.Basics.ArithSolver@@ -317,6 +328,7 @@ , TestSuite.Puzzles.U2Bridge , TestSuite.Queries.BasicQuery , TestSuite.Queries.BadOption+ , TestSuite.Queries.DSat , TestSuite.Queries.Enums , TestSuite.Queries.FreshVars , TestSuite.Queries.Int_ABC@@ -329,6 +341,7 @@ , TestSuite.Queries.Lists , TestSuite.Queries.Strings , TestSuite.Queries.Sums+ , TestSuite.Queries.Tables , TestSuite.Queries.Tuples , TestSuite.Queries.Uninterpreted , TestSuite.Queries.UISat@@ -341,11 +354,17 @@ , TestSuite.Uninterpreted.Sort , TestSuite.Uninterpreted.Uninterpreted +Test-Suite SBVConnections+ import : common-settings+ build-depends : sbv+ hs-source-dirs : SBVTestSuite+ main-is : SBVConnectionTest.hs+ type: exitcode-stdio-1.0+ Test-Suite SBVDocTest- Build-Depends: base, directory, filepath, random- , doctest, Glob, bytestring, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, mtl, QuickCheck, random- , sbv- ghc-options : -Wall -O2+ import : common-settings+ build-depends : base, directory, filepath, random+ , doctest, Glob, bytestring, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, mtl, QuickCheck, random, sbv other-extensions: DataKinds DeriveAnyClass DeriveDataTypeable@@ -360,19 +379,19 @@ TemplateHaskell TupleSections TypeApplications- default-language: Haskell2010- Hs-Source-Dirs : SBVTestSuite+ hs-source-dirs : SBVTestSuite main-is: SBVDocTest.hs- Other-modules : Utils.SBVTestFramework+ other-modules : Utils.SBVTestFramework type: exitcode-stdio-1.0 Test-Suite SBVHLint+ import : common-settings+ if flag(skipHLintTester) buildable: False- build-depends: base, directory, filepath, random- , hlint, bytestring, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, mtl, QuickCheck- , sbv- ghc-options : -Wall -O2++ build-depends : base, directory, filepath, random+ , hlint, bytestring, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, mtl, QuickCheck, sbv other-extensions: DataKinds DeriveAnyClass DeriveDataTypeable@@ -387,16 +406,120 @@ TemplateHaskell TupleSections TypeApplications- default-language: Haskell2010- hs-source-dirs: SBVTestSuite- Other-modules : Utils.SBVTestFramework- main-is: SBVHLint.hs- type: exitcode-stdio-1.0+ hs-source-dirs : SBVTestSuite+ other-modules : Utils.SBVTestFramework+ main-is : SBVHLint.hs+ type : exitcode-stdio-1.0 +Benchmark SBVBenchmark+ import : common-settings+ type : exitcode-stdio-1.0+ ghc-options : -with-rtsopts=-K64m+ other-extensions: DataKinds+ DeriveAnyClass+ DeriveDataTypeable+ FlexibleContexts+ GeneralizedNewtypeDeriving+ OverloadedLists+ OverloadedStrings+ Rank2Types+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ build-depends : filepath, syb, crackNum+ , sbv, directory, random, mtl, containers, time+ , gauge, process, deepseq, bench-show, silently+ hs-source-dirs : SBVBenchSuite+ main-is : SBVBenchmark.hs+ other-modules : Utils.SBVBenchFramework+ , BenchSuite.Bench.Bench+ , BenchSuite.Puzzles.Birthday+ , BenchSuite.Puzzles.Coins+ , BenchSuite.Puzzles.Counts+ , BenchSuite.Puzzles.DogCatMouse+ , BenchSuite.Puzzles.Euler185+ , BenchSuite.Puzzles.Garden+ , BenchSuite.Puzzles.LadyAndTigers+ , BenchSuite.Puzzles.MagicSquare+ , BenchSuite.Puzzles.NQueens+ , BenchSuite.Puzzles.SendMoreMoney+ , BenchSuite.Puzzles.Sudoku+ , BenchSuite.Puzzles.U2Bridge+ , BenchSuite.BitPrecise.BitTricks+ , BenchSuite.BitPrecise.BrokenSearch+ , BenchSuite.BitPrecise.Legato+ , BenchSuite.BitPrecise.MergeSort+ , BenchSuite.BitPrecise.MultMask+ , BenchSuite.BitPrecise.PrefixSum+ , BenchSuite.Queries.AllSat+ , BenchSuite.Queries.CaseSplit+ , BenchSuite.Queries.Concurrency+ , BenchSuite.Queries.Enums+ , BenchSuite.Queries.FourFours+ , BenchSuite.Queries.GuessNumber+ , BenchSuite.Queries.Interpolants+ , BenchSuite.Queries.UnsatCore+ , BenchSuite.WeakestPreconditions.Instances+ , BenchSuite.WeakestPreconditions.Append+ , BenchSuite.WeakestPreconditions.Basics+ , BenchSuite.WeakestPreconditions.Fib+ , BenchSuite.WeakestPreconditions.GCD+ , BenchSuite.WeakestPreconditions.IntDiv+ , BenchSuite.WeakestPreconditions.IntSqrt+ , BenchSuite.WeakestPreconditions.Length+ , BenchSuite.WeakestPreconditions.Sum+ , BenchSuite.Optimization.Instances+ , BenchSuite.Optimization.Enumerate+ , BenchSuite.Optimization.ExtField+ , BenchSuite.Optimization.LinearOpt+ , BenchSuite.Optimization.Production+ , BenchSuite.Optimization.VM+ , BenchSuite.Uninterpreted.AUF+ , BenchSuite.Uninterpreted.Deduce+ , BenchSuite.Uninterpreted.Function+ , BenchSuite.Uninterpreted.Multiply+ , BenchSuite.Uninterpreted.Shannon+ , BenchSuite.Uninterpreted.Sort+ , BenchSuite.Uninterpreted.UISortAllSat+ , BenchSuite.ProofTools.BMC+ , BenchSuite.ProofTools.Fibonacci+ , BenchSuite.ProofTools.Strengthen+ , BenchSuite.ProofTools.Sum+ , BenchSuite.CodeGeneration.AddSub+ , BenchSuite.CodeGeneration.CRC_USB5+ , BenchSuite.CodeGeneration.Fibonacci+ , BenchSuite.CodeGeneration.GCD+ , BenchSuite.CodeGeneration.PopulationCount+ , BenchSuite.CodeGeneration.Uninterpreted+ , BenchSuite.Crypto.AES+ , BenchSuite.Crypto.RC4+ , BenchSuite.Crypto.SHA+ , BenchSuite.Misc.Auxiliary+ , BenchSuite.Misc.Enumerate+ , BenchSuite.Misc.Floating+ , BenchSuite.Misc.ModelExtract+ , BenchSuite.Misc.Newtypes+ , BenchSuite.Misc.NoDiv0+ , BenchSuite.Misc.Polynomials+ , BenchSuite.Misc.SetAlgebra+ , BenchSuite.Misc.SoftConstrain+ , BenchSuite.Misc.Tuple+ , BenchSuite.Lists.BoundedMutex+ , BenchSuite.Lists.Fibonacci+ , BenchSuite.Lists.Nested+ , BenchSuite.Strings.RegexCrossword+ , BenchSuite.Strings.SQLInjection+ , BenchSuite.Existentials.CRCPolynomial+ , BenchSuite.Existentials.Diophantine+ , BenchSuite.Transformers.SymbolicEval+ Benchmark SBVBench+ import : common-settings type : exitcode-stdio-1.0- default-language: Haskell2010- ghc-options : -with-rtsopts=-K64m -O2+ ghc-options : -with-rtsopts=-K64m other-extensions: DataKinds DeriveAnyClass DeriveDataTypeable@@ -411,12 +534,12 @@ TemplateHaskell TupleSections TypeApplications- Build-depends : base >= 4.11, filepath, syb, crackNum >= 2.3- , sbv, directory, random, mtl, containers- , gauge, process, deepseq, silently- Hs-Source-Dirs : SBVBenchSuite+ build-depends : filepath, syb, crackNum+ , sbv, directory, random, mtl, containers, time+ , gauge, process, deepseq, silently, bench-show+ hs-source-dirs : SBVBenchSuite main-is : SBVBench.hs- Other-modules : Utils.SBVBenchFramework+ other-modules : Utils.SBVBenchFramework , BenchSuite.Bench.Bench , BenchSuite.Puzzles.Birthday , BenchSuite.Puzzles.Coins