packages feed

sbv 5.15 → 6.0

raw patch · 98 files changed

+7802/−6335 lines, 98 files

Files

CHANGES.md view
@@ -1,8 +1,122 @@ * Hackage: <http://hackage.haskell.org/package/sbv> * GitHub:  <http://leventerkok.github.com/sbv/> -* Latest Hackage released version: 5.15, 2017-01-30+* Latest Hackage released version: 6.0, 2017-05-07 +### Version 6.0, 2017-05-07++  * This is a backwards compatibility breaking release, hence the major version+    bump from 5.15 to 6.0:+     +        * Most of existing code should work with no changes+	* Old code relying on some features might require extra imports,+	  since we no longer export some functionality directly from Data.SBV.+          This was done in order to reduce the number of exported items to+          avoid extra clutter.+        * Old optimization features are removed, as the new and much improved+	  capabilities should be used instead.++  * The next two bullets cover new features in SBV regarding optimization, based+    on the capabilities of the z3 SMT solver. With this release SBV gains the+    capability optimize objectives, and solve MaxSAT problems; by appropriately+    employing the corresponding capabilities in z3. A good review of these features+    as implemented by Z3, and thus what is available in SBV is given in this+    paper: http://www.easychair.org/publications/download/Z_-_Maximal_Satisfaction_with_Z3+++  * SBV now allows for  real or integral valued metrics. Goals can be lexicographically+    (default), independently, or pareto-front optimized. Currently, only the z3 backend+    supports optimization routines.++    Optimization can be done over bit-vector, real, and integer goals. The relevant+    functions are:++    	* `minimize`: Minimize a given arithmetic goal+    	* `maximize`: Minimize a given arithmetic goal++    For instance, a call of the form +    +         minimize "name-of-goal" $ x + 2*y++    Minimizes the arithmetic goal x+2*y, where x and y can be bit-vectors, reals,+    or integers. Such goals will be lexicographicly optimized, i.e., in the order+    given. If there are multiple goals, then user can also ask for independent+    optimization results, or pareto-fronts.++    Once the objectives are given, a top level call to `optimize` (similar to `prove`+    and `sat`) performs the optimization.++  * SBV now implements soft-asserts. A soft assertion is a hint to the SMT solver that+    we would like a particular condition to hold if *possible*. That is, if there is+    a solution satisfying it, then we would like it to hold. However, if the set of+    constraints is unsatisfiable, then a soft-assertion can be violated by incurring+    a user-given numeric penalty to satisfy the remaining constraints. The solver then+    tries to minimize the penalty, i.e., satisfy as many of the soft-asserts as possible+    such that the total penalty for those that are not satisfied is minimized.+    +    Note that `assertSoft` works well with optimization goals (minimize/maximize etc.),+    and are most useful when we are optimizing a metric and thus some of the constraints+    can be relaxed with a penalty to obtain a good solution.++  * SBV no longer provides the old optimization routines, based on iterative and quantifier+    based methods. Those methods were rarely used, and are now superseded by the above+    mechanism. If the old code is needed, please contact for help: They can be resurrected+    in your own code if absolutely necessary.++  * SBV now implements tactics, which allow the user to navigate the proof process.+    This is an advanced feature that most users will have no need of, but can become+    handy when dealing with complicated problems. Users can, for instance, implement+    case-splitting in a proof to guide the underlying solver through. Here is the list+    of tactics implemented:++       * `CaseSplit`         : Case-split, with implicit coverage. Bool says whether we should be verbose.+       * `CheckCaseVacuity`  : Should the case-splits be checked for vacuity? (Default: True.)+       * `ParallelCase`      : Run case-splits in parallel. (Default: Sequential.)+       * `CheckConstrVacuity`: Should constraints be checked for vacuity? (Default: False.)+       * `StopAfter`         : Time-out given to solver, in seconds.+       * `CheckUsing`        : Invoke with check-sat-using command, instead of check-sat+       * `UseLogic`          : Use this logic, a custom one can be specified too+       * `UseSolver`         : Use this solver (z3, yices, etc.)+       * `OptimizePriority`  : Specify priority for optimization: Lexicographic (default), Independent, or Pareto.++  * Name-space clean-up. The following modules are no longer automatically exported+    from Data.SBV:++	- `Data.SBV.Tools.ExpectedValue` (computing with expected values)+	- `Data.SBV.Tools.GenTest` (test case generation)+	- `Data.SBV.Tools.Polynomial` (polynomial arithmetic, CRCs etc.)+	- `Data.SBV.Tools.STree` (full symbolic binary trees)+ +    To use the functionality of these modules, users must now explicitly import the corresponding+    module. Not other changes should be needed other than the explicit import.++  * Changed the signatures of:++          isSatisfiableInCurrentPath :: SBool -> Symbolic Bool+        svIsSatisfiableInCurrentPath :: SVal  -> Symbolic Bool++    to:++          isSatisfiableInCurrentPath :: SBool -> Symbolic (Maybe SatResult)+        svIsSatisfiableInCurrentPath :: SVal  -> Symbolic (Maybe SatResult)++    which returns the result in case of SAT. This is more useful than before. This is+    backwards-compatibility breaking, but is more useful. (Requested by Jared Ziegler.)++  * Add instance `Provable (Symbolic ())`, which simply stands for returning true+    for proof/sat purposes. This allows for simpler coding, as constrain/minimize/maximize+    calls (which return unit) can now be directly sat/prove processed, without needing+    a final call to return at the end.++  * Add type synonym Goal (for "Symbolic ()"), in order to simplify type signatures++  * SBV now properly adds check-sat commands and other directives in debugging output.++  * New examples:+      - Data.SBV.Examples.Optimization.LinearOpt: Simple linear-optimization example.+      - Data.SBV.Examples.Optimization.Production: Scheduling machines in a shop+      - Data.SBV.Examples.Optimization.VM: Scheduling virtual-machines in a data-center+     ### Version 5.15, 2017-01-30    * Bump up dependency on CrackNum >= 1.9, to get access to hexadecimal floats.
Data/SBV.hs view
@@ -105,7 +105,8 @@ -- get in touch if there is a solver you'd like to see included. --------------------------------------------------------------------------------- -{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE    FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Data.SBV (   -- * Programming with symbolic values@@ -142,8 +143,6 @@   , SBV   -- *** Arrays of symbolic values   , SymArray(..), SArray, SFunArray, mkSFunArray-  -- *** Full binary trees-  , STree, readSTree, writeSTree, mkSTree   -- ** Operations on symbolic values   -- *** Word level   , sTestBit, sExtractBits, sPopCount, sShiftLeft, sShiftRight, sRotateLeft, sRotateRight, sSignedShiftArithRight, sFromIntegral, setBitTo, oneIf@@ -158,8 +157,7 @@   , blastBE, blastLE, FromBits(..)   -- *** Splitting, joining, and extending   , Splittable(..)-  -- ** Polynomial arithmetic and CRCs-  , Polynomial(..), crcBV, crc+   -- ** Conditionals: Mergeable values   , Mergeable(..), ite, iteLazy   -- ** Symbolic equality@@ -188,9 +186,9 @@    -- * Properties, proofs, satisfiability, and safety   -- $proveIntro--  -- ** Predicates-  , Predicate, Provable(..), Equality(..)+  -- $noteOnNestedQuantifiers+  -- ** Predicates and Goals+  , Predicate, Goal, Provable(..), Equality(..)   -- ** Proving properties   , prove, proveWith, isTheorem, isTheoremWith   -- ** Checking satisfiability@@ -214,20 +212,21 @@   -- $multiIntro   , proveWithAll, proveWithAny, satWithAll, satWithAny -  -- * Optimization-  -- $optimizeIntro-  , minimize, maximize, optimize-  , minimizeWith, maximizeWith, optimizeWith+  -- * Tactics+  -- $tacticIntro+  , Tactic(..), tactic -  -- * Computing expected values-  , expectedValue, expectedValueWith+  -- * Optimization+  -- $optiIntro+  , OptimizeStyle(..), Penalty(..), Objective(..), minimize, maximize, assertSoft, optimize, optimizeWith+  , ExtCW(..), GeneralizedCW(..)    -- * Model extraction   -- $modelExtraction    -- ** Inspecting proof results   -- $resultTypes-  , ThmResult(..), SatResult(..), SafeResult(..), AllSatResult(..), SMTResult(..)+  , ThmResult(..), SatResult(..), AllSatResult(..), SafeResult(..), OptimizeResult(..), SMTResult(..)    -- ** Programmable model extraction   -- $programmableExtraction@@ -235,8 +234,9 @@   , getModelDictionaries, getModelValues, getModelUninterpretedValues    -- * SMT Interface: Configurations and solvers-  , SMTConfig(..), SMTLibVersion(..), SMTLibLogic(..), Logic(..), OptimizeOpts(..), Solver(..), SMTSolver(..), boolector, cvc4, yices, z3, mathSAT, abc, defaultSolverConfig, sbvCurrentSolver, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers-  , Timing(..), TimedStep(..), TimingInfo, showTDiff+  , SMTConfig(..), SMTLibVersion(..), SMTLibLogic(..), Logic(..), Solver(..), SMTSolver(..)+  , boolector, cvc4, yices, z3, mathSAT, abc, defaultSolverConfig, sbvCurrentSolver, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers+  , Timing(..), TimedStep(..), TimingInfo, showTDiff, CW(..), HasKind(..), Kind(..), cwToBool    -- * Symbolic computations   , Symbolic, output, SymWord(..)@@ -244,9 +244,6 @@   -- * Getting SMT-Lib output (for offline analysis)   , compileToSMTLib, generateSMTBenchmarks -  -- * Test case generation-  , genTest, getTestValues, TestVectors, TestStyle(..), renderTest, CW(..), HasKind(..), Kind(..), cwToBool-   -- * Code generation from symbolic programs   -- $cCodeGeneration   , SBVCodeGen@@ -286,22 +283,21 @@ import Control.Concurrent.Async (async, waitAny, waitAnyCancel) import System.IO.Unsafe         (unsafeInterleaveIO)             -- only used safely! -import Data.SBV.BitVectors.AlgReals-import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.Model-import Data.SBV.BitVectors.Floating-import Data.SBV.BitVectors.PrettyNum-import Data.SBV.BitVectors.Splittable-import Data.SBV.BitVectors.STree+import Data.SBV.Core.AlgReals+import Data.SBV.Core.Data+import Data.SBV.Core.Model+import Data.SBV.Core.Floating+import Data.SBV.Core.Splittable+ import Data.SBV.Compilers.C import Data.SBV.Compilers.CodeGen+ import Data.SBV.Provers.Prover-import Data.SBV.Tools.GenTest-import Data.SBV.Tools.ExpectedValue-import Data.SBV.Tools.Optimize-import Data.SBV.Tools.Polynomial+ import Data.SBV.Utils.Boolean import Data.SBV.Utils.TDiff+import Data.SBV.Utils.PrettyNum+ import Data.Bits import Data.Int import Data.Ratio@@ -383,6 +379,14 @@ satWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, SatResult) satWithAny    = (`sbvWithAny` satWith) +-- If we get a program producing nothing (i.e., Symbolic ()), pretend it simply returns True.+-- This is useful since min/max calls and constraints will provide the context+instance Provable Goal where+  forAll_    a = forAll_    ((a >> return true) :: Predicate)+  forAll ns  a = forAll ns  ((a >> return true) :: Predicate)+  forSome_   a = forSome_   ((a >> return true) :: Predicate)+  forSome ns a = forSome ns ((a >> return true) :: Predicate)+ -- | Equality as a proof method. Allows for -- very concise construction of equivalence proofs, which is very typical in -- bit-precise proofs.@@ -527,47 +531,126 @@ -}  -{- $optimizeIntro-Symbolic optimization. A call of the form:+{- $tacticIntro+In certain cases, the prove/sat calls can benefit from user guidance, in terms of tactics. From a semantic view,+a tactic has no effect on the meaning of a predicate. It is merely guidance for SBV to guide the proof. It is+also used for executing cases in parallel ('ParallelCase'), or picking the logic to use ('UseLogic'), or+specifying a timeout ('StopAfter'). For most users, default values of these should suffice.+-} -    @minimize Quantified cost n valid@+{- $optiIntro+  SBV can optimize metric functions, i.e., those that generate both bounded 'SIntN', 'SWordN', and unbounded 'SInteger'+  types, along with those produce 'SReal's. That is, it can find models satisfying all the constraints while minimizing+  or maximizing user given metrics. Currently, optimization requires the use of the z3 SMT solver as the backend,+  and a good review of these features is given+  in this paper: <http://www.easychair.org/publications/download/Z_-_Maximal_Satisfaction_with_Z3>. -returns @Just xs@, such that:+  Goals can be lexicographically (default), independently, or pareto-front optimized. The relevant functions are: -   * @xs@ has precisely @n@ elements+      * 'minimize': Minimize a given arithmetic goal+      * 'maximize': Minimize a given arithmetic goal -   * @valid xs@ holds+  Goals can be optimized at a regular or an extended value: An extended value is either positive or negative infinity+  (for unbounded integers and reals) or positive or negative epsilon differential from a real value (for reals). -   * @cost xs@ is minimal. That is, for all sequences @ys@ that satisfy the first two criteria above, @cost xs .<= cost ys@ holds.+  For instance, a call of the form  -If there is no such sequence, then 'minimize' will return 'Nothing'.+       @ 'minimize' "name-of-goal" $ x + 2*y @ -The function 'maximize' is similar, except the comparator is '.>='. So the value returned has the largest cost (or value, in that case).+  minimizes the arithmetic goal @x+2*y@, where @x@ and @y@ can be signed\/unsigned bit-vectors, reals,+  or integers. -The function 'optimize' allows the user to give a custom comparison function.+== A simple example -The 'OptimizeOpts' argument controls how the optimization is done. If 'Quantified' is used, then the SBV optimization engine satisfies the following predicate:+  Here's an optimization example in action: -   @exists xs. forall ys. valid xs && (valid ys \`implies\` (cost xs \`cmp\` cost ys))@+  >>> optimize $ \x y -> minimize "goal" (x+2*(y::SInteger))+  Optimal in an extension field:+    goal = -oo :: Integer -Note that this may cause efficiency problems as it involves alternating quantifiers.-If 'OptimizeOpts' is set to 'Iterative' 'True', then SBV will programmatically-search for an optimal solution, by repeatedly calling the solver appropriately. (The boolean argument controls whether progress reports are given. Use-'False' for quiet operation.)+  Of course, this becomes more useful when the result is not in an extension field: -=== Quantified vs Iterative+  @+      optimize $ do x <- sInteger "x"+                    y <- sInteger "y" -Note that the quantified and iterative versions are two different optimization approaches and may not necessarily yield the same-results. In particular, the quantified version can tell us no such solution exists if there is no global optimum value, while the iterative-version might simply loop forever for such a problem. To wit, consider the example:+                    constrain $ x .> 0+                    constrain $ x .< 6+                    constrain $ y .> 2+                    constrain $ y .< 12 -   @ maximize Quantified head 1 (const true :: [SInteger] -> SBool) @+                    minimize "goal" (x+2*(y::SInteger))+  @ -which asks for the largest `SInteger` value. The SMT solver will happily answer back saying there is no such value with the 'Quantified' call, but the 'Iterative' variant-will simply loop forever as it would search through an infinite chain of ascending 'SInteger' values.+  This will produce: -In practice, however, the iterative version is usually the more effective choice since alternating quantifiers are hard to deal with for many SMT-solvers and thus will-likely result in an @unknown@ result. While the 'Iterative' variant can loop for a long time, one can simply use the boolean flag 'True' and see how the search is progressing.+  @+  Optimal model:+    x    = 1 :: Integer+    y    = 3 :: Integer+    goal = 7 :: Integer+   @++  As usual, the programmatic API can be used to extract the values of objectives and model-values ('getModelObjectives',+  'getModel', etc.) to access these values and program with them further.++== Multiple optimization goals++  Multiple goals can be specified, using the same syntax. In this case, the user gets to pick what style of+  optimization to perform:++    * The default is lexicographic. That is, solver will optimize the goals in the given order, optimizing+      the latter ones under the model that optimizes the previous ones. This is the default behavior, but+      can also be explicitly specified by:++       @ 'tactic' $ 'OptimizePriority' 'Lexicographic' @++    * Goals can also be independently optimized. In this case the user will be presented a model for each+      goal given. To enable this, use the tactic:++       @ 'tactic' $ 'OptimizePriority' 'Independent' @++    * Finally, the user can query for pareto-fronts. A pareto front is an model such that no goal can be made+      "better" without making some other goal "worse." To enable this style, use:++       @ 'tactic' $ 'OptimizePriority' 'Pareto' @++== Soft Assertions++  Related to optimization, SBV implements soft-asserts via 'assertSoft' calls. A soft assertion+  is a hint to the SMT solver that we would like a particular condition to hold if **possible*.+  That is, if there is a solution satisfying it, then we would like it to hold, but it can be violated+  if there is no way to satisfy it. Each soft-assertion can be associated with a numeric penalty for+  not satisfying it, hence turning it into an optimization problem.++  Note that 'assertSoft' works well with optimization goals ('minimize'/'maximize' etc.),+  and are most useful when we are optimizing a metric and thus some of the constraints+  can be relaxed with a penalty to obtain a good solution. Again+  see <http://www.easychair.org/publications/download/Z_-_Maximal_Satisfaction_with_Z3>+  for a good overview of the features in Z3 that SBV is providing the bridge for.++  A soft assertion can be specified in one of the following three main ways:++       @+         'assertSoft' "bounded_x" (x .< 5) 'DefaultPenalty'+         'assertSoft' "bounded_x" (x .< 5) ('Penalty' 2.3 Nothing)+         'assertSoft' "bounded_x" (x .< 5) ('Penalty' 4.7 (Just "group-1")) @++  In the first form, we are saying that the constraint @x .< 5@ must be satisfied, if possible,+  but if this constraint can not be satisfied to find a model, it can be violated with the default penalty of 1.++  In the second case, we are associating a penalty value of @2.3@.++  Finally in the third case, we are also associating this constraint with a group. The group+  name is only needed if we have classes of soft-constraints that should be considered together.++== Optimization examples++  The following examples illustrate the use of basic optimization routines:++     * "Data.SBV.Examples.Optimization.LinearOpt": Simple linear-optimization example.+     * "Data.SBV.Examples.Optimization.Production": Scheduling machines in a shop+     * "Data.SBV.Examples.Optimization.VM": Scheduling virtual-machines in a data-center -}  {- $modelExtraction@@ -683,7 +766,7 @@ Note that the proper reading of a constraint depends on the context: -    * In a 'sat' (or 'allSat') call: The constraint added is asserted+  * In a 'sat' (or 'allSat') call: The constraint added is asserted     conjunctively. That is, the resulting satisfying model (if any) will     always satisfy all the constraints given. @@ -729,9 +812,7 @@ A probabilistic constraint (see 'pConstrain') attaches a probability threshold for the constraint to be considered. For instance: -  @-     'pConstrain' 0.8 c-  @+  @ 'pConstrain' 0.8 c @  will make sure that the condition @c@ is satisfied 80% of the time (and correspondingly, falsified 20% of the time), in expectation. This variant is useful for 'genTest' and 'quickCheck' functions, where we@@ -751,6 +832,17 @@ 'genTest' or 'quickCheck'. Calls to 'pConstrain' in a prove/sat call will be rejected as SBV does not deal with probabilistic constraints when it comes to satisfiability and proofs. Also, both 'constrain' and 'pConstrain' calls during code-generation will also be rejected, for similar reasons.++=== Constraint vacuity++SBV does not check that a given constraints is not vacuous. That is, that it can never be satisfied. This is usually+the right behavior, since checking vacuity can be costly. The functions 'isVacuous' and 'isVacuousWith' should be used+to explicitly check for constraint vacuity if desired. Alternatively, the tactic:++  @ 'tactic' $  'CheckConstrVacuity' True @++can be given which will force SBV to run an explicit check that constraints are not vacuous. (And complain if they are!)+Note that this adds an extra call to the solver for each constraint, and thus can be rather costly. -}  {- $uninterpreted@@ -808,6 +900,21 @@  Note that the result is properly typed as @X@ elements; these are not mere strings. So, in a 'getModel' scenario, the user can recover actual elements of the domain and program further with those values as usual.+-}++{- $noteOnNestedQuantifiers+=== A note on reasoning in the presence of quantifers++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+prenex-normal form: <https://en.wikipedia.org/wiki/Prenex_normal_form>. That is,+all the input declarations are treated as happening at the beginning of a predicate, followed by the actual formula. Unfortunately,+the way predicates are written can be misleading at times, since symbolic inputs can be created at arbitrary points; interleaving them+with other code. The rule is simple, however: All inputs are assumed at the top, in the order declared, regardless of their quantifiers.+SBV will apply skolemization to get rid of existentials before sending predicates to backend solvers. However, if you do want nested+quantification, you will manually have to first convert to prenex-normal form (which produces an equisatisfiable but not necessarily+equivalent formula), and code that explicitly in SBV. See <https://github.com/LeventErkok/sbv/issues/256> for a detailed discussion+of this issue. -}  {-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-}
− Data/SBV/BitVectors/AlgReals.hs 
@@ -1,234 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.BitVectors.AlgReals--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Algrebraic reals in Haskell.--------------------------------------------------------------------------------{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Data.SBV.BitVectors.AlgReals (AlgReal(..), mkPolyReal, algRealToSMTLib2, algRealToHaskell, mergeAlgReals, isExactRational, algRealStructuralEqual, algRealStructuralCompare) where--import Data.List       (sortBy, isPrefixOf, partition)-import Data.Ratio      ((%), numerator, denominator)-import Data.Function   (on)-import System.Random-import Test.QuickCheck (Arbitrary(..))---- | 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,  Polynomial) -- which root-                           (Maybe String)         -- approximate decimal representation with given precision, if available---- | Check wheter a given argument is an exact rational-isExactRational :: AlgReal -> Bool-isExactRational (AlgRational True _) = True-isExactRational _                    = False---- | A univariate polynomial, represented simply as a--- coefficient list. For instance, "5x^3 + 2x - 5" is--- represented as [(5, 3), (2, 1), (-5, 0)]-newtype Polynomial = Polynomial [(Integer, Integer)]-                   deriving (Eq, Ord)---- | Construct a poly-root real with a given approximate value (either as a decimal, or polynomial-root)-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)-mkPolyReal (Right (k, coeffs))- = AlgPolyRoot (k, Polynomial (normalize coeffs)) Nothing- where normalize :: [(Integer, Integer)] -> [(Integer, Integer)]-       normalize = merge . sortBy (flip compare `on` snd)-       merge []                     = []-       merge [x]                    = [x]-       merge ((a, b):r@((c, d):xs))-         | b == d                   = merge ((a+c, b):xs)-         | True                     = (a, b) : merge r--instance Show Polynomial where-  show (Polynomial xs) = chkEmpty (join (concat [term p | p@(_, x) <- xs, x /= 0])) ++ " = " ++ show c-     where c  = -1 * head ([k | (k, 0) <- xs] ++ [0])-           term ( 0, _) = []-           term ( 1, 1) = [ "x"]-           term ( 1, p) = [ "x^" ++ show p]-           term (-1, 1) = ["-x"]-           term (-1, p) = ["-x^" ++ show p]-           term (k,  1) = [show k ++ "x"]-           term (k,  p) = [show k ++ "x^" ++ show p]-           join []      = ""-           join (k:ks) = k ++ s ++ join ks-             where s = case ks of-                        []    -> ""-                        (y:_) | "-" `isPrefixOf` y -> ""-                              | "+" `isPrefixOf` y -> ""-                              | True               -> "+"-           chkEmpty s = if null s then "0" else s--instance Show AlgReal where-  show (AlgRational exact a)         = showRat exact a-  show (AlgPolyRoot (i, p) mbApprox) = "root(" ++ show i ++ ", " ++ show p ++ ")" ++ maybe "" app mbApprox-     where app v | last v == '?' = " = " ++ init v ++ "..."-                 | True          = " = " ++ v---- lift unary op through an exact rational, otherwise bail-lift1 :: String -> (Rational -> Rational) -> AlgReal -> AlgReal-lift1 _  o (AlgRational e a) = AlgRational e (o a)-lift1 nm _ a                 = error $ "AlgReal." ++ nm ++ ": unsupported argument: " ++ show a---- lift binary op through exact rationals, otherwise bail-lift2 :: String -> (Rational -> Rational -> Rational) -> AlgReal -> AlgReal -> AlgReal-lift2 _  o (AlgRational True a) (AlgRational True b) = AlgRational True (a `o` b)-lift2 nm _ a                    b                    = error $ "AlgReal." ++ nm ++ ": unsupported arguments: " ++ show (a, b)---- The idea in the instances below is that we will fully support operations--- on "AlgRational" AlgReals, but leave everything else undefined. When we are--- on the Haskell side, the AlgReal's are *not* reachable. They only represent--- return values from SMT solvers, which we should *not* need to manipulate.-instance Eq AlgReal where-  AlgRational True a == AlgRational True b = a == b-  a                  == b                  = error $ "AlgReal.==: unsupported arguments: " ++ show (a, b)--instance Ord AlgReal where-  AlgRational True a `compare` AlgRational True b = a `compare` b-  a                  `compare` b                  = error $ "AlgReal.compare: unsupported arguments: " ++ show (a, b)---- | Structural equality for AlgReal; used when constants are Map keys-algRealStructuralEqual   :: AlgReal -> AlgReal -> Bool-AlgRational a b `algRealStructuralEqual` AlgRational c d = (a, b) == (c, d)-AlgPolyRoot a b `algRealStructuralEqual` AlgPolyRoot c d = (a, b) == (c, d)-_               `algRealStructuralEqual` _               = False---- | Structural comparisons for AlgReal; used when constants are Map keys-algRealStructuralCompare :: AlgReal -> AlgReal -> Ordering-AlgRational a b `algRealStructuralCompare` AlgRational c d = (a, b) `compare` (c, d)-AlgRational _ _ `algRealStructuralCompare` AlgPolyRoot _ _ = LT-AlgPolyRoot _ _ `algRealStructuralCompare` AlgRational _ _ = GT-AlgPolyRoot a b `algRealStructuralCompare` AlgPolyRoot c d = (a, b) `compare` (c, d)--instance Num AlgReal where-  (+)         = lift2 "+"      (+)-  (*)         = lift2 "*"      (*)-  (-)         = lift2 "-"      (-)-  negate      = lift1 "negate" negate-  abs         = lift1 "abs"    abs-  signum      = lift1 "signum" signum-  fromInteger = AlgRational True . fromInteger---- |  NB: Following the other types we have, we require `a/0` to be `0` for all a.-instance Fractional AlgReal where-  (AlgRational True _) / (AlgRational True b) | b == 0 = 0-  a                    / b                             = lift2 "/" (/) a b-  fromRational = AlgRational True--instance Real AlgReal where-  toRational (AlgRational True v) = v-  toRational x                    = error $ "AlgReal.toRational: Argument cannot be represented as a rational value: " ++ algRealToHaskell x--instance Random Rational where-  random g = (a % b', g'')-     where (a, g')  = random g-           (b, g'') = random g'-           b'       = if 0 < b then b else 1 - b -- ensures 0 < b--  randomR (l, h) g = (r * d + l, g'')-     where (b, g')  = random g-           b'       = if 0 < b then b else 1 - b -- ensures 0 < b-           (a, g'') = randomR (0, b') g'--           r = a % b'-           d = h - l--instance Random AlgReal where-  random g = let (a, g') = random g in (AlgRational True a, g')-  randomR (AlgRational True l, AlgRational True h) g = let (a, g') = randomR (l, h) g in (AlgRational True a, g')-  randomR lh                                       _ = error $ "AlgReal.randomR: unsupported bounds: " ++ show lh---- | Render an 'AlgReal' as an SMTLib2 value. Only supports rationals for the time being.-algRealToSMTLib2 :: AlgReal -> String-algRealToSMTLib2 (AlgRational True r)-   | m == 0 = "0.0"-   | m < 0  = "(- (/ "  ++ show (abs m) ++ ".0 " ++ show n ++ ".0))"-   | True   =    "(/ "  ++ show m       ++ ".0 " ++ show n ++ ".0)"-  where (m, n) = (numerator r, denominator r)-algRealToSMTLib2 r@(AlgRational False _)-   = error $ "SBV: Unexpected inexact rational to be converted to SMTLib2: " ++ show r-algRealToSMTLib2 (AlgPolyRoot (i, Polynomial xs) _) = "(root-obj (+ " ++ unwords (concatMap term xs) ++ ") " ++ show i ++ ")"-  where term (0, _) = []-        term (k, 0) = [coeff k]-        term (1, 1) = ["x"]-        term (1, p) = ["(^ x " ++ show p ++ ")"]-        term (k, 1) = ["(* " ++ coeff k ++ " x)"]-        term (k, p) = ["(* " ++ coeff k ++ " (^ x " ++ show p ++ "))"]-        coeff n | n < 0 = "(- " ++ show (abs n) ++ ")"-                | True  = show n---- | 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.-algRealToHaskell :: AlgReal -> String-algRealToHaskell (AlgRational True r) = "((" ++ show r ++ ") :: Rational)"-algRealToHaskell r                    = error $ "SBV.algRealToHaskell: Unsupported argument: " ++ show r---- Try to show a rational precisely if we can, with finite number of--- digits. Otherwise, show it as a rational value.-showRat :: Bool -> Rational -> String-showRat exact r = p $ case f25 (denominator r) [] of-                       Nothing               -> show r   -- bail out, not precisely representable with finite digits-                       Just (noOfZeros, num) -> let present = length num-                                                in neg $ case noOfZeros `compare` present of-                                                           LT -> let (b, a) = splitAt (present - noOfZeros) num in b ++ "." ++ if null a then "0" else a-                                                           EQ -> "0." ++ num-                                                           GT -> "0." ++ replicate (noOfZeros - present) '0' ++ num-  where p   = if exact then id else (++ "...")-        neg = if r < 0 then ('-':) else id-        -- factor a number in 2's and 5's if possible-        -- If so, it'll return the number of digits after the zero-        -- to reach the next power of 10, and the numerator value scaled-        -- appropriately and shown as a string-        f25 :: Integer -> [Integer] -> Maybe (Int, String)-        f25 1 sofar = let (ts, fs)   = partition (== 2) sofar-                          [lts, lfs] = map length [ts, fs]-                          noOfZeros  = lts `max` lfs-                      in Just (noOfZeros, show (abs (numerator r)  * factor ts fs))-        f25 v sofar = let (q2, r2) = v `quotRem` 2-                          (q5, r5) = v `quotRem` 5-                      in case (r2, r5) of-                           (0, _) -> f25 q2 (2 : sofar)-                           (_, 0) -> f25 q5 (5 : sofar)-                           _      -> Nothing-        -- compute the next power of 10 we need to get to-        factor []     fs     = product [2 | _ <- fs]-        factor ts     []     = product [5 | _ <- ts]-        factor (_:ts) (_:fs) = factor ts fs---- | Merge the representation of two algebraic reals, one assumed to be--- in polynomial form, the other in decimal. Arguments can be the same--- kind, so long as they are both rationals and equivalent; if not there--- must be one that is precise. It's an error to pass anything--- else to this function! (Used in reconstructing SMT counter-example values with reals).-mergeAlgReals :: String -> AlgReal -> AlgReal -> AlgReal-mergeAlgReals _ f@(AlgRational exact r) (AlgPolyRoot kp Nothing)-  | exact = f-  | True  = AlgPolyRoot kp (Just (showRat False r))-mergeAlgReals _ (AlgPolyRoot kp Nothing) f@(AlgRational exact r)-  | exact = f-  | True  = AlgPolyRoot kp (Just (showRat False r))-mergeAlgReals _ f@(AlgRational e1 r1) s@(AlgRational e2 r2)-  | (e1, r1) == (e2, r2) = f-  | e1                   = f-  | e2                   = s-mergeAlgReals m _ _ = error m---- Quickcheck instance-instance Arbitrary AlgReal where-  arbitrary = AlgRational True `fmap` arbitrary
− Data/SBV/BitVectors/Concrete.hs 
@@ -1,194 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.BitVectors.Concrete--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Operations on concrete values--------------------------------------------------------------------------------module Data.SBV.BitVectors.Concrete-  ( module Data.SBV.BitVectors.Concrete-  ) where--import Data.Bits-import System.Random (randomIO, randomRIO)--import Data.SBV.BitVectors.Kind-import Data.SBV.BitVectors.AlgReals---- | A constant value-data CWVal = CWAlgReal  !AlgReal              -- ^ algebraic real-           | CWInteger  !Integer              -- ^ bit-vector/unbounded integer-           | CWFloat    !Float                -- ^ float-           | CWDouble   !Double               -- ^ double-           | CWUserSort !(Maybe Int, String)  -- ^ value of an uninterpreted/user kind. The Maybe Int shows index position for enumerations---- | Eq instance for CWVal. Note that we cannot simply derive Eq/Ord, since CWAlgReal doesn't have proper--- instances for these when values are infinitely precise reals. However, we do--- need a structural eq/ord for Map indexes; so define custom ones here:-instance Eq CWVal where-  CWAlgReal a  == CWAlgReal b       = a `algRealStructuralEqual` b-  CWInteger a  == CWInteger b       = a == b-  CWUserSort a == CWUserSort b = a == b-  CWFloat a    == CWFloat b         = a == b-  CWDouble a   == CWDouble b        = a == b-  _            == _                 = False---- | Ord instance for CWVal. Same comments as the 'Eq' instance why this cannot be derived.-instance Ord CWVal where-  CWAlgReal a `compare` CWAlgReal b   = a `algRealStructuralCompare` b-  CWAlgReal _ `compare` CWInteger _   = LT-  CWAlgReal _ `compare` CWFloat _     = LT-  CWAlgReal _ `compare` CWDouble _    = LT-  CWAlgReal _ `compare` CWUserSort _  = LT--  CWInteger _ `compare` CWAlgReal _   = GT-  CWInteger a `compare` CWInteger b   = a `compare` b-  CWInteger _ `compare` CWFloat _     = LT-  CWInteger _ `compare` CWDouble _    = LT-  CWInteger _ `compare` CWUserSort _  = LT--  CWFloat _   `compare` CWAlgReal _   = GT-  CWFloat _   `compare` CWInteger _   = GT-  CWFloat a   `compare` CWFloat b     = a `compare` b-  CWFloat _   `compare` CWDouble _    = LT-  CWFloat _   `compare` CWUserSort _  = LT--  CWDouble _  `compare` CWAlgReal _   = GT-  CWDouble _  `compare` CWInteger _   = GT-  CWDouble _  `compare` CWFloat _     = GT-  CWDouble a  `compare` CWDouble b    = a `compare` b-  CWDouble _  `compare` CWUserSort _  = LT--  CWUserSort _ `compare` CWAlgReal _  = GT-  CWUserSort _ `compare` CWInteger _  = GT-  CWUserSort _ `compare` CWFloat _    = GT-  CWUserSort _ `compare` CWDouble _   = GT-  CWUserSort a `compare` CWUserSort b = a `compare` b---- | 'CW' represents a concrete word of a fixed size:--- Endianness is mostly irrelevant (see the 'FromBits' class).--- For signed words, the most significant digit is considered to be the sign.-data CW = CW { _cwKind  :: !Kind-             , cwVal    :: !CWVal-             }-        deriving (Eq, Ord)---- | 'Kind' instance for CW-instance HasKind CW where-  kindOf (CW k _) = k---- | Are two CW's of the same type?-cwSameType :: CW -> CW -> Bool-cwSameType x y = kindOf x == kindOf y---- | Convert a CW to a Haskell boolean (NB. Assumes input is well-kinded)-cwToBool :: CW -> Bool-cwToBool x = cwVal x /= CWInteger 0---- | Normalize a CW. Essentially performs modular arithmetic to make sure the--- value can fit in the given bit-size. Note that this is rather tricky for--- negative values, due to asymmetry. (i.e., an 8-bit negative number represents--- values in the range -128 to 127; thus we have to be careful on the negative side.)-normCW :: CW -> CW-normCW c@(CW (KBounded signed sz) (CWInteger v)) = c { cwVal = CWInteger 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)-normCW c@(CW KBool (CWInteger v)) = c { cwVal = CWInteger (v .&. 1) }-normCW c = c---- | Constant False as a CW. We represent it using the integer value 0.-falseCW :: CW-falseCW = CW KBool (CWInteger 0)---- | Constant True as a CW. We represent it using the integer value 1.-trueCW :: CW-trueCW  = CW KBool (CWInteger 1)---- | Lift a unary function through a CW-liftCW :: (AlgReal -> b) -> (Integer -> b) -> (Float -> b) -> (Double -> b) -> ((Maybe Int, String) -> b) -> CW -> b-liftCW f _ _ _ _ (CW _ (CWAlgReal v))  = f v-liftCW _ f _ _ _ (CW _ (CWInteger v))  = f v-liftCW _ _ f _ _ (CW _ (CWFloat v))    = f v-liftCW _ _ _ f _ (CW _ (CWDouble v))   = f v-liftCW _ _ _ _ f (CW _ (CWUserSort v)) = f v---- | Lift a binary function through a CW-liftCW2 :: (AlgReal -> AlgReal -> b) -> (Integer -> Integer -> b) -> (Float -> Float -> b) -> (Double -> Double -> b) -> ((Maybe Int, String) -> (Maybe Int, String) -> b) -> CW -> CW -> b-liftCW2 r i f d u x y = case (cwVal x, cwVal y) of-                         (CWAlgReal a,  CWAlgReal b)  -> r a b-                         (CWInteger a,  CWInteger b)  -> i a b-                         (CWFloat a,    CWFloat b)    -> f a b-                         (CWDouble a,   CWDouble b)   -> d a b-                         (CWUserSort a, CWUserSort b) -> u a b-                         _                            -> error $ "SBV.liftCW2: impossible, incompatible args received: " ++ show (x, y)---- | Map a unary function through a CW.-mapCW :: (AlgReal -> AlgReal) -> (Integer -> Integer) -> (Float -> Float) -> (Double -> Double) -> ((Maybe Int, String) -> (Maybe Int, String)) -> CW -> CW-mapCW r i f d u x  = normCW $ CW (kindOf x) $ case cwVal x of-                                               CWAlgReal a  -> CWAlgReal  (r a)-                                               CWInteger a  -> CWInteger  (i a)-                                               CWFloat a    -> CWFloat    (f a)-                                               CWDouble a   -> CWDouble   (d a)-                                               CWUserSort a -> CWUserSort (u a)---- | Map a binary function through a CW.-mapCW2 :: (AlgReal -> AlgReal -> AlgReal) -> (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> (Double -> Double -> Double) -> ((Maybe Int, String) -> (Maybe Int, String) -> (Maybe Int, String)) -> CW -> CW -> CW-mapCW2 r i f d u x y = case (cwSameType x y, cwVal x, cwVal y) of-                        (True, CWAlgReal a,  CWAlgReal b)  -> normCW $ CW (kindOf x) (CWAlgReal  (r a b))-                        (True, CWInteger a,  CWInteger b)  -> normCW $ CW (kindOf x) (CWInteger  (i a b))-                        (True, CWFloat a,    CWFloat b)    -> normCW $ CW (kindOf x) (CWFloat    (f a b))-                        (True, CWDouble a,   CWDouble b)   -> normCW $ CW (kindOf x) (CWDouble   (d a b))-                        (True, CWUserSort a, CWUserSort b) -> normCW $ CW (kindOf x) (CWUserSort (u a b))-                        _                                  -> error $ "SBV.mapCW2: impossible, incompatible args received: " ++ show (x, y)---- | Show instance for 'CW'.-instance Show CW where-  show = showCW True---- | Show a CW, with kind info if bool is True-showCW :: Bool -> CW -> String-showCW shk w | isBoolean w = show (cwToBool w) ++ (if shk then " :: Bool" else "")-showCW shk w               = liftCW show show show show snd w ++ kInfo-      where kInfo | shk  = " :: " ++ shKind (kindOf w)-                  | True = ""-            shKind k@KUserSort {}         = show k-            shKind k | ('S':sk) <- show k = sk-            shKind k                      = show k---- | Create a constant word from an integral.-mkConstCW :: Integral a => Kind -> a -> CW-mkConstCW KBool           a = normCW $ CW KBool      (CWInteger (toInteger a))-mkConstCW k@KBounded{}    a = normCW $ CW k          (CWInteger (toInteger a))-mkConstCW KUnbounded      a = normCW $ CW KUnbounded (CWInteger (toInteger a))-mkConstCW KReal           a = normCW $ CW KReal      (CWAlgReal (fromInteger (toInteger a)))-mkConstCW KFloat          a = normCW $ CW KFloat     (CWFloat   (fromInteger (toInteger a)))-mkConstCW KDouble         a = normCW $ CW KDouble    (CWDouble  (fromInteger (toInteger a)))-mkConstCW (KUserSort s _) a = error $ "Unexpected call to mkConstCW with uninterpreted kind: " ++ s ++ " with value: " ++ show (toInteger a)---- | Generate a random constant value ('CWVal') of the correct kind.-randomCWVal :: Kind -> IO CWVal-randomCWVal k =-  case k of-    KBool         -> fmap CWInteger (randomRIO (0,1))-    KBounded s w  -> fmap CWInteger (randomRIO (bounds s w))-    KUnbounded    -> fmap CWInteger randomIO-    KReal         -> fmap CWAlgReal randomIO-    KFloat        -> fmap CWFloat randomIO-    KDouble       -> fmap CWDouble randomIO-    KUserSort s _ -> error $ "Unexpected call to randomCWVal with uninterpreted kind: " ++ s-  where-    bounds :: Bool -> Int -> (Integer, Integer)-    bounds False w = (0, 2^w - 1)-    bounds True w = (-x, x-1) where x = 2^(w-1)---- | Generate a random constant value ('CW') of the correct kind.-randomCW :: Kind -> IO CW-randomCW k = fmap (CW k) (randomCWVal k)
− Data/SBV/BitVectors/Data.hs 
@@ -1,542 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.BitVectors.Data--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Internal data-structures for the sbv library--------------------------------------------------------------------------------{-# LANGUAGE TypeSynonymInstances  #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE PatternGuards         #-}-{-# LANGUAGE DefaultSignatures     #-}-{-# LANGUAGE NamedFieldPuns        #-}--module Data.SBV.BitVectors.Data- ( SBool, SWord8, SWord16, SWord32, SWord64- , SInt8, SInt16, SInt32, SInt64, SInteger, SReal, SFloat, SDouble- , nan, infinity, sNaN, sInfinity, RoundingMode(..), SRoundingMode- , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero- , sRNE, sRNA, sRTP, sRTN, sRTZ- , SymWord(..)- , CW(..), CWVal(..), AlgReal(..), cwSameType, cwToBool- , mkConstCW ,liftCW2, mapCW, mapCW2- , SW(..), trueSW, falseSW, trueCW, falseCW, normCW- , SVal(..)- , SBV(..), NodeId(..), mkSymSBV- , ArrayContext(..), ArrayInfo, SymArray(..), SFunArray(..), mkSFunArray, SArray(..)- , sbvToSW, sbvToSymSW, forceSWArg- , SBVExpr(..), newExpr- , cache, Cached, uncache, uncacheAI, HasKind(..)- , Op(..), FPOp(..), NamedSymVar, getTableIndex- , SBVPgm(..), Symbolic, SExecutable(..), runSymbolic, runSymbolic', State, getPathCondition, extendPathCondition- , inProofMode, SBVRunMode(..), Kind(..), Outputtable(..), Result(..)- , Logic(..), SMTLibLogic(..)- , addConstraint, internalVariable, internalConstraint, isCodeGenMode- , SBVType(..), newUninterpreted, addAxiom- , Quantifier(..), needsExistentials- , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension, smtLibReservedNames- , SolverCapabilities(..)- , extractSymbolicSimulationState- , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), getSBranchRunConfig- , declNewSArray, declNewSFunArray- ) where--import Control.DeepSeq      (NFData(..))-import Control.Monad.Reader (ask)-import Control.Monad.Trans  (liftIO)-import Data.Int             (Int8, Int16, Int32, Int64)-import Data.Word            (Word8, Word16, Word32, Word64)-import Data.List            (elemIndex, intercalate)-import Data.Maybe           (fromMaybe)--import qualified Data.Generics as G    (Data(..))--import System.Random--import Data.SBV.BitVectors.AlgReals-import Data.SBV.Utils.Lib--import Data.SBV.BitVectors.Kind-import Data.SBV.BitVectors.Concrete-import Data.SBV.BitVectors.Symbolic-import Data.SBV.SMT.SMTLibNames--import Prelude ()-import Prelude.Compat---- | Get the current path condition-getPathCondition :: State -> SBool-getPathCondition st = SBV (getSValPathCondition st)---- | Extend the path condition with the given test value.-extendPathCondition :: State -> (SBool -> SBool) -> State-extendPathCondition st f = extendSValPathCondition st (unSBV . f . SBV)---- | The "Symbolic" value. The parameter 'a' is phantom, but is--- extremely important in keeping the user interface strongly typed.-newtype SBV a = SBV { unSBV :: SVal }---- | A symbolic boolean/bit-type SBool   = SBV Bool---- | 8-bit unsigned symbolic value-type SWord8  = SBV Word8---- | 16-bit unsigned symbolic value-type SWord16 = SBV Word16---- | 32-bit unsigned symbolic value-type SWord32 = SBV Word32---- | 64-bit unsigned symbolic value-type SWord64 = SBV Word64---- | 8-bit signed symbolic value, 2's complement representation-type SInt8   = SBV Int8---- | 16-bit signed symbolic value, 2's complement representation-type SInt16  = SBV Int16---- | 32-bit signed symbolic value, 2's complement representation-type SInt32  = SBV Int32---- | 64-bit signed symbolic value, 2's complement representation-type SInt64  = SBV Int64---- | Infinite precision signed symbolic value-type SInteger = SBV Integer---- | Infinite precision symbolic algebraic real value-type SReal = SBV AlgReal---- | IEEE-754 single-precision floating point numbers-type SFloat = SBV Float---- | IEEE-754 double-precision floating point numbers-type SDouble = SBV Double---- | Not-A-Number for 'Double' and 'Float'. Surprisingly, Haskell--- Prelude doesn't have this value defined, so we provide it here.-nan :: Floating a => a-nan = 0/0---- | Infinity for 'Double' and 'Float'. Surprisingly, Haskell--- Prelude doesn't have this value defined, so we provide it here.-infinity :: Floating a => a-infinity = 1/0---- | Symbolic variant of Not-A-Number. This value will inhabit both--- 'SDouble' and 'SFloat'.-sNaN :: (Floating a, SymWord a) => SBV a-sNaN = literal nan---- | Symbolic variant of infinity. This value will inhabit both--- 'SDouble' and 'SFloat'.-sInfinity :: (Floating a, SymWord a) => SBV a-sInfinity = literal infinity---- | 'RoundingMode' can be used symbolically-instance SymWord RoundingMode---- | The symbolic variant of 'RoundingMode'-type SRoundingMode = SBV RoundingMode---- | Symbolic variant of 'RoundNearestTiesToEven'-sRoundNearestTiesToEven :: SRoundingMode-sRoundNearestTiesToEven = literal RoundNearestTiesToEven---- | Symbolic variant of 'RoundNearestTiesToAway'-sRoundNearestTiesToAway :: SRoundingMode-sRoundNearestTiesToAway = literal RoundNearestTiesToAway---- | Symbolic variant of 'RoundNearestPositive'-sRoundTowardPositive :: SRoundingMode-sRoundTowardPositive = literal RoundTowardPositive---- | Symbolic variant of 'RoundTowardNegative'-sRoundTowardNegative :: SRoundingMode-sRoundTowardNegative = literal RoundTowardNegative---- | Symbolic variant of 'RoundTowardZero'-sRoundTowardZero :: SRoundingMode-sRoundTowardZero = literal RoundTowardZero---- | Alias for 'sRoundNearestTiesToEven'-sRNE :: SRoundingMode-sRNE = sRoundNearestTiesToEven---- | Alias for 'sRoundNearestTiesToAway'-sRNA :: SRoundingMode-sRNA = sRoundNearestTiesToAway---- | Alias for 'sRoundTowardPositive'-sRTP :: SRoundingMode-sRTP = sRoundTowardPositive---- | Alias for 'sRoundTowardNegative'-sRTN :: SRoundingMode-sRTN = sRoundTowardNegative---- | Alias for 'sRoundTowardZero'-sRTZ :: SRoundingMode-sRTZ = sRoundTowardZero---- Not particularly "desirable", but will do if needed-instance Show (SBV a) where-  show (SBV sv) = show sv---- Equality constraint on SBV values. Not desirable since we can't really compare two--- symbolic values, but will do.-instance Eq (SBV a) where-  SBV a == SBV b = a == b-  SBV a /= SBV b = a /= b--instance HasKind (SBV a) where-  kindOf (SBV (SVal k _)) = k---- | Convert a symbolic value to a symbolic-word-sbvToSW :: State -> SBV a -> IO SW-sbvToSW st (SBV s) = svToSW st s------------------------------------------------------------------------------ * Symbolic Computations------------------------------------------------------------------------------ | Create a symbolic variable.-mkSymSBV :: forall a. Maybe Quantifier -> Kind -> Maybe String -> Symbolic (SBV a)-mkSymSBV mbQ k mbNm = fmap SBV (svMkSymVar mbQ k mbNm)---- | Convert a symbolic value to an SW, inside the Symbolic monad-sbvToSymSW :: SBV a -> Symbolic SW-sbvToSymSW sbv = do-        st <- ask-        liftIO $ sbvToSW st sbv---- | A class representing what can be returned from a symbolic computation.-class Outputtable a where-  -- | Mark an interim result as an output. Useful when constructing Symbolic programs-  -- that return multiple values, or when the result is programmatically computed.-  output :: a -> Symbolic a--instance Outputtable (SBV a) where-  output i = do-          outputSVal (unSBV i)-          return i--instance Outputtable a => Outputtable [a] where-  output = mapM output--instance Outputtable () where-  output = return--instance (Outputtable a, Outputtable b) => Outputtable (a, b) where-  output = mlift2 (,) output output--instance (Outputtable a, Outputtable b, Outputtable c) => Outputtable (a, b, c) where-  output = mlift3 (,,) output output output--instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d) => Outputtable (a, b, c, d) where-  output = mlift4 (,,,) output output output output--instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e) => Outputtable (a, b, c, d, e) where-  output = mlift5 (,,,,) output output output output output--instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f) => Outputtable (a, b, c, d, e, f) where-  output = mlift6 (,,,,,) output output output output output output--instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f, Outputtable g) => Outputtable (a, b, c, d, e, f, g) where-  output = mlift7 (,,,,,,) output output output output output output output--instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f, Outputtable g, Outputtable h) => Outputtable (a, b, c, d, e, f, g, h) where-  output = mlift8 (,,,,,,,) output output output output output output output output------------------------------------------------------------------------------------ * Symbolic Words----------------------------------------------------------------------------------- | A 'SymWord' is a potential symbolic bitvector that can be created instances of--- to be fed to a symbolic program. Note that these methods are typically not needed--- in casual uses with 'prove', 'sat', 'allSat' etc, as default instances automatically--- provide the necessary bits.-class (HasKind a, Ord a) => SymWord a where-  -- | Create a user named input (universal)-  forall :: String -> Symbolic (SBV a)-  -- | Create an automatically named input-  forall_ :: Symbolic (SBV a)-  -- | Get a bunch of new words-  mkForallVars :: Int -> Symbolic [SBV a]-  -- | Create an existential variable-  exists  :: String -> Symbolic (SBV a)-  -- | Create an automatically named existential variable-  exists_ :: Symbolic (SBV a)-  -- | Create a bunch of existentials-  mkExistVars :: Int -> Symbolic [SBV a]-  -- | Create a free variable, universal in a proof, existential in sat-  free :: String -> Symbolic (SBV a)-  -- | Create an unnamed free variable, universal in proof, existential in sat-  free_ :: Symbolic (SBV a)-  -- | Create a bunch of free vars-  mkFreeVars :: Int -> Symbolic [SBV a]-  -- | Similar to free; Just a more convenient name-  symbolic  :: String -> Symbolic (SBV a)-  -- | Similar to mkFreeVars; but automatically gives names based on the strings-  symbolics :: [String] -> Symbolic [SBV a]-  -- | Turn a literal constant to symbolic-  literal :: a -> SBV a-  -- | Extract a literal, if the value is concrete-  unliteral :: SBV a -> Maybe a-  -- | Extract a literal, from a CW representation-  fromCW :: CW -> a-  -- | Is the symbolic word concrete?-  isConcrete :: SBV a -> Bool-  -- | Is the symbolic word really symbolic?-  isSymbolic :: SBV a -> Bool-  -- | Does it concretely satisfy the given predicate?-  isConcretely :: SBV a -> (a -> Bool) -> Bool-  -- | One stop allocator-  mkSymWord :: Maybe Quantifier -> Maybe String -> Symbolic (SBV a)--  -- minimal complete definition:: Nothing.-  -- Giving no instances is ok when defining an uninterpreted/enumerated sort, but otherwise you really-  -- want to define: literal, fromCW, mkSymWord-  forall   = mkSymWord (Just ALL) . Just-  forall_  = mkSymWord (Just ALL)   Nothing-  exists   = mkSymWord (Just EX)  . Just-  exists_  = mkSymWord (Just EX)    Nothing-  free     = mkSymWord Nothing    . Just-  free_    = mkSymWord Nothing      Nothing-  mkForallVars n = mapM (const forall_) [1 .. n]-  mkExistVars n  = mapM (const exists_) [1 .. n]-  mkFreeVars n   = mapM (const free_)   [1 .. n]-  symbolic       = free-  symbolics      = mapM symbolic-  unliteral (SBV (SVal _ (Left c)))  = Just $ fromCW c-  unliteral _                        = Nothing-  isConcrete (SBV (SVal _ (Left _))) = True-  isConcrete _                       = False-  isSymbolic = not . isConcrete-  isConcretely s p-    | Just i <- unliteral s = p i-    | True                  = False--  default literal :: Show a => a -> SBV a-  literal x = let k@(KUserSort  _ conts) = kindOf x-                  sx                     = show x-                  mbIdx = case conts of-                            Right xs -> sx `elemIndex` xs-                            _        -> Nothing-              in SBV $ SVal k (Left (CW k (CWUserSort (mbIdx, sx))))--  default fromCW :: Read a => CW -> a-  fromCW (CW _ (CWUserSort (_, s))) = read s-  fromCW cw                         = error $ "Cannot convert CW " ++ show cw ++ " to kind " ++ show (kindOf (undefined :: a))--  default mkSymWord :: (Read a, G.Data a) => Maybe Quantifier -> Maybe String -> Symbolic (SBV a)-  mkSymWord mbQ mbNm = SBV <$> mkSValUserSort k mbQ mbNm-    where k = constructUKind (undefined :: a)--instance (Random a, SymWord a) => Random (SBV a) where-  randomR (l, h) g = case (unliteral l, unliteral h) of-                       (Just lb, Just hb) -> let (v, g') = randomR (lb, hb) g in (literal (v :: a), g')-                       _                  -> error "SBV.Random: Cannot generate random values with symbolic bounds"-  random         g = let (v, g') = random g in (literal (v :: a) , g')------------------------------------------------------------------------------------- * Symbolic Arrays-------------------------------------------------------------------------------------- | Flat arrays of symbolic values--- An @array a b@ is an array indexed by the type @'SBV' a@, with elements of type @'SBV' b@--- If an initial value is not provided in 'newArray_' and 'newArray' methods, then the elements--- are left unspecified, i.e., the solver is free to choose any value. This is the right thing--- to do if arrays are used as inputs to functions to be verified, typically. ------ While it's certainly possible for user to create instances of 'SymArray', the--- 'SArray' and 'SFunArray' instances already provided should cover most use cases--- in practice. (There are some differences between these models, however, see the corresponding--- declaration.)--------- Minimal complete definition: All methods are required, no defaults.-class SymArray array where-  -- | Create a new array, with an optional initial value-  newArray_      :: (HasKind a, HasKind b) => Maybe (SBV b) -> Symbolic (array a b)-  -- | Create a named new array, with an optional initial value-  newArray       :: (HasKind a, HasKind b) => String -> Maybe (SBV b) -> Symbolic (array a b)-  -- | Read the array element at @a@-  readArray      :: array a b -> SBV a -> SBV b-  -- | Reset all the elements of the array to the value @b@-  resetArray     :: SymWord b => array a b -> SBV b -> array a b-  -- | Update the element at @a@ to be @b@-  writeArray     :: SymWord b => array a b -> SBV a -> SBV b -> array a b-  -- | Merge two given arrays on the symbolic condition-  -- Intuitively: @mergeArrays cond a b = if cond then a else b@.-  -- Merging pushes the if-then-else choice down on to elements-  mergeArrays    :: SymWord b => SBV Bool -> array a b -> array a b -> array a b---- | Arrays implemented in terms of SMT-arrays: <http://smtlib.cs.uiowa.edu/theories-ArraysEx.shtml>------   * Maps directly to SMT-lib arrays------   * Reading from an unintialized value is OK and yields an unspecified result------   * Can check for equality of these arrays------   * Cannot quick-check theorems using @SArray@ values------   * Typically slower as it heavily relies on SMT-solving for the array theory----newtype SArray a b = SArray { unSArray :: SArr }--instance (HasKind a, HasKind b) => Show (SArray a b) where-  show SArray{} = "SArray<" ++ showType (undefined :: a) ++ ":" ++ showType (undefined :: b) ++ ">"--instance SymArray SArray where-  newArray_                                      = declNewSArray (\t -> "array_" ++ show t)-  newArray n                                     = declNewSArray (const n)-  readArray   (SArray arr) (SBV a)               = SBV (readSArr arr a)-  resetArray  (SArray arr) (SBV b)               = SArray (resetSArr arr b)-  writeArray  (SArray arr) (SBV a)    (SBV b)    = SArray (writeSArr arr a b)-  mergeArrays (SBV t)      (SArray a) (SArray b) = SArray (mergeSArr t a b)---- | Declare a new symbolic array, with a potential initial value-declNewSArray :: forall a b. (HasKind a, HasKind b) => (Int -> String) -> Maybe (SBV b) -> Symbolic (SArray a b)-declNewSArray mkNm mbInit = do-   let aknd = kindOf (undefined :: a)-       bknd = kindOf (undefined :: b)-   arr <- newSArr (aknd, bknd) mkNm (fmap unSBV mbInit)-   return (SArray arr)---- | Declare a new functional symbolic array, with a potential initial value. Note that a read from an uninitialized cell will result in an error.-declNewSFunArray :: forall a b. (HasKind a, HasKind b) => Maybe (SBV b) -> Symbolic (SFunArray a b)-declNewSFunArray mbiVal = return $ SFunArray $ const $ fromMaybe (error "Reading from an uninitialized array entry") mbiVal---- | Arrays implemented internally as functions------    * Internally handled by the library and not mapped to SMT-Lib------    * Reading an uninitialized value is considered an error (will throw exception)------    * Cannot check for equality (internally represented as functions)------    * Can quick-check------    * Typically faster as it gets compiled away during translation----newtype SFunArray a b = SFunArray (SBV a -> SBV b)--instance (HasKind a, HasKind b) => Show (SFunArray a b) where-  show (SFunArray _) = "SFunArray<" ++ showType (undefined :: a) ++ ":" ++ showType (undefined :: b) ++ ">"---- | Lift a function to an array. Useful for creating arrays in a pure context. (Otherwise use `newArray`.)-mkSFunArray :: (SBV a -> SBV b) -> SFunArray a b-mkSFunArray = SFunArray---- | Add a constraint with a given probability-addConstraint :: Maybe Double -> SBool -> SBool -> Symbolic ()-addConstraint mt (SBV c) (SBV c') = addSValConstraint mt c c'--instance NFData (SBV a) where-  rnf (SBV x) = rnf x `seq` ()---- | Symbolically executable program fragments. This class is mainly used for 'safe' calls, and is sufficently 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 SExecutable a where-   sName_ :: a -> Symbolic ()-   sName  :: [String] -> a -> Symbolic ()--instance NFData a => SExecutable (Symbolic a) where-   sName_   a = a >>= \r -> rnf r `seq` return ()-   sName []   = sName_-   sName xs   = error $ "SBV.SExecutable.sName: Extra unmapped name(s): " ++ intercalate ", " xs--instance SExecutable (SBV a) where-   sName_   v = sName_ (output v)-   sName xs v = sName xs (output v)---- Unit output-instance SExecutable () where-   sName_   () = sName_   (output ())-   sName xs () = sName xs (output ())---- List output-instance SExecutable [SBV a] where-   sName_   vs = sName_   (output vs)-   sName xs vs = sName xs (output vs)---- 2 Tuple output-instance (NFData a, SymWord a, NFData b, SymWord b) => SExecutable (SBV a, SBV b) where-  sName_ (a, b) = sName_ (output a >> output b)-  sName _       = sName_---- 3 Tuple output-instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c) => SExecutable (SBV a, SBV b, SBV c) where-  sName_ (a, b, c) = sName_ (output a >> output b >> output c)-  sName _          = sName_---- 4 Tuple output-instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d) => SExecutable (SBV a, SBV b, SBV c, SBV d) where-  sName_ (a, b, c, d) = sName_ (output a >> output b >> output c >> output c >> output d)-  sName _             = sName_---- 5 Tuple output-instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e) where-  sName_ (a, b, c, d, e) = sName_ (output a >> output b >> output c >> output d >> output e)-  sName _                = sName_---- 6 Tuple output-instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e, NFData f, SymWord f) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) where-  sName_ (a, b, c, d, e, f) = sName_ (output a >> output b >> output c >> output d >> output e >> output f)-  sName _                   = sName_---- 7 Tuple output-instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e, NFData f, SymWord f, NFData g, SymWord g) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) where-  sName_ (a, b, c, d, e, f, g) = sName_ (output a >> output b >> output c >> output d >> output e >> output f >> output g)-  sName _                      = sName_---- Functions-instance (SymWord a, SExecutable p) => SExecutable (SBV a -> p) where-   sName_        k = forall_   >>= \a -> sName_   $ k a-   sName (s:ss)  k = forall s  >>= \a -> sName ss $ k a-   sName []      k = sName_ k---- 2 Tuple input-instance (SymWord a, SymWord b, SExecutable p) => SExecutable ((SBV a, SBV b) -> p) where-  sName_        k = forall_  >>= \a -> sName_   $ \b -> k (a, b)-  sName (s:ss)  k = forall s >>= \a -> sName ss $ \b -> k (a, b)-  sName []      k = sName_ k---- 3 Tuple input-instance (SymWord a, SymWord b, SymWord c, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c) -> p) where-  sName_       k  = forall_  >>= \a -> sName_   $ \b c -> k (a, b, c)-  sName (s:ss) k  = forall s >>= \a -> sName ss $ \b c -> k (a, b, c)-  sName []     k  = sName_ k---- 4 Tuple input-instance (SymWord a, SymWord b, SymWord c, SymWord d, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d) -> p) where-  sName_        k = forall_  >>= \a -> sName_   $ \b c d -> k (a, b, c, d)-  sName (s:ss)  k = forall s >>= \a -> sName ss $ \b c d -> k (a, b, c, d)-  sName []      k = sName_ k---- 5 Tuple input-instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e) -> p) where-  sName_        k = forall_  >>= \a -> sName_   $ \b c d e -> k (a, b, c, d, e)-  sName (s:ss)  k = forall s >>= \a -> sName ss $ \b c d e -> k (a, b, c, d, e)-  sName []      k = sName_ k---- 6 Tuple input-instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> p) where-  sName_        k = forall_  >>= \a -> sName_   $ \b c d e f -> k (a, b, c, d, e, f)-  sName (s:ss)  k = forall s >>= \a -> sName ss $ \b c d e f -> k (a, b, c, d, e, f)-  sName []      k = sName_ k---- 7 Tuple input-instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SymWord g, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> p) where-  sName_        k = forall_  >>= \a -> sName_   $ \b c d e f g -> k (a, b, c, d, e, f, g)-  sName (s:ss)  k = forall s >>= \a -> sName ss $ \b c d e f g -> k (a, b, c, d, e, f, g)-  sName []      k = sName_ k
− Data/SBV/BitVectors/Floating.hs 
@@ -1,446 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.BitVectors.Floating--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Implementation of floating-point operations mapping to SMT-Lib2 floats--------------------------------------------------------------------------------{-# LANGUAGE Rank2Types          #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.SBV.BitVectors.Floating (-         IEEEFloating(..), IEEEFloatConvertable(..)-       , sFloatAsSWord32, sDoubleAsSWord64, sWord32AsSFloat, sWord64AsSDouble-       , blastSFloat, blastSDouble-       ) where--import Control.Monad (join)--import qualified Data.Binary.IEEE754 as DB (wordToFloat, wordToDouble, floatToWord, doubleToWord)--import Data.Int            (Int8,  Int16,  Int32,  Int64)-import Data.Word           (Word8, Word16, Word32, Word64)--import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.Model-import Data.SBV.BitVectors.AlgReals (isExactRational)-import Data.SBV.Utils.Boolean-import Data.SBV.Utils.Numeric---- | A class of floating-point (IEEE754) operations, some of--- which behave differently based on rounding modes. Note that unless--- the rounding mode is concretely RoundNearestTiesToEven, we will--- not concretely evaluate these, but rather pass down to the SMT solver.-class (SymWord a, RealFloat a) => IEEEFloating a where-  -- | Compute the floating point absolute value.-  fpAbs             ::                  SBV a -> SBV a--  -- | Compute the unary negation. Note that @0 - x@ is not equivalent to @-x@ for floating-point, since @-0@ and @0@ are different.-  fpNeg             ::                  SBV a -> SBV a--  -- | Add two floating point values, using the given rounding mode-  fpAdd             :: SRoundingMode -> SBV a -> SBV a -> SBV a--  -- | Subtract two floating point values, using the given rounding mode-  fpSub             :: SRoundingMode -> SBV a -> SBV a -> SBV a--  -- | Multiply two floating point values, using the given rounding mode-  fpMul             :: SRoundingMode -> SBV a -> SBV a -> SBV a--  -- | Divide two floating point values, using the given rounding mode-  fpDiv             :: SRoundingMode -> SBV a -> SBV a -> SBV a--  -- | Fused-multiply-add three floating point values, using the given rounding mode. @fpFMA x y z = x*y+z@ but with only-  -- one rounding done for the whole operation; not two. Note that we will never concretely evaluate this function since-  -- Haskell lacks an FMA implementation.-  fpFMA             :: SRoundingMode -> SBV a -> SBV a -> SBV a -> SBV a--  -- | Compute the square-root of a float, using the given rounding mode-  fpSqrt            :: SRoundingMode -> SBV a -> SBV a--  -- | Compute the remainder: @x - y * n@, where @n@ is the truncated integer nearest to x/y. The rounding mode-  -- is implicitly assumed to be @RoundNearestTiesToEven@.-  fpRem             ::                  SBV a -> SBV a -> SBV a--  -- | Round to the nearest integral value, using the given rounding mode.-  fpRoundToIntegral :: SRoundingMode -> SBV a -> SBV a--  -- | Compute the minimum of two floats, respects @infinity@ and @NaN@ values-  fpMin             ::                  SBV a -> SBV a -> SBV a--  -- | Compute the maximum of two floats, respects @infinity@ and @NaN@ values-  fpMax             ::                  SBV a -> SBV a -> SBV a--  -- | Are the two given floats exactly the same. That is, @NaN@ will compare equal to itself, @+0@ will /not/ compare-  -- equal to @-0@ etc. This is the object level equality, as opposed to the semantic equality. (For the latter, just use '.=='.)-  fpIsEqualObject   ::                  SBV a -> SBV a -> SBool--  -- | Is the floating-point number a normal value. (i.e., not denormalized.)-  fpIsNormal :: SBV a -> SBool--  -- | Is the floating-point number a subnormal value. (Also known as denormal.)-  fpIsSubnormal :: SBV a -> SBool--  -- | Is the floating-point number 0? (Note that both +0 and -0 will satisfy this predicate.)-  fpIsZero :: SBV a -> SBool--  -- | Is the floating-point number infinity? (Note that both +oo and -oo will satisfy this predicate.)-  fpIsInfinite :: SBV a -> SBool--  -- | Is the floating-point number a NaN value?-  fpIsNaN ::  SBV a -> SBool--  -- | Is the floating-point number negative? Note that -0 satisfies this predicate but +0 does not.-  fpIsNegative :: SBV a -> SBool--  -- | Is the floating-point number positive? Note that +0 satisfies this predicate but -0 does not.-  fpIsPositive :: SBV a -> SBool--  -- | Is the floating point number -0?-  fpIsNegativeZero :: SBV a -> SBool--  -- | Is the floating point number +0?-  fpIsPositiveZero :: SBV a -> SBool--  -- | Is the floating-point number a regular floating point, i.e., not NaN, nor +oo, nor -oo. Normals or denormals are allowed.-  fpIsPoint :: SBV a -> SBool--  -- Default definitions. Minimal complete definition: None! All should be taken care by defaults-  -- Note that we never evaluate FMA concretely, as there's no fma operator in Haskell-  fpAbs              = lift1  FP_Abs             (Just abs)                Nothing-  fpNeg              = lift1  FP_Neg             (Just negate)             Nothing-  fpAdd              = lift2  FP_Add             (Just (+))                . Just-  fpSub              = lift2  FP_Sub             (Just (-))                . Just-  fpMul              = lift2  FP_Mul             (Just (*))                . Just-  fpDiv              = lift2  FP_Div             (Just (/))                . Just-  fpFMA              = lift3  FP_FMA             Nothing                   . Just-  fpSqrt             = lift1  FP_Sqrt            (Just sqrt)               . Just-  fpRem              = lift2  FP_Rem             (Just fpRemH)             Nothing-  fpRoundToIntegral  = lift1  FP_RoundToIntegral (Just fpRoundToIntegralH) . Just-  fpMin              = liftMM FP_Min             (Just fpMinH)             Nothing-  fpMax              = liftMM FP_Max             (Just fpMaxH)             Nothing-  fpIsEqualObject    = lift2B FP_ObjEqual        (Just fpIsEqualObjectH)   Nothing-  fpIsNormal         = lift1B FP_IsNormal        fpIsNormalizedH-  fpIsSubnormal      = lift1B FP_IsSubnormal     isDenormalized-  fpIsZero           = lift1B FP_IsZero          (== 0)-  fpIsInfinite       = lift1B FP_IsInfinite      isInfinite-  fpIsNaN            = lift1B FP_IsNaN           isNaN-  fpIsNegative       = lift1B FP_IsNegative      (\x -> x < 0 ||       isNegativeZero x)-  fpIsPositive       = lift1B FP_IsPositive      (\x -> x >= 0 && not (isNegativeZero x))-  fpIsNegativeZero x = fpIsZero x &&& fpIsNegative x-  fpIsPositiveZero x = fpIsZero x &&& fpIsPositive x-  fpIsPoint        x = bnot (fpIsNaN x ||| fpIsInfinite x)---- | SFloat instance-instance IEEEFloating Float---- | SDouble instance-instance IEEEFloating Double---- | Capture convertability from/to FloatingPoint representations--- NB. 'fromSFloat' and 'fromSDouble' are underspecified when given--- when given a @NaN@, @+oo@, or @-oo@ value that cannot be represented--- in the target domain. For these inputs, we define the result to be +0, arbitrarily.-class IEEEFloatConvertable a where-  fromSFloat  :: SRoundingMode -> SFloat  -> SBV a-  toSFloat    :: SRoundingMode -> SBV a   -> SFloat-  fromSDouble :: SRoundingMode -> SDouble -> SBV a-  toSDouble   :: SRoundingMode -> SBV a   -> SDouble---- | A generic converter that will work for most of our instances. (But not all!)-genericFPConverter :: forall a r. (SymWord a, HasKind r, SymWord r, Num r) => Maybe (a -> Bool) -> Maybe (SBV a -> SBool) -> (a -> r) -> SRoundingMode -> SBV a -> SBV r-genericFPConverter mbConcreteOK mbSymbolicOK converter rm f-  | Just w <- unliteral f, Just RoundNearestTiesToEven <- unliteral rm, check w-  = literal $ converter w-  | Just symCheck <- mbSymbolicOK-  = ite (symCheck f) result (literal 0)-  | True-  = result-  where result  = SBV (SVal kTo (Right (cache y)))-        check w = maybe True ($ w) mbConcreteOK-        kFrom   = kindOf f-        kTo     = kindOf (undefined :: r)-        y st    = do msw <- sbvToSW st rm-                     xsw <- sbvToSW st f-                     newExpr st kTo (SBVApp (IEEEFP (FP_Cast kFrom kTo msw)) [xsw])---- | Check that a given float is a point-ptCheck :: IEEEFloating a => Maybe (SBV a -> SBool)-ptCheck = Just fpIsPoint--instance IEEEFloatConvertable Int8 where-  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))-  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)-  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))-  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)--instance IEEEFloatConvertable Int16 where-  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))-  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)-  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))-  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)--instance IEEEFloatConvertable Int32 where-  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))-  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)-  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))-  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)--instance IEEEFloatConvertable Int64 where-  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))-  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)-  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))-  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)--instance IEEEFloatConvertable Word8 where-  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))-  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)-  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))-  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)--instance IEEEFloatConvertable Word16 where-  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))-  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)-  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))-  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)--instance IEEEFloatConvertable Word32 where-  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))-  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)-  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))-  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)--instance IEEEFloatConvertable Word64 where-  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))-  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)-  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))-  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)--instance IEEEFloatConvertable Float where-  fromSFloat _ f = f-  toSFloat   _ f = f-  fromSDouble    = genericFPConverter Nothing Nothing fp2fp-  toSDouble      = genericFPConverter Nothing Nothing fp2fp--instance IEEEFloatConvertable Double where-  fromSFloat      = genericFPConverter Nothing Nothing fp2fp-  toSFloat        = genericFPConverter Nothing Nothing fp2fp-  fromSDouble _ d = d-  toSDouble   _ d = d--instance IEEEFloatConvertable Integer where-  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))-  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)-  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))-  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)---- For AlgReal; be careful to only process exact rationals concretely-instance IEEEFloatConvertable AlgReal where-  fromSFloat  = genericFPConverter Nothing                ptCheck (fromRational . fpRatio0)-  toSFloat    = genericFPConverter (Just isExactRational) Nothing (fromRational . toRational)-  fromSDouble = genericFPConverter Nothing                ptCheck (fromRational . fpRatio0)-  toSDouble   = genericFPConverter (Just isExactRational) Nothing (fromRational . toRational)---- | Concretely evaluate one arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data-concEval1 :: SymWord a => Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> Maybe (SBV a)-concEval1 mbOp mbRm a = do op <- mbOp-                           v  <- unliteral a-                           case join (unliteral `fmap` mbRm) of-                             Nothing                     -> (Just . literal) (op v)-                             Just RoundNearestTiesToEven -> (Just . literal) (op v)-                             _                           -> Nothing---- | Concretely evaluate two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data-concEval2 :: SymWord a => Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> Maybe (SBV a)-concEval2 mbOp mbRm a b  = do op <- mbOp-                              v1 <- unliteral a-                              v2 <- unliteral b-                              case join (unliteral `fmap` mbRm) of-                                Nothing                     -> (Just . literal) (v1 `op` v2)-                                Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2)-                                _                           -> Nothing---- | Concretely evaluate a bool producing two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data-concEval2B :: SymWord a => Maybe (a -> a -> Bool) -> Maybe SRoundingMode -> SBV a -> SBV a -> Maybe SBool-concEval2B mbOp mbRm a b  = do op <- mbOp-                               v1 <- unliteral a-                               v2 <- unliteral b-                               case join (unliteral `fmap` mbRm) of-                                 Nothing                     -> (Just . literal) (v1 `op` v2)-                                 Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2)-                                 _                           -> Nothing---- | Concretely evaluate two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data-concEval3 :: SymWord a => Maybe (a -> a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a -> Maybe (SBV a)-concEval3 mbOp mbRm a b c = do op <- mbOp-                               v1 <- unliteral a-                               v2 <- unliteral b-                               v3 <- unliteral c-                               case join (unliteral `fmap` mbRm) of-                                 Nothing                     -> (Just . literal) (op v1 v2 v3)-                                 Just RoundNearestTiesToEven -> (Just . literal) (op v1 v2 v3)-                                 _                           -> Nothing---- | Add the converted rounding mode if given as an argument-addRM :: State -> Maybe SRoundingMode -> [SW] -> IO [SW]-addRM _  Nothing   as = return as-addRM st (Just rm) as = do swm <- sbvToSW st rm-                           return (swm : as)---- | Lift a 1 arg FP-op-lift1 :: SymWord a => FPOp -> Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a-lift1 w mbOp mbRm a-  | Just cv <- concEval1 mbOp mbRm a-  = cv-  | True-  = SBV $ SVal k $ Right $ cache r-  where k    = kindOf a-        r st = do swa  <- sbvToSW st a-                  args <- addRM st mbRm [swa]-                  newExpr st k (SBVApp (IEEEFP w) args)---- | Lift an FP predicate-lift1B :: SymWord a => FPOp -> (a -> Bool) -> SBV a -> SBool-lift1B w f a-   | Just v <- unliteral a = literal $ f v-   | True                  = SBV $ SVal KBool $ Right $ cache r-   where r st = do swa <- sbvToSW st a-                   newExpr st KBool (SBVApp (IEEEFP w) [swa])----- | Lift a 2 arg FP-op-lift2 :: SymWord a => FPOp -> Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a-lift2 w mbOp mbRm a b-  | Just cv <- concEval2 mbOp mbRm a b-  = cv-  | True-  = SBV $ SVal k $ Right $ cache r-  where k    = kindOf a-        r st = do swa  <- sbvToSW st a-                  swb  <- sbvToSW st b-                  args <- addRM st mbRm [swa, swb]-                  newExpr st k (SBVApp (IEEEFP w) args)---- | Lift min/max: Note that we protect against constant folding if args are alternating sign 0's, since--- SMTLib is deliberately nondeterministic in this case-liftMM :: (SymWord a, RealFloat a) => FPOp -> Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a-liftMM w mbOp mbRm a b-  | Just v1 <- unliteral a-  , Just v2 <- unliteral b-  , not ((isN0 v1 && isP0 v2) || (isP0 v1 && isN0 v2))          -- If not +0/-0 or -0/+0-  , Just cv <- concEval2 mbOp mbRm a b-  = cv-  | True-  = SBV $ SVal k $ Right $ cache r-  where isN0   = isNegativeZero-        isP0 x = x == 0 && not (isN0 x)-        k    = kindOf a-        r st = do swa  <- sbvToSW st a-                  swb  <- sbvToSW st b-                  args <- addRM st mbRm [swa, swb]-                  newExpr st k (SBVApp (IEEEFP w) args)---- | Lift a 2 arg FP-op, producing bool-lift2B :: SymWord a => FPOp -> Maybe (a -> a -> Bool) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBool-lift2B w mbOp mbRm a b-  | Just cv <- concEval2B mbOp mbRm a b-  = cv-  | True-  = SBV $ SVal KBool $ Right $ cache r-  where r st = do swa  <- sbvToSW st a-                  swb  <- sbvToSW st b-                  args <- addRM st mbRm [swa, swb]-                  newExpr st KBool (SBVApp (IEEEFP w) args)---- | Lift a 3 arg FP-op-lift3 :: SymWord a => FPOp -> Maybe (a -> a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a -> SBV a-lift3 w mbOp mbRm a b c-  | Just cv <- concEval3 mbOp mbRm a b c-  = cv-  | True-  = SBV $ SVal k $ Right $ cache r-  where k    = kindOf a-        r st = do swa  <- sbvToSW st a-                  swb  <- sbvToSW st b-                  swc  <- sbvToSW st c-                  args <- addRM st mbRm [swa, swb, swc]-                  newExpr st k (SBVApp (IEEEFP w) args)---- | Convert an 'SFloat' to an 'SWord32', preserving the bit-correspondence. Note that since the--- representation for @NaN@s are not unique, this function will return a symbolic value when given a--- concrete @NaN@.------ Implementation note: Since there's no corresponding function in SMTLib for conversion to--- bit-representation due to partiality, we use a translation trick by allocating a new word variable,--- converting it to float, and requiring it to be equivalent to the input. In code-generation mode, we simply map--- it to a simple conversion.-sFloatAsSWord32 :: SFloat -> SWord32-sFloatAsSWord32 fVal-  | Just f <- unliteral fVal, not (isNaN f)-  = literal (DB.floatToWord f)-  | True-  = SBV (SVal w32 (Right (cache y)))-  where w32  = KBounded False 32-        y st | isCodeGenMode st-             = do f <- sbvToSW st fVal-                  newExpr st w32 (SBVApp (IEEEFP (FP_Reinterpret KFloat w32)) [f])-             | True-             = do n   <- internalVariable st w32-                  ysw <- newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret w32 KFloat)) [n])-                  internalConstraint st $ unSBV $ fVal `fpIsEqualObject` SBV (SVal KFloat (Right (cache (\_ -> return ysw))))-                  return n---- | Convert an 'SDouble' to an 'SWord64', preserving the bit-correspondence. Note that since the--- representation for @NaN@s are not unique, this function will return a symbolic value when given a--- concrete @NaN@.------ See the implementation note for 'sFloatAsSWord32', as it applies here as well.-sDoubleAsSWord64 :: SDouble -> SWord64-sDoubleAsSWord64 fVal-  | Just f <- unliteral fVal, not (isNaN f)-  = literal (DB.doubleToWord f)-  | True-  = SBV (SVal w64 (Right (cache y)))-  where w64  = KBounded False 64-        y st | isCodeGenMode st-             = do f <- sbvToSW st fVal-                  newExpr st w64 (SBVApp (IEEEFP (FP_Reinterpret KDouble w64)) [f])-             | True-             = do n   <- internalVariable st w64-                  ysw <- newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret w64 KDouble)) [n])-                  internalConstraint st $ unSBV $ fVal `fpIsEqualObject` SBV (SVal KDouble (Right (cache (\_ -> return ysw))))-                  return n---- | Extract the sign\/exponent\/mantissa of a single-precision float. The output will have--- 8 bits in the second argument for exponent, and 23 in the third for the mantissa.-blastSFloat :: SFloat -> (SBool, [SBool], [SBool])-blastSFloat = extract . sFloatAsSWord32- where extract x = (sTestBit x 31, sExtractBits x [30, 29 .. 23], sExtractBits x [22, 21 .. 0])---- | Extract the sign\/exponent\/mantissa of a single-precision float. The output will have--- 11 bits in the second argument for exponent, and 52 in the third for the mantissa.-blastSDouble :: SDouble -> (SBool, [SBool], [SBool])-blastSDouble = extract . sDoubleAsSWord64- where extract x = (sTestBit x 63, sExtractBits x [62, 61 .. 52], sExtractBits x [51, 50 .. 0])---- | Reinterpret the bits in a 32-bit word as a single-precision floating point number-sWord32AsSFloat :: SWord32 -> SFloat-sWord32AsSFloat fVal-  | Just f <- unliteral fVal = literal $ DB.wordToFloat f-  | True                     = SBV (SVal KFloat (Right (cache y)))-  where y st = do xsw <- sbvToSW st fVal-                  newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret (kindOf fVal) KFloat)) [xsw])---- | Reinterpret the bits in a 32-bit word as a single-precision floating point number-sWord64AsSDouble :: SWord64 -> SDouble-sWord64AsSDouble dVal-  | Just d <- unliteral dVal = literal $ DB.wordToDouble d-  | True                     = SBV (SVal KDouble (Right (cache y)))-  where y st = do xsw <- sbvToSW st dVal-                  newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret (kindOf dVal) KDouble)) [xsw])--{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
− Data/SBV/BitVectors/Kind.hs 
@@ -1,160 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.BitVectors.Kind--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Internal data-structures for the sbv library--------------------------------------------------------------------------------{-# LANGUAGE    DefaultSignatures   #-}-{-# LANGUAGE    ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans   #-}--module Data.SBV.BitVectors.Kind (Kind(..), HasKind(..), constructUKind) where--import qualified Data.Generics as G (Data(..), DataType, dataTypeName, dataTypeOf, tyconUQname, dataTypeConstrs, constrFields)--import Data.Int-import Data.Word-import Data.SBV.BitVectors.AlgReals---- | Kind of symbolic value-data Kind = KBool-          | KBounded !Bool !Int-          | KUnbounded-          | KReal-          | KUserSort String (Either String [String])-          | KFloat-          | KDouble---- | Helper for Eq/Ord instances below-kindRank :: Kind -> Either Int (Either (Bool, Int) String)-kindRank KBool           = Left 0-kindRank (KBounded  b i) = Right (Left (b, i))-kindRank KUnbounded      = Left 1-kindRank KReal           = Left 2-kindRank (KUserSort s _) = Right (Right s)-kindRank KFloat          = Left 3-kindRank KDouble         = Left 4-{-# INLINE kindRank #-}---- | We want to equate user-sorts only by name-instance Eq Kind where-  k1 == k2 = kindRank k1 == kindRank k2---- | We want to order user-sorts only by name-instance Ord Kind where-  k1 `compare` k2 = kindRank k1 `compare` kindRank k2--instance Show Kind where-  show KBool              = "SBool"-  show (KBounded False n) = "SWord" ++ show n-  show (KBounded True n)  = "SInt"  ++ show n-  show KUnbounded         = "SInteger"-  show KReal              = "SReal"-  show (KUserSort s _)    = s-  show KFloat             = "SFloat"-  show KDouble            = "SDouble"--instance Eq  G.DataType where-   a == b = G.tyconUQname (G.dataTypeName a) == G.tyconUQname (G.dataTypeName b)--instance Ord G.DataType where-   a `compare` b = G.tyconUQname (G.dataTypeName a) `compare` G.tyconUQname (G.dataTypeName b)---- | Does this kind represent a signed quantity?-kindHasSign :: Kind -> Bool-kindHasSign k =-  case k of-    KBool        -> False-    KBounded b _ -> b-    KUnbounded   -> True-    KReal        -> True-    KFloat       -> True-    KDouble      -> True-    KUserSort{}  -> 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 = KUserSort sortName mbEnumFields-  where 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"---- | A class for capturing values that have a sign and a size (finite or infinite)--- minimal complete definition: kindOf. This class can be automatically derived--- for data-types that have a 'Data' instance; this is useful for creating uninterpreted--- sorts.-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-  isInteger       :: a -> Bool-  isUninterpreted :: 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)"-                  KUserSort s _ -> error $ "SBV.HasKind.intSizeOf: Uninterpreted sort: " ++ s-  isBoolean       x | KBool{}      <- kindOf x = True-                    | True                     = False-  isBounded       x | KBounded{}   <- kindOf x = True-                    | True                     = False-  isReal          x | KReal{}      <- kindOf x = True-                    | True                     = False-  isFloat         x | KFloat{}     <- kindOf x = True-                    | True                     = False-  isDouble        x | KDouble{}    <- kindOf x = True-                    | True                     = False-  isInteger       x | KUnbounded{} <- kindOf x = True-                    | True                     = False-  isUninterpreted x | KUserSort{}  <- kindOf x = True-                    | True                     = False-  showType = show . kindOf--  -- default signature for uninterpreted/enumerated kinds-  default kindOf :: (Read a, G.Data a) => a -> Kind-  kindOf = constructUKind--instance HasKind Bool    where kindOf _ = KBool-instance HasKind Int8    where kindOf _ = KBounded True  8-instance HasKind Word8   where kindOf _ = KBounded False 8-instance HasKind Int16   where kindOf _ = KBounded True  16-instance HasKind Word16  where kindOf _ = KBounded False 16-instance HasKind Int32   where kindOf _ = KBounded True  32-instance HasKind Word32  where kindOf _ = KBounded False 32-instance HasKind Int64   where kindOf _ = KBounded True  64-instance HasKind Word64  where kindOf _ = KBounded False 64-instance HasKind Integer where kindOf _ = KUnbounded-instance HasKind AlgReal where kindOf _ = KReal-instance HasKind Float   where kindOf _ = KFloat-instance HasKind Double  where kindOf _ = KDouble--instance HasKind Kind where-  kindOf = id
− Data/SBV/BitVectors/Model.hs 
@@ -1,1698 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.BitVectors.Model--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Instance declarations for our symbolic world--------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-orphans   #-}-{-# LANGUAGE TypeSynonymInstances   #-}-{-# LANGUAGE BangPatterns           #-}-{-# LANGUAGE PatternGuards          #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE Rank2Types             #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE DefaultSignatures      #-}--module Data.SBV.BitVectors.Model (-    Mergeable(..), EqSymbolic(..), OrdSymbolic(..), SDivisible(..), Uninterpreted(..), SIntegral-  , ite, iteLazy, sTestBit, sExtractBits, sPopCount, setBitTo, sFromIntegral-  , sShiftLeft, sShiftRight, sRotateLeft, sRotateRight, sSignedShiftArithRight, (.^)-  , allEqual, allDifferent, inRange, sElem, oneIf, blastBE, blastLE, fullAdder, fullMultiplier-  , lsb, msb, genVar, genVar_, forall, forall_, exists, exists_-  , constrain, pConstrain, sBool, sBools, sWord8, sWord8s, sWord16, sWord16s, sWord32-  , sWord32s, sWord64, sWord64s, sInt8, sInt8s, sInt16, sInt16s, sInt32, sInt32s, sInt64-  , sInt64s, sInteger, sIntegers, sReal, sReals, sFloat, sFloats, sDouble, sDoubles, slet-  , sRealToSInteger, label-  , sAssert-  , liftQRem, liftDMod, symbolicMergeWithKind-  , genLiteral, genFromCW, genMkSymVar-  , isSatisfiableInCurrentPath-  , sbvQuickCheck-  )-  where--import Control.Monad        (when, unless)-import Control.Monad.Reader (ask)-import Control.Monad.Trans  (liftIO)--import GHC.Generics (U1(..), M1(..), (:*:)(..), K1(..))-import qualified GHC.Generics as G-import GHC.Stack.Compat--import Data.Array      (Array, Ix, listArray, elems, bounds, rangeSize)-import Data.Bits       (Bits(..))-import Data.Int        (Int8, Int16, Int32, Int64)-import Data.List       (genericLength, genericIndex, genericTake, unzip4, unzip5, unzip6, unzip7, intercalate)-import Data.Maybe      (fromMaybe)-import Data.Word       (Word8, Word16, Word32, Word64)--import Test.QuickCheck                         (Testable(..), Arbitrary(..))-import qualified Test.QuickCheck.Test    as QC (isSuccess)-import qualified Test.QuickCheck         as QC (quickCheckResult, counterexample)-import qualified Test.QuickCheck.Monadic as QC (monadicIO, run, assert, pre, monitor)-import System.Random--import Data.SBV.BitVectors.AlgReals-import Data.SBV.BitVectors.Data-import Data.SBV.Utils.Boolean--import Data.SBV.Provers.Prover (isVacuous, prove, defaultSMTCfg, internalSATCheck)-import Data.SBV.SMT.SMT        (ThmResult, SatResult(..), showModel)--import Data.SBV.BitVectors.Symbolic-import Data.SBV.BitVectors.Operations---- | Newer versions of GHC (Starting with 7.8 I think), distinguishes between FiniteBits and Bits classes.--- We should really use FiniteBitSize for SBV which would make things better. In the interim, just work--- around pesky warnings..-ghcBitSize :: Bits a => a -> Int-ghcBitSize x = fromMaybe (error "SBV.ghcBitSize: Unexpected non-finite usage!") (bitSizeMaybe x)--mkSymOpSC :: (SW -> SW -> Maybe SW) -> Op -> State -> Kind -> SW -> SW -> IO SW-mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) return (shortCut a b)--mkSymOp :: Op -> State -> Kind -> SW -> SW -> IO SW-mkSymOp = mkSymOpSC (const (const Nothing))---- Symbolic-Word class instances---- | Generate a finite symbolic bitvector, named-genVar :: Maybe Quantifier -> Kind -> String -> Symbolic (SBV a)-genVar q k = mkSymSBV q k . Just---- | Generate a finite symbolic bitvector, unnamed-genVar_ :: Maybe Quantifier -> Kind -> Symbolic (SBV a)-genVar_ q k = mkSymSBV q k Nothing---- | Generate a finite constant bitvector-genLiteral :: Integral a => Kind -> a -> SBV b-genLiteral k = SBV . SVal k . Left . mkConstCW k---- | Convert a constant to an integral value-genFromCW :: Integral a => CW -> a-genFromCW (CW _ (CWInteger x)) = fromInteger x-genFromCW c                    = error $ "genFromCW: Unsupported non-integral value: " ++ show c---- | Generically make a symbolic var-genMkSymVar :: Kind -> Maybe Quantifier -> Maybe String -> Symbolic (SBV a)-genMkSymVar k mbq Nothing  = genVar_ mbq k-genMkSymVar k mbq (Just s) = genVar  mbq k s---- | Base type of () allows simple construction for uninterpreted types.-instance SymWord ()-instance HasKind ()--instance SymWord Bool where-  mkSymWord  = genMkSymVar KBool-  literal x  = SBV (svBool x)-  fromCW     = cwToBool--instance SymWord Word8 where-  mkSymWord  = genMkSymVar (KBounded False 8)-  literal    = genLiteral  (KBounded False 8)-  fromCW     = genFromCW--instance SymWord Int8 where-  mkSymWord  = genMkSymVar (KBounded True 8)-  literal    = genLiteral  (KBounded True 8)-  fromCW     = genFromCW--instance SymWord Word16 where-  mkSymWord  = genMkSymVar (KBounded False 16)-  literal    = genLiteral  (KBounded False 16)-  fromCW     = genFromCW--instance SymWord Int16 where-  mkSymWord  = genMkSymVar (KBounded True 16)-  literal    = genLiteral  (KBounded True 16)-  fromCW     = genFromCW--instance SymWord Word32 where-  mkSymWord  = genMkSymVar (KBounded False 32)-  literal    = genLiteral  (KBounded False 32)-  fromCW     = genFromCW--instance SymWord Int32 where-  mkSymWord  = genMkSymVar (KBounded True 32)-  literal    = genLiteral  (KBounded True 32)-  fromCW     = genFromCW--instance SymWord Word64 where-  mkSymWord  = genMkSymVar (KBounded False 64)-  literal    = genLiteral  (KBounded False 64)-  fromCW     = genFromCW--instance SymWord Int64 where-  mkSymWord  = genMkSymVar (KBounded True 64)-  literal    = genLiteral  (KBounded True 64)-  fromCW     = genFromCW--instance SymWord Integer where-  mkSymWord  = genMkSymVar KUnbounded-  literal    = SBV . SVal KUnbounded . Left . mkConstCW KUnbounded-  fromCW     = genFromCW--instance SymWord AlgReal where-  mkSymWord  = genMkSymVar KReal-  literal    = SBV . SVal KReal . Left . CW KReal . CWAlgReal-  fromCW (CW _ (CWAlgReal a)) = a-  fromCW c                    = error $ "SymWord.AlgReal: Unexpected non-real value: " ++ show c-  -- AlgReal needs its own definition of isConcretely-  -- to make sure we avoid using unimplementable Haskell functions-  isConcretely (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) p-     | isExactRational v = p v-  isConcretely _ _       = False--instance SymWord Float where-  mkSymWord  = genMkSymVar KFloat-  literal    = SBV . SVal KFloat . Left . CW KFloat . CWFloat-  fromCW (CW _ (CWFloat a)) = a-  fromCW c                  = error $ "SymWord.Float: Unexpected non-float value: " ++ show c-  -- For Float, we conservatively return 'False' for isConcretely. The reason is that-  -- this function is used for optimizations when only one of the argument is concrete,-  -- and in the presence of NaN's it would be incorrect to do any optimization-  isConcretely _ _ = False--instance SymWord Double where-  mkSymWord  = genMkSymVar KDouble-  literal    = SBV . SVal KDouble . Left . CW KDouble . CWDouble-  fromCW (CW _ (CWDouble a)) = a-  fromCW c                   = error $ "SymWord.Double: Unexpected non-double value: " ++ show c-  -- For Double, we conservatively return 'False' for isConcretely. The reason is that-  -- this function is used for optimizations when only one of the argument is concrete,-  -- and in the presence of NaN's it would be incorrect to do any optimization-  isConcretely _ _ = False----------------------------------------------------------------------------------------- * Smart constructors for creating symbolic values. These are not strictly--- necessary, as they are mere aliases for 'symbolic' and 'symbolics', but --- they nonetheless make programming easier.---------------------------------------------------------------------------------------- | Declare an 'SBool'-sBool :: String -> Symbolic SBool-sBool = symbolic---- | Declare a list of 'SBool's-sBools :: [String] -> Symbolic [SBool]-sBools = symbolics---- | Declare an 'SWord8'-sWord8 :: String -> Symbolic SWord8-sWord8 = symbolic---- | Declare a list of 'SWord8's-sWord8s :: [String] -> Symbolic [SWord8]-sWord8s = symbolics---- | Declare an 'SWord16'-sWord16 :: String -> Symbolic SWord16-sWord16 = symbolic---- | Declare a list of 'SWord16's-sWord16s :: [String] -> Symbolic [SWord16]-sWord16s = symbolics---- | Declare an 'SWord32'-sWord32 :: String -> Symbolic SWord32-sWord32 = symbolic---- | Declare a list of 'SWord32's-sWord32s :: [String] -> Symbolic [SWord32]-sWord32s = symbolics---- | Declare an 'SWord64'-sWord64 :: String -> Symbolic SWord64-sWord64 = symbolic---- | Declare a list of 'SWord64's-sWord64s :: [String] -> Symbolic [SWord64]-sWord64s = symbolics---- | Declare an 'SInt8'-sInt8 :: String -> Symbolic SInt8-sInt8 = symbolic---- | Declare a list of 'SInt8's-sInt8s :: [String] -> Symbolic [SInt8]-sInt8s = symbolics---- | Declare an 'SInt16'-sInt16 :: String -> Symbolic SInt16-sInt16 = symbolic---- | Declare a list of 'SInt16's-sInt16s :: [String] -> Symbolic [SInt16]-sInt16s = symbolics---- | Declare an 'SInt32'-sInt32 :: String -> Symbolic SInt32-sInt32 = symbolic---- | Declare a list of 'SInt32's-sInt32s :: [String] -> Symbolic [SInt32]-sInt32s = symbolics---- | Declare an 'SInt64'-sInt64 :: String -> Symbolic SInt64-sInt64 = symbolic---- | Declare a list of 'SInt64's-sInt64s :: [String] -> Symbolic [SInt64]-sInt64s = symbolics---- | Declare an 'SInteger'-sInteger:: String -> Symbolic SInteger-sInteger = symbolic---- | Declare a list of 'SInteger's-sIntegers :: [String] -> Symbolic [SInteger]-sIntegers = symbolics---- | Declare an 'SReal'-sReal:: String -> Symbolic SReal-sReal = symbolic---- | Declare a list of 'SReal's-sReals :: [String] -> Symbolic [SReal]-sReals = symbolics---- | Declare an 'SFloat'-sFloat :: String -> Symbolic SFloat-sFloat = symbolic---- | Declare a list of 'SFloat's-sFloats :: [String] -> Symbolic [SFloat]-sFloats = symbolics---- | Declare an 'SDouble'-sDouble :: String -> Symbolic SDouble-sDouble = symbolic---- | Declare a list of 'SDouble's-sDoubles :: [String] -> Symbolic [SDouble]-sDoubles = symbolics---- | Convert an SReal to an SInteger. That is, it computes the--- largest integer @n@ that satisfies @sIntegerToSReal n <= r@--- essentially giving us the @floor@.------ For instance, @1.3@ will be @1@, but @-1.3@ will be @-2@.-sRealToSInteger :: SReal -> SInteger-sRealToSInteger x-  | Just i <- unliteral x, isExactRational i-  = literal $ floor (toRational i)-  | True-  = SBV (SVal KUnbounded (Right (cache y)))-  where y st = do xsw <- sbvToSW st x-                  newExpr st KUnbounded (SBVApp (KindCast KReal KUnbounded) [xsw])---- | label: Label the result of an expression. This is essentially a no-op, but useful as it generates a comment in the generated C/SMT-Lib code.--- Note that if the argument is a constant, then the label is dropped completely, per the usual constant folding strategy.-label :: SymWord a => String -> SBV a -> SBV a-label m x-   | Just _ <- unliteral x = x-   | True                  = SBV $ SVal k $ Right $ cache r-  where k    = kindOf x-        r st = do xsw <- sbvToSW st x-                  newExpr st k (SBVApp (Label m) [xsw])---- | Symbolic Equality. Note that we can't use Haskell's 'Eq' class since Haskell insists on returning Bool--- Comparing symbolic values will necessarily return a symbolic value.------ Minimal complete definition: '.=='-infix 4 .==, ./=-class EqSymbolic a where-  (.==), (./=) :: a -> a -> SBool-  -- minimal complete definition: .==-  x ./= y = bnot (x .== y)---- | Symbolic Comparisons. Similar to 'Eq', we cannot implement Haskell's 'Ord' class--- since there is no way to return an 'Ordering' value from a symbolic comparison.--- Furthermore, 'OrdSymbolic' requires 'Mergeable' to implement if-then-else, for the--- benefit of implementing symbolic versions of 'max' and 'min' functions.------ Minimal complete definition: '.<'-infix 4 .<, .<=, .>, .>=-class (Mergeable a, EqSymbolic a) => OrdSymbolic a where-  (.<), (.<=), (.>), (.>=) :: a -> a -> SBool-  smin, smax :: a -> a -> a-  -- minimal complete definition: .<-  a .<= b    = a .< b ||| a .== b-  a .>  b    = b .<  a-  a .>= b    = b .<= a-  a `smin` b = ite (a .<= b) a b-  a `smax` b = ite (a .<= b) b a--{- We can't have a generic instance of the form:--instance Eq a => EqSymbolic a where-  x .== y = if x == y then true else false--even if we're willing to allow Flexible/undecidable instances..-This is because if we allow this it would imply EqSymbolic (SBV a);-since (SBV a) has to be Eq as it must be a Num. But this wouldn't be-the right choice obviously; as the Eq instance is bogus for SBV-for natural reasons..--}--instance EqSymbolic (SBV a) where-  SBV x .== SBV y = SBV (svEqual x y)-  SBV x ./= SBV y = SBV (svNotEqual x y)--instance SymWord a => OrdSymbolic (SBV a) where-  SBV x .<  SBV y = SBV (svLessThan x y)-  SBV x .<= SBV y = SBV (svLessEq x y)-  SBV x .>  SBV y = SBV (svGreaterThan x y)-  SBV x .>= SBV y = SBV (svGreaterEq x y)---- Bool-instance EqSymbolic Bool where-  x .== y = if x == y then true else false---- Lists-instance EqSymbolic a => EqSymbolic [a] where-  []     .== []     = true-  (x:xs) .== (y:ys) = x .== y &&& xs .== ys-  _      .== _      = false--instance OrdSymbolic a => OrdSymbolic [a] where-  []     .< []     = false-  []     .< _      = true-  _      .< []     = false-  (x:xs) .< (y:ys) = x .< y ||| (x .== y &&& xs .< ys)---- Maybe-instance EqSymbolic a => EqSymbolic (Maybe a) where-  Nothing .== Nothing = true-  Just a  .== Just b  = a .== b-  _       .== _       = false--instance (OrdSymbolic a) => OrdSymbolic (Maybe a) where-  Nothing .<  Nothing = false-  Nothing .<  _       = true-  Just _  .<  Nothing = false-  Just a  .<  Just b  = a .< b---- Either-instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (Either a b) where-  Left a  .== Left b  = a .== b-  Right a .== Right b = a .== b-  _       .== _       = false--instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (Either a b) where-  Left a  .< Left b  = a .< b-  Left _  .< Right _ = true-  Right _ .< Left _  = false-  Right a .< Right b = a .< b---- 2-Tuple-instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (a, b) where-  (a0, b0) .== (a1, b1) = a0 .== a1 &&& b0 .== b1--instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (a, b) where-  (a0, b0) .< (a1, b1) = a0 .< a1 ||| (a0 .== a1 &&& b0 .< b1)---- 3-Tuple-instance (EqSymbolic a, EqSymbolic b, EqSymbolic c) => EqSymbolic (a, b, c) where-  (a0, b0, c0) .== (a1, b1, c1) = (a0, b0) .== (a1, b1) &&& c0 .== c1--instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c) => OrdSymbolic (a, b, c) where-  (a0, b0, c0) .< (a1, b1, c1) = (a0, b0) .< (a1, b1) ||| ((a0, b0) .== (a1, b1) &&& c0 .< c1)---- 4-Tuple-instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d) => EqSymbolic (a, b, c, d) where-  (a0, b0, c0, d0) .== (a1, b1, c1, d1) = (a0, b0, c0) .== (a1, b1, c1) &&& d0 .== d1--instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d) => OrdSymbolic (a, b, c, d) where-  (a0, b0, c0, d0) .< (a1, b1, c1, d1) = (a0, b0, c0) .< (a1, b1, c1) ||| ((a0, b0, c0) .== (a1, b1, c1) &&& d0 .< d1)---- 5-Tuple-instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e) => EqSymbolic (a, b, c, d, e) where-  (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .== (a1, b1, c1, d1) &&& e0 .== e1--instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e) => OrdSymbolic (a, b, c, d, e) where-  (a0, b0, c0, d0, e0) .< (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .< (a1, b1, c1, d1) ||| ((a0, b0, c0, d0) .== (a1, b1, c1, d1) &&& e0 .< e1)---- 6-Tuple-instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f) => EqSymbolic (a, b, c, d, e, f) where-  (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) = (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) &&& f0 .== f1--instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f) => OrdSymbolic (a, b, c, d, e, f) where-  (a0, b0, c0, d0, e0, f0) .< (a1, b1, c1, d1, e1, f1) =    (a0, b0, c0, d0, e0) .<  (a1, b1, c1, d1, e1)-                                                       ||| ((a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) &&& f0 .< f1)---- 7-Tuple-instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f, EqSymbolic g) => EqSymbolic (a, b, c, d, e, f, g) where-  (a0, b0, c0, d0, e0, f0, g0) .== (a1, b1, c1, d1, e1, f1, g1) = (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) &&& g0 .== g1--instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f, OrdSymbolic g) => OrdSymbolic (a, b, c, d, e, f, g) where-  (a0, b0, c0, d0, e0, f0, g0) .< (a1, b1, c1, d1, e1, f1, g1) =    (a0, b0, c0, d0, e0, f0) .<  (a1, b1, c1, d1, e1, f1)-                                                               ||| ((a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) &&& g0 .< g1)---- | Symbolic Numbers. This is a simple class that simply incorporates all number like--- base types together, simplifying writing polymorphic type-signatures that work for all--- symbolic numbers, such as 'SWord8', 'SInt8' etc. For instance, we can write a generic--- list-minimum function as follows:------ @---    mm :: SIntegral a => [SBV a] -> SBV a---    mm = foldr1 (\a b -> ite (a .<= b) a b)--- @------ It is similar to the standard 'Integral' class, except ranging over symbolic instances.-class (SymWord a, Num a, Bits a) => SIntegral a---- 'SIntegral' Instances, including all possible variants except 'Bool', since booleans--- are not numbers.-instance SIntegral Word8-instance SIntegral Word16-instance SIntegral Word32-instance SIntegral Word64-instance SIntegral Int8-instance SIntegral Int16-instance SIntegral Int32-instance SIntegral Int64-instance SIntegral Integer---- Boolean combinators-instance Boolean SBool where-  true  = literal True-  false = literal False-  bnot (SBV b) = SBV (svNot b)-  SBV a &&& SBV b = SBV (svAnd a b)-  SBV a ||| SBV b = SBV (svOr a b)-  SBV a <+> SBV b = SBV (svXOr a b)---- | Returns (symbolic) true if all the elements of the given list are different.-allDifferent :: EqSymbolic a => [a] -> SBool-allDifferent []     = true-allDifferent (x:xs) = bAll (x ./=) xs &&& allDifferent xs---- | Returns (symbolic) true if all the elements of the given list are the same.-allEqual :: EqSymbolic a => [a] -> SBool-allEqual []     = true-allEqual (x:xs) = bAll (x .==) xs---- | Returns (symbolic) true if the argument is in range-inRange :: OrdSymbolic a => a -> (a, a) -> SBool-inRange x (y, z) = x .>= y &&& x .<= z---- | Symbolic membership test-sElem :: EqSymbolic a => a -> [a] -> SBool-sElem x xs = bAny (.== x) xs---- | Returns 1 if the boolean is true, otherwise 0.-oneIf :: (Num a, SymWord a) => SBool -> SBV a-oneIf t = ite t 1 0---- | Predicate for optimizing word operations like (+) and (*).-isConcreteZero :: SBV a -> Bool-isConcreteZero (SBV (SVal _     (Left (CW _     (CWInteger n))))) = n == 0-isConcreteZero (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) = isExactRational v && v == 0-isConcreteZero _                                                  = False---- | Predicate for optimizing word operations like (+) and (*).-isConcreteOne :: SBV a -> Bool-isConcreteOne (SBV (SVal _     (Left (CW _     (CWInteger 1))))) = True-isConcreteOne (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) = isExactRational v && v == 1-isConcreteOne _                                                  = False---- Num instance for symbolic words.-instance (Ord a, Num a, SymWord a) => Num (SBV a) where-  fromInteger = literal . fromIntegral-  SBV x + SBV y = SBV (svPlus x y)-  SBV x * SBV y = SBV (svTimes x y)-  SBV x - SBV y = SBV (svMinus x y)-  -- Abs is problematic for floating point, due to -0; case, so we carefully shuttle it down-  -- to the solver to avoid the can of worms. (Alternative would be to do an if-then-else here.)-  abs (SBV x) = SBV (svAbs x)-  signum a-    -- NB. The following "carefully" tests the number for == 0, as Float/Double's NaN and +/-0-    -- cases would cause trouble with explicit equality tests.-    | hasSign a = ite (a .> z) i-                $ ite (a .< z) (negate i) a-    | True      = ite (a .> z) i a-    where z = genLiteral (kindOf a) (0::Integer)-          i = genLiteral (kindOf a) (1::Integer)-  -- negate is tricky because on double/float -0 is different than 0; so we cannot-  -- just rely on the default definition; which would be 0-0, which is not -0!-  negate (SBV x) = SBV (svUNeg x)---- | Symbolic exponentiation using bit blasting and repeated squaring.------ N.B. The exponent must be unsigned. Signed exponents will be rejected.-(.^) :: (Mergeable b, Num b, SIntegral e) => b -> SBV e -> b-b .^ e | isSigned e = error "(.^): exponentiation only works with unsigned exponents"-       | True       = product $ zipWith (\use n -> ite use n 1)-                                        (blastLE e)-                                        (iterate (\x -> x*x) b)--instance (SymWord a, Fractional a) => Fractional (SBV a) where-  fromRational  = literal . fromRational-  SBV x / sy@(SBV y) | div0 = ite (sy .== 0) 0 res-                     | True = res-       where res  = SBV (svDivide x y)-             -- Identify those kinds where we have a div-0 equals 0 exception-             div0 = case kindOf sy of-                      KFloat        -> False-                      KDouble       -> False-                      KReal         -> True-                      -- Following two 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@KUserSort{} -> 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.-instance (SymWord 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---- | Lift a 1 arg FP-op, using sRNE default-lift1F :: SymWord a => FPOp -> (a -> a) -> SBV a -> SBV a-lift1F w op a-  | Just v <- unliteral a-  = literal $ op v-  | True-  = SBV $ SVal k $ Right $ cache r-  where k    = kindOf a-        r st = do swa  <- sbvToSW st a-                  swm  <- sbvToSW st sRNE-                  newExpr st k (SBVApp (IEEEFP w) [swm, swa])---- | Lift a float/double unary function, only over constants-lift1FNS :: (SymWord a, Floating a) => String -> (a -> a) -> SBV a -> SBV a-lift1FNS nm f sv-  | Just v <- unliteral sv = literal $ f v-  | True                   = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv)---- | Lift a float/double binary function, only over constants-lift2FNS :: (SymWord a, Floating a) => String -> (a -> a -> a) -> SBV a -> SBV a -> SBV a-lift2FNS nm f sv1 sv2-  | Just v1 <- unliteral sv1-  , Just v2 <- unliteral sv2 = literal $ f v1 v2-  | True                     = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv1)---- NB. In the optimizations below, use of -1 is valid as--- -1 has all bits set to True for both signed and unsigned values-instance (Num a, Bits a, SymWord a) => Bits (SBV a) where-  SBV x .&. SBV y    = SBV (svAnd x y)-  SBV x .|. SBV y    = SBV (svOr x y)-  SBV x `xor` SBV y  = SBV (svXOr x y)-  complement (SBV x) = SBV (svNot x)-  bitSize  x         = intSizeOf x-  bitSizeMaybe x     = Just $ intSizeOf x-  isSigned x         = hasSign x-  bit i              = 1 `shiftL` i-  setBit        x i  = x .|. genLiteral (kindOf x) (bit i :: Integer)-  clearBit      x i  = x .&. genLiteral (kindOf x) (complement (bit i) :: Integer)-  complementBit x i  = x `xor` genLiteral (kindOf x) (bit i :: Integer)-  shiftL  (SBV x) i  = SBV (svShl x i)-  shiftR  (SBV x) i  = SBV (svShr x i)-  rotateL (SBV x) i  = SBV (svRol x i)-  rotateR (SBV x) i  = SBV (svRor x i)-  -- NB. testBit is *not* implementable on non-concrete symbolic words-  x `testBit` i-    | SBV (SVal _ (Left (CW _ (CWInteger n)))) <- x-    = testBit n i-    | True-    = error $ "SBV.testBit: Called on symbolic value: " ++ show x ++ ". Use sTestBit instead."-  -- NB. popCount is *not* implementable on non-concrete symbolic words-  popCount x-    | SBV (SVal _ (Left (CW (KBounded _ w) (CWInteger n)))) <- x-    = popCount (n .&. (bit w - 1))-    | True-    = error $ "SBV.popCount: Called on symbolic value: " ++ show x ++ ". Use sPopCount instead."---- | Replacement for 'testBit'. Since 'testBit' requires a 'Bool' to be returned,--- we cannot implement it for symbolic words. Index 0 is the least-significant bit.-sTestBit :: SBV a -> Int -> SBool-sTestBit (SBV x) i = SBV (svTestBit x i)---- | Variant of 'sTestBit', where we want to extract multiple bit positions.-sExtractBits :: SBV a -> [Int] -> [SBool]-sExtractBits x = map (sTestBit x)---- | Replacement for 'popCount'. Since 'popCount' returns an 'Int', we cannot implement--- it for symbolic words. Here, we return an 'SWord8', which can overflow when used on--- quantities that have more than 255 bits. Currently, that's only the 'SInteger' type--- that SBV supports, all other types are safe. Even with 'SInteger', this will only--- overflow if there are at least 256-bits set in the number, and the smallest such--- number is 2^256-1, which is a pretty darn big number to worry about for practical--- purposes. In any case, we do not support 'sPopCount' for unbounded symbolic integers,--- as the only possible implementation wouldn't symbolically terminate. So the only overflow--- issue is with really-really large concrete 'SInteger' values.-sPopCount :: (Num a, Bits a, SymWord a) => SBV a -> SWord8-sPopCount x-  | isReal x          = error "SBV.sPopCount: Called on a real value" -- can't really happen due to types, but being overcautious-  | isConcrete x      = go 0 x-  | not (isBounded x) = error "SBV.sPopCount: Called on an infinite precision symbolic value"-  | True              = sum [ite b 1 0 | b <- blastLE x]-  where -- concrete case-        go !c 0 = c-        go !c w = go (c+1) (w .&. (w-1))---- | Generalization of 'setBit' based on a symbolic boolean. Note that 'setBit' and--- 'clearBit' are still available on Symbolic words, this operation comes handy when--- the condition to set/clear happens to be symbolic.-setBitTo :: (Num a, Bits a, SymWord a) => SBV a -> Int -> SBool -> SBV a-setBitTo x i b = ite b (setBit x i) (clearBit x i)---- | Conversion between integral-symbolic values, akin to Haskell's fromIntegral-sFromIntegral :: forall a b. (Integral a, HasKind a, Num a, SymWord a, HasKind b, Num b, SymWord b) => SBV a -> SBV b-sFromIntegral x-  | isReal x-  = error "SBV.sFromIntegral: Called on a real value" -- can't really happen due to types, but being overcautious-  | Just v <- unliteral x-  = literal (fromIntegral v)-  | True-  = result-  where result = SBV (SVal kTo (Right (cache y)))-        kFrom  = kindOf x-        kTo    = kindOf (undefined :: b)-        y st   = do xsw <- sbvToSW st x-                    newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsw])---- | Generalization of 'shiftL', when the shift-amount is symbolic. Since Haskell's--- 'shiftL' only takes an 'Int' as the shift amount, it cannot be used when we have--- a symbolic amount to shift with. The first argument should be a bounded quantity.-sShiftLeft :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a-sShiftLeft x i-  | not (isBounded x)-  = error "SBV.sShiftRight: Shifted amount should be a bounded quantity!"-  | True-  = ite (i .< 0)-        (select [x `shiftR` k | k <- [0 .. ghcBitSize x - 1]] z (-i))-        (select [x `shiftL` k | k <- [0 .. ghcBitSize x - 1]] z   i )-  where z = genLiteral (kindOf x) (0::Integer)---- | Generalization of 'shiftR', when the shift-amount is symbolic. Since Haskell's--- 'shiftR' only takes an 'Int' as the shift amount, it cannot be used when we have--- a symbolic amount to shift with. The first argument should be a bounded quantity.------ NB. If the shiftee is signed, then this is an arithmetic shift; otherwise it's logical,--- following the usual Haskell convention. See 'sSignedShiftArithRight' for a variant--- that explicitly uses the msb as the sign bit, even for unsigned underlying types.-sShiftRight :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a-sShiftRight x i-  | not (isBounded x)-  = error "SBV.sShiftRight: Shifted amount should be a bounded quantity!"-  | True-  = ite (i .< 0)-        (select [x `shiftL` k | k <- [0 .. ghcBitSize x - 1]] z (-i))-        (select [x `shiftR` k | k <- [0 .. ghcBitSize x - 1]] z   i )-  where z = genLiteral (kindOf x) (0::Integer)---- | Arithmetic shift-right with a symbolic unsigned shift amount. This is equivalent--- to 'sShiftRight' when the argument is signed. However, if the argument is unsigned,--- then it explicitly treats its msb as a sign-bit, and uses it as the bit that--- gets shifted in. Useful when using the underlying unsigned bit representation to implement--- custom signed operations. Note that there is no direct Haskell analogue of this function.-sSignedShiftArithRight:: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a-sSignedShiftArithRight x i-  | isSigned i = error "sSignedShiftArithRight: shift amount should be unsigned"-  | isSigned x = sShiftRight x i-  | True       = ite (msb x)-                     (complement (sShiftRight (complement x) i))-                     (sShiftRight x i)---- | Generalization of 'rotateL', when the shift-amount is symbolic. Since Haskell's--- 'rotateL' only takes an 'Int' as the shift amount, it cannot be used when we have--- a symbolic amount to shift with. The first argument should be a bounded quantity.-sRotateLeft :: (SIntegral a, SIntegral b, SDivisible (SBV b)) => SBV a -> SBV b -> SBV a-sRotateLeft x i-  | not (isBounded x)-  = sShiftLeft x i-  | isBounded i && bit si <= toInteger sx    -- wrap-around not possible-  = ite (i .< 0)-        (select [x `rotateR` k | k <- [0 .. bit si - 1]] z (-i))-        (select [x `rotateL` k | k <- [0 .. bit si - 1]] z   i )-  | True-  = ite (i .< 0)-        (select [x `rotateR` k | k <- [0 .. sx     - 1]] z ((-i) `sRem` n))-        (select [x `rotateL` k | k <- [0 .. sx     - 1]] z (  i  `sRem` n))-    where sx = ghcBitSize x-          si = ghcBitSize i-          z  = genLiteral (kindOf x) (0::Integer)-          n  = genLiteral (kindOf i) (toInteger sx)---- | Generalization of 'rotateR', when the shift-amount is symbolic. Since Haskell's--- 'rotateR' only takes an 'Int' as the shift amount, it cannot be used when we have--- a symbolic amount to shift with. The first argument should be a bounded quantity.-sRotateRight :: (SIntegral a, SIntegral b, SDivisible (SBV b)) => SBV a -> SBV b -> SBV a-sRotateRight x i-  | not (isBounded x)-  = sShiftRight x i-  | isBounded i && bit si <= toInteger sx   -- wrap-around not possible-  = ite (i .< 0)-        (select [x `rotateL` k | k <- [0 .. bit si - 1]] z (-i))-        (select [x `rotateR` k | k <- [0 .. bit si - 1]] z   i)-  | True-  = ite (i .< 0)-        (select [x `rotateL` k | k <- [0 .. sx     - 1]] z ((-i) `sRem` n))-        (select [x `rotateR` k | k <- [0 .. sx     - 1]] z (  i  `sRem` n))-    where sx = ghcBitSize x-          si = ghcBitSize i-          z  = genLiteral (kindOf x) (0::Integer)-          n  = genLiteral (kindOf i) (toInteger sx)---- | Full adder. Returns the carry-out from the addition.------ N.B. Only works for unsigned types. Signed arguments will be rejected.-fullAdder :: SIntegral a => SBV a -> SBV a -> (SBool, SBV a)-fullAdder a b-  | isSigned a = error "fullAdder: only works on unsigned numbers"-  | True       = (a .> s ||| b .> s, s)-  where s = a + b---- | Full multiplier: Returns both the high-order and the low-order bits in a tuple,--- thus fully accounting for the overflow.------ N.B. Only works for unsigned types. Signed arguments will be rejected.------ N.B. The higher-order bits are determined using a simple shift-add multiplier,--- thus involving bit-blasting. It'd be naive to expect SMT solvers to deal efficiently--- with properties involving this function, at least with the current state of the art.-fullMultiplier :: SIntegral a => SBV a -> SBV a -> (SBV a, SBV a)-fullMultiplier a b-  | isSigned a = error "fullMultiplier: only works on unsigned numbers"-  | True       = (go (ghcBitSize a) 0 a, a*b)-  where go 0 p _ = p-        go n p x = let (c, p')  = ite (lsb x) (fullAdder p b) (false, p)-                       (o, p'') = shiftIn c p'-                       (_, x')  = shiftIn o x-                   in go (n-1) p'' x'-        shiftIn k v = (lsb v, mask .|. (v `shiftR` 1))-           where mask = ite k (bit (ghcBitSize v - 1)) 0---- | Little-endian blasting of a word into its bits. Also see the 'FromBits' class.-blastLE :: (Num a, Bits a, SymWord a) => SBV a -> [SBool]-blastLE x- | isReal x          = error "SBV.blastLE: Called on a real value"- | not (isBounded x) = error "SBV.blastLE: Called on an infinite precision value"- | True              = map (sTestBit x) [0 .. intSizeOf x - 1]---- | Big-endian blasting of a word into its bits. Also see the 'FromBits' class.-blastBE :: (Num a, Bits a, SymWord a) => SBV a -> [SBool]-blastBE = reverse . blastLE---- | Least significant bit of a word, always stored at index 0.-lsb :: SBV a -> SBool-lsb x = sTestBit x 0---- | Most significant bit of a word, always stored at the last position.-msb :: (Num a, Bits a, SymWord a) => SBV a -> SBool-msb x- | isReal x          = error "SBV.msb: Called on a real value"- | not (isBounded x) = error "SBV.msb: Called on an infinite precision value"- | True              = sTestBit x (intSizeOf x - 1)---- Enum instance. These instances are suitable for use with concrete values,--- and will be less useful for symbolic values around. Note that `fromEnum` requires--- a concrete argument for obvious reasons. Other variants (succ, pred, [x..]) etc are similarly--- limited. While symbolic variants can be defined for many of these, they will just diverge--- as final sizes cannot be determined statically.-instance (Show a, Bounded a, Integral a, Num a, SymWord a) => Enum (SBV a) where-  succ x-    | v == (maxBound :: a) = error $ "Enum.succ{" ++ showType x ++ "}: tried to take `succ' of maxBound"-    | True                 = fromIntegral $ v + 1-    where v = enumCvt "succ" x-  pred x-    | v == (minBound :: a) = error $ "Enum.pred{" ++ showType x ++ "}: tried to take `pred' of minBound"-    | True                 = fromIntegral $ v - 1-    where v = enumCvt "pred" x-  toEnum x-    | xi < fromIntegral (minBound :: a) || xi > fromIntegral (maxBound :: a)-    = error $ "Enum.toEnum{" ++ showType r ++ "}: " ++ show x ++ " is out-of-bounds " ++ show (minBound :: a, maxBound :: a)-    | True-    = r-    where xi :: Integer-          xi = fromIntegral x-          r  :: SBV a-          r  = fromIntegral x-  fromEnum x-     | r < fromIntegral (minBound :: Int) || r > fromIntegral (maxBound :: Int)-     = error $ "Enum.fromEnum{" ++ showType x ++ "}:  value " ++ show r ++ " is outside of Int's bounds " ++ show (minBound :: Int, maxBound :: Int)-     | True-     = fromIntegral r-    where r :: Integer-          r = enumCvt "fromEnum" x-  enumFrom x = map fromIntegral [xi .. fromIntegral (maxBound :: a)]-     where xi :: Integer-           xi = enumCvt "enumFrom" x-  enumFromThen x y-     | yi >= xi  = map fromIntegral [xi, yi .. fromIntegral (maxBound :: a)]-     | True      = map fromIntegral [xi, yi .. fromIntegral (minBound :: a)]-       where xi, yi :: Integer-             xi = enumCvt "enumFromThen.x" x-             yi = enumCvt "enumFromThen.y" y-  enumFromThenTo x y z = map fromIntegral [xi, yi .. zi]-       where xi, yi, zi :: Integer-             xi = enumCvt "enumFromThenTo.x" x-             yi = enumCvt "enumFromThenTo.y" y-             zi = enumCvt "enumFromThenTo.z" z---- | Helper function for use in enum operations-enumCvt :: (SymWord a, Integral a, Num b) => String -> SBV a -> b-enumCvt w x = case unliteral x of-                Nothing -> error $ "Enum." ++ w ++ "{" ++ showType x ++ "}: Called on symbolic value " ++ show x-                Just v  -> fromIntegral v---- | The 'SDivisible' class captures the essence of division.--- Unfortunately we cannot use Haskell's 'Integral' class since the 'Real'--- and 'Enum' superclasses are not implementable for symbolic bit-vectors.--- However, 'quotRem' and 'divMod' makes perfect sense, and the 'SDivisible' class captures--- this operation. One issue is how division by 0 behaves. The verification--- technology requires total functions, and there are several design choices--- here. We follow Isabelle/HOL approach of assigning the value 0 for division--- by 0. Therefore, we impose the following pair of laws:------ @---      x `sQuotRem` 0 = (0, x)---      x `sDivMod`  0 = (0, x)--- @------ Note that our instances implement this law even when @x@ is @0@ itself.------ NB. 'quot' truncates toward zero, while 'div' truncates toward negative infinity.------ Minimal complete definition: 'sQuotRem', 'sDivMod'-class SDivisible a where-  sQuotRem :: a -> a -> (a, a)-  sDivMod  :: a -> a -> (a, a)-  sQuot    :: a -> a -> a-  sRem     :: a -> a -> a-  sDiv     :: a -> a -> a-  sMod     :: a -> a -> a--  x `sQuot` y = fst $ x `sQuotRem` y-  x `sRem`  y = snd $ x `sQuotRem` y-  x `sDiv`  y = fst $ x `sDivMod`  y-  x `sMod`  y = snd $ x `sDivMod`  y--instance SDivisible Word64 where-  sQuotRem x 0 = (0, x)-  sQuotRem x y = x `quotRem` y-  sDivMod  x 0 = (0, x)-  sDivMod  x y = x `divMod` y--instance SDivisible Int64 where-  sQuotRem x 0 = (0, x)-  sQuotRem x y = x `quotRem` y-  sDivMod  x 0 = (0, x)-  sDivMod  x y = x `divMod` y--instance SDivisible Word32 where-  sQuotRem x 0 = (0, x)-  sQuotRem x y = x `quotRem` y-  sDivMod  x 0 = (0, x)-  sDivMod  x y = x `divMod` y--instance SDivisible Int32 where-  sQuotRem x 0 = (0, x)-  sQuotRem x y = x `quotRem` y-  sDivMod  x 0 = (0, x)-  sDivMod  x y = x `divMod` y--instance SDivisible Word16 where-  sQuotRem x 0 = (0, x)-  sQuotRem x y = x `quotRem` y-  sDivMod  x 0 = (0, x)-  sDivMod  x y = x `divMod` y--instance SDivisible Int16 where-  sQuotRem x 0 = (0, x)-  sQuotRem x y = x `quotRem` y-  sDivMod  x 0 = (0, x)-  sDivMod  x y = x `divMod` y--instance SDivisible Word8 where-  sQuotRem x 0 = (0, x)-  sQuotRem x y = x `quotRem` y-  sDivMod  x 0 = (0, x)-  sDivMod  x y = x `divMod` y--instance SDivisible Int8 where-  sQuotRem x 0 = (0, x)-  sQuotRem x y = x `quotRem` y-  sDivMod  x 0 = (0, x)-  sDivMod  x y = x `divMod` y--instance SDivisible Integer where-  sQuotRem x 0 = (0, x)-  sQuotRem x y = x `quotRem` y-  sDivMod  x 0 = (0, x)-  sDivMod  x y = x `divMod` y--instance SDivisible CW where-  sQuotRem a b-    | CWInteger x <- cwVal a, CWInteger y <- cwVal b-    = let (r1, r2) = sQuotRem x y in (normCW a{ cwVal = CWInteger r1 }, normCW b{ cwVal = CWInteger r2 })-  sQuotRem a b = error $ "SBV.sQuotRem: impossible, unexpected args received: " ++ show (a, b)-  sDivMod a b-    | CWInteger x <- cwVal a, CWInteger y <- cwVal b-    = let (r1, r2) = sDivMod x y in (normCW a { cwVal = CWInteger r1 }, normCW b { cwVal = CWInteger r2 })-  sDivMod a b = error $ "SBV.sDivMod: impossible, unexpected args received: " ++ show (a, b)--instance SDivisible SWord64 where-  sQuotRem = liftQRem-  sDivMod  = liftDMod--instance SDivisible SInt64 where-  sQuotRem = liftQRem-  sDivMod  = liftDMod--instance SDivisible SWord32 where-  sQuotRem = liftQRem-  sDivMod  = liftDMod--instance SDivisible SInt32 where-  sQuotRem = liftQRem-  sDivMod  = liftDMod--instance SDivisible SWord16 where-  sQuotRem = liftQRem-  sDivMod  = liftDMod--instance SDivisible SInt16 where-  sQuotRem = liftQRem-  sDivMod  = liftDMod--instance SDivisible SWord8 where-  sQuotRem = liftQRem-  sDivMod  = liftDMod--instance SDivisible SInt8 where-  sQuotRem = liftQRem-  sDivMod  = liftDMod---- | Lift 'QRem' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which--- holds even when @x@ is @0@ itself.-liftQRem :: SymWord a => SBV a -> SBV a -> (SBV a, SBV a)-liftQRem x y-  | isConcreteZero x-  = (x, x)-  | isConcreteOne y-  = (x, z)-{-------------------------------- - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed;- - and also is problematic around the minBound.. So, we refrain from that optimization-  | isConcreteOnes y-  = (-x, z)---------------------------------}-  | True-  = ite (y .== z) (z, x) (qr x y)-  where qr (SBV (SVal sgnsz (Left a))) (SBV (SVal _ (Left b))) = let (q, r) = sQuotRem a b in (SBV (SVal sgnsz (Left q)), SBV (SVal sgnsz (Left r)))-        qr a@(SBV (SVal sgnsz _))      b                       = (SBV (SVal sgnsz (Right (cache (mk Quot)))), SBV (SVal sgnsz (Right (cache (mk Rem)))))-                where mk o st = do sw1 <- sbvToSW st a-                                   sw2 <- sbvToSW st b-                                   mkSymOp o st sgnsz sw1 sw2-        z = genLiteral (kindOf x) (0::Integer)---- | Lift 'DMod' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which--- holds even when @x@ is @0@ itself. Essentially, this is conversion from quotRem--- (truncate to 0) to divMod (truncate towards negative infinity)-liftDMod :: (SymWord a, Num a, SDivisible (SBV a)) => SBV a -> SBV a -> (SBV a, SBV a)-liftDMod x y-  | isConcreteZero x-  = (x, x)-  | isConcreteOne y-  = (x, z)-{-------------------------------- - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed;- - and also is problematic around the minBound.. So, we refrain from that optimization-  | isConcreteOnes y-  = (-x, z)---------------------------------}-  | True-  = ite (y .== z) (z, x) $ ite (signum r .== negate (signum y)) (q-i, r+y) qr- where qr@(q, r) = x `sQuotRem` y-       z = genLiteral (kindOf x) (0::Integer)-       i = genLiteral (kindOf x) (1::Integer)---- SInteger instance for quotRem/divMod are tricky!--- SMT-Lib only has Euclidean operations, but Haskell--- uses "truncate to 0" for quotRem, and "truncate to negative infinity" for divMod.--- So, we cannot just use the above liftings directly.-instance SDivisible SInteger where-  sDivMod = liftDMod-  sQuotRem x y-    | not (isSymbolic x || isSymbolic y)-    = liftQRem x y-    | True-    = ite (y .== 0) (0, x) (qE+i, rE-i*y)-    where (qE, rE) = liftQRem x y   -- for integers, this is euclidean due to SMTLib semantics-          i = ite (x .>= 0 ||| rE .== 0) 0-            $ ite (y .>  0)              1 (-1)---- Quickcheck interface---- The Arbitrary instance for SFunArray returns an array initialized--- to an arbitrary element-instance (SymWord b, Arbitrary b) => Arbitrary (SFunArray a b) where-  arbitrary = arbitrary >>= \r -> return $ SFunArray (const r)--instance (SymWord a, Arbitrary a) => Arbitrary (SBV a) where-  arbitrary = literal `fmap` arbitrary---- |  Symbolic conditionals are modeled by the 'Mergeable' class, describing--- how to merge the results of an if-then-else call with a symbolic test. SBV--- provides all basic types as instances of this class, so users only need--- to declare instances for custom data-types of their programs as needed.------ A 'Mergeable' instance may be automatically derived for a custom data-type--- with a single constructor where the type of each field is an instance of--- 'Mergeable', such as a record of symbolic values. Users only need to add--- 'G.Generic' and 'Mergeable' to the @deriving@ clause for the data-type. See--- 'Data.SBV.Examples.Puzzles.U2Bridge.Status' for an example and an--- illustration of what the instance would look like if written by hand.------ The function 'select' is a total-indexing function out of a list of choices--- with a default value, simulating array/list indexing. It's an n-way generalization--- of the 'ite' function.------ Minimal complete definition: None, if the type is instance of 'Generic'. Otherwise--- 'symbolicMerge'. Note that most types subject to merging are likely to be--- trivial instances of 'Generic'.-class Mergeable a where-   -- | Merge two values based on the condition. The first argument states-   -- whether we force the then-and-else branches before the merging, at the-   -- word level. This is an efficiency concern; one that we'd rather not-   -- make but unfortunately necessary for getting symbolic simulation-   -- working efficiently.-   symbolicMerge :: Bool -> SBool -> a -> a -> a-   -- | Total indexing operation. @select xs default index@ is intuitively-   -- the same as @xs !! index@, except it evaluates to @default@ if @index@-   -- underflows/overflows.-   select :: (SymWord b, Num b) => [a] -> a -> SBV b -> a-   -- NB. Earlier implementation of select used the binary-search trick-   -- on the index to chop down the search space. While that is a good trick-   -- in general, it doesn't work for SBV since we do not have any notion of-   -- "concrete" subwords: If an index is symbolic, then all its bits are-   -- symbolic as well. So, the binary search only pays off only if the indexed-   -- list is really humongous, which is not very common in general. (Also,-   -- for the case when the list is bit-vectors, we use SMT tables anyhow.)-   select xs err ind-    | isReal   ind = bad "real"-    | isFloat  ind = bad "float"-    | isDouble ind = bad "double"-    | hasSign  ind = ite (ind .< 0) err (walk xs ind err)-    | True         =                     walk xs ind err-    where bad w = error $ "SBV.select: unsupported " ++ w ++ " valued select/index expression"-          walk []     _ acc = acc-          walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc)--   -- Default implementation for 'symbolicMerge' if the type is 'Generic'-   default symbolicMerge :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a-   symbolicMerge = symbolicMergeDefault----- | If-then-else. This is by definition 'symbolicMerge' with both--- branches forced. This is typically the desired behavior, but also--- see 'iteLazy' should you need more laziness.-ite :: Mergeable a => SBool -> a -> a -> a-ite t a b-  | Just r <- unliteral t = if r then a else b-  | True                  = symbolicMerge True t a b---- | A Lazy version of ite, which does not force its arguments. This might--- cause issues for symbolic simulation with large thunks around, so use with--- care.-iteLazy :: Mergeable a => SBool -> a -> a -> a-iteLazy t a b-  | Just r <- unliteral t = if r then a else b-  | True                  = symbolicMerge False t a b---- | Symbolic assert. Check that the given boolean condition is always true in the given path. The--- optional first argument can be used to provide call-stack info via GHC's location facilities.-sAssert :: Maybe CallStack -> String -> SBool -> SBV a -> SBV a-sAssert cs msg cond x = SBV $ SVal k $ Right $ cache r-  where k     = kindOf x-        r st  = do xsw <- sbvToSW st x-                   let pc = getPathCondition st-                       -- We're checking if there are any cases where the path-condition holds, but not the condition-                       -- Any violations of this, should be signaled, i.e., whenever the following formula is satisfiable-                       mustNeverHappen = pc &&& bnot cond-                   cnd <- sbvToSW st mustNeverHappen-                   addAssertion st cs msg cnd-                   return xsw---- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make--- sure they do not evaluate to the same result. This should only be used for internal purposes;--- as default definitions provided should suffice in many cases. (i.e., End users should--- only need to define 'symbolicMerge' when needed; which should be rare to start with.)-symbolicMergeWithKind :: Kind -> Bool -> SBool -> SBV a -> SBV a -> SBV a-symbolicMergeWithKind k force (SBV t) (SBV a) (SBV b) = SBV (svSymbolicMerge k force t a b)--instance SymWord a => Mergeable (SBV a) where-    symbolicMerge force t x y-    -- Carefully use the kindOf instance to avoid strictness issues.-       | force = symbolicMergeWithKind (kindOf x)                True  t x y-       | True  = symbolicMergeWithKind (kindOf (undefined :: a)) False t x y-    -- Custom version of select that translates to SMT-Lib tables at the base type of words-    select xs err ind-      | SBV (SVal _ (Left c)) <- ind = case cwVal c of-                                         CWInteger i -> if i < 0 || i >= genericLength xs-                                                        then err-                                                        else xs `genericIndex` i-                                         _           -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"-    select xsOrig err ind = xs `seq` SBV (SVal kElt (Right (cache r)))-      where kInd = kindOf ind-            kElt = kindOf err-            -- Based on the index size, we need to limit the elements. For instance if the index is 8 bits, but there-            -- are 257 elements, that last element will never be used and we can chop it of..-            xs   = case kindOf ind of-                     KBounded False i -> genericTake ((2::Integer) ^ (fromIntegral i     :: Integer)) xsOrig-                     KBounded True  i -> genericTake ((2::Integer) ^ (fromIntegral (i-1) :: Integer)) xsOrig-                     KUnbounded       -> xsOrig-                     _                -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"-            r st  = do sws <- mapM (sbvToSW st) xs-                       swe <- sbvToSW st err-                       if all (== swe) sws  -- off-chance that all elts are the same. Note that this also correctly covers the case when list is empty.-                          then return swe-                          else do idx <- getTableIndex st kInd kElt sws-                                  swi <- sbvToSW st ind-                                  let len = length xs-                                  -- NB. No need to worry here that the index might be < 0; as the SMTLib translation takes care of that automatically-                                  newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) [])---- Unit-instance Mergeable () where-   symbolicMerge _ _ _ _ = ()-   select _ _ _ = ()---- Mergeable instances for List/Maybe/Either/Array are useful, but can--- throw exceptions if there is no structural matching of the results--- It's a question whether we should really keep them..---- Lists-instance Mergeable a => Mergeable [a] where-  symbolicMerge f t xs ys-    | lxs == lys = zipWith (symbolicMerge f t) xs ys-    | True       = error $ "SBV.Mergeable.List: No least-upper-bound for lists of differing size " ++ show (lxs, lys)-    where (lxs, lys) = (length xs, length ys)---- Maybe-instance Mergeable a => Mergeable (Maybe a) where-  symbolicMerge _ _ Nothing  Nothing  = Nothing-  symbolicMerge f t (Just a) (Just b) = Just $ symbolicMerge f t a b-  symbolicMerge _ _ a b = error $ "SBV.Mergeable.Maybe: No least-upper-bound for " ++ show (k a, k b)-      where k Nothing = "Nothing"-            k _       = "Just"---- Either-instance (Mergeable a, Mergeable b) => Mergeable (Either a b) where-  symbolicMerge f t (Left a)  (Left b)  = Left  $ symbolicMerge f t a b-  symbolicMerge f t (Right a) (Right b) = Right $ symbolicMerge f t a b-  symbolicMerge _ _ a b = error $ "SBV.Mergeable.Either: No least-upper-bound for " ++ show (k a, k b)-     where k (Left _)  = "Left"-           k (Right _) = "Right"---- Arrays-instance (Ix a, Mergeable b) => Mergeable (Array a b) where-  symbolicMerge f t a b-    | ba == bb = listArray ba (zipWith (symbolicMerge f t) (elems a) (elems b))-    | True     = error $ "SBV.Mergeable.Array: No least-upper-bound for rangeSizes" ++ show (k ba, k bb)-    where [ba, bb] = map bounds [a, b]-          k = rangeSize---- Functions-instance Mergeable b => Mergeable (a -> b) where-  symbolicMerge f t g h x = symbolicMerge f t (g x) (h x)-  {- Following definition, while correct, is utterly inefficient. Since the-     application is delayed, this hangs on to the inner list and all the-     impending merges, even when ind is concrete. Thus, it's much better to-     simply use the default definition for the function case.-  -}-  -- select xs err ind = \x -> select (map ($ x) xs) (err x) ind---- 2-Tuple-instance (Mergeable a, Mergeable b) => Mergeable (a, b) where-  symbolicMerge f t (i0, i1) (j0, j1) = (i i0 j0, i i1 j1)-    where i a b = symbolicMerge f t a b-  select xs (err1, err2) ind = (select as err1 ind, select bs err2 ind)-    where (as, bs) = unzip xs---- 3-Tuple-instance (Mergeable a, Mergeable b, Mergeable c) => Mergeable (a, b, c) where-  symbolicMerge f t (i0, i1, i2) (j0, j1, j2) = (i i0 j0, i i1 j1, i i2 j2)-    where i a b = symbolicMerge f t a b-  select xs (err1, err2, err3) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind)-    where (as, bs, cs) = unzip3 xs---- 4-Tuple-instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => Mergeable (a, b, c, d) where-  symbolicMerge f t (i0, i1, i2, i3) (j0, j1, j2, j3) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3)-    where i a b = symbolicMerge f t a b-  select xs (err1, err2, err3, err4) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind)-    where (as, bs, cs, ds) = unzip4 xs---- 5-Tuple-instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => Mergeable (a, b, c, d, e) where-  symbolicMerge f t (i0, i1, i2, i3, i4) (j0, j1, j2, j3, j4) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4)-    where i a b = symbolicMerge f t a b-  select xs (err1, err2, err3, err4, err5) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind)-    where (as, bs, cs, ds, es) = unzip5 xs---- 6-Tuple-instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f) => Mergeable (a, b, c, d, e, f) where-  symbolicMerge f t (i0, i1, i2, i3, i4, i5) (j0, j1, j2, j3, j4, j5) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4, i i5 j5)-    where i a b = symbolicMerge f t a b-  select xs (err1, err2, err3, err4, err5, err6) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind, select fs err6 ind)-    where (as, bs, cs, ds, es, fs) = unzip6 xs---- 7-Tuple-instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f, Mergeable g) => Mergeable (a, b, c, d, e, f, g) where-  symbolicMerge f t (i0, i1, i2, i3, i4, i5, i6) (j0, j1, j2, j3, j4, j5, j6) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4, i i5 j5, i i6 j6)-    where i a b = symbolicMerge f t a b-  select xs (err1, err2, err3, err4, err5, err6, err7) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind, select fs err6 ind, select gs err7 ind)-    where (as, bs, cs, ds, es, fs, gs) = unzip7 xs---- Arbitrary product types, using GHC.Generics------ NB: Because of the way GHC.Generics works, the implementation of--- symbolicMerge' is recursive. The derived instance for @data T a = T a a a a@--- resembles that for (a, (a, (a, a))), not the flat 4-tuple (a, a, a, a). This--- difference should have no effect in practice. Note also that, unlike the--- hand-rolled tuple instances, the generic instance does not provide a custom--- 'select' implementation, and so does not benefit from the SMT-table--- implementation in the 'SBV a' instance.---- | Not exported. Symbolic merge using the generic representation provided by--- 'G.Generics'.-symbolicMergeDefault :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a-symbolicMergeDefault force t x y = G.to $ symbolicMerge' force t (G.from x) (G.from y)---- | Not exported. Used only in 'symbolicMergeDefault'. Instances are provided for--- the generic representations of product types where each element is Mergeable.-class GMergeable f where-  symbolicMerge' :: Bool -> SBool -> f a -> f a -> f a--instance GMergeable U1 where-  symbolicMerge' _ _ _ _ = U1--instance (Mergeable c) => GMergeable (K1 i c) where-  symbolicMerge' force t (K1 x) (K1 y) = K1 $ symbolicMerge force t x y--instance (GMergeable f) => GMergeable (M1 i c f) where-  symbolicMerge' force t (M1 x) (M1 y) = M1 $ symbolicMerge' force t x y--instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where-  symbolicMerge' force t (x1 :*: y1) (x2 :*: y2) = symbolicMerge' force t x1 x2 :*: symbolicMerge' force t y1 y2---- Bounded instances-instance (SymWord a, Bounded a) => Bounded (SBV a) where-  minBound = literal minBound-  maxBound = literal maxBound---- Arrays---- SArrays are both "EqSymbolic" and "Mergeable"-instance EqSymbolic (SArray a b) where-  (SArray a) .== (SArray b) = SBV (eqSArr a b)---- When merging arrays; we'll ignore the force argument. This is arguably--- the right thing to do as we've too many things and likely we want to keep it efficient.-instance SymWord b => Mergeable (SArray a b) where-  symbolicMerge _ = mergeArrays---- SFunArrays are only "Mergeable". Although a brute--- force equality can be defined, any non-toy instance--- will suffer from efficiency issues; so we don't define it-instance SymArray SFunArray where-  newArray _                                  = newArray_ -- the name is irrelevant in this case-  newArray_     mbiVal                        = declNewSFunArray mbiVal-  readArray     (SFunArray f)                 = f-  resetArray    (SFunArray _) a               = SFunArray $ const a-  writeArray    (SFunArray f) a b             = SFunArray (\a' -> ite (a .== a') b (f a'))-  mergeArrays t (SFunArray g)   (SFunArray h) = SFunArray (\x -> ite t (g x) (h x))---- When merging arrays; we'll ignore the force argument. This is arguably--- the right thing to do as we've too many things and likely we want to keep it efficient.-instance SymWord b => Mergeable (SFunArray a b) where-  symbolicMerge _ = mergeArrays---- | Uninterpreted constants and functions. An uninterpreted constant is--- a value that is indexed by its name. The only property the prover assumes--- about these values are that they are equivalent to themselves; i.e., (for--- functions) they return the same results when applied to same arguments.--- We support uninterpreted-functions as a general means of black-box'ing--- operations that are /irrelevant/ for the purposes of the proof; i.e., when--- the proofs can be performed without any knowledge about the function itself.------ Minimal complete definition: 'sbvUninterpret'. However, most instances in--- practice are already provided by SBV, so end-users should not need to define their--- own instances.-class Uninterpreted a where-  -- | Uninterpret a value, receiving an object that can be used instead. Use this version-  -- when you do not need to add an axiom about this value.-  uninterpret :: String -> a-  -- | Uninterpret a value, only for the purposes of code-generation. For execution-  -- and verification the value is used as is. For code-generation, the alternate-  -- definition is used. This is useful when we want to take advantage of native-  -- libraries on the target languages.-  cgUninterpret :: String -> [String] -> a -> a-  -- | Most generalized form of uninterpretation, this function should not be needed-  -- by end-user-code, but is rather useful for the library development.-  sbvUninterpret :: Maybe ([String], a) -> String -> a--  -- minimal complete definition: 'sbvUninterpret'-  uninterpret             = sbvUninterpret Nothing-  cgUninterpret nm code v = sbvUninterpret (Just (code, v)) nm---- Plain constants-instance HasKind a => Uninterpreted (SBV a) where-  sbvUninterpret mbCgData nm-     | Just (_, v) <- mbCgData = v-     | True                    = SBV $ SVal ka $ Right $ cache result-    where ka = kindOf (undefined :: a)-          result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st v-                    | True = do newUninterpreted st nm (SBVType [ka]) (fst `fmap` mbCgData)-                                newExpr st ka $ SBVApp (Uninterpreted nm) []---- Functions of one argument-instance (SymWord b, HasKind a) => Uninterpreted (SBV b -> SBV a) where-  sbvUninterpret mbCgData nm = f-    where f arg0-           | Just (_, v) <- mbCgData, isConcrete arg0-           = v arg0-           | True-           = SBV $ SVal ka $ Right $ cache result-           where ka = kindOf (undefined :: a)-                 kb = kindOf (undefined :: b)-                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0)-                           | True = do newUninterpreted st nm (SBVType [kb, ka]) (fst `fmap` mbCgData)-                                       sw0 <- sbvToSW st arg0-                                       mapM_ forceSWArg [sw0]-                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0]---- Functions of two arguments-instance (SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV c -> SBV b -> SBV a) where-  sbvUninterpret mbCgData nm = f-    where f arg0 arg1-           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1-           = v arg0 arg1-           | True-           = SBV $ SVal ka $ Right $ cache result-           where ka = kindOf (undefined :: a)-                 kb = kindOf (undefined :: b)-                 kc = kindOf (undefined :: c)-                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1)-                           | True = do newUninterpreted st nm (SBVType [kc, kb, ka]) (fst `fmap` mbCgData)-                                       sw0 <- sbvToSW st arg0-                                       sw1 <- sbvToSW st arg1-                                       mapM_ forceSWArg [sw0, sw1]-                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1]---- Functions of three arguments-instance (SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV d -> SBV c -> SBV b -> SBV a) where-  sbvUninterpret mbCgData nm = f-    where f arg0 arg1 arg2-           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2-           = v arg0 arg1 arg2-           | True-           = SBV $ SVal ka $ Right $ cache result-           where ka = kindOf (undefined :: a)-                 kb = kindOf (undefined :: b)-                 kc = kindOf (undefined :: c)-                 kd = kindOf (undefined :: d)-                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2)-                           | True = do newUninterpreted st nm (SBVType [kd, kc, kb, ka]) (fst `fmap` mbCgData)-                                       sw0 <- sbvToSW st arg0-                                       sw1 <- sbvToSW st arg1-                                       sw2 <- sbvToSW st arg2-                                       mapM_ forceSWArg [sw0, sw1, sw2]-                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2]---- Functions of four arguments-instance (SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where-  sbvUninterpret mbCgData nm = f-    where f arg0 arg1 arg2 arg3-           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3-           = v arg0 arg1 arg2 arg3-           | True-           = SBV $ SVal ka $ Right $ cache result-           where ka = kindOf (undefined :: a)-                 kb = kindOf (undefined :: b)-                 kc = kindOf (undefined :: c)-                 kd = kindOf (undefined :: d)-                 ke = kindOf (undefined :: e)-                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3)-                           | True = do newUninterpreted st nm (SBVType [ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)-                                       sw0 <- sbvToSW st arg0-                                       sw1 <- sbvToSW st arg1-                                       sw2 <- sbvToSW st arg2-                                       sw3 <- sbvToSW st arg3-                                       mapM_ forceSWArg [sw0, sw1, sw2, sw3]-                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3]---- Functions of five arguments-instance (SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where-  sbvUninterpret mbCgData nm = f-    where f arg0 arg1 arg2 arg3 arg4-           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4-           = v arg0 arg1 arg2 arg3 arg4-           | True-           = SBV $ SVal ka $ Right $ cache result-           where ka = kindOf (undefined :: a)-                 kb = kindOf (undefined :: b)-                 kc = kindOf (undefined :: c)-                 kd = kindOf (undefined :: d)-                 ke = kindOf (undefined :: e)-                 kf = kindOf (undefined :: f)-                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4)-                           | True = do newUninterpreted st nm (SBVType [kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)-                                       sw0 <- sbvToSW st arg0-                                       sw1 <- sbvToSW st arg1-                                       sw2 <- sbvToSW st arg2-                                       sw3 <- sbvToSW st arg3-                                       sw4 <- sbvToSW st arg4-                                       mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4]-                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4]---- Functions of six arguments-instance (SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV g -> SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where-  sbvUninterpret mbCgData nm = f-    where f arg0 arg1 arg2 arg3 arg4 arg5-           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4, isConcrete arg5-           = v arg0 arg1 arg2 arg3 arg4 arg5-           | True-           = SBV $ SVal ka $ Right $ cache result-           where ka = kindOf (undefined :: a)-                 kb = kindOf (undefined :: b)-                 kc = kindOf (undefined :: c)-                 kd = kindOf (undefined :: d)-                 ke = kindOf (undefined :: e)-                 kf = kindOf (undefined :: f)-                 kg = kindOf (undefined :: g)-                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4 arg5)-                           | True = do newUninterpreted st nm (SBVType [kg, kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)-                                       sw0 <- sbvToSW st arg0-                                       sw1 <- sbvToSW st arg1-                                       sw2 <- sbvToSW st arg2-                                       sw3 <- sbvToSW st arg3-                                       sw4 <- sbvToSW st arg4-                                       sw5 <- sbvToSW st arg5-                                       mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4, sw5]-                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4, sw5]---- Functions of seven arguments-instance (SymWord h, SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a)-            => Uninterpreted (SBV h -> SBV g -> SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where-  sbvUninterpret mbCgData nm = f-    where f arg0 arg1 arg2 arg3 arg4 arg5 arg6-           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4, isConcrete arg5, isConcrete arg6-           = v arg0 arg1 arg2 arg3 arg4 arg5 arg6-           | True-           = SBV $ SVal ka $ Right $ cache result-           where ka = kindOf (undefined :: a)-                 kb = kindOf (undefined :: b)-                 kc = kindOf (undefined :: c)-                 kd = kindOf (undefined :: d)-                 ke = kindOf (undefined :: e)-                 kf = kindOf (undefined :: f)-                 kg = kindOf (undefined :: g)-                 kh = kindOf (undefined :: h)-                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4 arg5 arg6)-                           | True = do newUninterpreted st nm (SBVType [kh, kg, kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)-                                       sw0 <- sbvToSW st arg0-                                       sw1 <- sbvToSW st arg1-                                       sw2 <- sbvToSW st arg2-                                       sw3 <- sbvToSW st arg3-                                       sw4 <- sbvToSW st arg4-                                       sw5 <- sbvToSW st arg5-                                       sw6 <- sbvToSW st arg6-                                       mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4, sw5, sw6]-                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4, sw5, sw6]---- Uncurried functions of two arguments-instance (SymWord c, SymWord b, HasKind a) => Uninterpreted ((SBV c, SBV b) -> SBV a) where-  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc2 `fmap` mbCgData) nm in uncurry f-    where uc2 (cs, fn) = (cs, curry fn)---- Uncurried functions of three arguments-instance (SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted ((SBV d, SBV c, SBV b) -> SBV a) where-  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc3 `fmap` mbCgData) nm in \(arg0, arg1, arg2) -> f arg0 arg1 arg2-    where uc3 (cs, fn) = (cs, \a b c -> fn (a, b, c))---- Uncurried functions of four arguments-instance (SymWord e, SymWord d, SymWord c, SymWord b, HasKind a)-            => Uninterpreted ((SBV e, SBV d, SBV c, SBV b) -> SBV a) where-  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc4 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3) -> f arg0 arg1 arg2 arg3-    where uc4 (cs, fn) = (cs, \a b c d -> fn (a, b, c, d))---- Uncurried functions of five arguments-instance (SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a)-            => Uninterpreted ((SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where-  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc5 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4) -> f arg0 arg1 arg2 arg3 arg4-    where uc5 (cs, fn) = (cs, \a b c d e -> fn (a, b, c, d, e))---- Uncurried functions of six arguments-instance (SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a)-            => Uninterpreted ((SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where-  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc6 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4, arg5) -> f arg0 arg1 arg2 arg3 arg4 arg5-    where uc6 (cs, fn) = (cs, \a b c d e f -> fn (a, b, c, d, e, f))---- Uncurried functions of seven arguments-instance (SymWord h, SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a)-            => Uninterpreted ((SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where-  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc7 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4, arg5, arg6) -> f arg0 arg1 arg2 arg3 arg4 arg5 arg6-    where uc7 (cs, fn) = (cs, \a b c d e f g -> fn (a, b, c, d, e, f, g))---- | Adding arbitrary constraints. When adding constraints, one has to be careful about--- making sure they are not inconsistent. The function 'isVacuous' can be use for this purpose.--- Here is an example. Consider the following predicate:------ >>> let pred = do { x <- forall "x"; constrain $ x .< x; return $ x .>= (5 :: SWord8) }------ This predicate asserts that all 8-bit values are larger than 5, subject to the constraint that the--- values considered satisfy @x .< x@, i.e., they are less than themselves. Since there are no values that--- satisfy this constraint, the proof will pass vacuously:------ >>> prove pred--- Q.E.D.------ We can use 'isVacuous' to make sure to see that the pass was vacuous:------ >>> isVacuous pred--- True------ While the above example is trivial, things can get complicated if there are multiple constraints with--- non-straightforward relations; so if constraints are used one should make sure to check the predicate--- is not vacuously true. Here's an example that is not vacuous:------  >>> let pred' = do { x <- forall "x"; constrain $ x .> 6; return $ x .>= (5 :: SWord8) }------ This time the proof passes as expected:------  >>> prove pred'---  Q.E.D.------ And the proof is not vacuous:------  >>> isVacuous pred'---  False-constrain :: SBool -> Symbolic ()-constrain c = addConstraint Nothing c (bnot c)---- | Adding a probabilistic constraint. The 'Double' argument is the probability--- threshold. Probabilistic constraints are useful for 'genTest' and 'quickCheck'--- calls where we restrict our attention to /interesting/ parts of the input domain.-pConstrain :: Double -> SBool -> Symbolic ()-pConstrain t c = addConstraint (Just t) c (bnot c)---- Quickcheck interface on symbolic-booleans..-instance Testable SBool where-  property (SBV (SVal _ (Left b))) = property (cwToBool b)-  property s                       = error $ "Cannot quick-check in the presence of uninterpreted constants! (" ++ show s ++ ")"--instance Testable (Symbolic SBool) where-   property prop = QC.monadicIO $ do (cond, r, tvals) <- QC.run (newStdGen >>= test)-                                     QC.pre cond-                                     unless (r || null tvals) $ QC.monitor (QC.counterexample (complain tvals))-                                     QC.assert r-     where test g = do (r, Result{resTraces=tvals, resConsts=cs, resConstraints=cstrs, resUIConsts=unints}) <- runSymbolic' (Concrete g) prop-                       let cval = fromMaybe (error "Cannot quick-check in the presence of uninterpeted constants!") . (`lookup` cs)-                           cond = all (cwToBool . cval) cstrs-                       case map fst unints of-                         [] -> case unliteral r of-                                 Nothing -> noQC [show r]-                                 Just b  -> return (cond, b, tvals)-                         us -> noQC us-           complain qcInfo = showModel defaultSMTCfg (SMTModel qcInfo)-           noQC us         = error $ "Cannot quick-check in the presence of uninterpreted constants: " ++ intercalate ", " us---- | Quick check an SBV property. Note that a regular 'quickCheck' call will work just as--- well. Use this variant if you want to receive the boolean result.-sbvQuickCheck :: Symbolic SBool -> IO Bool-sbvQuickCheck prop = QC.isSuccess `fmap` QC.quickCheckResult prop---- Quickcheck interface on dynamically-typed values. A run-time check--- ensures that the value has boolean type.-instance Testable (Symbolic SVal) where-  property m = property $ do s <- m-                             when (kindOf s /= KBool) $ error "Cannot quickcheck non-boolean value"-                             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://ittc.ku.edu/~andygill/paper.php?label=DSLExtract09>).--- 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.-slet :: forall a b. (HasKind a, HasKind b) => SBV a -> (SBV a -> SBV b) -> SBV b-slet x f = SBV $ SVal k $ Right $ cache r-    where k    = kindOf (undefined :: b)-          r st = do xsw <- sbvToSW st x-                    let xsbv = SBV $ SVal (kindOf x) (Right (cache (const (return xsw))))-                        res  = f xsbv-                    sbvToSW st res---- | Check if a boolean condition is satisfiable in the current state. This function can be useful in contexts where an--- interpreter implemented on top of SBV needs to decide if a particular stae (represented by the boolean) is reachable--- in the current if-then-else paths implied by the 'ite' calls.-isSatisfiableInCurrentPath :: SBool -> Symbolic Bool-isSatisfiableInCurrentPath cond = do-       st <- ask-       let cfg  = fromMaybe defaultSMTCfg (getSBranchRunConfig st)-           msg  = when (verbose cfg) . putStrLn . ("** " ++)-           pc   = getPathCondition st-       check <- liftIO $ internalSATCheck cfg (pc &&& cond) st "isSatisfiableInCurrentPath: Checking satisfiability"-       let res = case check of-                   SatResult Satisfiable{}     -> True-                   SatResult (Unsatisfiable _) -> False-                   _                           -> error $ "isSatisfiableInCurrentPath: Unexpected external result: " ++ show check-       res `seq` liftIO $ msg $ "isSatisfiableInCurrentPath: Conclusion: " ++ if res then "Satisfiable" else "Unsatisfiable"-       return res---- We use 'isVacuous' and 'prove' only for the "test" section in this file, and GHC complains about that. So, this shuts it up.-__unused :: a-__unused = error "__unused" (isVacuous :: SBool -> IO Bool) (prove :: SBool -> IO ThmResult)--{-# ANN module   ("HLint: ignore Reduce duplication" :: String)#-}-{-# ANN module   ("HLint: ignore Eta reduce" :: String)        #-}
− Data/SBV/BitVectors/Operations.hs 
@@ -1,807 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.BitVectors.Operations--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Constructors and basic operations on symbolic values--------------------------------------------------------------------------------{-# LANGUAGE BangPatterns #-}--module Data.SBV.BitVectors.Operations-  (-  -- ** Basic constructors-    svTrue, svFalse, svBool-  , svInteger, svFloat, svDouble, svReal, svEnumFromThenTo-  -- ** Basic destructors-  , svAsBool, svAsInteger, svNumerator, svDenominator-  -- ** Basic operations-  , svPlus, svTimes, svMinus, svUNeg, svAbs-  , svDivide, svQuot, svRem-  , svEqual, svNotEqual-  , svLessThan, svGreaterThan, svLessEq, svGreaterEq-  , svAnd, svOr, svXOr, svNot-  , svShl, svShr, svRol, svRor-  , svExtract, svJoin-  , svUninterpreted-  , svIte, svLazyIte, svSymbolicMerge-  , svSelect-  , svSign, svUnsign, svSetBit, svWordFromBE, svWordFromLE-  , svExp, svFromIntegral-  -- ** Derived operations-  , svToWord1, svFromWord1, svTestBit-  , svShiftLeft, svShiftRight-  , svRotateLeft, svRotateRight-  , svBlastLE, svBlastBE-  , svAddConstant, svIncrement, svDecrement-  )-  where--import Data.Bits (Bits(..))-import Data.List (genericIndex, genericLength, genericTake)--import Data.SBV.BitVectors.AlgReals-import Data.SBV.BitVectors.Kind-import Data.SBV.BitVectors.Concrete-import Data.SBV.BitVectors.Symbolic--import Data.Ratio------------------------------------------------------------------------------------- Basic constructors---- | Boolean True.-svTrue :: SVal-svTrue = SVal KBool (Left trueCW)---- | Boolean False.-svFalse :: SVal-svFalse = SVal KBool (Left falseCW)---- | Convert from a Boolean.-svBool :: Bool -> SVal-svBool b = if b then svTrue else svFalse---- | Convert from an Integer.-svInteger :: Kind -> Integer -> SVal-svInteger k n = SVal k (Left $! mkConstCW k n)---- | Convert from a Float-svFloat :: Float -> SVal-svFloat f = SVal KFloat (Left $! CW KFloat (CWFloat f))---- | Convert from a Float-svDouble :: Double -> SVal-svDouble d = SVal KDouble (Left $! CW KDouble (CWDouble d))---- | Convert from a Rational-svReal :: Rational -> SVal-svReal d = SVal KReal (Left $! CW KReal (CWAlgReal (fromRational d)))------------------------------------------------------------------------------------- Basic destructors---- | Extract a bool, by properly interpreting the integer stored.-svAsBool :: SVal -> Maybe Bool-svAsBool (SVal _ (Left cw)) = Just (cwToBool cw)-svAsBool _                  = Nothing---- | Extract an integer from a concrete value.-svAsInteger :: SVal -> Maybe Integer-svAsInteger (SVal _ (Left (CW _ (CWInteger n)))) = Just n-svAsInteger _                                    = Nothing---- | Grab the numerator of an SReal, if available-svNumerator :: SVal -> Maybe Integer-svNumerator (SVal KReal (Left (CW KReal (CWAlgReal (AlgRational True r))))) = Just $ numerator r-svNumerator _                                                               = Nothing---- | Grab the denominator of an SReal, if available-svDenominator :: SVal -> Maybe Integer-svDenominator (SVal KReal (Left (CW KReal (CWAlgReal (AlgRational True r))))) = Just $ denominator r-svDenominator _                                                               = Nothing------------------------------------------------------------------------------------------ | Constructing [x, y, .. z] and [x .. y]. Only works when all arguments are concrete and integral and the result is guaranteed finite--- Note that the it isn't "obviously" clear why the following works; after all we're doing the construction over Integer's and mapping--- it back to other types such as SIntN/SWordN. The reason is that the values we receive are guaranteed to be in their domains; and thus--- the lifting to Integers preserves the bounds; and then going back is just fine. So, things like @[1, 5 .. 200] :: [SInt8]@ work just--- fine (end evaluate to empty list), since we see @[1, 5 .. -56]@ in the @Integer@ domain. Also note the explicit check for @s /= f@--- below to make sure we don't stutter and produce an infinite list.-svEnumFromThenTo :: SVal -> Maybe SVal -> SVal -> Maybe [SVal]-svEnumFromThenTo bf mbs bt-  | Just bs <- mbs, Just f <- svAsInteger bf, Just s <- svAsInteger bs, Just t <- svAsInteger bt, s /= f = Just $ map (svInteger (kindOf bf)) [f, s .. t]-  | Nothing <- mbs, Just f <- svAsInteger bf,                           Just t <- svAsInteger bt         = Just $ map (svInteger (kindOf bf)) [f    .. t]-  | True                                                                                                 = Nothing------------------------------------------------------------------------------------------ Basic operations---- | Addition.-svPlus :: SVal -> SVal -> SVal-svPlus x y-  | isConcreteZero x = y-  | isConcreteZero y = x-  | True             = liftSym2 (mkSymOp Plus) rationalCheck (+) (+) (+) (+) x y---- | Multiplication.-svTimes :: SVal -> SVal -> SVal-svTimes x y-  | isConcreteZero x = x-  | isConcreteZero y = y-  | isConcreteOne x  = y-  | isConcreteOne y  = x-  | True             = liftSym2 (mkSymOp Times) rationalCheck (*) (*) (*) (*) x y---- | Subtraction.-svMinus :: SVal -> SVal -> SVal-svMinus x y-  | isConcreteZero y = x-  | True             = liftSym2 (mkSymOp Minus) rationalCheck (-) (-) (-) (-) x y---- | Unary minus.-svUNeg :: SVal -> SVal-svUNeg = liftSym1 (mkSymOp1 UNeg) negate negate negate negate---- | Absolute value.-svAbs :: SVal -> SVal-svAbs = liftSym1 (mkSymOp1 Abs) abs abs abs abs---- | Division.-svDivide :: SVal -> SVal -> SVal-svDivide = liftSym2 (mkSymOp Quot) rationalCheck (/) die (/) (/)-   where -- should never happen-         die = error "impossible: integer valued data found in Fractional instance"---- | Exponentiation.-svExp :: SVal -> SVal -> SVal-svExp b e | hasSign (kindOf e) = error "svExp: exponentiation only works with unsigned exponents"-          | True               = prod $ zipWith (\use n -> svIte use n one)-                                                (svBlastLE e)-                                                (iterate (\x -> svTimes x x) b)-         where prod = foldr svTimes one-               one  = svInteger (kindOf b) 1---- | Bit-blast: Little-endian. Assumes the input is a bit-vector.-svBlastLE :: SVal -> [SVal]-svBlastLE x = map (svTestBit x) [0 .. intSizeOf x - 1]---- | Set a given bit at index-svSetBit :: SVal -> Int -> SVal-svSetBit x i = x `svXOr` svInteger (kindOf x) (bit i :: Integer)---- | Bit-blast: Big-endian. Assumes the input is a bit-vector.-svBlastBE :: SVal -> [SVal]-svBlastBE = reverse . svBlastLE---- | Un-bit-blast from big-endian representation to a word of the right size.--- The input is assumed to be unsigned.-svWordFromLE :: [SVal] -> SVal-svWordFromLE bs = go zero 0 bs-  where zero = svInteger (KBounded False (length bs)) 0-        go !acc _  []     = acc-        go !acc !i (x:xs) = go (svIte x (svSetBit acc i) acc) (i+1) xs---- | Un-bit-blast from little-endian representation to a word of the right size.--- The input is assumed to be unsigned.-svWordFromBE :: [SVal] -> SVal-svWordFromBE = svWordFromLE . reverse---- | Add a constant value:-svAddConstant :: Integral a => SVal -> a -> SVal-svAddConstant x i = x `svPlus` svInteger (kindOf x) (fromIntegral i)---- | Increment:-svIncrement :: SVal -> SVal-svIncrement x = svAddConstant x (1::Integer)---- | Decrement:-svDecrement :: SVal -> SVal-svDecrement x = svAddConstant x (-1 :: Integer)---- | Quotient: Overloaded operation whose meaning depends on the kind at which--- it is used: For unbounded integers, it corresponds to the SMT-Lib--- "div" operator ("Euclidean" division, which always has a--- non-negative remainder). For unsigned bitvectors, it is "bvudiv";--- and for signed bitvectors it is "bvsdiv", which rounds toward zero.--- All operations have unspecified semantics in case @y = 0@.-svQuot :: SVal -> SVal -> SVal-svQuot x y-  | isConcreteZero x = x-  | isConcreteOne y  = x-  | True             = liftSym2 (mkSymOp Quot) nonzeroCheck-                                (noReal "quot") quot' (noFloat "quot") (noDouble "quot") x y-  where-    quot' a b | kindOf x == KUnbounded = div a (abs b) * signum b-              | otherwise              = quot a b---- | Remainder: Overloaded operation whose meaning depends on the kind at which--- it is used: For unbounded integers, it corresponds to the SMT-Lib--- "mod" operator (always non-negative). For unsigned bitvectors, it--- is "bvurem"; and for signed bitvectors it is "bvsrem", which rounds--- toward zero (sign of remainder matches that of @x@). All operations--- have unspecified semantics in case @y = 0@.-svRem :: SVal -> SVal -> SVal-svRem x y-  | isConcreteZero x = x-  | isConcreteOne y  = svInteger (kindOf x) 0-  | True             = liftSym2 (mkSymOp Rem) nonzeroCheck-                                (noReal "rem") rem' (noFloat "rem") (noDouble "rem") x y-  where-    rem' a b | kindOf x == KUnbounded = mod a (abs b)-             | otherwise              = rem a b---- | Optimize away x == true and x /= false to x; otherwise just do eqOpt-eqOptBool :: Op -> SW -> SW -> SW -> Maybe SW-eqOptBool op w x y-  | k == KBool && op == Equal    && x == trueSW  = Just y         -- true  .== y     --> y-  | k == KBool && op == Equal    && y == trueSW  = Just x         -- x     .== true  --> x-  | k == KBool && op == NotEqual && x == falseSW = Just y         -- false ./= y     --> y-  | k == KBool && op == NotEqual && y == falseSW = Just x         -- x     ./= false --> x-  | True                                         = eqOpt w x y    -- fallback-  where k = swKind x---- | Equality.-svEqual :: SVal -> SVal -> SVal-svEqual = liftSym2B (mkSymOpSC (eqOptBool Equal trueSW) Equal) rationalCheck (==) (==) (==) (==) (==)---- | Inequality.-svNotEqual :: SVal -> SVal -> SVal-svNotEqual = liftSym2B (mkSymOpSC (eqOptBool NotEqual falseSW) NotEqual) rationalCheck (/=) (/=) (/=) (/=) (/=)---- | Less than.-svLessThan :: SVal -> SVal -> SVal-svLessThan x y-  | isConcreteMax x = svFalse-  | isConcreteMin y = svFalse-  | True            = liftSym2B (mkSymOpSC (eqOpt falseSW) LessThan) rationalCheck (<) (<) (<) (<) (uiLift "<" (<)) x y---- | Greater than.-svGreaterThan :: SVal -> SVal -> SVal-svGreaterThan x y-  | isConcreteMin x = svFalse-  | isConcreteMax y = svFalse-  | True            = liftSym2B (mkSymOpSC (eqOpt falseSW) GreaterThan) rationalCheck (>) (>) (>) (>) (uiLift ">"  (>)) x y---- | Less than or equal to.-svLessEq :: SVal -> SVal -> SVal-svLessEq x y-  | isConcreteMin x = svTrue-  | isConcreteMax y = svTrue-  | True            = liftSym2B (mkSymOpSC (eqOpt trueSW) LessEq) rationalCheck (<=) (<=) (<=) (<=) (uiLift "<=" (<=)) x y---- | Greater than or equal to.-svGreaterEq :: SVal -> SVal -> SVal-svGreaterEq x y-  | isConcreteMax x = svTrue-  | isConcreteMin y = svTrue-  | True            = liftSym2B (mkSymOpSC (eqOpt trueSW) GreaterEq) rationalCheck (>=) (>=) (>=) (>=) (uiLift ">=" (>=)) x y---- | Bitwise and.-svAnd :: SVal -> SVal -> SVal-svAnd x y-  | isConcreteZero x = x-  | isConcreteOnes x = y-  | isConcreteZero y = y-  | isConcreteOnes y = x-  | True             = liftSym2 (mkSymOpSC opt And) (const (const True)) (noReal ".&.") (.&.) (noFloat ".&.") (noDouble ".&.") x y-  where opt a b-          | a == falseSW || b == falseSW = Just falseSW-          | a == trueSW                  = Just b-          | b == trueSW                  = Just a-          | True                         = Nothing---- | Bitwise or.-svOr :: SVal -> SVal -> SVal-svOr x y-  | isConcreteZero x = y-  | isConcreteOnes x = x-  | isConcreteZero y = x-  | isConcreteOnes y = y-  | True             = liftSym2 (mkSymOpSC opt Or) (const (const True))-                       (noReal ".|.") (.|.) (noFloat ".|.") (noDouble ".|.") x y-  where opt a b-          | a == trueSW || b == trueSW = Just trueSW-          | a == falseSW               = Just b-          | b == falseSW               = Just a-          | True                       = Nothing---- | Bitwise xor.-svXOr :: SVal -> SVal -> SVal-svXOr x y-  | isConcreteZero x = y-  | isConcreteOnes x = svNot y-  | isConcreteZero y = x-  | isConcreteOnes y = svNot x-  | True             = liftSym2 (mkSymOpSC opt XOr) (const (const True))-                       (noReal "xor") xor (noFloat "xor") (noDouble "xor") x y-  where opt a b-          | a == b && swKind a == KBool = Just falseSW-          | a == falseSW                = Just b-          | b == falseSW                = Just a-          | True                        = Nothing---- | Bitwise complement.-svNot :: SVal -> SVal-svNot = liftSym1 (mkSymOp1SC opt Not)-                 (noRealUnary "complement") complement-                 (noFloatUnary "complement") (noDoubleUnary "complement")-  where opt a-          | a == falseSW = Just trueSW-          | a == trueSW  = Just falseSW-          | True         = Nothing---- | Shift left by a constant amount. Translates to the "bvshl"--- operation in SMT-Lib.-svShl :: SVal -> Int -> SVal-svShl x i-  | i < 0   = svShr x (-i)-  | i == 0  = x-  | True    = liftSym1 (mkSymOp1 (Shl i))-                       (noRealUnary "shiftL") (`shiftL` i)-                       (noFloatUnary "shiftL") (noDoubleUnary "shiftL") x---- | Shift right by a constant amount. Translates to either "bvlshr"--- (logical shift right) or "bvashr" (arithmetic shift right) in--- SMT-Lib, depending on whether @x@ is a signed bitvector.-svShr :: SVal -> Int -> SVal-svShr x i-  | i < 0   = svShl x (-i)-  | i == 0  = x-  | True    = liftSym1 (mkSymOp1 (Shr i))-                       (noRealUnary "shiftR") (`shiftR` i)-                       (noFloatUnary "shiftR") (noDoubleUnary "shiftR") x---- | Rotate-left, by a constant-svRol :: SVal -> Int -> SVal-svRol x i-  | i < 0   = svRor x (-i)-  | i == 0  = x-  | True    = case kindOf x of-                KBounded _ sz -> liftSym1 (mkSymOp1 (Rol (i `mod` sz)))-                                          (noRealUnary "rotateL") (rot True sz i)-                                          (noFloatUnary "rotateL") (noDoubleUnary "rotateL") x-                _ -> svShl x i   -- for unbounded Integers, rotateL is the same as shiftL in Haskell---- | Rotate-right, by a constant-svRor :: SVal -> Int -> SVal-svRor x i-  | i < 0   = svRol x (-i)-  | i == 0  = x-  | True    = case kindOf x of-                KBounded _ sz -> liftSym1 (mkSymOp1 (Ror (i `mod` sz)))-                                          (noRealUnary "rotateR") (rot False sz i)-                                          (noFloatUnary "rotateR") (noDoubleUnary "rotateR") x-                _ -> svShr x i   -- for unbounded integers, rotateR is the same as shiftR in Haskell---- | Generic rotation. Since the underlying representation is just Integers, rotations has to be--- careful on the bit-size.-rot :: Bool -> Int -> Int -> Integer -> Integer-rot toLeft sz amt x-  | sz < 2 = x-  | True   = norm x y' `shiftL` y  .|. norm (x `shiftR` y') y-  where (y, y') | toLeft = (amt `mod` sz, sz - y)-                | True   = (sz - y', amt `mod` sz)-        norm v s = v .&. ((1 `shiftL` s) - 1)---- | Extract bit-sequences.-svExtract :: Int -> Int -> SVal -> SVal-svExtract i j x@(SVal (KBounded s _) _)-  | i < j-  = SVal k (Left $! CW k (CWInteger 0))-  | SVal _ (Left (CW _ (CWInteger v))) <- x-  = SVal k (Left $! normCW (CW k (CWInteger (v `shiftR` j))))-  | True-  = SVal k (Right (cache y))-  where k = KBounded s (i - j + 1)-        y st = do sw <- svToSW st x-                  newExpr st k (SBVApp (Extract i j) [sw])-svExtract _ _ _ = error "extract: non-bitvector type"---- | Join two words, by concataneting-svJoin :: SVal -> SVal -> SVal-svJoin x@(SVal (KBounded s i) a) y@(SVal (KBounded _ j) b)-  | i == 0 = y-  | j == 0 = x-  | Left (CW _ (CWInteger m)) <- a, Left (CW _ (CWInteger n)) <- b-  = SVal k (Left $! CW k (CWInteger (m `shiftL` j .|. n)))-  | True-  = SVal k (Right (cache z))-  where-    k = KBounded s (i + j)-    z st = do xsw <- svToSW st x-              ysw <- svToSW st y-              newExpr st k (SBVApp Join [xsw, ysw])-svJoin _ _ = error "svJoin: non-bitvector type"---- | Uninterpreted constants and functions. An uninterpreted constant is--- a value that is indexed by its name. The only property the prover assumes--- about these values are that they are equivalent to themselves; i.e., (for--- functions) they return the same results when applied to same arguments.--- We support uninterpreted-functions as a general means of black-box'ing--- operations that are /irrelevant/ for the purposes of the proof; i.e., when--- the proofs can be performed without any knowledge about the function itself.-svUninterpreted :: Kind -> String -> Maybe [String] -> [SVal] -> SVal-svUninterpreted k nm code args = SVal k $ Right $ cache result-  where result st = do let ty = SBVType (map kindOf args ++ [k])-                       newUninterpreted st nm ty code-                       sws <- mapM (svToSW st) args-                       mapM_ forceSWArg sws-                       newExpr st k $ SBVApp (Uninterpreted nm) sws---- | If-then-else. This one will force branches.-svIte :: SVal -> SVal -> SVal -> SVal-svIte t a b = svSymbolicMerge (kindOf a) True t a b---- | Lazy If-then-else. This one will delay forcing the branches unless it's really necessary.-svLazyIte :: Kind -> SVal -> SVal -> SVal -> SVal-svLazyIte k t a b = svSymbolicMerge k False t a b---- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make--- sure they do not evaluate to the same result.-svSymbolicMerge :: Kind -> Bool -> SVal -> SVal -> SVal -> SVal-svSymbolicMerge k force t a b-  | Just r <- svAsBool t-  = if r then a else b-  | force, rationalSBVCheck a b, areConcretelyEqual a b-  = a-  | True-  = SVal k $ Right $ cache c-  where c st = do swt <- svToSW st t-                  case () of-                    () | swt == trueSW  -> svToSW st a       -- these two cases should never be needed as we expect symbolicMerge to be-                    () | swt == falseSW -> svToSW st b       -- called with symbolic tests, but just in case..-                    () -> do {- It is tempting to record the choice of the test expression here as we branch down to the 'then' and 'else' branches. That is,-                                when we evaluate 'a', we can make use of the fact that the test expression is True, and similarly we can use the fact that it-                                is False when b is evaluated. In certain cases this can cut down on symbolic simulation significantly, for instance if-                                repetitive decisions are made in a recursive loop. Unfortunately, the implementation of this idea is quite tricky, due to-                                our sharing based implementation. As the 'then' branch is evaluated, we will create many expressions that are likely going-                                to be "reused" when the 'else' branch is executed. But, it would be *dead wrong* to share those values, as they were "cached"-                                under the incorrect assumptions. To wit, consider the following:--                                   foo x y = ite (y .== 0) k (k+1)-                                     where k = ite (y .== 0) x (x+1)--                                When we reduce the 'then' branch of the first ite, we'd record the assumption that y is 0. But while reducing the 'then' branch, we'd-                                like to share 'k', which would evaluate (correctly) to 'x' under the given assumption. When we backtrack and evaluate the 'else'-                                branch of the first ite, we'd see 'k' is needed again, and we'd look it up from our sharing map to find (incorrectly) that its value-                                is 'x', which was stored there under the assumption that y was 0, which no longer holds. Clearly, this is unsound.--                                A sound implementation would have to precisely track which assumptions were active at the time expressions get shared. That is,-                                in the above example, we should record that the value of 'k' was cached under the assumption that 'y' is 0. While sound, this-                                approach unfortunately leads to significant loss of valid sharing when the value itself had nothing to do with the assumption itself.-                                To wit, consider:--                                   foo x y = ite (y .== 0) k (k+1)-                                     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,-                                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-                                than blindly recording all the assumptions present at that time. SBV's symbolic simulation engine clearly has all the info needed to do this-                                properly, but the implementation is not straightforward at all. For each subexpression, we would need to chase down its dependencies-                                transitively, which can require a lot of scanning of the generated program causing major slow-down; thus potentially defeating the-                                whole purpose of sharing in the first place.--                                Design choice: Keep it simple, and simply do not track the assumption at all. This will maximize sharing, at the cost of evaluating-                                unreachable branches. I think the simplicity is more important at this point than efficiency.--                                Also note that the user can avoid most such issues by properly combining if-then-else's with common conditions together. That is, the-                                first program above should be written like this:--                                  foo x y = ite (y .== 0) x (x+2)--                                In general, the following transformations should be done whenever possible:--                                  ite e1 (ite e1 e2 e3) e4  --> ite e1 e2 e4-                                  ite e1 e2 (ite e1 e3 e4)  --> ite e1 e2 e4--                                This is in accordance with the general rule-of-thumb stating conditionals should be avoided as much as possible. However, we might prefer-                                the following:--                                  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.-                             -}-                             let sta = st `extendSValPathCondition` svAnd t-                             let stb = st `extendSValPathCondition` svAnd (svNot t)-                             swa <- svToSW sta a -- evaluate 'then' branch-                             swb <- svToSW stb b -- evaluate 'else' branch-                             case () of               -- merge:-                               () | swa == swb                      -> return swa-                               () | swa == trueSW && swb == falseSW -> return swt-                               () | swa == falseSW && swb == trueSW -> newExpr st k (SBVApp Not [swt])-                               ()                                   -> newExpr st k (SBVApp Ite [swt, swa, swb])---- | Total indexing operation. @svSelect xs default index@ is--- intuitively the same as @xs !! index@, except it evaluates to--- @default@ if @index@ overflows. Translates to SMT-Lib tables.-svSelect :: [SVal] -> SVal -> SVal -> SVal-svSelect xs err ind-  | SVal _ (Left c) <- ind =-    case cwVal c of-      CWInteger i -> if i < 0 || i >= genericLength xs-                     then err-                     else xs `genericIndex` i-      _           -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"-svSelect xsOrig err ind = xs `seq` SVal kElt (Right (cache r))-  where-    kInd = kindOf ind-    kElt = kindOf err-    -- Based on the index size, we need to limit the elements. For-    -- instance if the index is 8 bits, but there are 257 elements,-    -- that last element will never be used and we can chop it off.-    xs = case kInd of-           KBounded False i -> genericTake ((2::Integer) ^ i) xsOrig-           KBounded True  i -> genericTake ((2::Integer) ^ (i-1)) xsOrig-           KUnbounded       -> xsOrig-           _                -> error $ "SBV.select: unsupported " ++ show kInd ++ " valued select/index expression"-    r st = do sws <- mapM (svToSW st) xs-              swe <- svToSW st err-              if all (== swe) sws  -- off-chance that all elts are the same-                 then return swe-                 else do idx <- getTableIndex st kInd kElt sws-                         swi <- svToSW st ind-                         let len = length xs-                         -- NB. No need to worry here that the index-                         -- might be < 0; as the SMTLib translation-                         -- takes care of that automatically-                         newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) [])--svChangeSign :: Bool -> SVal -> SVal-svChangeSign s x-  | Just n <- svAsInteger x = svInteger k n-  | True                    = SVal k (Right (cache y))-  where-    k = KBounded s (intSizeOf x)-    y st = do xsw <- svToSW st x-              newExpr st k (SBVApp (Extract (intSizeOf x - 1) 0) [xsw])---- | Convert a symbolic bitvector from unsigned to signed.-svSign :: SVal -> SVal-svSign = svChangeSign True---- | Convert a symbolic bitvector from signed to unsigned.-svUnsign :: SVal -> SVal-svUnsign = svChangeSign False---- | Convert a symbolic bitvector from one integral kind to another.-svFromIntegral :: Kind -> SVal -> SVal-svFromIntegral kTo x-  | Just v <- svAsInteger x-  = svInteger kTo v-  | True-  = result-  where result = SVal kTo (Right (cache y))-        kFrom  = kindOf x-        y st   = do xsw <- svToSW st x-                    newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsw])------------------------------------------------------------------------------------- Derived operations---- | Convert an SVal from kind Bool to an unsigned bitvector of size 1.-svToWord1 :: SVal -> SVal-svToWord1 b = svSymbolicMerge k True b (svInteger k 1) (svInteger k 0)-  where k = KBounded False 1---- | Convert an SVal from a bitvector of size 1 (signed or unsigned) to kind Bool.-svFromWord1 :: SVal -> SVal-svFromWord1 x = svNotEqual x (svInteger k 0)-  where k = kindOf x---- | Test the value of a bit. Note that we do an extract here--- as opposed to masking and checking against zero, as we found--- extraction to be much faster with large bit-vectors.-svTestBit :: SVal -> Int -> SVal-svTestBit x i-  | i < intSizeOf x = svFromWord1 (svExtract i i x)-  | True            = svFalse---- | Generalization of 'svShl', where the shift-amount is symbolic.--- The first argument should be a bounded quantity.-svShiftLeft :: SVal -> SVal -> SVal-svShiftLeft x i-  | not (isBounded x)-  = error "SBV.svShiftLeft: Shifted amount should be a bounded quantity!"-  | True-  = svIte (svLessThan i zi)-          (svSelect [svShr x k | k <- [0 .. intSizeOf x - 1]] z (svUNeg i))-          (svSelect [svShl x k | k <- [0 .. intSizeOf x - 1]] z         i)-  where z  = svInteger (kindOf x) 0-        zi = svInteger (kindOf i) 0---- | Generalization of 'svShr', where the shift-amount is symbolic.--- The first argument should be a bounded quantity.------ NB. If the shiftee is signed, then this is an arithmetic shift;--- otherwise it's logical.-svShiftRight :: SVal -> SVal -> SVal-svShiftRight x i-  | not (isBounded x)-  = error "SBV.svShiftLeft: Shifted amount should be a bounded quantity!"-  | True-  = svIte (svLessThan i zi)-          (svSelect [svShl x k | k <- [0 .. intSizeOf x - 1]] z (svUNeg i))-          (svSelect [svShr x k | k <- [0 .. intSizeOf x - 1]] z         i)-  where z  = svInteger (kindOf x) 0-        zi = svInteger (kindOf i) 0---- | Generalization of 'svRol', where the rotation amount is symbolic.--- The first argument should be a bounded quantity.-svRotateLeft :: SVal -> SVal -> SVal-svRotateLeft x i-  | not (isBounded x)-  = svShiftLeft x i-  | isBounded i && bit si <= toInteger sx            -- wrap-around not possible-  = svIte (svLessThan i zi)-          (svSelect [x `svRor` k | k <- [0 .. bit si - 1]] z (svUNeg i))-          (svSelect [x `svRol` k | k <- [0 .. bit si - 1]] z         i)-  | True-  = svIte (svLessThan i zi)-          (svSelect [x `svRor` k | k <- [0 .. sx     - 1]] z (svUNeg i `svRem` n))-          (svSelect [x `svRol` k | k <- [0 .. sx     - 1]] z (       i  `svRem` n))-    where sx = intSizeOf x-          si = intSizeOf i-          z  = svInteger (kindOf x) 0-          zi = svInteger (kindOf i) 0-          n  = svInteger (kindOf i) (toInteger sx)---- | Generalization of 'svRor', where the rotation amount is symbolic.--- The first argument should be a bounded quantity.-svRotateRight :: SVal -> SVal -> SVal-svRotateRight x i-  | not (isBounded x)-  = svShiftRight x i-  | isBounded i && bit si <= toInteger sx                   -- wrap-around not possible-  = svIte (svLessThan i zi)-          (svSelect [x `svRol` k | k <- [0 .. bit si - 1]] z (svUNeg i))-          (svSelect [x `svRor` k | k <- [0 .. bit si - 1]] z         i)-  | True-  = svIte (svLessThan i zi)-          (svSelect [x `svRol` k | k <- [0 .. sx     - 1]] z (svUNeg i `svRem` n))-          (svSelect [x `svRor` k | k <- [0 .. sx     - 1]] z (       i  `svRem` n))-    where sx = intSizeOf x-          si = intSizeOf i-          z  = svInteger (kindOf x) 0-          zi = svInteger (kindOf i) 0-          n  = svInteger (kindOf i) (toInteger sx)------------------------------------------------------------------------------------- Utility functions--noUnint  :: (Maybe Int, String) -> a-noUnint x = error $ "Unexpected operation called on uninterpreted/enumerated value: " ++ show x--noUnint2 :: (Maybe Int, String) -> (Maybe Int, String) -> a-noUnint2 x y = error $ "Unexpected binary operation called on uninterpreted/enumerated values: " ++ show (x, y)--liftSym1 :: (State -> Kind -> SW -> IO SW) -> (AlgReal -> AlgReal) -> (Integer -> Integer) -> (Float -> Float) -> (Double -> Double) -> SVal -> SVal-liftSym1 _   opCR opCI opCF opCD   (SVal k (Left a)) = SVal k . Left  $! mapCW opCR opCI opCF opCD noUnint a-liftSym1 opS _    _    _    _    a@(SVal k _)        = SVal k $ Right $ cache c-   where c st = do swa <- svToSW st a-                   opS st k swa--liftSW2 :: (State -> Kind -> SW -> SW -> IO SW) -> Kind -> SVal -> SVal -> Cached SW-liftSW2 opS k a b = cache c-  where c st = do sw1 <- svToSW st a-                  sw2 <- svToSW st b-                  opS st k sw1 sw2--liftSym2 :: (State -> Kind -> SW -> SW -> IO SW) -> (CW -> CW -> Bool) -> (AlgReal -> AlgReal -> AlgReal) -> (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> (Double -> Double -> Double) -> SVal -> SVal -> SVal-liftSym2 _   okCW opCR opCI opCF opCD   (SVal k (Left a)) (SVal _ (Left b)) | okCW a b = SVal k . Left  $! mapCW2 opCR opCI opCF opCD noUnint2 a b-liftSym2 opS _    _    _    _    _    a@(SVal k _)        b                            = SVal k $ Right $  liftSW2 opS k a b--liftSym2B :: (State -> Kind -> SW -> SW -> IO SW) -> (CW -> CW -> Bool) -> (AlgReal -> AlgReal -> Bool) -> (Integer -> Integer -> Bool) -> (Float -> Float -> Bool) -> (Double -> Double -> Bool) -> ((Maybe Int, String) -> (Maybe Int, String) -> Bool) -> SVal -> SVal -> SVal-liftSym2B _   okCW opCR opCI opCF opCD opUI (SVal _ (Left a)) (SVal _ (Left b)) | okCW a b = svBool (liftCW2 opCR opCI opCF opCD opUI a b)-liftSym2B opS _    _    _    _    _    _    a                 b                            = SVal KBool $ Right $ liftSW2 opS KBool a b--mkSymOpSC :: (SW -> SW -> Maybe SW) -> Op -> State -> Kind -> SW -> SW -> IO SW-mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) return (shortCut a b)--mkSymOp :: Op -> State -> Kind -> SW -> SW -> IO SW-mkSymOp = mkSymOpSC (const (const Nothing))--mkSymOp1SC :: (SW -> Maybe SW) -> Op -> State -> Kind -> SW -> IO SW-mkSymOp1SC shortCut op st k a = maybe (newExpr st k (SBVApp op [a])) return (shortCut a)--mkSymOp1 :: Op -> State -> Kind -> SW -> IO SW-mkSymOp1 = mkSymOp1SC (const Nothing)---- | eqOpt says the references are to the same SW, thus we can optimize. Note that--- we explicitly disallow KFloat/KDouble here. Why? Because it's *NOT* true that--- NaN == NaN, NaN >= NaN, and so-forth. So, we have to make sure we don't optimize--- floats and doubles, in case the argument turns out to be NaN.-eqOpt :: SW -> SW -> SW -> Maybe SW-eqOpt w x y = case swKind x of-                KFloat  -> Nothing-                KDouble -> Nothing-                _       -> if x == y then Just w else Nothing---- For uninterpreted/enumerated values, we carefully lift through the constructor index for comparisons:-uiLift :: String -> (Int -> Int -> Bool) -> (Maybe Int, String) -> (Maybe Int, String) -> Bool-uiLift _ cmp (Just i, _) (Just j, _) = i `cmp` j-uiLift w _   a           b           = error $ "Data.SBV.BitVectors.Model: Impossible happened while trying to lift " ++ w ++ " over " ++ show (a, b)---- | Predicate for optimizing word operations like (+) and (*).-isConcreteZero :: SVal -> Bool-isConcreteZero (SVal _     (Left (CW _     (CWInteger n)))) = n == 0-isConcreteZero (SVal KReal (Left (CW KReal (CWAlgReal v)))) = isExactRational v && v == 0-isConcreteZero _                                            = False---- | Predicate for optimizing word operations like (+) and (*).-isConcreteOne :: SVal -> Bool-isConcreteOne (SVal _     (Left (CW _     (CWInteger 1)))) = True-isConcreteOne (SVal KReal (Left (CW KReal (CWAlgReal v)))) = isExactRational v && v == 1-isConcreteOne _                                            = False---- | Predicate for optimizing bitwise operations.-isConcreteOnes :: SVal -> Bool-isConcreteOnes (SVal _ (Left (CW (KBounded b w) (CWInteger n)))) = n == if b then -1 else bit w - 1-isConcreteOnes (SVal _ (Left (CW KUnbounded     (CWInteger n)))) = n == -1-isConcreteOnes (SVal _ (Left (CW KBool          (CWInteger n)))) = n == 1-isConcreteOnes _                                                 = False---- | Predicate for optimizing comparisons.-isConcreteMax :: SVal -> Bool-isConcreteMax (SVal _ (Left (CW (KBounded False w) (CWInteger n)))) = n == bit w - 1-isConcreteMax (SVal _ (Left (CW (KBounded True  w) (CWInteger n)))) = n == bit (w - 1) - 1-isConcreteMax (SVal _ (Left (CW KBool              (CWInteger n)))) = n == 1-isConcreteMax _                                                     = False---- | Predicate for optimizing comparisons.-isConcreteMin :: SVal -> Bool-isConcreteMin (SVal _ (Left (CW (KBounded False _) (CWInteger n)))) = n == 0-isConcreteMin (SVal _ (Left (CW (KBounded True  w) (CWInteger n)))) = n == - bit (w - 1)-isConcreteMin (SVal _ (Left (CW KBool              (CWInteger n)))) = n == 0-isConcreteMin _                                                     = False---- | Predicate for optimizing conditionals.-areConcretelyEqual :: SVal -> SVal -> Bool-areConcretelyEqual (SVal _ (Left a)) (SVal _ (Left b)) = a == b-areConcretelyEqual _                       _           = False---- | Most operations on concrete rationals require a compatibility check to avoid faulting--- on algebraic reals.-rationalCheck :: CW -> CW -> Bool-rationalCheck a b = case (cwVal a, cwVal b) of-                     (CWAlgReal x, CWAlgReal y) -> isExactRational x && isExactRational y-                     _                          -> True---- | Quot/Rem operations require a nonzero check on the divisor.----nonzeroCheck :: CW -> CW -> Bool-nonzeroCheck _ b = cwVal b /= CWInteger 0---- | Same as rationalCheck, except for SBV's-rationalSBVCheck :: SVal -> SVal -> Bool-rationalSBVCheck (SVal KReal (Left a)) (SVal KReal (Left b)) = rationalCheck a b-rationalSBVCheck _                     _                     = True--noReal :: String -> AlgReal -> AlgReal -> AlgReal-noReal o a b = error $ "SBV.AlgReal." ++ o ++ ": Unexpected arguments: " ++ show (a, b)--noFloat :: String -> Float -> Float -> Float-noFloat o a b = error $ "SBV.Float." ++ o ++ ": Unexpected arguments: " ++ show (a, b)--noDouble :: String -> Double -> Double -> Double-noDouble o a b = error $ "SBV.Double." ++ o ++ ": Unexpected arguments: " ++ show (a, b)--noRealUnary :: String -> AlgReal -> AlgReal-noRealUnary o a = error $ "SBV.AlgReal." ++ o ++ ": Unexpected argument: " ++ show a--noFloatUnary :: String -> Float -> Float-noFloatUnary o a = error $ "SBV.Float." ++ o ++ ": Unexpected argument: " ++ show a--noDoubleUnary :: String -> Double -> Double-noDoubleUnary o a = error $ "SBV.Double." ++ o ++ ": Unexpected argument: " ++ show a--{-# ANN svIte     ("HLint: ignore Eta reduce" :: String)         #-}-{-# ANN svLazyIte ("HLint: ignore Eta reduce" :: String)         #-}-{-# ANN module    ("HLint: ignore Reduce duplication" :: String) #-}
− Data/SBV/BitVectors/PrettyNum.hs 
@@ -1,296 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.BitVectors.PrettyNum--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Number representations in hex/bin--------------------------------------------------------------------------------{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Data.SBV.BitVectors.PrettyNum (-        PrettyNum(..), readBin, shex, shexI, sbin, sbinI-      , showCFloat, showCDouble, showHFloat, showHDouble-      , showSMTFloat, showSMTDouble, smtRoundingMode, cwToSMTLib, mkSkolemZero-      ) where--import Data.Char  (ord, intToDigit)-import Data.Int   (Int8, Int16, Int32, Int64)-import Data.List  (isPrefixOf)-import Data.Maybe (fromJust, fromMaybe, listToMaybe)-import Data.Ratio (numerator, denominator)-import Data.Word  (Word8, Word16, Word32, Word64)-import Numeric    (showIntAtBase, showHex, readInt)--import Data.Numbers.CrackNum (floatToFP, doubleToFP)--import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.AlgReals (algRealToSMTLib2)---- | PrettyNum class captures printing of numbers in hex and binary formats; also supporting negative numbers.------ Minimal complete definition: 'hexS' and 'binS'-class PrettyNum a where-  -- | Show a number in hexadecimal (starting with @0x@ and type.)-  hexS :: a -> String-  -- | Show a number in binary (starting with @0b@ and type.)-  binS :: a -> String-  -- | Show a number in hex, without prefix, or types.-  hex :: a -> String-  -- | Show a number in bin, without prefix, or types.-  bin :: a -> String---- Why not default methods? Because defaults need "Integral a" but Bool is not..-instance PrettyNum Bool where-  {hexS = show; binS = show; hex = show; bin = show}-instance PrettyNum Word8 where-  {hexS = shex True True (False,8) ; binS = sbin True True (False,8) ; hex = shex False False (False,8) ; bin = sbin False False (False,8) ;}-instance PrettyNum Int8 where-  {hexS = shex True True (True,8)  ; binS = sbin True True (True,8)  ; hex = shex False False (True,8)  ; bin = sbin False False (True,8)  ;}-instance PrettyNum Word16 where-  {hexS = shex True True (False,16); binS = sbin True True (False,16); hex = shex False False (False,16); bin = sbin False False (False,16);}-instance PrettyNum Int16  where-  {hexS = shex True True (True,16);  binS = sbin True True (True,16) ; hex = shex False False (True,16);  bin = sbin False False (True,16) ;}-instance PrettyNum Word32 where-  {hexS = shex True True (False,32); binS = sbin True True (False,32); hex = shex False False (False,32); bin = sbin False False (False,32);}-instance PrettyNum Int32  where-  {hexS = shex True True (True,32);  binS = sbin True True (True,32) ; hex = shex False False (True,32);  bin = sbin False False (True,32) ;}-instance PrettyNum Word64 where-  {hexS = shex True True (False,64); binS = sbin True True (False,64); hex = shex False False (False,64); bin = sbin False False (False,64);}-instance PrettyNum Int64  where-  {hexS = shex True True (True,64);  binS = sbin True True (True,64) ; hex = shex False False (True,64);  bin = sbin False False (True,64) ;}-instance PrettyNum Integer where-  {hexS = shexI True True; binS = sbinI True True; hex = shexI False False; bin = sbinI False False;}--instance PrettyNum CW where-  hexS cw | isUninterpreted cw = show cw ++ " :: " ++ show (kindOf cw)-          | isBoolean cw       = hexS (cwToBool cw) ++ " :: Bool"-          | isFloat cw         = let CWFloat  f  = cwVal cw in show f ++ " :: Float\n"  ++ show (floatToFP f)-          | isDouble cw        = let CWDouble d  = cwVal cw in show d ++ " :: Double\n" ++ show (doubleToFP d)-          | isReal cw          = let CWAlgReal w = cwVal cw in show w ++ " :: Real"-          | not (isBounded cw) = let CWInteger w = cwVal cw in shexI True True w-          | True               = let CWInteger w = cwVal cw in shex  True True (hasSign cw, intSizeOf cw) w--  binS cw | isUninterpreted cw = show cw  ++ " :: " ++ show (kindOf cw)-          | isBoolean cw       = binS (cwToBool cw)  ++ " :: Bool"-          | isFloat cw         = let CWFloat  f  = cwVal cw in show f ++ " :: Float\n"  ++ show (floatToFP f)-          | isDouble cw        = let CWDouble d  = cwVal cw in show d ++ " :: Double\n" ++ show (doubleToFP d)-          | isReal cw          = let CWAlgReal w = cwVal cw in show w ++ " :: Real"-          | not (isBounded cw) = let CWInteger w = cwVal cw in sbinI True True w-          | True               = let CWInteger w = cwVal cw in sbin  True True (hasSign cw, intSizeOf cw) w--  hex cw | isUninterpreted cw = show cw-         | isBoolean cw       = hexS (cwToBool cw) ++ " :: Bool"-         | isFloat cw         = let CWFloat  f  = cwVal cw in show f-         | isDouble cw        = let CWDouble d  = cwVal cw in show d-         | isReal cw          = let CWAlgReal w = cwVal cw in show w-         | not (isBounded cw) = let CWInteger w = cwVal cw in shexI False False w-         | True               = let CWInteger w = cwVal cw in shex  False False (hasSign cw, intSizeOf cw) w--  bin cw | isUninterpreted cw = show cw-         | isBoolean cw       = binS (cwToBool cw) ++ " :: Bool"-         | isFloat cw         = let CWFloat  f  = cwVal cw in show f-         | isDouble cw        = let CWDouble d  = cwVal cw in show d-         | isReal cw          = let CWAlgReal w = cwVal cw in show w-         | not (isBounded cw) = let CWInteger w = cwVal cw in sbinI False False w-         | True               = let CWInteger w = cwVal cw in sbin  False False (hasSign cw, intSizeOf cw) w--instance (SymWord a, PrettyNum a) => PrettyNum (SBV a) where-  hexS s = maybe (show s) (hexS :: a -> String) $ unliteral s-  binS s = maybe (show s) (binS :: a -> String) $ unliteral s-  hex  s = maybe (show s) (hex  :: a -> String) $ unliteral s-  bin  s = maybe (show s) (bin  :: a -> String) $ unliteral s---- | Show as a hexadecimal value. First bool controls whether type info is printed--- while the second boolean controls wether 0x prefix is printed. The tuple is--- the signedness and the bit-length of the input. The length of the string--- will /not/ depend on the value, but rather the bit-length.-shex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String-shex shType shPre (signed, size) a- | a < 0- = "-" ++ pre ++ pad l (s16 (abs (fromIntegral a :: Integer)))  ++ t- | True- = pre ++ pad l (s16 a) ++ t- where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size-         | True   = ""-       pre | shPre = "0x"-           | True  = ""-       l = (size + 3) `div` 4---- | Show as a hexadecimal value, integer version. Almost the same as shex above--- except we don't have a bit-length so the length of the string will depend--- on the actual value.-shexI :: Bool -> Bool -> Integer -> String-shexI shType shPre a- | a < 0- = "-" ++ pre ++ s16 (abs a)  ++ t- | True- = pre ++ s16 a ++ t- where t | shType = " :: Integer"-         | True   = ""-       pre | shPre = "0x"-           | True  = ""---- | Similar to 'shex'; except in binary.-sbin :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String-sbin shType shPre (signed,size) a- | a < 0- = "-" ++ pre ++ pad size (s2 (abs (fromIntegral a :: Integer)))  ++ t- | True- = pre ++ pad size (s2 a) ++ t- where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size-         | True   = ""-       pre | shPre = "0b"-           | True  = ""---- | Similar to 'shexI'; except in binary.-sbinI :: Bool -> Bool -> Integer -> String-sbinI shType shPre a- | a < 0- = "-" ++ pre ++ s2 (abs a) ++ t- | True- =  pre ++ s2 a ++ t- where t | shType = " :: Integer"-         | True   = ""-       pre | shPre = "0b"-           | True  = ""---- | Pad a string to a given length. If the string is longer, then we don't drop anything.-pad :: Int -> String -> String-pad l s = replicate (l - length s) '0' ++ s---- | Binary printer-s2 :: (Show a, Integral a) => a -> String-s2  v = showIntAtBase 2 dig v "" where dig = fromJust . flip lookup [(0, '0'), (1, '1')]---- | Hex printer-s16 :: (Show a, Integral a) => a -> String-s16 v = showHex v ""---- | A more convenient interface for reading binary numbers, also supports negative numbers-readBin :: Num a => String -> a-readBin ('-':s) = -(readBin s)-readBin s = case readInt 2 isDigit cvt s' of-              [(a, "")] -> a-              _         -> error $ "SBV.readBin: Cannot read a binary number from: " ++ show s-  where cvt c = ord c - ord '0'-        isDigit = (`elem` "01")-        s' | "0b" `isPrefixOf` s = drop 2 s-           | True                = s---- | A version of show for floats that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included.-showCFloat :: Float -> String-showCFloat f-   | isNaN f             = "((float) NAN)"-   | isInfinite f, f < 0 = "((float) (-INFINITY))"-   | isInfinite f        = "((float) INFINITY)"-   | True                = show f ++ "F"---- | A version of show for doubles that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included.-showCDouble :: Double -> String-showCDouble f-   | isNaN f             = "((double) NAN)"-   | isInfinite f, f < 0 = "((double) (-INFINITY))"-   | isInfinite f        = "((double) INFINITY)"-   | True                = show f---- | A version of show for floats that generates correct Haskell literals for nan/infinite-showHFloat :: Float -> String-showHFloat f-   | isNaN f             = "((0/0) :: Float)"-   | isInfinite f, f < 0 = "((-1/0) :: Float)"-   | isInfinite f        = "((1/0) :: Float)"-   | True                = show f---- | A version of show for doubles that generates correct Haskell literals for nan/infinite-showHDouble :: Double -> String-showHDouble d-   | isNaN d             = "((0/0) :: Double)"-   | isInfinite d, d < 0 = "((-1/0) :: Double)"-   | isInfinite d        = "((1/0) :: Double)"-   | True                = show d---- | A version of show for floats that generates correct SMTLib literals using the rounding mode-showSMTFloat :: RoundingMode -> Float -> String-showSMTFloat rm f-   | isNaN f             = as "NaN"-   | isInfinite f, f < 0 = as "-oo"-   | isInfinite f        = as "+oo"-   | isNegativeZero f    = as "-zero"-   | f == 0              = as "+zero"-   | True                = "((_ to_fp 8 24) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational f) ++ ")"-   where as s = "(_ " ++ s ++ " 8 24)"---- | A version of show for doubles that generates correct SMTLib literals using the rounding mode-showSMTDouble :: RoundingMode -> Double -> String-showSMTDouble rm d-   | isNaN d             = as "NaN"-   | isInfinite d, d < 0 = as "-oo"-   | isInfinite d        = as "+oo"-   | isNegativeZero d    = as "-zero"-   | d == 0              = as "+zero"-   | True                = "((_ to_fp 11 53) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational d) ++ ")"-   where as s = "(_ " ++ s ++ " 11 53)"---- | Show a rational in SMTLib format-toSMTLibRational :: Rational -> String-toSMTLibRational r-   | n < 0-   = "(- (/ "  ++ show (abs n) ++ " " ++ show d ++ "))"-   | True-   = "(/ " ++ show n ++ " " ++ show d ++ ")"-  where n = numerator r-        d = denominator r---- | Convert a rounding mode to the format SMT-Lib2 understands.-smtRoundingMode :: RoundingMode -> String-smtRoundingMode RoundNearestTiesToEven = "roundNearestTiesToEven"-smtRoundingMode RoundNearestTiesToAway = "roundNearestTiesToAway"-smtRoundingMode RoundTowardPositive    = "roundTowardPositive"-smtRoundingMode RoundTowardNegative    = "roundTowardNegative"-smtRoundingMode RoundTowardZero        = "roundTowardZero"---- | Convert a CW to an SMTLib2 compliant value-cwToSMTLib :: RoundingMode -> CW -> String-cwToSMTLib rm x-  | isBoolean       x, CWInteger  w      <- cwVal x = if w == 0 then "false" else "true"-  | isUninterpreted x, CWUserSort (_, s) <- cwVal x = roundModeConvert s-  | isReal          x, CWAlgReal  r      <- cwVal x = algRealToSMTLib2 r-  | isFloat         x, CWFloat    f      <- cwVal x = showSMTFloat  rm f-  | isDouble        x, CWDouble   d      <- cwVal x = showSMTDouble rm d-  | not (isBounded x), CWInteger  w      <- cwVal x = if w >= 0 then show w else "(- " ++ show (abs w) ++ ")"-  | not (hasSign x)  , CWInteger  w      <- cwVal x = smtLibHex (intSizeOf x) w-  -- signed numbers (with 2's complement representation) is problematic-  -- since there's no way to put a bvneg over a positive number to get minBound..-  -- Hence, we punt and use binary notation in that particular case-  | hasSign x        , CWInteger  w      <- cwVal x = if w == negate (2 ^ intSizeOf x)-                                                      then mkMinBound (intSizeOf x)-                                                      else negIf (w < 0) $ smtLibHex (intSizeOf x) (abs w)-  | True = error $ "SBV.cvtCW: Impossible happened: Kind/Value disagreement on: " ++ show (kindOf x, x)-  where roundModeConvert s = fromMaybe s (listToMaybe [smtRoundingMode m | m <- [minBound .. maxBound] :: [RoundingMode], show m == s])-        -- Carefully code hex numbers, SMTLib is picky about lengths of hex constants. For the time-        -- being, SBV only supports sizes that are multiples of 4, but the below code is more robust-        -- in case of future extensions to support arbitrary sizes.-        smtLibHex :: Int -> Integer -> String-        smtLibHex 1  v = "#b" ++ show v-        smtLibHex sz v-          | sz `mod` 4 == 0 = "#x" ++ pad (sz `div` 4) (showHex v "")-          | True            = "#b" ++ pad sz (showBin v "")-           where showBin = showIntAtBase 2 intToDigit-        negIf :: Bool -> String -> String-        negIf True  a = "(bvneg " ++ a ++ ")"-        negIf False a = a-        -- anamoly at the 2's complement min value! Have to use binary notation here-        -- as there is no positive value we can provide to make the bvneg work.. (see above)-        mkMinBound :: Int -> String-        mkMinBound i = "#b1" ++ replicate (i-1) '0'---- | Create a skolem 0 for the kind-mkSkolemZero :: RoundingMode -> Kind -> String-mkSkolemZero _ (KUserSort _ (Right (f:_))) = f-mkSkolemZero _ (KUserSort s _)             = error $ "SBV.mkSkolemZero: Unexpected uninterpreted sort: " ++ s-mkSkolemZero rm k                          = cwToSMTLib rm (mkConstCW k (0::Integer))
− Data/SBV/BitVectors/STree.hs 
@@ -1,75 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.BitVectors.STree--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Implementation of full-binary symbolic trees, providing logarithmic--- time access to elements. Both reads and writes are supported.--------------------------------------------------------------------------------{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}--module Data.SBV.BitVectors.STree (STree, readSTree, writeSTree, mkSTree) where--import Data.Bits (Bits(..))--import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.Model---- | A symbolic tree containing values of type e, indexed by--- elements of type i. Note that these are full-trees, and their--- their shapes remain constant. There is no API provided that--- can change the shape of the tree. These structures are useful--- when dealing with data-structures that are indexed with symbolic--- values where access time is important. 'STree' structures provide--- logarithmic time reads and writes.-type STree i e = STreeInternal (SBV i) (SBV e)---- Internal representation, not exposed to the user-data STreeInternal i e = SLeaf e                        -- NB. parameter 'i' is phantom-                       | SBin  (STreeInternal i e) (STreeInternal i e)-                       deriving Show--instance (SymWord e, Mergeable (SBV e)) => Mergeable (STree i e) where-  symbolicMerge f b (SLeaf i)  (SLeaf j)    = SLeaf (symbolicMerge f b i j)-  symbolicMerge f b (SBin l r) (SBin l' r') = SBin  (symbolicMerge f b l l') (symbolicMerge f b r r')-  symbolicMerge _ _ _          _            = error "SBV.STree.symbolicMerge: Impossible happened while merging states"---- | Reading a value. We bit-blast the index and descend down the full tree--- according to bit-values.-readSTree :: (Num i, Bits i, SymWord i, SymWord e) => STree i e -> SBV i -> SBV e-readSTree s i = walk (blastBE i) s-  where walk []     (SLeaf v)  = v-        walk (b:bs) (SBin l r) = ite b (walk bs r) (walk bs l)-        walk _      _          = error $ "SBV.STree.readSTree: Impossible happened while reading: " ++ show i---- | Writing a value, similar to how reads are done. The important thing is that the tree--- representation keeps updates to a minimum.-writeSTree :: (Mergeable (SBV e), Num i, Bits i, SymWord i, SymWord e) => STree i e -> SBV i -> SBV e -> STree i e-writeSTree s i j = walk (blastBE i) s-  where walk []     _          = SLeaf j-        walk (b:bs) (SBin l r) = SBin (ite b l (walk bs l)) (ite b (walk bs r) r)-        walk _      _          = error $ "SBV.STree.writeSTree: Impossible happened while reading: " ++ show i---- | Construct the fully balanced initial tree using the given values.-mkSTree :: forall i e. HasKind i => [SBV e] -> STree i e-mkSTree ivals-  | isReal (undefined :: i)-  = error "SBV.STree.mkSTree: Cannot build a real-valued sized tree"-  | not (isBounded (undefined :: i))-  = error "SBV.STree.mkSTree: Cannot build an infinitely large tree"-  | reqd /= given-  = error $ "SBV.STree.mkSTree: Required " ++ show reqd ++ " elements, received: " ++ show given-  | True-  = go ivals-  where reqd = 2 ^ intSizeOf (undefined :: i)-        given = length ivals-        go []  = error "SBV.STree.mkSTree: Impossible happened, ran out of elements"-        go [l] = SLeaf l-        go ns  = let (l, r) = splitAt (length ns `div` 2) ns in SBin (go l) (go r)
− Data/SBV/BitVectors/Splittable.hs 
@@ -1,119 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.BitVectors.Splittable--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Implementation of bit-vector concatanetation and splits--------------------------------------------------------------------------------{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE TypeSynonymInstances   #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE BangPatterns           #-}--module Data.SBV.BitVectors.Splittable (Splittable(..), FromBits(..), checkAndConvert) where--import Data.Bits (Bits(..))-import Data.Word (Word8, Word16, Word32, Word64)--import Data.SBV.BitVectors.Operations-import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.Model--infixr 5 #--- | Splitting an @a@ into two @b@'s and joining back.--- Intuitively, @a@ is a larger bit-size word than @b@, typically double.--- The 'extend' operation captures embedding of a @b@ value into an @a@--- without changing its semantic value.------ Minimal complete definition: All, no defaults.-class Splittable a b | b -> a where-  split  :: a -> (b, b)-  (#)    :: b -> b -> a-  extend :: b -> a--genSplit :: (Integral a, Num b) => Int -> a -> (b, b)-genSplit ss x = (fromIntegral ((ix `shiftR` ss) .&. mask), fromIntegral (ix .&. mask))-  where ix = toInteger x-        mask = 2 ^ ss - 1--genJoin :: (Integral b, Num a) => Int -> b -> b -> a-genJoin ss x y = fromIntegral ((ix `shiftL` ss) .|. iy)-  where ix = toInteger x-        iy = toInteger y---- concrete instances-instance Splittable Word64 Word32 where-  split = genSplit 32-  (#)   = genJoin  32-  extend b = 0 # b--instance Splittable Word32 Word16 where-  split = genSplit 16-  (#)   = genJoin  16-  extend b = 0 # b--instance Splittable Word16 Word8 where-  split = genSplit 8-  (#)   = genJoin  8-  extend b = 0 # b---- symbolic instances-instance Splittable SWord64 SWord32 where-  split (SBV x) = (SBV (svExtract 63 32 x), SBV (svExtract 31 0 x))-  SBV a # SBV b = SBV (svJoin a b)-  extend b = 0 # b--instance Splittable SWord32 SWord16 where-  split (SBV x) = (SBV (svExtract 31 16 x), SBV (svExtract 15 0 x))-  SBV a # SBV b = SBV (svJoin a b)-  extend b = 0 # b--instance Splittable SWord16 SWord8 where-  split (SBV x) = (SBV (svExtract 15 8 x), SBV (svExtract 7 0 x))-  SBV a # SBV b = SBV (svJoin a b)-  extend b = 0 # b---- | Unblasting a value from symbolic-bits. The bits can be given little-endian--- or big-endian. For a signed number in little-endian, we assume the very last bit--- is the sign digit. This is a bit awkward, but it is more consistent with the "reverse" view of--- little-big-endian representations------ Minimal complete definition: 'fromBitsLE'-class FromBits a where- fromBitsLE, fromBitsBE :: [SBool] -> a- fromBitsBE = fromBitsLE . reverse---- | Construct a symbolic word from its bits given in little-endian-fromBinLE :: (Num a, Bits a, SymWord a) => [SBool] -> SBV a-fromBinLE = go 0 0-  where go !acc _  []     = acc-        go !acc !i (x:xs) = go (ite x (setBit acc i) acc) (i+1) xs---- | Perform a sanity check that we should receive precisely the same--- number of bits as required by the resulting type. The input is little-endian-checkAndConvert :: (Num a, Bits a, SymWord a) => Int -> [SBool] -> SBV a-checkAndConvert sz xs-  | sz /= l-  = error $ "SBV.fromBits.SWord" ++ ssz ++ ": Expected " ++ ssz ++ " elements, got: " ++ show l-  | True-  = fromBinLE xs-  where l   = length xs-        ssz = show sz--instance FromBits SBool where- fromBitsLE [x] = x- fromBitsLE xs  = error $ "SBV.fromBits.SBool: Expected 1 element, got: " ++ show (length xs)--instance FromBits SWord8  where fromBitsLE = checkAndConvert  8-instance FromBits SInt8   where fromBitsLE = checkAndConvert  8-instance FromBits SWord16 where fromBitsLE = checkAndConvert 16-instance FromBits SInt16  where fromBitsLE = checkAndConvert 16-instance FromBits SWord32 where fromBitsLE = checkAndConvert 32-instance FromBits SInt32  where fromBitsLE = checkAndConvert 32-instance FromBits SWord64 where fromBitsLE = checkAndConvert 64-instance FromBits SInt64  where fromBitsLE = checkAndConvert 64
− Data/SBV/BitVectors/Symbolic.hs 
@@ -1,1122 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.BitVectors.Symbolic--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Symbolic values--------------------------------------------------------------------------------{-# LANGUAGE    GeneralizedNewtypeDeriving #-}-{-# LANGUAGE    TypeSynonymInstances       #-}-{-# LANGUAGE    TypeOperators              #-}-{-# LANGUAGE    MultiParamTypeClasses      #-}-{-# LANGUAGE    ScopedTypeVariables        #-}-{-# LANGUAGE    FlexibleInstances          #-}-{-# LANGUAGE    PatternGuards              #-}-{-# LANGUAGE    NamedFieldPuns             #-}-{-# LANGUAGE    DeriveDataTypeable         #-}-{-# LANGUAGE    CPP                        #-}-{-# OPTIONS_GHC -fno-warn-orphans          #-}--module Data.SBV.BitVectors.Symbolic-  ( NodeId(..)-  , SW(..), swKind, trueSW, falseSW-  , Op(..), FPOp(..)-  , Quantifier(..), needsExistentials-  , RoundingMode(..)-  , SBVType(..), newUninterpreted, addAxiom-  , SVal(..)-  , svMkSymVar-  , ArrayContext(..), ArrayInfo-  , svToSW, svToSymSW, forceSWArg-  , SBVExpr(..), newExpr, isCodeGenMode-  , Cached, cache, uncache-  , ArrayIndex, uncacheAI-  , NamedSymVar-  , getSValPathCondition, extendSValPathCondition-  , getTableIndex-  , SBVPgm(..), Symbolic, runSymbolic, runSymbolic', State-  , inProofMode, SBVRunMode(..), Result(..)-  , Logic(..), SMTLibLogic(..)-  , addAssertion, addSValConstraint, internalConstraint, internalVariable-  , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension-  , SolverCapabilities(..)-  , extractSymbolicSimulationState-  , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), SMTEngine, getSBranchRunConfig-  , outputSVal-  , mkSValUserSort-  , SArr(..), readSArr, resetSArr, writeSArr, mergeSArr, newSArr, eqSArr-  ) where--import Control.DeepSeq      (NFData(..))-import Control.Monad        (when, unless)-import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)-import Control.Monad.Trans  (MonadIO, liftIO)-import Data.Char            (isAlpha, isAlphaNum, toLower)-import Data.IORef           (IORef, newIORef, modifyIORef, readIORef, writeIORef)-import Data.List            (intercalate, sortBy)-import Data.Maybe           (isJust, fromJust, fromMaybe)--import GHC.Stack.Compat--import qualified Data.Generics as G    (Data(..))-import qualified Data.IntMap   as IMap (IntMap, empty, size, toAscList, lookup, insert, insertWith)-import qualified Data.Map      as Map  (Map, empty, toList, size, insert, lookup)-import qualified Data.Set      as Set  (Set, empty, toList, insert)-import qualified Data.Foldable as F    (toList)-import qualified Data.Sequence as S    (Seq, empty, (|>))--import System.Mem.StableName-import System.Random--import Data.SBV.BitVectors.Kind-import Data.SBV.BitVectors.Concrete-import Data.SBV.SMT.SMTLibNames-import Data.SBV.Utils.TDiff(Timing)--import Prelude ()-import Prelude.Compat---- | A symbolic node id-newtype NodeId = NodeId Int deriving (Eq, Ord)---- | A symbolic word, tracking it's signedness and size.-data SW = SW !Kind !NodeId deriving (Eq, Ord)--instance HasKind SW where-  kindOf (SW k _) = k--instance Show SW where-  show (SW _ (NodeId n))-    | n < 0 = "s_" ++ show (abs n)-    | True  = 's' : show n---- | Kind of a symbolic word.-swKind :: SW -> Kind-swKind (SW k _) = k---- | Forcing an argument; this is a necessary evil to make sure all the arguments--- to an uninterpreted function and sBranch test conditions are evaluated before called;--- the semantics of uinterpreted functions is necessarily strict; deviating from Haskell's-forceSWArg :: SW -> IO ()-forceSWArg (SW k n) = k `seq` n `seq` return ()---- | Constant False as an SW. Note that this value always occupies slot -2.-falseSW :: SW-falseSW = SW KBool $ NodeId (-2)---- | Constant True as an SW. Note that this value always occupies slot -1.-trueSW :: SW-trueSW  = SW KBool $ NodeId (-1)---- | Symbolic operations-data Op = Plus-        | Times-        | Minus-        | UNeg-        | Abs-        | Quot-        | Rem-        | Equal-        | NotEqual-        | LessThan-        | GreaterThan-        | LessEq-        | GreaterEq-        | Ite-        | And-        | Or-        | XOr-        | Not-        | Shl Int-        | Shr Int-        | Rol Int-        | Ror Int-        | Extract Int Int                       -- Extract i j: extract bits i to j. Least significant bit is 0 (big-endian)-        | Join                                  -- Concat two words to form a bigger one, in the order given-        | LkUp (Int, Kind, Kind, Int) !SW !SW   -- (table-index, arg-type, res-type, length of the table) index out-of-bounds-value-        | ArrEq   Int Int                       -- Array equality-        | ArrRead Int-        | KindCast Kind Kind-        | Uninterpreted String-        | Label String                          -- Essentially no-op; useful for code generation to emit comments.-        | IEEEFP FPOp                           -- Floating-point ops, categorized separately-        deriving (Eq, Ord)---- | Floating point operations-data FPOp = FP_Cast        Kind Kind SW   -- From-Kind, To-Kind, RoundingMode. This is "value" conversion-          | FP_Reinterpret Kind Kind      -- From-Kind, To-Kind. This is bit-reinterpretation using IEEE-754 interchange format-          | FP_Abs-          | FP_Neg-          | FP_Add-          | FP_Sub-          | FP_Mul-          | FP_Div-          | FP_FMA-          | FP_Sqrt-          | FP_Rem-          | FP_RoundToIntegral-          | FP_Min-          | FP_Max-          | FP_ObjEqual-          | FP_IsNormal-          | FP_IsSubnormal-          | FP_IsZero-          | FP_IsInfinite-          | FP_IsNaN-          | FP_IsNegative-          | FP_IsPositive-          deriving (Eq, Ord)---- | Note that the show instance maps to the SMTLib names. We need to make sure--- this mapping stays correct through SMTLib changes. The only exception--- is FP_Cast; where we handle different source/origins explicitly later on.-instance Show FPOp where-   show (FP_Cast f t r)      = "(FP_Cast: " ++ show f ++ " -> " ++ show t ++ ", using RM [" ++ show r ++ "])"-   show (FP_Reinterpret f t) = case (f, t) of-                                  (KBounded False 32, KFloat)  -> "(_ to_fp 8 24)"-                                  (KBounded False 64, KDouble) -> "(_ to_fp 11 53)"-                                  _                            -> error $ "SBV.FP_Reinterpret: Unexpected conversion: " ++ show f ++ " to " ++ show t-   show FP_Abs               = "fp.abs"-   show FP_Neg               = "fp.neg"-   show FP_Add               = "fp.add"-   show FP_Sub               = "fp.sub"-   show FP_Mul               = "fp.mul"-   show FP_Div               = "fp.div"-   show FP_FMA               = "fp.fma"-   show FP_Sqrt              = "fp.sqrt"-   show FP_Rem               = "fp.rem"-   show FP_RoundToIntegral   = "fp.roundToIntegral"-   show FP_Min               = "fp.min"-   show FP_Max               = "fp.max"-   show FP_ObjEqual          = "="-   show FP_IsNormal          = "fp.isNormal"-   show FP_IsSubnormal       = "fp.isSubnormal"-   show FP_IsZero            = "fp.isZero"-   show FP_IsInfinite        = "fp.isInfinite"-   show FP_IsNaN             = "fp.isNaN"-   show FP_IsNegative        = "fp.isNegative"-   show FP_IsPositive        = "fp.isPositive"---- | Show instance for 'Op'. Note that this is largely for debugging purposes, not used--- for being read by any tool.-instance Show Op where-  show (Shl i) = "<<"  ++ show i-  show (Shr i) = ">>"  ++ show i-  show (Rol i) = "<<<" ++ show i-  show (Ror i) = ">>>" ++ show i-  show (Extract i j) = "choose [" ++ show i ++ ":" ++ show j ++ "]"-  show (LkUp (ti, at, rt, l) i e)-        = "lookup(" ++ tinfo ++ ", " ++ show i ++ ", " ++ show e ++ ")"-        where tinfo = "table" ++ show ti ++ "(" ++ show at ++ " -> " ++ show rt ++ ", " ++ show l ++ ")"-  show (ArrEq i j)       = "array_" ++ show i ++ " == array_" ++ show j-  show (ArrRead i)       = "select array_" ++ show i-  show (KindCast fr to)  = "cast_" ++ show fr ++ "_" ++ show to-  show (Uninterpreted i) = "[uninterpreted] " ++ i-  show (Label s)         = "[label] " ++ s-  show (IEEEFP w)        = show w-  show op-    | Just s <- op `lookup` syms = s-    | True                       = error "impossible happened; can't find op!"-    where syms = [ (Plus, "+"), (Times, "*"), (Minus, "-"), (UNeg, "-"), (Abs, "abs")-                 , (Quot, "quot")-                 , (Rem,  "rem")-                 , (Equal, "=="), (NotEqual, "/=")-                 , (LessThan, "<"), (GreaterThan, ">"), (LessEq, "<="), (GreaterEq, ">=")-                 , (Ite, "if_then_else")-                 , (And, "&"), (Or, "|"), (XOr, "^"), (Not, "~")-                 , (Join, "#")-                 ]---- | Quantifiers: forall or exists. Note that we allow--- arbitrary nestings.-data Quantifier = ALL | EX deriving Eq---- | Are there any existential quantifiers?-needsExistentials :: [Quantifier] -> Bool-needsExistentials = (EX `elem`)---- | A simple type for SBV computations, used mainly for uninterpreted constants.--- We keep track of the signedness/size of the arguments. A non-function will--- have just one entry in the list.-newtype SBVType = SBVType [Kind]-             deriving (Eq, Ord)--instance Show SBVType where-  show (SBVType []) = error "SBV: internal error, empty SBVType"-  show (SBVType xs) = intercalate " -> " $ map show xs---- | A symbolic expression-data SBVExpr = SBVApp !Op ![SW]-             deriving (Eq, Ord)---- | To improve hash-consing, take advantage of commutative operators by--- reordering their arguments.-reorder :: SBVExpr -> SBVExpr-reorder s = case s of-              SBVApp op [a, b] | isCommutative op && a > b -> SBVApp op [b, a]-              _ -> s-  where isCommutative :: Op -> Bool-        isCommutative o = o `elem` [Plus, Times, Equal, NotEqual, And, Or, XOr]---- | Show instance for 'SBVExpr'. Again, only for debugging purposes.-instance Show SBVExpr where-  show (SBVApp Ite [t, a, b]) = unwords ["if", show t, "then", show a, "else", show b]-  show (SBVApp (Shl i) [a])   = unwords [show a, "<<", show i]-  show (SBVApp (Shr i) [a])   = unwords [show a, ">>", show i]-  show (SBVApp (Rol i) [a])   = unwords [show a, "<<<", show i]-  show (SBVApp (Ror i) [a])   = unwords [show a, ">>>", show i]-  show (SBVApp op  [a, b])    = unwords [show a, show op, show b]-  show (SBVApp op  args)      = unwords (show op : map show args)---- | A program is a sequence of assignments-newtype SBVPgm = SBVPgm {pgmAssignments :: S.Seq (SW, SBVExpr)}---- | 'NamedSymVar' pairs symbolic words and user given/automatically generated names-type NamedSymVar = (SW, String)---- | Result of running a symbolic computation-data Result = Result { reskinds       :: Set.Set Kind                     -- ^ kinds used in the program-                     , resTraces      :: [(String, CW)]                   -- ^ quick-check counter-example information (if any)-                     , resUISegs      :: [(String, [String])]             -- ^ uninterpeted code segments-                     , resInputs      :: [(Quantifier, NamedSymVar)]      -- ^ inputs (possibly existential)-                     , resConsts      :: [(SW, CW)]                       -- ^ constants-                     , resTables      :: [((Int, Kind, Kind), [SW])]      -- ^ tables (automatically constructed) (tableno, index-type, result-type) elts-                     , resArrays      :: [(Int, ArrayInfo)]               -- ^ arrays (user specified)-                     , resUIConsts    :: [(String, SBVType)]              -- ^ uninterpreted constants-                     , resAxioms      :: [(String, [String])]             -- ^ axioms-                     , resAsgns       :: SBVPgm                           -- ^ assignments-                     , resConstraints :: [SW]                             -- ^ additional constraints (boolean)-                     , resAssertions  :: [(String, Maybe CallStack, SW)]  -- ^ assertions-                     , resOutputs     :: [SW]                             -- ^ outputs-                     }---- | Show instance for 'Result'. Only for debugging purposes.-instance Show Result where-  show (Result _ _ _ _ cs _ _ [] [] _ [] _ [r])-    | Just c <- r `lookup` cs-    = show c-  show (Result kinds _ cgs is cs ts as uis axs xs cstrs asserts os)  = intercalate "\n" $-                   (if null usorts then [] else "SORTS" : map ("  " ++) usorts)-                ++ ["INPUTS"]-                ++ map shn is-                ++ ["CONSTANTS"]-                ++ map shc cs-                ++ ["TABLES"]-                ++ map sht ts-                ++ ["ARRAYS"]-                ++ map sha as-                ++ ["UNINTERPRETED CONSTANTS"]-                ++ map shui uis-                ++ ["USER GIVEN CODE SEGMENTS"]-                ++ concatMap shcg cgs-                ++ ["AXIOMS"]-                ++ map shax axs-                ++ ["DEFINE"]-                ++ map (\(s, e) -> "  " ++ shs s ++ " = " ++ show e) (F.toList (pgmAssignments xs))-                ++ ["CONSTRAINTS"]-                ++ map (("  " ++) . show) cstrs-                ++ ["ASSERTIONS"]-                ++ map (("  "++) . shAssert) asserts-                ++ ["OUTPUTS"]-                ++ map (("  " ++) . show) os-    where usorts = [sh s t | KUserSort s t <- Set.toList kinds]-                   where sh s (Left   _) = s-                         sh s (Right es) = s ++ " (" ++ intercalate ", " es ++ ")"-          shs sw = show sw ++ " :: " ++ show (swKind sw)-          sht ((i, at, rt), es)  = "  Table " ++ show i ++ " : " ++ show at ++ "->" ++ show rt ++ " = " ++ show es-          shc (sw, cw) = "  " ++ show sw ++ " = " ++ show cw-          shcg (s, ss) = ("Variable: " ++ s) : map ("  " ++) ss-          shn (q, (sw, nm)) = "  " ++ ni ++ " :: " ++ show (swKind sw) ++ ex ++ alias-            where ni = show sw-                  ex | q == ALL = ""-                     | True     = ", existential"-                  alias | ni == nm = ""-                        | True     = ", aliasing " ++ show nm-          sha (i, (nm, (ai, bi), ctx)) = "  " ++ ni ++ " :: " ++ show ai ++ " -> " ++ show bi ++ alias-                                       ++ "\n     Context: "     ++ show ctx-            where ni = "array_" ++ show i-                  alias | ni == nm = ""-                        | True     = ", aliasing " ++ show nm-          shui (nm, t) = "  [uninterpreted] " ++ nm ++ " :: " ++ show t-          shax (nm, ss) = "  -- user defined axiom: " ++ nm ++ "\n  " ++ intercalate "\n  " ss-          shAssert (nm, stk, p) = "  -- assertion: " ++ nm ++ " " ++ maybe "[No location]"-#if MIN_VERSION_base(4,9,0)-                prettyCallStack-#else-                showCallStack-#endif-                stk ++ ": " ++ show p---- | The context of a symbolic array as created-data ArrayContext = ArrayFree (Maybe SW)     -- ^ A new array, with potential initializer for each cell-                  | ArrayReset Int SW        -- ^ An array created from another array by fixing each element to another value-                  | ArrayMutate Int SW SW    -- ^ An array created by mutating another array at a given cell-                  | ArrayMerge  SW Int Int   -- ^ An array created by symbolically merging two other arrays--instance Show ArrayContext where-  show (ArrayFree Nothing)  = " initialized with random elements"-  show (ArrayFree (Just s)) = " initialized with " ++ show s ++ " :: " ++ show (swKind s)-  show (ArrayReset i s)     = " reset array_" ++ show i ++ " with " ++ show s ++ " :: " ++ show (swKind s)-  show (ArrayMutate i a b)  = " cloned from array_" ++ show i ++ " with " ++ show a ++ " :: " ++ show (swKind a) ++ " |-> " ++ show b ++ " :: " ++ show (swKind b)-  show (ArrayMerge s i j)   = " merged arrays " ++ show i ++ " and " ++ show j ++ " on condition " ++ show s---- | Expression map, used for hash-consing-type ExprMap   = Map.Map SBVExpr SW---- | Constants are stored in a map, for hash-consing. The bool is needed to tell -0 from +0, sigh-type CnstMap   = Map.Map (Bool, CW) SW---- | Kinds used in the program; used for determining the final SMT-Lib logic to pick-type KindSet = Set.Set Kind---- | Tables generated during a symbolic run-type TableMap  = Map.Map (Kind, Kind, [SW]) Int---- | Representation for symbolic arrays-type ArrayInfo = (String, (Kind, Kind), ArrayContext)---- | Arrays generated during a symbolic run-type ArrayMap  = IMap.IntMap ArrayInfo---- | Uninterpreted-constants generated during a symbolic run-type UIMap     = Map.Map String SBVType---- | Code-segments for Uninterpreted-constants, as given by the user-type CgMap     = Map.Map String [String]---- | Cached values, implementing sharing-type Cache a   = IMap.IntMap [(StableName (State -> IO a), a)]---- | Different means of running a symbolic piece of code-data SBVRunMode = Proof (Bool, SMTConfig) -- ^ Fully Symbolic, proof mode.-                | CodeGen                 -- ^ Code generation mode.-                | Concrete StdGen         -- ^ Concrete simulation mode. The StdGen is for the pConstrain acceptance in cross runs.---- | Is this a concrete run? (i.e., quick-check or test-generation like)-isConcreteMode :: State -> Bool-isConcreteMode State{runMode} = case runMode of-                                  Concrete{} -> True-                                  Proof{}    -> False-                                  CodeGen    -> False---- | Is this a CodeGen run? (i.e., generating code)-isCodeGenMode :: State -> Bool-isCodeGenMode State{runMode} = case runMode of-                                 Concrete{} -> False-                                 Proof{}    -> False-                                 CodeGen    -> True---- | The state of the symbolic interpreter-data State  = State { runMode      :: SBVRunMode-                    , pathCond     :: SVal                             -- ^ kind KBool-                    , rStdGen      :: IORef StdGen-                    , rCInfo       :: IORef [(String, CW)]-                    , rctr         :: IORef Int-                    , rUsedKinds   :: IORef KindSet-                    , rinps        :: IORef [(Quantifier, NamedSymVar)]-                    , rConstraints :: IORef [SW]-                    , routs        :: IORef [SW]-                    , rtblMap      :: IORef TableMap-                    , spgm         :: IORef SBVPgm-                    , rconstMap    :: IORef CnstMap-                    , rexprMap     :: IORef ExprMap-                    , rArrayMap    :: IORef ArrayMap-                    , rUIMap       :: IORef UIMap-                    , rCgMap       :: IORef CgMap-                    , raxioms      :: IORef [(String, [String])]-                    , rAsserts     :: IORef [(String, Maybe CallStack, SW)]-                    , rSWCache     :: IORef (Cache SW)-                    , rAICache     :: IORef (Cache Int)-                    }---- | Get the current path condition-getSValPathCondition :: State -> SVal-getSValPathCondition = pathCond---- | Extend the path condition with the given test value.-extendSValPathCondition :: State -> (SVal -> SVal) -> State-extendSValPathCondition st f = st{pathCond = f (pathCond st)}---- | Are we running in proof mode?-inProofMode :: State -> Bool-inProofMode s = case runMode s of-                  Proof{}    -> True-                  CodeGen    -> False-                  Concrete{} -> False---- | If in proof mode, get the underlying configuration (used for 'sBranch')-getSBranchRunConfig :: State -> Maybe SMTConfig-getSBranchRunConfig st = case runMode st of-                           Proof (_, s)  -> Just s-                           _             -> Nothing---- | The "Symbolic" value. Either a constant (@Left@) or a symbolic--- value (@Right Cached@). Note that caching is essential for making--- sure sharing is preserved.-data SVal = SVal !Kind !(Either CW (Cached SW))--instance HasKind SVal where-  kindOf (SVal k _) = k---- | Show instance for 'SVal'. Not particularly "desirable", but will do if needed--- NB. We do not show the type info on constant KBool values, since there's no--- implicit "fromBoolean" applied to Booleans in Haskell; and thus a statement--- of the form "True :: SBool" is just meaningless. (There should be a fromBoolean!)-instance Show SVal where-  show (SVal KBool (Left c))  = showCW False c-  show (SVal k     (Left c))  = showCW False c ++ " :: " ++ show k-  show (SVal k     (Right _)) =         "<symbolic> :: " ++ show k---- | Equality constraint on SBV values. Not desirable since we can't really compare two--- symbolic values, but will do.-instance Eq SVal where-  SVal _ (Left a) == SVal _ (Left b) = a == b-  a == b = error $ "Comparing symbolic bit-vectors; Use (.==) instead. Received: " ++ show (a, b)-  SVal _ (Left a) /= SVal _ (Left b) = a /= b-  a /= b = error $ "Comparing symbolic bit-vectors; Use (./=) instead. Received: " ++ show (a, b)---- | Increment the variable counter-incCtr :: State -> IO Int-incCtr s = do ctr <- readIORef (rctr s)-              let i = ctr + 1-              i `seq` writeIORef (rctr s) i-              return ctr---- | Generate a random value, for quick-check and test-gen purposes-throwDice :: State -> IO Double-throwDice st = do g <- readIORef (rStdGen st)-                  let (r, g') = randomR (0, 1) g-                  writeIORef (rStdGen st) g'-                  return r---- | Create a new uninterpreted symbol, possibly with user given code-newUninterpreted :: State -> String -> SBVType -> Maybe [String] -> IO ()-newUninterpreted st nm t mbCode-  | null nm || not enclosed && (not (isAlpha (head nm)) || not (all validChar (tail nm)))-  = error $ "Bad uninterpreted constant name: " ++ show nm ++ ". Must be a valid identifier."-  | True = do-        uiMap <- readIORef (rUIMap st)-        case nm `Map.lookup` uiMap of-          Just t' -> when (t /= t') $ error $  "Uninterpreted constant " ++ show nm ++ " used at incompatible types\n"-                                            ++ "      Current type      : " ++ show t ++ "\n"-                                            ++ "      Previously used at: " ++ show t'-          Nothing -> do modifyIORef (rUIMap st) (Map.insert nm t)-                        when (isJust mbCode) $ modifyIORef (rCgMap st) (Map.insert nm (fromJust mbCode))-  where validChar x = isAlphaNum x || x `elem` "_"-        enclosed    = head nm == '|' && last nm == '|' && length nm > 2 && not (any (`elem` "|\\") (tail (init nm)))---- | Add a new sAssert based constraint-addAssertion :: State -> Maybe CallStack -> String -> SW -> IO ()-addAssertion st cs msg cond = modifyIORef (rAsserts st) ((msg, cs, cond):)---- | Create an internal variable, which acts as an input but isn't visible to the user.--- Such variables are existentially quantified in a SAT context, and universally quantified--- in a proof context.-internalVariable :: State -> Kind -> IO SW-internalVariable st k = do (sw, nm) <- newSW st k-                           let q = case runMode st of-                                     Proof (True,  _) -> EX-                                     _                -> ALL-                           modifyIORef (rinps st) ((q, (sw, "__internal_sbv_" ++ nm)):)-                           return sw-{-# INLINE internalVariable #-}---- | Create a new SW-newSW :: State -> Kind -> IO (SW, String)-newSW st k = do ctr <- incCtr st-                let sw = SW k (NodeId ctr)-                registerKind st k-                return (sw, 's' : show ctr)-{-# INLINE newSW #-}---- | Register a new kind with the system, used for uninterpreted sorts-registerKind :: State -> Kind -> IO ()-registerKind st k-  | KUserSort sortName _ <- k, map toLower sortName `elem` smtLibReservedNames-  = error $ "SBV: " ++ show sortName ++ " is a reserved sort; please use a different name."-  | True-  = modifyIORef (rUsedKinds st) (Set.insert k)---- | Create a new constant; hash-cons as necessary--- NB. For each constant, we also store weather it's negative-0 or not,--- as otherwise +0 == -0 and thus we'd confuse those entries. That's a--- bummer as we incur an extra boolean for this rare case, but it's simple--- and hopefully we don't generate a ton of constants in general.-newConst :: State -> CW -> IO SW-newConst st c = do-  constMap <- readIORef (rconstMap st)-  let key = (isNeg0 (cwVal c), c)-  case key `Map.lookup` constMap of-    Just sw -> return sw-    Nothing -> do let k = kindOf c-                  (sw, _) <- newSW st k-                  modifyIORef (rconstMap st) (Map.insert key sw)-                  return sw-  where isNeg0 (CWFloat  f) = isNegativeZero f-        isNeg0 (CWDouble d) = isNegativeZero d-        isNeg0 _            = False-{-# INLINE newConst #-}---- | Create a new table; hash-cons as necessary-getTableIndex :: State -> Kind -> Kind -> [SW] -> IO Int-getTableIndex st at rt elts = do-  let key = (at, rt, elts)-  tblMap <- readIORef (rtblMap st)-  case key `Map.lookup` tblMap of-    Just i -> return i-    _      -> do let i = Map.size tblMap-                 modifyIORef (rtblMap st) (Map.insert key i)-                 return i---- | Create a new expression; hash-cons as necessary-newExpr :: State -> Kind -> SBVExpr -> IO SW-newExpr st k app = do-   let e = reorder app-   exprMap <- readIORef (rexprMap st)-   case e `Map.lookup` exprMap of-     Just sw -> return sw-     Nothing -> do (sw, _) <- newSW st k-                   modifyIORef (spgm st)     (\(SBVPgm xs) -> SBVPgm (xs S.|> (sw, e)))-                   modifyIORef (rexprMap st) (Map.insert e sw)-                   return sw-{-# INLINE newExpr #-}---- | Convert a symbolic value to a symbolic-word-svToSW :: State -> SVal -> IO SW-svToSW st (SVal _ (Left c))  = newConst st c-svToSW st (SVal _ (Right f)) = uncache f st---- | Convert a symbolic value to an SW, inside the Symbolic monad-svToSymSW :: SVal -> Symbolic SW-svToSymSW sbv = do st <- ask-                   liftIO $ svToSW st sbv------------------------------------------------------------------------------ * Symbolic Computations----------------------------------------------------------------------------- | A Symbolic computation. Represented by a reader monad carrying the--- state of the computation, layered on top of IO for creating unique--- references to hold onto intermediate results.-newtype Symbolic a = Symbolic (ReaderT State IO a)-                   deriving (Applicative, Functor, Monad, MonadIO, MonadReader State)---- | 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 existential for SAT calls and universal for everything else.--- @randomCW@ is used for generating random values for this variable--- when used for 'quickCheck' purposes.-svMkSymVar :: Maybe Quantifier -> Kind -> Maybe String -> Symbolic SVal-svMkSymVar mbQ k mbNm = do-        st <- ask-        let q = case (mbQ, runMode st) of-                  (Just x,  _)                -> x   -- user given, just take it-                  (Nothing, Concrete{})       -> ALL -- concrete simulation, pick universal-                  (Nothing, Proof (True,  _)) -> EX  -- sat mode, pick existential-                  (Nothing, Proof (False, _)) -> ALL -- proof mode, pick universal-                  (Nothing, CodeGen)          -> ALL -- code generation, pick universal-        case runMode st of-          Concrete _ | q == EX -> case mbNm of-                                    Nothing -> error $ "Cannot quick-check in the presence of existential variables, type: " ++ show k-                                    Just nm -> error $ "Cannot quick-check in the presence of existential variable " ++ nm ++ " :: " ++ show k-          Concrete _           -> do cw <- liftIO (randomCW k)-                                     liftIO $ modifyIORef (rCInfo st) ((fromMaybe "_" mbNm, cw):)-                                     return (SVal k (Left cw))-          _          -> do (sw, internalName) <- liftIO $ newSW st k-                           let nm = fromMaybe internalName mbNm-                           liftIO $ modifyIORef (rinps st) ((q, (sw, nm)):)-                           return $ SVal k $ Right $ cache (const (return sw))---- | Create a properly quantified variable of a user defined sort. Only valid--- in proof contexts.-mkSValUserSort :: Kind -> Maybe Quantifier -> Maybe String -> Symbolic SVal-mkSValUserSort k mbQ mbNm = do-        st <- ask-        let (KUserSort sortName _) = k-        liftIO $ registerKind st k-        let q = case (mbQ, runMode st) of-                  (Just x,  _)                -> x-                  (Nothing, Proof (True,  _)) -> EX-                  (Nothing, Proof (False, _)) -> ALL-                  (Nothing, CodeGen)          -> error $ "SBV: Uninterpreted sort " ++ sortName ++ " can not be used in code-generation mode."-                  (Nothing, Concrete{})       -> error $ "SBV: Uninterpreted sort " ++ sortName ++ " can not be used in concrete simulation mode."-        ctr <- liftIO $ incCtr st-        let sw = SW k (NodeId ctr)-            nm = fromMaybe ('s':show ctr) mbNm-        liftIO $ modifyIORef (rinps st) ((q, (sw, nm)):)-        return $ SVal k $ Right $ cache (const (return sw))---- | 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.--- A separate formalization of SMT-Lib would be very useful here.-addAxiom :: String -> [String] -> Symbolic ()-addAxiom nm ax = do-        st <- ask-        liftIO $ modifyIORef (raxioms st) ((nm, ax) :)---- | Run a symbolic computation in Proof mode and return a 'Result'. The boolean--- argument indicates if this is a sat instance or not.-runSymbolic :: (Bool, SMTConfig) -> Symbolic a -> IO Result-runSymbolic m c = snd `fmap` runSymbolic' (Proof m) c---- | Run a symbolic computation, and return a extra value paired up with the 'Result'-runSymbolic' :: SBVRunMode -> Symbolic a -> IO (a, Result)-runSymbolic' currentRunMode (Symbolic c) = do-   ctr       <- newIORef (-2) -- start from -2; False and True will always occupy the first two elements-   cInfo     <- newIORef []-   pgm       <- newIORef (SBVPgm S.empty)-   emap      <- newIORef Map.empty-   cmap      <- newIORef Map.empty-   inps      <- newIORef []-   outs      <- newIORef []-   tables    <- newIORef Map.empty-   arrays    <- newIORef IMap.empty-   uis       <- newIORef Map.empty-   cgs       <- newIORef Map.empty-   axioms    <- newIORef []-   swCache   <- newIORef IMap.empty-   aiCache   <- newIORef IMap.empty-   usedKinds <- newIORef Set.empty-   cstrs     <- newIORef []-   asserts   <- newIORef []-   rGen      <- case currentRunMode of-                  Concrete g -> newIORef g-                  _          -> newStdGen >>= newIORef-   let st = State { runMode      = currentRunMode-                  , pathCond     = SVal KBool (Left trueCW)-                  , rStdGen      = rGen-                  , rCInfo       = cInfo-                  , rctr         = ctr-                  , rUsedKinds   = usedKinds-                  , rinps        = inps-                  , routs        = outs-                  , rtblMap      = tables-                  , spgm         = pgm-                  , rconstMap    = cmap-                  , rArrayMap    = arrays-                  , rexprMap     = emap-                  , rUIMap       = uis-                  , rCgMap       = cgs-                  , raxioms      = axioms-                  , rSWCache     = swCache-                  , rAICache     = aiCache-                  , rConstraints = cstrs-                  , rAsserts     = asserts-                  }-   _ <- newConst st falseCW -- s(-2) == falseSW-   _ <- newConst st trueCW  -- s(-1) == trueSW-   r <- runReaderT c st-   res <- extractSymbolicSimulationState st-   return (r, res)---- | Grab the program from a running symbolic simulation state. This is useful for internal purposes, for--- instance when implementing 'sBranch'.-extractSymbolicSimulationState :: State -> IO Result-extractSymbolicSimulationState st@State{ spgm=pgm, rinps=inps, routs=outs, rtblMap=tables, rArrayMap=arrays, rUIMap=uis, raxioms=axioms-                                       , rAsserts=asserts, rUsedKinds=usedKinds, rCgMap=cgs, rCInfo=cInfo, rConstraints=cstrs} = do-   SBVPgm rpgm  <- readIORef pgm-   inpsO <- reverse `fmap` readIORef inps-   outsO <- reverse `fmap` readIORef outs-   let swap  (a, b)              = (b, a)-       swapc ((_, a), b)         = (b, a)-       cmp   (a, _) (b, _)       = a `compare` b-       arrange (i, (at, rt, es)) = ((i, at, rt), es)-   cnsts <- (sortBy cmp . map swapc . Map.toList) `fmap` readIORef (rconstMap st)-   tbls  <- (map arrange . sortBy cmp . map swap . Map.toList) `fmap` readIORef tables-   arrs  <- IMap.toAscList `fmap` readIORef arrays-   unint <- Map.toList `fmap` readIORef uis-   axs   <- reverse `fmap` readIORef axioms-   knds  <- readIORef usedKinds-   cgMap <- Map.toList `fmap` readIORef cgs-   traceVals <- reverse `fmap` readIORef cInfo-   extraCstrs <- reverse `fmap` readIORef cstrs-   assertions <- reverse `fmap` readIORef asserts-   return $ Result knds traceVals cgMap inpsO cnsts tbls arrs unint axs (SBVPgm rpgm) extraCstrs assertions outsO---- | Handling constraints-imposeConstraint :: SVal -> Symbolic ()-imposeConstraint c = do st <- ask-                        case runMode st of-                          CodeGen -> error "SBV: constraints are not allowed in code-generation"-                          _       -> liftIO $ internalConstraint st c---- | Require a boolean condition to be true in the state. Only used for internal purposes.-internalConstraint :: State -> SVal -> IO ()-internalConstraint st b = do v <- svToSW st b-                             modifyIORef (rConstraints st) (v:)---- | Add a constraint with a given probability-addSValConstraint :: Maybe Double -> SVal -> SVal -> Symbolic ()-addSValConstraint Nothing  c _  = imposeConstraint c-addSValConstraint (Just t) c c'-  | t < 0 || t > 1-  = error $ "SBV: pConstrain: Invalid probability threshold: " ++ show t ++ ", must be in [0, 1]."-  | True-  = do st <- ask-       unless (isConcreteMode st) $ error "SBV: pConstrain only allowed in 'genTest' or 'quickCheck' contexts."-       case () of-         () | t > 0 && t < 1 -> liftIO (throwDice st) >>= \d -> imposeConstraint (if d <= t then c else c')-            | t > 0          -> imposeConstraint c-            | True           -> imposeConstraint c'---- | Mark an interim result as an output. Useful when constructing Symbolic programs--- that return multiple values, or when the result is programmatically computed.-outputSVal :: SVal -> Symbolic ()-outputSVal (SVal _ (Left c)) = do-  st <- ask-  sw <- liftIO $ newConst st c-  liftIO $ modifyIORef (routs st) (sw:)-outputSVal (SVal _ (Right f)) = do-  st <- ask-  sw <- liftIO $ uncache f st-  liftIO $ modifyIORef (routs st) (sw:)-------------------------------------------------------------------------------------- * Symbolic Arrays-------------------------------------------------------------------------------------- | Arrays implemented in terms of SMT-arrays: <http://smtlib.cs.uiowa.edu/theories-ArraysEx.shtml>------   * Maps directly to SMT-lib arrays------   * Reading from an unintialized value is OK and yields an unspecified result------   * Can check for equality of these arrays------   * Cannot quick-check theorems using @SArr@ values------   * Typically slower as it heavily relies on SMT-solving for the array theory-----data SArr = SArr (Kind, Kind) (Cached ArrayIndex)---- | Read the array element at @a@-readSArr :: SArr -> SVal -> SVal-readSArr (SArr (_, bk) f) a = SVal bk $ Right $ cache r-  where r st = do arr <- uncacheAI f st-                  i   <- svToSW st a-                  newExpr st bk (SBVApp (ArrRead arr) [i])---- | Reset all the elements of the array to the value @b@-resetSArr :: SArr -> SVal -> SArr-resetSArr (SArr ainfo f) b = SArr ainfo $ cache g-  where g st = do amap <- readIORef (rArrayMap st)-                  val <- svToSW st b-                  i <- uncacheAI f st-                  let j = IMap.size amap-                  j `seq` modifyIORef (rArrayMap st) (IMap.insert j ("array_" ++ show j, ainfo, ArrayReset i val))-                  return j---- | Update the element at @a@ to be @b@-writeSArr :: SArr -> SVal -> SVal -> SArr-writeSArr (SArr ainfo f) a b = SArr ainfo $ cache g-  where g st = do arr  <- uncacheAI f st-                  addr <- svToSW st a-                  val  <- svToSW st b-                  amap <- readIORef (rArrayMap st)-                  let j = IMap.size amap-                  j `seq` modifyIORef (rArrayMap st) (IMap.insert j ("array_" ++ show j, ainfo, ArrayMutate arr addr val))-                  return j---- | Merge two given arrays on the symbolic condition--- Intuitively: @mergeArrays cond a b = if cond then a else b@.--- Merging pushes the if-then-else choice down on to elements-mergeSArr :: SVal -> SArr -> SArr -> SArr-mergeSArr t (SArr ainfo a) (SArr _ b) = SArr ainfo $ cache h-  where h st = do ai <- uncacheAI a st-                  bi <- uncacheAI b st-                  ts <- svToSW st t-                  amap <- readIORef (rArrayMap st)-                  let k = IMap.size amap-                  k `seq` modifyIORef (rArrayMap st) (IMap.insert k ("array_" ++ show k, ainfo, ArrayMerge ts ai bi))-                  return k---- | Create a named new array, with an optional initial value-newSArr :: (Kind, Kind) -> (Int -> String) -> Maybe SVal -> Symbolic SArr-newSArr ainfo mkNm mbInit = do-    st <- ask-    amap <- liftIO $ readIORef $ rArrayMap st-    let i = IMap.size amap-        nm = mkNm i-    actx <- liftIO $ case mbInit of-                       Nothing   -> return $ ArrayFree Nothing-                       Just ival -> svToSW st ival >>= \sw -> return $ ArrayFree (Just sw)-    liftIO $ modifyIORef (rArrayMap st) (IMap.insert i (nm, ainfo, actx))-    return $ SArr ainfo $ cache $ const $ return i---- | Compare two arrays for equality-eqSArr :: SArr -> SArr -> SVal-eqSArr (SArr _ a) (SArr _ b) = SVal KBool $ Right $ cache c-  where c st = do ai <- uncacheAI a st-                  bi <- uncacheAI b st-                  newExpr st KBool (SBVApp (ArrEq ai bi) [])-------------------------------------------------------------------------------------- * Cached values-------------------------------------------------------------------------------------- | We implement a peculiar caching mechanism, applicable to the use case in--- implementation of SBV's.  Whenever we do a state based computation, we do--- not want to keep on evaluating it in the then-current state. That will--- produce essentially a semantically equivalent value. Thus, we want to run--- it only once, and reuse that result, capturing the sharing at the Haskell--- 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--- this technique: <http://ittc.ku.edu/~andygill/paper.php?label=DSLExtract09>------ Note that this is *not* a general memo utility!-newtype Cached a = Cached (State -> IO a)---- | Cache a state-based computation-cache :: (State -> IO a) -> Cached a-cache = Cached---- | Uncache a previously cached computation-uncache :: Cached SW -> State -> IO SW-uncache = uncacheGen rSWCache---- | An array index is simple an int value-type ArrayIndex = Int---- | Uncache, retrieving array indexes-uncacheAI :: Cached ArrayIndex -> State -> IO ArrayIndex-uncacheAI = uncacheGen rAICache---- | Generic uncaching. Note that this is entirely safe, since we do it in the IO monad.-uncacheGen :: (State -> IORef (Cache a)) -> Cached a -> State -> IO a-uncacheGen getCache (Cached f) st = do-        let rCache = getCache st-        stored <- readIORef rCache-        sn <- f `seq` makeStableName f-        let h = hashStableName sn-        case maybe Nothing (sn `lookup`) (h `IMap.lookup` stored) of-          Just r  -> return r-          Nothing -> do r <- f st-                        r `seq` modifyIORef rCache (IMap.insertWith (++) h [(sn, r)])-                        return r---- | Representation of SMTLib Program versions. As of June 2015, we're dropping support--- for SMTLib1, and supporting SMTLib2 only. We keep this data-type around in case--- SMTLib3 comes along and we want to support 2 and 3 simultaneously.-data SMTLibVersion = SMTLib2-                   deriving (Bounded, Enum, Eq, Show)---- | The extension associated with the version-smtLibVersionExtension :: SMTLibVersion -> String-smtLibVersionExtension SMTLib2 = "smt2"---- | Representation of an SMT-Lib program. In between pre and post goes the refuted models-data SMTLibPgm = SMTLibPgm SMTLibVersion  ( [(String, SW)]  -- alias table-                                          , [String]        -- pre: declarations.-                                          , [String])       -- post: formula-instance NFData SMTLibVersion where rnf a                       = a `seq` ()-instance NFData SMTLibPgm     where rnf (SMTLibPgm v (t, d, p)) = rnf v `seq` rnf t `seq` rnf d `seq` rnf p `seq` ()--instance Show SMTLibPgm where-  show (SMTLibPgm _ (_, pre, post)) = intercalate "\n" $ pre ++ post---- Other Technicalities..-instance NFData CW where-  rnf (CW x y) = x `seq` y `seq` ()--#if MIN_VERSION_base(4,9,0)-#else--- Can't really force this, but not a big deal-instance NFData CallStack where-  rnf _ = ()-#endif-  ---instance NFData Result where-  rnf (Result kindInfo qcInfo cgs inps consts tbls arrs uis axs pgm cstr asserts outs)-        = rnf kindInfo `seq` rnf qcInfo `seq` rnf cgs     `seq` rnf inps-                       `seq` rnf consts `seq` rnf tbls    `seq` rnf arrs-                       `seq` rnf uis    `seq` rnf axs     `seq` rnf pgm-                       `seq` rnf cstr   `seq` rnf asserts `seq` rnf outs-instance NFData Kind         where rnf a          = seq a ()-instance NFData ArrayContext where rnf a          = seq a ()-instance NFData SW           where rnf a          = seq a ()-instance NFData SBVExpr      where rnf a          = seq a ()-instance NFData Quantifier   where rnf a          = seq a ()-instance NFData SBVType      where rnf a          = seq a ()-instance NFData SBVPgm       where rnf a          = seq a ()-instance NFData (Cached a)   where rnf (Cached f) = f `seq` ()-instance NFData SVal         where rnf (SVal x y) = rnf x `seq` rnf y `seq` ()--instance NFData SMTResult where-  rnf (Unsatisfiable _)   = ()-  rnf (Satisfiable _ xs)  = rnf xs `seq` ()-  rnf (Unknown _ xs)      = rnf xs `seq` ()-  rnf (ProofError _ xs)   = rnf xs `seq` ()-  rnf (TimeOut _)         = ()--instance NFData SMTModel where-  rnf (SMTModel assocs) = rnf assocs `seq` ()--instance NFData SMTScript where-  rnf (SMTScript b m) = rnf b `seq` rnf m `seq` ()---- | SMT-Lib logics. If left unspecified SBV will pick the logic based on what it determines is needed. However, the--- user can override this choice using the 'useLogic' parameter to the configuration. This is especially handy if--- one is experimenting with custom logics that might be supported on new solvers. See <http://smtlib.cs.uiowa.edu/logics.shtml>--- for the official list.-data SMTLibLogic-  = AUFLIA    -- ^ Formulas over the theory of linear integer arithmetic and arrays extended with free sort and function symbols but restricted to arrays with integer indices and values-  | AUFLIRA   -- ^ Linear formulas with free sort and function symbols over one- and two-dimentional arrays of integer index and real value-  | AUFNIRA   -- ^ Formulas with free function and predicate symbols over a theory of arrays of arrays of integer index and real value-  | LRA       -- ^ Linear formulas in linear real arithmetic-  | QF_ABV    -- ^ Quantifier-free formulas over the theory of bitvectors and bitvector arrays-  | QF_AUFBV  -- ^ Quantifier-free formulas over the theory of bitvectors and bitvector arrays extended with free sort and function symbols-  | QF_AUFLIA -- ^ Quantifier-free linear formulas over the theory of integer arrays extended with free sort and function symbols-  | QF_AX     -- ^ Quantifier-free formulas over the theory of arrays with extensionality-  | QF_BV     -- ^ Quantifier-free formulas over the theory of fixed-size bitvectors-  | QF_IDL    -- ^ Difference Logic over the integers. Boolean combinations of inequations of the form x - y < b where x and y are integer variables and b is an integer constant-  | QF_LIA    -- ^ Unquantified linear integer arithmetic. In essence, Boolean combinations of inequations between linear polynomials over integer variables-  | QF_LRA    -- ^ Unquantified linear real arithmetic. In essence, Boolean combinations of inequations between linear polynomials over real variables.-  | QF_NIA    -- ^ Quantifier-free integer arithmetic.-  | QF_NRA    -- ^ Quantifier-free real arithmetic.-  | QF_RDL    -- ^ Difference Logic over the reals. In essence, Boolean combinations of inequations of the form x - y < b where x and y are real variables and b is a rational constant.-  | QF_UF     -- ^ Unquantified formulas built over a signature of uninterpreted (i.e., free) sort and function symbols.-  | QF_UFBV   -- ^ Unquantified formulas over bitvectors with uninterpreted sort function and symbols.-  | QF_UFIDL  -- ^ Difference Logic over the integers (in essence) but with uninterpreted sort and function symbols.-  | QF_UFLIA  -- ^ Unquantified linear integer arithmetic with uninterpreted sort and function symbols.-  | QF_UFLRA  -- ^ Unquantified linear real arithmetic with uninterpreted sort and function symbols.-  | QF_UFNRA  -- ^ Unquantified non-linear real arithmetic with uninterpreted sort and function symbols.-  | UFLRA     -- ^ Linear real arithmetic with uninterpreted sort and function symbols.-  | UFNIA     -- ^ Non-linear integer arithmetic with uninterpreted sort and function symbols.-  | QF_FPBV   -- ^ Quantifier-free formulas over the theory of floating point numbers, arrays, and bit-vectors-  | QF_FP     -- ^ Quantifier-free formulas over the theory of floating point numbers-  deriving Show---- | Chosen logic for the solver-data Logic = PredefinedLogic SMTLibLogic  -- ^ Use one of the logics as defined by the standard-           | CustomLogic     String       -- ^ Use this name for the logic--instance Show Logic where-  show (PredefinedLogic l) = show l-  show (CustomLogic     s) = s---- | Translation tricks needed for specific capabilities afforded by each solver-data SolverCapabilities = SolverCapabilities {-         capSolverName              :: String               -- ^ Name of the solver-       , mbDefaultLogic             :: Bool -> Maybe String -- ^ set-logic string to use in case not automatically determined (if any). If Bool is True, then reals are present.-       , supportsMacros             :: Bool                 -- ^ Does the solver understand SMT-Lib2 macros?-       , supportsProduceModels      :: Bool                 -- ^ Does the solver understand produce-models option setting-       , supportsQuantifiers        :: Bool                 -- ^ Does the solver understand SMT-Lib2 style quantifiers?-       , supportsUninterpretedSorts :: Bool                 -- ^ Does the solver understand SMT-Lib2 style uninterpreted-sorts-       , supportsUnboundedInts      :: Bool                 -- ^ Does the solver support unbounded integers?-       , supportsReals              :: Bool                 -- ^ Does the solver support reals?-       , supportsFloats             :: Bool                 -- ^ Does the solver support single-precision floating point numbers?-       , supportsDoubles            :: Bool                 -- ^ Does the solver support double-precision floating point numbers?-       }---- | Rounding mode to be used for the IEEE floating-point operations.--- Note that Haskell's default is 'RoundNearestTiesToEven'. If you use--- a different rounding mode, then the counter-examples you get may not--- match what you observe in Haskell.-data RoundingMode = RoundNearestTiesToEven  -- ^ Round to nearest representable floating point value.-                                            -- If precisely at half-way, pick the even number.-                                            -- (In this context, /even/ means the lowest-order bit is zero.)-                  | RoundNearestTiesToAway  -- ^ Round to nearest representable floating point value.-                                            -- If precisely at half-way, pick the number further away from 0.-                                            -- (That is, for positive values, pick the greater; for negative values, pick the smaller.)-                  | RoundTowardPositive     -- ^ Round towards positive infinity. (Also known as rounding-up or ceiling.)-                  | RoundTowardNegative     -- ^ Round towards negative infinity. (Also known as rounding-down or floor.)-                  | RoundTowardZero         -- ^ Round towards zero. (Also known as truncation.)-                  deriving (Eq, Ord, Show, Read, G.Data, Bounded, Enum)---- | 'RoundingMode' kind-instance HasKind RoundingMode---- | Solver configuration. See also 'z3', 'yices', 'cvc4', 'boolector', 'mathSAT', etc. which are instantiations of this type for those solvers, with--- reasonable defaults. In particular, custom configuration can be created by varying those values. (Such as @z3{verbose=True}@.)------ Most fields are self explanatory. The notion of precision for printing algebraic reals stems from the fact that such values does--- not necessarily have finite decimal representations, and hence we have to stop printing at some depth. It is important to--- emphasize that such values always have infinite precision internally. The issue is merely with how we print such an infinite--- precision value on the screen. The field 'printRealPrec' controls the printing precision, by specifying the number of digits after--- the decimal point. The default value is 16, but it can be set to any positive integer.------ When printing, SBV will add the suffix @...@ at the and of a real-value, if the given bound is not sufficient to represent the real-value--- exactly. Otherwise, the number will be written out in standard decimal notation. Note that SBV will always print the whole value if it--- is precise (i.e., if it fits in a finite number of digits), regardless of the precision limit. The limit only applies if the representation--- of the real value is not finite, i.e., if it is not rational.------ The 'printBase' field can be used to print numbers in base 2, 10, or 16. If base 2 or 16 is used, then floating-point values will--- be printed in their internal memory-layout format as well, which can come in handy for bit-precise analysis.-data SMTConfig = SMTConfig {-         verbose        :: Bool           -- ^ Debug mode-       , timing         :: Timing         -- ^ Print timing information on how long different phases took (construction, solving, etc.)-       , sBranchTimeOut :: Maybe Int      -- ^ How much time to give to the solver for each call of 'sBranch' check. (In seconds. Default: No limit.)-       , timeOut        :: Maybe Int      -- ^ How much time to give to the solver. (In seconds. Default: No limit.)-       , printBase      :: Int            -- ^ Print integral literals in this base (2, 10, and 16 are supported.)-       , printRealPrec  :: Int            -- ^ Print algebraic real values with this precision. (SReal, default: 16)-       , solverTweaks   :: [String]       -- ^ Additional lines of script to give to the solver (user specified)-       , satCmd         :: String         -- ^ Usually "(check-sat)". However, users might tweak it based on solver characteristics.-       , isNonModelVar  :: String -> Bool -- ^ When constructing a model, ignore variables whose name satisfy this predicate. (Default: (const False), i.e., don't ignore anything)-       , smtFile        :: Maybe FilePath -- ^ If Just, the generated SMT script will be put in this file (for debugging purposes mostly)-       , smtLibVersion  :: SMTLibVersion  -- ^ What version of SMT-lib we use for the tool-       , solver         :: SMTSolver      -- ^ The actual SMT solver.-       , roundingMode   :: RoundingMode   -- ^ Rounding mode to use for floating-point conversions-       , useLogic       :: Maybe Logic    -- ^ If Nothing, pick automatically. Otherwise, either use the given one, or use the custom string.-       }--instance Show SMTConfig where-  show = show . solver---- | A model, as returned by a solver-newtype SMTModel = SMTModel {-        modelAssocs    :: [(String, CW)]        -- ^ Mapping of symbolic values to constants.-     }-     deriving Show---- | The result of an SMT solver call. Each constructor is tagged with--- the 'SMTConfig' that created it so that further tools can inspect it--- and build layers of results, if needed. For ordinary uses of the library,--- this type should not be needed, instead use the accessor functions on--- it. (Custom Show instances and model extractors.)-data SMTResult = Unsatisfiable SMTConfig            -- ^ Unsatisfiable-               | Satisfiable   SMTConfig SMTModel   -- ^ Satisfiable with model-               | Unknown       SMTConfig SMTModel   -- ^ Prover returned unknown, with a potential (possibly bogus) model-               | ProofError    SMTConfig [String]   -- ^ Prover errored out-               | TimeOut       SMTConfig            -- ^ Computation timed out (see the 'timeout' combinator)---- | A script, to be passed to the solver.-data SMTScript = SMTScript {-          scriptBody  :: String        -- ^ Initial feed-        , scriptModel :: Maybe String  -- ^ Optional continuation script, if the result is sat-        }---- | An SMT engine-type SMTEngine = SMTConfig -> Bool -> [(Quantifier, NamedSymVar)] -> [Either SW (SW, [SW])] -> String -> IO SMTResult---- | Solvers that SBV is aware of-data Solver = Z3-            | Yices-            | Boolector-            | CVC4-            | MathSAT-            | ABC-            deriving (Show, Enum, Bounded)---- | An SMT solver-data SMTSolver = SMTSolver {-         name           :: Solver             -- ^ The solver in use-       , executable     :: String             -- ^ The path to its executable-       , options        :: [String]           -- ^ Options to provide to the solver-       , engine         :: SMTEngine          -- ^ The solver engine, responsible for interpreting solver output-       , capabilities   :: SolverCapabilities -- ^ Various capabilities of the solver-       }--instance Show SMTSolver where-   show = show . name--{-# ANN type FPOp   ("HLint: ignore Use camelCase" :: String) #-}
Data/SBV/Bridge/ABC.hs view
@@ -24,14 +24,14 @@ module Data.SBV.Bridge.ABC (   -- * ABC specific interface   sbvCurrentSolver-  -- ** Proving, checking satisfiability-  , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable-  -- ** Optimization routines-  , optimize, minimize, maximize+  -- ** Proving, checking satisfiability, optimization+  , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable+  -- * Non-Boolector specific SBV interface+  -- $moduleExportIntro   , module Data.SBV   ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)+import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver)  -- | Current solver instance, pointing to abc. sbvCurrentSolver :: SMTConfig@@ -61,6 +61,12 @@        -> IO AllSatResult  -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using ABC+optimize :: Provable a+         => a                -- ^ Program with objectives+         -> IO OptimizeResult+optimize = optimizeWith sbvCurrentSolver+ -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using ABC isVacuous :: Provable a           => a             -- ^ Property to check@@ -80,34 +86,6 @@               -> a               -- ^ Property to check               -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver---- | Optimize cost functions, using ABC-optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> (SBV c -> SBV c -> SBool)   -- ^ Betterness check: This is the comparison predicate for optimization-         -> ([SBV a] -> SBV c)          -- ^ Cost function-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-optimize = optimizeWith sbvCurrentSolver---- | Minimize cost functions, using ABC-minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to minimize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-minimize = minimizeWith sbvCurrentSolver---- | Maximize cost functions, using ABC-maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to maximize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-maximize = maximizeWith sbvCurrentSolver  {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module.
Data/SBV/Bridge/Boolector.hs view
@@ -24,16 +24,14 @@ module Data.SBV.Bridge.Boolector (   -- * Boolector specific interface   sbvCurrentSolver-  -- ** Proving, checking satisfiability-  , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable-  -- ** Optimization routines-  , optimize, minimize, maximize+  -- ** Proving, checking satisfiability, optimization+  , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable   -- * Non-Boolector specific SBV interface   -- $moduleExportIntro   , module Data.SBV   ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)+import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver)  -- | Current solver instance, pointing to Boolector. sbvCurrentSolver :: SMTConfig@@ -63,6 +61,12 @@        -> IO AllSatResult  -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using Boolector+optimize :: Provable a+         => a                -- ^ Program with objectives+         -> IO OptimizeResult+optimize = optimizeWith sbvCurrentSolver+ -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the Boolector SMT solver isVacuous :: Provable a           => a             -- ^ Property to check@@ -82,34 +86,6 @@               -> a               -- ^ Property to check               -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver---- | Optimize cost functions, using the Boolector SMT solver-optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> (SBV c -> SBV c -> SBool)   -- ^ Betterness check: This is the comparison predicate for optimization-         -> ([SBV a] -> SBV c)          -- ^ Cost function-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-optimize = optimizeWith sbvCurrentSolver---- | Minimize cost functions, using the Boolector SMT solver-minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to minimize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-minimize = minimizeWith sbvCurrentSolver---- | Maximize cost functions, using the Boolector SMT solver-maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to maximize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-maximize = maximizeWith sbvCurrentSolver  {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module.
Data/SBV/Bridge/CVC4.hs view
@@ -24,16 +24,14 @@ module Data.SBV.Bridge.CVC4 (   -- * CVC4 specific interface   sbvCurrentSolver-  -- ** Proving, checking satisfiability-  , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable-  -- ** Optimization routines-  , optimize, minimize, maximize+  -- ** Proving, checking satisfiability, optimization+  , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable   -- * Non-CVC4 specific SBV interface   -- $moduleExportIntro   , module Data.SBV   ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)+import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver)  -- | Current solver instance, pointing to cvc4. sbvCurrentSolver :: SMTConfig@@ -63,6 +61,12 @@        -> IO AllSatResult  -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using CVC4+optimize :: Provable a+         => a                -- ^ Program with objectives+         -> IO OptimizeResult+optimize = optimizeWith sbvCurrentSolver+ -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the CVC4 SMT solver isVacuous :: Provable a           => a             -- ^ Property to check@@ -82,34 +86,6 @@               -> a               -- ^ Property to check               -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver---- | Optimize cost functions, using the CVC4 SMT solver-optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> (SBV c -> SBV c -> SBool)   -- ^ Betterness check: This is the comparison predicate for optimization-         -> ([SBV a] -> SBV c)          -- ^ Cost function-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-optimize = optimizeWith sbvCurrentSolver---- | Minimize cost functions, using the CVC4 SMT solver-minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to minimize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-minimize = minimizeWith sbvCurrentSolver---- | Maximize cost functions, using the CVC4 SMT solver-maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to maximize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-maximize = maximizeWith sbvCurrentSolver  {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module.
Data/SBV/Bridge/MathSAT.hs view
@@ -24,16 +24,14 @@ module Data.SBV.Bridge.MathSAT (   -- * MathSAT specific interface   sbvCurrentSolver-  -- ** Proving, checking satisfiability-  , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable-  -- ** Optimization routines-  , optimize, minimize, maximize+  -- ** Proving, checking satisfiability, optimization+  , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable   -- * Non-MathSAT specific SBV interface   -- $moduleExportIntro   , module Data.SBV   ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)+import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver)  -- | Current solver instance, pointing to MathSAT. sbvCurrentSolver :: SMTConfig@@ -63,6 +61,12 @@        -> IO AllSatResult  -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using MathSAT+optimize :: Provable a+         => a                -- ^ Program with objectives+         -> IO OptimizeResult+optimize = optimizeWith sbvCurrentSolver+ -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the MathSAT SMT solver isVacuous :: Provable a           => a             -- ^ Property to check@@ -82,34 +86,6 @@               -> a               -- ^ Property to check               -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver---- | Optimize cost functions, using the MathSAT SMT solver-optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> (SBV c -> SBV c -> SBool)   -- ^ Betterness check: This is the comparison predicate for optimization-         -> ([SBV a] -> SBV c)          -- ^ Cost function-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-optimize = optimizeWith sbvCurrentSolver---- | Minimize cost functions, using the MathSAT SMT solver-minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to minimize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-minimize = minimizeWith sbvCurrentSolver---- | Maximize cost functions, using the MathSAT SMT solver-maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to maximize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-maximize = maximizeWith sbvCurrentSolver  {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module.
Data/SBV/Bridge/Yices.hs view
@@ -24,16 +24,14 @@ module Data.SBV.Bridge.Yices (   -- * Yices specific interface   sbvCurrentSolver-  -- ** Proving, checking satisfiability-  , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable-  -- ** Optimization routines-  , optimize, minimize, maximize+  -- ** Proving, checking satisfiability, optimization+  , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable   -- * Non-Yices specific SBV interface   -- $moduleExportIntro   , module Data.SBV   ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)+import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver)  -- | Current solver instance, pointing to yices. sbvCurrentSolver :: SMTConfig@@ -63,6 +61,12 @@        -> IO AllSatResult  -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using Yices+optimize :: Provable a+         => a                -- ^ Program with objectives+         -> IO OptimizeResult+optimize = optimizeWith sbvCurrentSolver+ -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the Yices SMT solver isVacuous :: Provable a           => a             -- ^ Property to check@@ -82,34 +86,6 @@               -> a               -- ^ Property to check               -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver---- | Optimize cost functions, using the Yices SMT solver-optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> (SBV c -> SBV c -> SBool)   -- ^ Betterness check: This is the comparison predicate for optimization-         -> ([SBV a] -> SBV c)          -- ^ Cost function-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-optimize = optimizeWith sbvCurrentSolver---- | Minimize cost functions, using the Yices SMT solver-minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to minimize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-minimize = minimizeWith sbvCurrentSolver---- | Maximize cost functions, using the Yices SMT solver-maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to maximize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-maximize = maximizeWith sbvCurrentSolver  {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module.
Data/SBV/Bridge/Z3.hs view
@@ -24,16 +24,14 @@ module Data.SBV.Bridge.Z3 (   -- * Z3 specific interface   sbvCurrentSolver-  -- ** Proving, checking satisfiability-  , prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable-  -- ** Optimization routines-  , optimize, minimize, maximize+  -- ** Proving, checking satisfiability, optimization+  , prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable   -- * Non-Z3 specific SBV interface   -- $moduleExportIntro   , module Data.SBV   ) where -import Data.SBV hiding (prove, sat, safe, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)+import Data.SBV hiding (prove, sat, allSat, safe, optimize, isVacuous, isTheorem, isSatisfiable, sbvCurrentSolver)  -- | Current solver instance, pointing to z3. sbvCurrentSolver :: SMTConfig@@ -63,6 +61,12 @@        -> IO AllSatResult  -- ^ List of all satisfying models allSat = allSatWith sbvCurrentSolver +-- | Optimize objectives, using Yices+optimize :: Provable a+         => a                -- ^ Program with objectives+         -> IO OptimizeResult+optimize = optimizeWith sbvCurrentSolver+ -- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the Z3 SMT solver isVacuous :: Provable a           => a             -- ^ Property to check@@ -82,34 +86,6 @@               -> a               -- ^ Property to check               -> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers isSatisfiable = isSatisfiableWith sbvCurrentSolver---- | Optimize cost functions, using the Z3 SMT solver-optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> (SBV c -> SBV c -> SBool)   -- ^ Betterness check: This is the comparison predicate for optimization-         -> ([SBV a] -> SBV c)          -- ^ Cost function-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-optimize = optimizeWith sbvCurrentSolver---- | Minimize cost functions, using the Z3 SMT solver-minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to minimize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-minimize = minimizeWith sbvCurrentSolver---- | Maximize cost functions, using the Z3 SMT solver-maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-         => OptimizeOpts                -- ^ Parameters to optimization (Iterative, Quantified, etc.)-         -> ([SBV a] -> SBV c)          -- ^ Cost function to maximize-         -> Int                         -- ^ Number of inputs-         -> ([SBV a] -> SBool)          -- ^ Validity function-         -> IO (Maybe [a])              -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution-maximize = maximizeWith sbvCurrentSolver  {- $moduleExportIntro The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module.
Data/SBV/Compilers/C.hs view
@@ -24,8 +24,9 @@ import System.Random import Text.PrettyPrint.HughesPJ -import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.PrettyNum (shex, showCFloat, showCDouble)+import Data.SBV.Core.Data++import Data.SBV.Utils.PrettyNum (shex, showCFloat, showCDouble) import Data.SBV.Compilers.CodeGen  import GHC.Stack.Compat@@ -407,7 +408,7 @@  -- | Generate the C program genCProg :: CgConfig -> String -> Doc -> Result -> [(String, CgVal)] -> [(String, CgVal)] -> Maybe SW -> Doc -> [Doc]-genCProg cfg fn proto (Result kindInfo _tvals cgs ins preConsts tbls arrs _ _ (SBVPgm asgns) cstrs origAsserts _) inVars outVars mbRet extDecls+genCProg cfg fn proto (Result kindInfo _tvals cgs ins preConsts tbls arrs _uis _axioms (SBVPgm asgns) cstrs _tacs _goals origAsserts _) inVars outVars mbRet extDecls   | isNothing (cgInteger cfg) && KUnbounded `Set.member` kindInfo   = error $ "SBV->C: Unbounded integers are not supported by the C compiler."           ++ "\nUse 'cgIntegerSize' to specify a fixed size for SInteger representation."
Data/SBV/Compilers/CodeGen.hs view
@@ -26,8 +26,8 @@ import           Text.PrettyPrint.HughesPJ      (Doc, vcat) import qualified Text.PrettyPrint.HughesPJ as P (render) -import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.Symbolic (svToSymSW, svMkSymVar, outputSVal)+import Data.SBV.Core.Data+import Data.SBV.Core.Symbolic (svToSymSW, svMkSymVar, outputSVal)  import Prelude () import Prelude.Compat
+ Data/SBV/Core/AlgReals.hs view
@@ -0,0 +1,243 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Core.AlgReals+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Algrebraic reals in Haskell.+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.SBV.Core.AlgReals (+             AlgReal(..)+           , mkPolyReal+           , algRealToSMTLib2+           , algRealToHaskell+           , mergeAlgReals+           , isExactRational+           , algRealStructuralEqual+           , algRealStructuralCompare)+   where++import Data.List       (sortBy, isPrefixOf, partition)+import Data.Ratio      ((%), numerator, denominator)+import Data.Function   (on)+import System.Random+import Test.QuickCheck (Arbitrary(..))++-- | 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,  Polynomial) -- which root+                           (Maybe String)         -- approximate decimal representation with given precision, if available++-- | Check wheter a given argument is an exact rational+isExactRational :: AlgReal -> Bool+isExactRational (AlgRational True _) = True+isExactRational _                    = False++-- | A univariate polynomial, represented simply as a+-- coefficient list. For instance, "5x^3 + 2x - 5" is+-- represented as [(5, 3), (2, 1), (-5, 0)]+newtype Polynomial = Polynomial [(Integer, Integer)]+                   deriving (Eq, Ord)++-- | Construct a poly-root real with a given approximate value (either as a decimal, or polynomial-root)+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)+mkPolyReal (Right (k, coeffs))+ = AlgPolyRoot (k, Polynomial (normalize coeffs)) Nothing+ where normalize :: [(Integer, Integer)] -> [(Integer, Integer)]+       normalize = merge . sortBy (flip compare `on` snd)+       merge []                     = []+       merge [x]                    = [x]+       merge ((a, b):r@((c, d):xs))+         | b == d                   = merge ((a+c, b):xs)+         | True                     = (a, b) : merge r++instance Show Polynomial where+  show (Polynomial xs) = chkEmpty (join (concat [term p | p@(_, x) <- xs, x /= 0])) ++ " = " ++ show c+     where c  = -1 * head ([k | (k, 0) <- xs] ++ [0])+           term ( 0, _) = []+           term ( 1, 1) = [ "x"]+           term ( 1, p) = [ "x^" ++ show p]+           term (-1, 1) = ["-x"]+           term (-1, p) = ["-x^" ++ show p]+           term (k,  1) = [show k ++ "x"]+           term (k,  p) = [show k ++ "x^" ++ show p]+           join []      = ""+           join (k:ks) = k ++ s ++ join ks+             where s = case ks of+                        []    -> ""+                        (y:_) | "-" `isPrefixOf` y -> ""+                              | "+" `isPrefixOf` y -> ""+                              | True               -> "+"+           chkEmpty s = if null s then "0" else s++instance Show AlgReal where+  show (AlgRational exact a)         = showRat exact a+  show (AlgPolyRoot (i, p) mbApprox) = "root(" ++ show i ++ ", " ++ show p ++ ")" ++ maybe "" app mbApprox+     where app v | last v == '?' = " = " ++ init v ++ "..."+                 | True          = " = " ++ v++-- lift unary op through an exact rational, otherwise bail+lift1 :: String -> (Rational -> Rational) -> AlgReal -> AlgReal+lift1 _  o (AlgRational e a) = AlgRational e (o a)+lift1 nm _ a                 = error $ "AlgReal." ++ nm ++ ": unsupported argument: " ++ show a++-- lift binary op through exact rationals, otherwise bail+lift2 :: String -> (Rational -> Rational -> Rational) -> AlgReal -> AlgReal -> AlgReal+lift2 _  o (AlgRational True a) (AlgRational True b) = AlgRational True (a `o` b)+lift2 nm _ a                    b                    = error $ "AlgReal." ++ nm ++ ": unsupported arguments: " ++ show (a, b)++-- The idea in the instances below is that we will fully support operations+-- on "AlgRational" AlgReals, but leave everything else undefined. When we are+-- on the Haskell side, the AlgReal's are *not* reachable. They only represent+-- return values from SMT solvers, which we should *not* need to manipulate.+instance Eq AlgReal where+  AlgRational True a == AlgRational True b = a == b+  a                  == b                  = error $ "AlgReal.==: unsupported arguments: " ++ show (a, b)++instance Ord AlgReal where+  AlgRational True a `compare` AlgRational True b = a `compare` b+  a                  `compare` b                  = error $ "AlgReal.compare: unsupported arguments: " ++ show (a, b)++-- | Structural equality for AlgReal; used when constants are Map keys+algRealStructuralEqual   :: AlgReal -> AlgReal -> Bool+AlgRational a b `algRealStructuralEqual` AlgRational c d = (a, b) == (c, d)+AlgPolyRoot a b `algRealStructuralEqual` AlgPolyRoot c d = (a, b) == (c, d)+_               `algRealStructuralEqual` _               = False++-- | Structural comparisons for AlgReal; used when constants are Map keys+algRealStructuralCompare :: AlgReal -> AlgReal -> Ordering+AlgRational a b `algRealStructuralCompare` AlgRational c d = (a, b) `compare` (c, d)+AlgRational _ _ `algRealStructuralCompare` AlgPolyRoot _ _ = LT+AlgPolyRoot _ _ `algRealStructuralCompare` AlgRational _ _ = GT+AlgPolyRoot a b `algRealStructuralCompare` AlgPolyRoot c d = (a, b) `compare` (c, d)++instance Num AlgReal where+  (+)         = lift2 "+"      (+)+  (*)         = lift2 "*"      (*)+  (-)         = lift2 "-"      (-)+  negate      = lift1 "negate" negate+  abs         = lift1 "abs"    abs+  signum      = lift1 "signum" signum+  fromInteger = AlgRational True . fromInteger++-- |  NB: Following the other types we have, we require `a/0` to be `0` for all a.+instance Fractional AlgReal where+  (AlgRational True _) / (AlgRational True b) | b == 0 = 0+  a                    / b                             = lift2 "/" (/) a b+  fromRational = AlgRational True++instance Real AlgReal where+  toRational (AlgRational True v) = v+  toRational x                    = error $ "AlgReal.toRational: Argument cannot be represented as a rational value: " ++ algRealToHaskell x++instance Random Rational where+  random g = (a % b', g'')+     where (a, g')  = random g+           (b, g'') = random g'+           b'       = if 0 < b then b else 1 - b -- ensures 0 < b++  randomR (l, h) g = (r * d + l, g'')+     where (b, g')  = random g+           b'       = if 0 < b then b else 1 - b -- ensures 0 < b+           (a, g'') = randomR (0, b') g'++           r = a % b'+           d = h - l++instance Random AlgReal where+  random g = let (a, g') = random g in (AlgRational True a, g')+  randomR (AlgRational True l, AlgRational True h) g = let (a, g') = randomR (l, h) g in (AlgRational True a, g')+  randomR lh                                       _ = error $ "AlgReal.randomR: unsupported bounds: " ++ show lh++-- | Render an 'AlgReal' as an SMTLib2 value. Only supports rationals for the time being.+algRealToSMTLib2 :: AlgReal -> String+algRealToSMTLib2 (AlgRational True r)+   | m == 0 = "0.0"+   | m < 0  = "(- (/ "  ++ show (abs m) ++ ".0 " ++ show n ++ ".0))"+   | True   =    "(/ "  ++ show m       ++ ".0 " ++ show n ++ ".0)"+  where (m, n) = (numerator r, denominator r)+algRealToSMTLib2 r@(AlgRational False _)+   = error $ "SBV: Unexpected inexact rational to be converted to SMTLib2: " ++ show r+algRealToSMTLib2 (AlgPolyRoot (i, Polynomial xs) _) = "(root-obj (+ " ++ unwords (concatMap term xs) ++ ") " ++ show i ++ ")"+  where term (0, _) = []+        term (k, 0) = [coeff k]+        term (1, 1) = ["x"]+        term (1, p) = ["(^ x " ++ show p ++ ")"]+        term (k, 1) = ["(* " ++ coeff k ++ " x)"]+        term (k, p) = ["(* " ++ coeff k ++ " (^ x " ++ show p ++ "))"]+        coeff n | n < 0 = "(- " ++ show (abs n) ++ ")"+                | True  = show n++-- | 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.+algRealToHaskell :: AlgReal -> String+algRealToHaskell (AlgRational True r) = "((" ++ show r ++ ") :: Rational)"+algRealToHaskell r                    = error $ "SBV.algRealToHaskell: Unsupported argument: " ++ show r++-- Try to show a rational precisely if we can, with finite number of+-- digits. Otherwise, show it as a rational value.+showRat :: Bool -> Rational -> String+showRat exact r = p $ case f25 (denominator r) [] of+                       Nothing               -> show r   -- bail out, not precisely representable with finite digits+                       Just (noOfZeros, num) -> let present = length num+                                                in neg $ case noOfZeros `compare` present of+                                                           LT -> let (b, a) = splitAt (present - noOfZeros) num in b ++ "." ++ if null a then "0" else a+                                                           EQ -> "0." ++ num+                                                           GT -> "0." ++ replicate (noOfZeros - present) '0' ++ num+  where p   = if exact then id else (++ "...")+        neg = if r < 0 then ('-':) else id+        -- factor a number in 2's and 5's if possible+        -- If so, it'll return the number of digits after the zero+        -- to reach the next power of 10, and the numerator value scaled+        -- appropriately and shown as a string+        f25 :: Integer -> [Integer] -> Maybe (Int, String)+        f25 1 sofar = let (ts, fs)   = partition (== 2) sofar+                          [lts, lfs] = map length [ts, fs]+                          noOfZeros  = lts `max` lfs+                      in Just (noOfZeros, show (abs (numerator r)  * factor ts fs))+        f25 v sofar = let (q2, r2) = v `quotRem` 2+                          (q5, r5) = v `quotRem` 5+                      in case (r2, r5) of+                           (0, _) -> f25 q2 (2 : sofar)+                           (_, 0) -> f25 q5 (5 : sofar)+                           _      -> Nothing+        -- compute the next power of 10 we need to get to+        factor []     fs     = product [2 | _ <- fs]+        factor ts     []     = product [5 | _ <- ts]+        factor (_:ts) (_:fs) = factor ts fs++-- | Merge the representation of two algebraic reals, one assumed to be+-- in polynomial form, the other in decimal. Arguments can be the same+-- kind, so long as they are both rationals and equivalent; if not there+-- must be one that is precise. It's an error to pass anything+-- else to this function! (Used in reconstructing SMT counter-example values with reals).+mergeAlgReals :: String -> AlgReal -> AlgReal -> AlgReal+mergeAlgReals _ f@(AlgRational exact r) (AlgPolyRoot kp Nothing)+  | exact = f+  | True  = AlgPolyRoot kp (Just (showRat False r))+mergeAlgReals _ (AlgPolyRoot kp Nothing) f@(AlgRational exact r)+  | exact = f+  | True  = AlgPolyRoot kp (Just (showRat False r))+mergeAlgReals _ f@(AlgRational e1 r1) s@(AlgRational e2 r2)+  | (e1, r1) == (e2, r2) = f+  | e1                   = f+  | e2                   = s+mergeAlgReals m _ _ = error m++-- Quickcheck instance+instance Arbitrary AlgReal where+  arbitrary = AlgRational True `fmap` arbitrary
+ Data/SBV/Core/Concrete.hs view
@@ -0,0 +1,271 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Core.Concrete+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Operations on concrete values+-----------------------------------------------------------------------------++module Data.SBV.Core.Concrete+  ( module Data.SBV.Core.Concrete+  ) where++import Data.Bits+import System.Random (randomIO, randomRIO)++import Data.List (isPrefixOf)++import Data.SBV.Core.Kind+import Data.SBV.Core.AlgReals++-- | A constant value+data CWVal = CWAlgReal  !AlgReal              -- ^ algebraic real+           | CWInteger  !Integer              -- ^ bit-vector/unbounded integer+           | CWFloat    !Float                -- ^ float+           | CWDouble   !Double               -- ^ double+           | CWUserSort !(Maybe Int, String)  -- ^ value of an uninterpreted/user kind. The Maybe Int shows index position for enumerations++-- | Eq instance for CWVal. Note that we cannot simply derive Eq/Ord, since CWAlgReal doesn't have proper+-- instances for these when values are infinitely precise reals. However, we do+-- need a structural eq/ord for Map indexes; so define custom ones here:+instance Eq CWVal where+  CWAlgReal a  == CWAlgReal b       = a `algRealStructuralEqual` b+  CWInteger a  == CWInteger b       = a == b+  CWUserSort a == CWUserSort b = a == b+  CWFloat a    == CWFloat b         = a == b+  CWDouble a   == CWDouble b        = a == b+  _            == _                 = False++-- | Ord instance for CWVal. Same comments as the 'Eq' instance why this cannot be derived.+instance Ord CWVal where+  CWAlgReal a `compare` CWAlgReal b   = a `algRealStructuralCompare` b+  CWAlgReal _ `compare` CWInteger _   = LT+  CWAlgReal _ `compare` CWFloat _     = LT+  CWAlgReal _ `compare` CWDouble _    = LT+  CWAlgReal _ `compare` CWUserSort _  = LT++  CWInteger _ `compare` CWAlgReal _   = GT+  CWInteger a `compare` CWInteger b   = a `compare` b+  CWInteger _ `compare` CWFloat _     = LT+  CWInteger _ `compare` CWDouble _    = LT+  CWInteger _ `compare` CWUserSort _  = LT++  CWFloat _   `compare` CWAlgReal _   = GT+  CWFloat _   `compare` CWInteger _   = GT+  CWFloat a   `compare` CWFloat b     = a `compare` b+  CWFloat _   `compare` CWDouble _    = LT+  CWFloat _   `compare` CWUserSort _  = LT++  CWDouble _  `compare` CWAlgReal _   = GT+  CWDouble _  `compare` CWInteger _   = GT+  CWDouble _  `compare` CWFloat _     = GT+  CWDouble a  `compare` CWDouble b    = a `compare` b+  CWDouble _  `compare` CWUserSort _  = LT++  CWUserSort _ `compare` CWAlgReal _  = GT+  CWUserSort _ `compare` CWInteger _  = GT+  CWUserSort _ `compare` CWFloat _    = GT+  CWUserSort _ `compare` CWDouble _   = GT+  CWUserSort a `compare` CWUserSort b = a `compare` b++-- | 'CW' represents a concrete word of a fixed size:+-- Endianness is mostly irrelevant (see the 'FromBits' class).+-- For signed words, the most significant digit is considered to be the sign.+data CW = CW { _cwKind  :: !Kind+             , cwVal    :: !CWVal+             }+        deriving (Eq, Ord)++-- | A generalized CW allows for expressions involving infinite and epsilon values/intervals Used in optimization problems.+data GeneralizedCW = ExtendedCW ExtCW+                   | RegularCW  CW++-- | A simple expression type over extendent values, covering infinity, epsilon and intervals.+data ExtCW = Infinite  Kind         -- infinity+           | Epsilon   Kind         -- epsilon+           | Interval  ExtCW ExtCW  -- closed interval+           | BoundedCW CW           -- a bounded value (i.e., neither infinity, nor epsilon)+           | AddExtCW  ExtCW ExtCW  -- addition+           | MulExtCW  ExtCW ExtCW  -- multiplication++-- | Kind instance for Extended CW+instance HasKind ExtCW where+  kindOf (Infinite  k)   = k+  kindOf (Epsilon   k)   = k+  kindOf (Interval  l _) = kindOf l+  kindOf (BoundedCW  c)  = kindOf c+  kindOf (AddExtCW  l _) = kindOf l+  kindOf (MulExtCW  l _) = kindOf l++-- | Show instance, shows with the kind+instance Show ExtCW where+  show = showExtCW True++-- | Show an extended CW, with kind if required+showExtCW :: Bool -> ExtCW -> String+showExtCW = go False+  where go parens shk extCW = case extCW of+                                Infinite{}    -> withKind False "oo"+                                Epsilon{}     -> withKind False "epsilon"+                                Interval  l u -> withKind True  $ '['  : showExtCW False l ++ " .. " ++ showExtCW False u ++ "]"+                                BoundedCW c   -> showCW shk c+                                AddExtCW l r  -> par $ withKind False $ add (go True False l) (go True False r)++                                -- a few niceties here to grok -oo and -epsilon+                                MulExtCW (BoundedCW (CW KUnbounded (CWInteger (-1)))) Infinite{} -> withKind False "-oo"+                                MulExtCW (BoundedCW (CW KReal      (CWAlgReal (-1)))) Infinite{} -> withKind False "-oo"+                                MulExtCW (BoundedCW (CW KUnbounded (CWInteger (-1)))) Epsilon{}  -> withKind False "-epsilon"+                                MulExtCW (BoundedCW (CW KReal      (CWAlgReal (-1)))) Epsilon{}  -> withKind False "-epsilon"++                                MulExtCW l r  -> par $ withKind False $ mul (go True False l) (go True False r)+           where par v | parens = '(' : v ++ ")"+                       | True   = v+                 withKind isInterval v | not shk    = v+                                       | isInterval = v ++ " :: [" ++ showBaseKind (kindOf extCW) ++ "]"+                                       | True       = v ++ " :: "  ++ showBaseKind (kindOf extCW)++                 add :: String -> String -> String+                 add n v+                  | "-" `isPrefixOf` v = n ++ " - " ++ tail v+                  | True               = n ++ " + " ++ v++                 mul :: String -> String -> String+                 mul n v = n ++ " * " ++ v++-- | Is this a regular CW?+isRegularCW :: GeneralizedCW -> Bool+isRegularCW RegularCW{}  = True+isRegularCW ExtendedCW{} = False++-- | 'Kind' instance for CW+instance HasKind CW where+  kindOf (CW k _) = k++-- | 'Kind' instance for generalized CW+instance HasKind GeneralizedCW where+  kindOf (ExtendedCW e) = kindOf e+  kindOf (RegularCW  c) = kindOf c++-- | Are two CW's of the same type?+cwSameType :: CW -> CW -> Bool+cwSameType x y = kindOf x == kindOf y++-- | Convert a CW to a Haskell boolean (NB. Assumes input is well-kinded)+cwToBool :: CW -> Bool+cwToBool x = cwVal x /= CWInteger 0++-- | Normalize a CW. Essentially performs modular arithmetic to make sure the+-- value can fit in the given bit-size. Note that this is rather tricky for+-- negative values, due to asymmetry. (i.e., an 8-bit negative number represents+-- values in the range -128 to 127; thus we have to be careful on the negative side.)+normCW :: CW -> CW+normCW c@(CW (KBounded signed sz) (CWInteger v)) = c { cwVal = CWInteger 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)+normCW c@(CW KBool (CWInteger v)) = c { cwVal = CWInteger (v .&. 1) }+normCW c = c++-- | Constant False as a CW. We represent it using the integer value 0.+falseCW :: CW+falseCW = CW KBool (CWInteger 0)++-- | Constant True as a CW. We represent it using the integer value 1.+trueCW :: CW+trueCW  = CW KBool (CWInteger 1)++-- | Lift a unary function through a CW+liftCW :: (AlgReal -> b) -> (Integer -> b) -> (Float -> b) -> (Double -> b) -> ((Maybe Int, String) -> b) -> CW -> b+liftCW f _ _ _ _ (CW _ (CWAlgReal v))  = f v+liftCW _ f _ _ _ (CW _ (CWInteger v))  = f v+liftCW _ _ f _ _ (CW _ (CWFloat v))    = f v+liftCW _ _ _ f _ (CW _ (CWDouble v))   = f v+liftCW _ _ _ _ f (CW _ (CWUserSort v)) = f v++-- | Lift a binary function through a CW+liftCW2 :: (AlgReal -> AlgReal -> b) -> (Integer -> Integer -> b) -> (Float -> Float -> b) -> (Double -> Double -> b) -> ((Maybe Int, String) -> (Maybe Int, String) -> b) -> CW -> CW -> b+liftCW2 r i f d u x y = case (cwVal x, cwVal y) of+                         (CWAlgReal a,  CWAlgReal b)  -> r a b+                         (CWInteger a,  CWInteger b)  -> i a b+                         (CWFloat a,    CWFloat b)    -> f a b+                         (CWDouble a,   CWDouble b)   -> d a b+                         (CWUserSort a, CWUserSort b) -> u a b+                         _                            -> error $ "SBV.liftCW2: impossible, incompatible args received: " ++ show (x, y)++-- | Map a unary function through a CW.+mapCW :: (AlgReal -> AlgReal) -> (Integer -> Integer) -> (Float -> Float) -> (Double -> Double) -> ((Maybe Int, String) -> (Maybe Int, String)) -> CW -> CW+mapCW r i f d u x  = normCW $ CW (kindOf x) $ case cwVal x of+                                               CWAlgReal a  -> CWAlgReal  (r a)+                                               CWInteger a  -> CWInteger  (i a)+                                               CWFloat a    -> CWFloat    (f a)+                                               CWDouble a   -> CWDouble   (d a)+                                               CWUserSort a -> CWUserSort (u a)++-- | Map a binary function through a CW.+mapCW2 :: (AlgReal -> AlgReal -> AlgReal) -> (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> (Double -> Double -> Double) -> ((Maybe Int, String) -> (Maybe Int, String) -> (Maybe Int, String)) -> CW -> CW -> CW+mapCW2 r i f d u x y = case (cwSameType x y, cwVal x, cwVal y) of+                        (True, CWAlgReal a,  CWAlgReal b)  -> normCW $ CW (kindOf x) (CWAlgReal  (r a b))+                        (True, CWInteger a,  CWInteger b)  -> normCW $ CW (kindOf x) (CWInteger  (i a b))+                        (True, CWFloat a,    CWFloat b)    -> normCW $ CW (kindOf x) (CWFloat    (f a b))+                        (True, CWDouble a,   CWDouble b)   -> normCW $ CW (kindOf x) (CWDouble   (d a b))+                        (True, CWUserSort a, CWUserSort b) -> normCW $ CW (kindOf x) (CWUserSort (u a b))+                        _                                  -> error $ "SBV.mapCW2: impossible, incompatible args received: " ++ show (x, y)++-- | Show instance for 'CW'.+instance Show CW where+  show = showCW True++-- | Show instance for Generalized 'CW'+instance Show GeneralizedCW where+  show (ExtendedCW k) = showExtCW True k+  show (RegularCW  c) = showCW    True c++-- | Show a CW, with kind info if bool is True+showCW :: Bool -> CW -> String+showCW shk w | isBoolean w = show (cwToBool w) ++ (if shk then " :: Bool" else "")+showCW shk w               = liftCW show show show show snd w ++ kInfo+      where kInfo | shk  = " :: " ++ showBaseKind (kindOf w)+                  | True = ""++-- | A version of show for kinds that says Bool instead of SBool+showBaseKind :: Kind -> String+showBaseKind k@KUserSort {} = show k   -- Leave user-sorts untouched!+showBaseKind k = case show k of+                   ('S':sk) -> sk+                   s        -> s++-- | Create a constant word from an integral.+mkConstCW :: Integral a => Kind -> a -> CW+mkConstCW KBool           a = normCW $ CW KBool      (CWInteger (toInteger a))+mkConstCW k@KBounded{}    a = normCW $ CW k          (CWInteger (toInteger a))+mkConstCW KUnbounded      a = normCW $ CW KUnbounded (CWInteger (toInteger a))+mkConstCW KReal           a = normCW $ CW KReal      (CWAlgReal (fromInteger (toInteger a)))+mkConstCW KFloat          a = normCW $ CW KFloat     (CWFloat   (fromInteger (toInteger a)))+mkConstCW KDouble         a = normCW $ CW KDouble    (CWDouble  (fromInteger (toInteger a)))+mkConstCW (KUserSort s _) a = error $ "Unexpected call to mkConstCW with uninterpreted kind: " ++ s ++ " with value: " ++ show (toInteger a)++-- | Generate a random constant value ('CWVal') of the correct kind.+randomCWVal :: Kind -> IO CWVal+randomCWVal k =+  case k of+    KBool         -> fmap CWInteger (randomRIO (0,1))+    KBounded s w  -> fmap CWInteger (randomRIO (bounds s w))+    KUnbounded    -> fmap CWInteger randomIO+    KReal         -> fmap CWAlgReal randomIO+    KFloat        -> fmap CWFloat randomIO+    KDouble       -> fmap CWDouble randomIO+    KUserSort s _ -> error $ "Unexpected call to randomCWVal with uninterpreted kind: " ++ s+  where+    bounds :: Bool -> Int -> (Integer, Integer)+    bounds False w = (0, 2^w - 1)+    bounds True  w = (-x, x-1) where x = 2^(w-1)++-- | Generate a random constant value ('CW') of the correct kind.+randomCW :: Kind -> IO CW+randomCW k = fmap (CW k) (randomCWVal k)
+ Data/SBV/Core/Data.hs view
@@ -0,0 +1,581 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Core.Data+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Internal data-structures for the sbv library+-----------------------------------------------------------------------------++{-# LANGUAGE CPP                   #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE DefaultSignatures     #-}+{-# LANGUAGE NamedFieldPuns        #-}++module Data.SBV.Core.Data+ ( SBool, SWord8, SWord16, SWord32, SWord64+ , SInt8, SInt16, SInt32, SInt64, SInteger, SReal, SFloat, SDouble+ , nan, infinity, sNaN, sInfinity, RoundingMode(..), SRoundingMode+ , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero+ , sRNE, sRNA, sRTP, sRTN, sRTZ+ , SymWord(..)+ , CW(..), CWVal(..), AlgReal(..), ExtCW(..), GeneralizedCW(..), isRegularCW, cwSameType, cwToBool+ , mkConstCW ,liftCW2, mapCW, mapCW2+ , SW(..), trueSW, falseSW, trueCW, falseCW, normCW+ , SVal(..)+ , SBV(..), NodeId(..), mkSymSBV+ , ArrayContext(..), ArrayInfo, SymArray(..), SFunArray(..), mkSFunArray, SArray(..)+ , sbvToSW, sbvToSymSW, forceSWArg+ , SBVExpr(..), newExpr+ , cache, Cached, uncache, uncacheAI, HasKind(..)+ , Op(..), FPOp(..), NamedSymVar, getTableIndex+ , SBVPgm(..), Symbolic, SExecutable(..), runSymbolic, runSymbolic', State, getPathCondition, extendPathCondition+ , inProofMode, SBVRunMode(..), Kind(..), Outputtable(..), Result(..)+ , Logic(..), SMTLibLogic(..)+ , addConstraint, internalVariable, internalConstraint, isCodeGenMode+ , SBVType(..), newUninterpreted, addAxiom+ , Quantifier(..), needsExistentials+ , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension, smtLibReservedNames+ , SolverCapabilities(..)+ , extractSymbolicSimulationState+ , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), getSBranchRunConfig+ , declNewSArray, declNewSFunArray+ , OptimizeStyle(..), Penalty(..), Objective(..)+ , Tactic(..), CaseCond(..), SMTProblem(..), isParallelCaseAnywhere+ ) where++import Control.DeepSeq      (NFData(..))+import Control.Monad.Reader (ask)+import Control.Monad.Trans  (liftIO)+import Data.Int             (Int8, Int16, Int32, Int64)+import Data.Word            (Word8, Word16, Word32, Word64)+import Data.List            (elemIndex, intercalate)+import Data.Maybe           (fromMaybe)++import qualified Data.Set as Set (Set)+import qualified Data.Generics as G    (Data(..))++import GHC.Stack.Compat+#if !MIN_VERSION_base(4,9,0)+import GHC.SrcLoc.Compat+#endif++import System.Random++import Data.SBV.Core.AlgReals+import Data.SBV.Core.Kind+import Data.SBV.Core.Concrete+import Data.SBV.Core.Symbolic++import Data.SBV.SMT.SMTLibNames++import Data.SBV.Utils.Lib++import Prelude ()+import Prelude.Compat++-- | Get the current path condition+getPathCondition :: State -> SBool+getPathCondition st = SBV (getSValPathCondition st)++-- | Extend the path condition with the given test value.+extendPathCondition :: State -> (SBool -> SBool) -> State+extendPathCondition st f = extendSValPathCondition st (unSBV . f . SBV)++-- | The "Symbolic" value. The parameter 'a' is phantom, but is+-- extremely important in keeping the user interface strongly typed.+newtype SBV a = SBV { unSBV :: SVal }++-- | A symbolic boolean/bit+type SBool   = SBV Bool++-- | 8-bit unsigned symbolic value+type SWord8  = SBV Word8++-- | 16-bit unsigned symbolic value+type SWord16 = SBV Word16++-- | 32-bit unsigned symbolic value+type SWord32 = SBV Word32++-- | 64-bit unsigned symbolic value+type SWord64 = SBV Word64++-- | 8-bit signed symbolic value, 2's complement representation+type SInt8   = SBV Int8++-- | 16-bit signed symbolic value, 2's complement representation+type SInt16  = SBV Int16++-- | 32-bit signed symbolic value, 2's complement representation+type SInt32  = SBV Int32++-- | 64-bit signed symbolic value, 2's complement representation+type SInt64  = SBV Int64++-- | Infinite precision signed symbolic value+type SInteger = SBV Integer++-- | Infinite precision symbolic algebraic real value+type SReal = SBV AlgReal++-- | IEEE-754 single-precision floating point numbers+type SFloat = SBV Float++-- | IEEE-754 double-precision floating point numbers+type SDouble = SBV Double++-- | Not-A-Number for 'Double' and 'Float'. Surprisingly, Haskell+-- Prelude doesn't have this value defined, so we provide it here.+nan :: Floating a => a+nan = 0/0++-- | Infinity for 'Double' and 'Float'. Surprisingly, Haskell+-- Prelude doesn't have this value defined, so we provide it here.+infinity :: Floating a => a+infinity = 1/0++-- | Symbolic variant of Not-A-Number. This value will inhabit both+-- 'SDouble' and 'SFloat'.+sNaN :: (Floating a, SymWord a) => SBV a+sNaN = literal nan++-- | Symbolic variant of infinity. This value will inhabit both+-- 'SDouble' and 'SFloat'.+sInfinity :: (Floating a, SymWord a) => SBV a+sInfinity = literal infinity++-- | 'RoundingMode' can be used symbolically+instance SymWord RoundingMode++-- | The symbolic variant of 'RoundingMode'+type SRoundingMode = SBV RoundingMode++-- | Symbolic variant of 'RoundNearestTiesToEven'+sRoundNearestTiesToEven :: SRoundingMode+sRoundNearestTiesToEven = literal RoundNearestTiesToEven++-- | Symbolic variant of 'RoundNearestTiesToAway'+sRoundNearestTiesToAway :: SRoundingMode+sRoundNearestTiesToAway = literal RoundNearestTiesToAway++-- | Symbolic variant of 'RoundNearestPositive'+sRoundTowardPositive :: SRoundingMode+sRoundTowardPositive = literal RoundTowardPositive++-- | Symbolic variant of 'RoundTowardNegative'+sRoundTowardNegative :: SRoundingMode+sRoundTowardNegative = literal RoundTowardNegative++-- | Symbolic variant of 'RoundTowardZero'+sRoundTowardZero :: SRoundingMode+sRoundTowardZero = literal RoundTowardZero++-- | Alias for 'sRoundNearestTiesToEven'+sRNE :: SRoundingMode+sRNE = sRoundNearestTiesToEven++-- | Alias for 'sRoundNearestTiesToAway'+sRNA :: SRoundingMode+sRNA = sRoundNearestTiesToAway++-- | Alias for 'sRoundTowardPositive'+sRTP :: SRoundingMode+sRTP = sRoundTowardPositive++-- | Alias for 'sRoundTowardNegative'+sRTN :: SRoundingMode+sRTN = sRoundTowardNegative++-- | Alias for 'sRoundTowardZero'+sRTZ :: SRoundingMode+sRTZ = sRoundTowardZero++-- Not particularly "desirable", but will do if needed+instance Show (SBV a) where+  show (SBV sv) = show sv++-- Equality constraint on SBV values. Not desirable since we can't really compare two+-- symbolic values, but will do.+instance Eq (SBV a) where+  SBV a == SBV b = a == b+  SBV a /= SBV b = a /= b++instance HasKind (SBV a) where+  kindOf (SBV (SVal k _)) = k++-- | Convert a symbolic value to a symbolic-word+sbvToSW :: State -> SBV a -> IO SW+sbvToSW st (SBV s) = svToSW st s++-------------------------------------------------------------------------+-- * Symbolic Computations+-------------------------------------------------------------------------++-- | Create a symbolic variable.+mkSymSBV :: forall a. Maybe Quantifier -> Kind -> Maybe String -> Symbolic (SBV a)+mkSymSBV mbQ k mbNm = fmap SBV (svMkSymVar mbQ k mbNm)++-- | Convert a symbolic value to an SW, inside the Symbolic monad+sbvToSymSW :: SBV a -> Symbolic SW+sbvToSymSW sbv = do+        st <- ask+        liftIO $ sbvToSW st sbv++-- | A class representing what can be returned from a symbolic computation.+class Outputtable a where+  -- | Mark an interim result as an output. Useful when constructing Symbolic programs+  -- that return multiple values, or when the result is programmatically computed.+  output :: a -> Symbolic a++instance Outputtable (SBV a) where+  output i = do+          outputSVal (unSBV i)+          return i++instance Outputtable a => Outputtable [a] where+  output = mapM output++instance Outputtable () where+  output = return++instance (Outputtable a, Outputtable b) => Outputtable (a, b) where+  output = mlift2 (,) output output++instance (Outputtable a, Outputtable b, Outputtable c) => Outputtable (a, b, c) where+  output = mlift3 (,,) output output output++instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d) => Outputtable (a, b, c, d) where+  output = mlift4 (,,,) output output output output++instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e) => Outputtable (a, b, c, d, e) where+  output = mlift5 (,,,,) output output output output output++instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f) => Outputtable (a, b, c, d, e, f) where+  output = mlift6 (,,,,,) output output output output output output++instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f, Outputtable g) => Outputtable (a, b, c, d, e, f, g) where+  output = mlift7 (,,,,,,) output output output output output output output++instance (Outputtable a, Outputtable b, Outputtable c, Outputtable d, Outputtable e, Outputtable f, Outputtable g, Outputtable h) => Outputtable (a, b, c, d, e, f, g, h) where+  output = mlift8 (,,,,,,,) output output output output output output output output++-------------------------------------------------------------------------------+-- * Symbolic Words+-------------------------------------------------------------------------------+-- | A 'SymWord' is a potential symbolic bitvector that can be created instances of+-- to be fed to a symbolic program. Note that these methods are typically not needed+-- in casual uses with 'prove', 'sat', 'allSat' etc, as default instances automatically+-- provide the necessary bits.+class (HasKind a, Ord a) => SymWord a where+  -- | Create a user named input (universal)+  forall :: String -> Symbolic (SBV a)+  -- | Create an automatically named input+  forall_ :: Symbolic (SBV a)+  -- | Get a bunch of new words+  mkForallVars :: Int -> Symbolic [SBV a]+  -- | Create an existential variable+  exists  :: String -> Symbolic (SBV a)+  -- | Create an automatically named existential variable+  exists_ :: Symbolic (SBV a)+  -- | Create a bunch of existentials+  mkExistVars :: Int -> Symbolic [SBV a]+  -- | Create a free variable, universal in a proof, existential in sat+  free :: String -> Symbolic (SBV a)+  -- | Create an unnamed free variable, universal in proof, existential in sat+  free_ :: Symbolic (SBV a)+  -- | Create a bunch of free vars+  mkFreeVars :: Int -> Symbolic [SBV a]+  -- | Similar to free; Just a more convenient name+  symbolic  :: String -> Symbolic (SBV a)+  -- | Similar to mkFreeVars; but automatically gives names based on the strings+  symbolics :: [String] -> Symbolic [SBV a]+  -- | Turn a literal constant to symbolic+  literal :: a -> SBV a+  -- | Extract a literal, if the value is concrete+  unliteral :: SBV a -> Maybe a+  -- | Extract a literal, from a CW representation+  fromCW :: CW -> a+  -- | Is the symbolic word concrete?+  isConcrete :: SBV a -> Bool+  -- | Is the symbolic word really symbolic?+  isSymbolic :: SBV a -> Bool+  -- | Does it concretely satisfy the given predicate?+  isConcretely :: SBV a -> (a -> Bool) -> Bool+  -- | One stop allocator+  mkSymWord :: Maybe Quantifier -> Maybe String -> Symbolic (SBV a)++  -- minimal complete definition:: Nothing.+  -- Giving no instances is ok when defining an uninterpreted/enumerated sort, but otherwise you really+  -- want to define: literal, fromCW, mkSymWord+  forall   = mkSymWord (Just ALL) . Just+  forall_  = mkSymWord (Just ALL)   Nothing+  exists   = mkSymWord (Just EX)  . Just+  exists_  = mkSymWord (Just EX)    Nothing+  free     = mkSymWord Nothing    . Just+  free_    = mkSymWord Nothing      Nothing+  mkForallVars n = mapM (const forall_) [1 .. n]+  mkExistVars n  = mapM (const exists_) [1 .. n]+  mkFreeVars n   = mapM (const free_)   [1 .. n]+  symbolic       = free+  symbolics      = mapM symbolic+  unliteral (SBV (SVal _ (Left c)))  = Just $ fromCW c+  unliteral _                        = Nothing+  isConcrete (SBV (SVal _ (Left _))) = True+  isConcrete _                       = False+  isSymbolic = not . isConcrete+  isConcretely s p+    | Just i <- unliteral s = p i+    | True                  = False++  default literal :: Show a => a -> SBV a+  literal x = let k@(KUserSort  _ conts) = kindOf x+                  sx                     = show x+                  mbIdx = case conts of+                            Right xs -> sx `elemIndex` xs+                            _        -> Nothing+              in SBV $ SVal k (Left (CW k (CWUserSort (mbIdx, sx))))++  default fromCW :: Read a => CW -> a+  fromCW (CW _ (CWUserSort (_, s))) = read s+  fromCW cw                         = error $ "Cannot convert CW " ++ show cw ++ " to kind " ++ show (kindOf (undefined :: a))++  default mkSymWord :: (Read a, G.Data a) => Maybe Quantifier -> Maybe String -> Symbolic (SBV a)+  mkSymWord mbQ mbNm = SBV <$> mkSValUserSort k mbQ mbNm+    where k = constructUKind (undefined :: a)++instance (Random a, SymWord a) => Random (SBV a) where+  randomR (l, h) g = case (unliteral l, unliteral h) of+                       (Just lb, Just hb) -> let (v, g') = randomR (lb, hb) g in (literal (v :: a), g')+                       _                  -> error "SBV.Random: Cannot generate random values with symbolic bounds"+  random         g = let (v, g') = random g in (literal (v :: a) , g')+---------------------------------------------------------------------------------+-- * Symbolic Arrays+---------------------------------------------------------------------------------++-- | Flat arrays of symbolic values+-- An @array a b@ is an array indexed by the type @'SBV' a@, with elements of type @'SBV' b@+-- If an initial value is not provided in 'newArray_' and 'newArray' methods, then the elements+-- are left unspecified, i.e., the solver is free to choose any value. This is the right thing+-- to do if arrays are used as inputs to functions to be verified, typically. +--+-- While it's certainly possible for user to create instances of 'SymArray', the+-- 'SArray' and 'SFunArray' instances already provided should cover most use cases+-- in practice. (There are some differences between these models, however, see the corresponding+-- declaration.)+--+--+-- Minimal complete definition: All methods are required, no defaults.+class SymArray array where+  -- | Create a new array, with an optional initial value+  newArray_      :: (HasKind a, HasKind b) => Maybe (SBV b) -> Symbolic (array a b)+  -- | Create a named new array, with an optional initial value+  newArray       :: (HasKind a, HasKind b) => String -> Maybe (SBV b) -> Symbolic (array a b)+  -- | Read the array element at @a@+  readArray      :: array a b -> SBV a -> SBV b+  -- | Reset all the elements of the array to the value @b@+  resetArray     :: SymWord b => array a b -> SBV b -> array a b+  -- | Update the element at @a@ to be @b@+  writeArray     :: SymWord b => array a b -> SBV a -> SBV b -> array a b+  -- | Merge two given arrays on the symbolic condition+  -- Intuitively: @mergeArrays cond a b = if cond then a else b@.+  -- Merging pushes the if-then-else choice down on to elements+  mergeArrays    :: SymWord b => SBV Bool -> array a b -> array a b -> array a b++-- | Arrays implemented in terms of SMT-arrays: <http://smtlib.cs.uiowa.edu/theories-ArraysEx.shtml>+--+--   * Maps directly to SMT-lib arrays+--+--   * Reading from an unintialized value is OK and yields an unspecified result+--+--   * Can check for equality of these arrays+--+--   * Cannot quick-check theorems using @SArray@ values+--+--   * Typically slower as it heavily relies on SMT-solving for the array theory+--+newtype SArray a b = SArray { unSArray :: SArr }++instance (HasKind a, HasKind b) => Show (SArray a b) where+  show SArray{} = "SArray<" ++ showType (undefined :: a) ++ ":" ++ showType (undefined :: b) ++ ">"++instance SymArray SArray where+  newArray_                                      = declNewSArray (\t -> "array_" ++ show t)+  newArray n                                     = declNewSArray (const n)+  readArray   (SArray arr) (SBV a)               = SBV (readSArr arr a)+  resetArray  (SArray arr) (SBV b)               = SArray (resetSArr arr b)+  writeArray  (SArray arr) (SBV a)    (SBV b)    = SArray (writeSArr arr a b)+  mergeArrays (SBV t)      (SArray a) (SArray b) = SArray (mergeSArr t a b)++-- | Declare a new symbolic array, with a potential initial value+declNewSArray :: forall a b. (HasKind a, HasKind b) => (Int -> String) -> Maybe (SBV b) -> Symbolic (SArray a b)+declNewSArray mkNm mbInit = do+   let aknd = kindOf (undefined :: a)+       bknd = kindOf (undefined :: b)+   arr <- newSArr (aknd, bknd) mkNm (fmap unSBV mbInit)+   return (SArray arr)++-- | Declare a new functional symbolic array, with a potential initial value. Note that a read from an uninitialized cell will result in an error.+declNewSFunArray :: forall a b. (HasKind a, HasKind b) => Maybe (SBV b) -> Symbolic (SFunArray a b)+declNewSFunArray mbiVal = return $ SFunArray $ const $ fromMaybe (error "Reading from an uninitialized array entry") mbiVal++-- | Arrays implemented internally as functions+--+--    * Internally handled by the library and not mapped to SMT-Lib+--+--    * Reading an uninitialized value is considered an error (will throw exception)+--+--    * Cannot check for equality (internally represented as functions)+--+--    * Can quick-check+--+--    * Typically faster as it gets compiled away during translation+--+newtype SFunArray a b = SFunArray (SBV a -> SBV b)++instance (HasKind a, HasKind b) => Show (SFunArray a b) where+  show (SFunArray _) = "SFunArray<" ++ showType (undefined :: a) ++ ":" ++ showType (undefined :: b) ++ ">"++-- | Lift a function to an array. Useful for creating arrays in a pure context. (Otherwise use `newArray`.)+mkSFunArray :: (SBV a -> SBV b) -> SFunArray a b+mkSFunArray = SFunArray++-- | Add a constraint with a given probability.+addConstraint :: Maybe Double -> SBool -> SBool -> Symbolic ()+addConstraint mt (SBV c) (SBV c') = addSValConstraint mt c c'++-- | A case condition (internal)+data CaseCond = NoCase                         -- ^ No case-split+              | CasePath [SW]                  -- ^ In a case-path+              | CaseVac  [SW] SW               -- ^ For checking the vacuity of a case+              | CaseCov  [SW] [SW]             -- ^ In a case-path end, coverage (first arg is path cond, second arg is coverage cond)+              | CstrVac                        -- ^ In a constraint vacuity check (top-level)+              | Opt      [Objective (SW, SW)]  -- ^ In an optimization call++instance NFData CaseCond where+  rnf NoCase           = ()+  rnf (CasePath ps)    = rnf ps+  rnf (CaseVac  ps q)  = rnf ps `seq` rnf q  `seq` ()+  rnf (CaseCov  ps qs) = rnf ps `seq` rnf qs `seq` ()+  rnf CstrVac          = ()+  rnf (Opt os)         = rnf os `seq` ()++-- | Internal representation of a symbolic simulation result+data SMTProblem = SMTProblem { smtInputs    :: [(Quantifier, NamedSymVar)]        -- ^ inputs+                             , smtSkolemMap :: [Either SW (SW, [SW])]             -- ^ skolem-map+                             , kindsUsed    :: Set.Set Kind                       -- ^ kinds used+                             , smtAsserts   :: [(String, Maybe CallStack, SW)]    -- ^ assertions+                             , tactics      :: [Tactic SW]                        -- ^ tactics to use+                             , objectives   :: [Objective (SW, SW)]               -- ^ optimization goals, if any+                             , smtLibPgm    :: SMTConfig -> CaseCond -> SMTLibPgm -- ^ SMTLib representation, given the config and case-splits+                             }++instance NFData SMTProblem where+  rnf (SMTProblem i m k a t o p) = rnf i `seq` rnf m `seq` rnf k `seq` rnf a `seq` rnf t `seq` rnf o `seq` rnf p `seq` ()++instance NFData (SBV a) where+  rnf (SBV x) = rnf x `seq` ()++-- | Symbolically executable program fragments. This class is mainly used for 'safe' calls, and is sufficently 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 SExecutable a where+   sName_ :: a -> Symbolic ()+   sName  :: [String] -> a -> Symbolic ()++instance NFData a => SExecutable (Symbolic a) where+   sName_   a = a >>= \r -> rnf r `seq` return ()+   sName []   = sName_+   sName xs   = error $ "SBV.SExecutable.sName: Extra unmapped name(s): " ++ intercalate ", " xs++instance SExecutable (SBV a) where+   sName_   v = sName_ (output v)+   sName xs v = sName xs (output v)++-- Unit output+instance SExecutable () where+   sName_   () = sName_   (output ())+   sName xs () = sName xs (output ())++-- List output+instance SExecutable [SBV a] where+   sName_   vs = sName_   (output vs)+   sName xs vs = sName xs (output vs)++-- 2 Tuple output+instance (NFData a, SymWord a, NFData b, SymWord b) => SExecutable (SBV a, SBV b) where+  sName_ (a, b) = sName_ (output a >> output b)+  sName _       = sName_++-- 3 Tuple output+instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c) => SExecutable (SBV a, SBV b, SBV c) where+  sName_ (a, b, c) = sName_ (output a >> output b >> output c)+  sName _          = sName_++-- 4 Tuple output+instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d) => SExecutable (SBV a, SBV b, SBV c, SBV d) where+  sName_ (a, b, c, d) = sName_ (output a >> output b >> output c >> output c >> output d)+  sName _             = sName_++-- 5 Tuple output+instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e) where+  sName_ (a, b, c, d, e) = sName_ (output a >> output b >> output c >> output d >> output e)+  sName _                = sName_++-- 6 Tuple output+instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e, NFData f, SymWord f) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) where+  sName_ (a, b, c, d, e, f) = sName_ (output a >> output b >> output c >> output d >> output e >> output f)+  sName _                   = sName_++-- 7 Tuple output+instance (NFData a, SymWord a, NFData b, SymWord b, NFData c, SymWord c, NFData d, SymWord d, NFData e, SymWord e, NFData f, SymWord f, NFData g, SymWord g) => SExecutable (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) where+  sName_ (a, b, c, d, e, f, g) = sName_ (output a >> output b >> output c >> output d >> output e >> output f >> output g)+  sName _                      = sName_++-- Functions+instance (SymWord a, SExecutable p) => SExecutable (SBV a -> p) where+   sName_        k = forall_   >>= \a -> sName_   $ k a+   sName (s:ss)  k = forall s  >>= \a -> sName ss $ k a+   sName []      k = sName_ k++-- 2 Tuple input+instance (SymWord a, SymWord b, SExecutable p) => SExecutable ((SBV a, SBV b) -> p) where+  sName_        k = forall_  >>= \a -> sName_   $ \b -> k (a, b)+  sName (s:ss)  k = forall s >>= \a -> sName ss $ \b -> k (a, b)+  sName []      k = sName_ k++-- 3 Tuple input+instance (SymWord a, SymWord b, SymWord c, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c) -> p) where+  sName_       k  = forall_  >>= \a -> sName_   $ \b c -> k (a, b, c)+  sName (s:ss) k  = forall s >>= \a -> sName ss $ \b c -> k (a, b, c)+  sName []     k  = sName_ k++-- 4 Tuple input+instance (SymWord a, SymWord b, SymWord c, SymWord d, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d) -> p) where+  sName_        k = forall_  >>= \a -> sName_   $ \b c d -> k (a, b, c, d)+  sName (s:ss)  k = forall s >>= \a -> sName ss $ \b c d -> k (a, b, c, d)+  sName []      k = sName_ k++-- 5 Tuple input+instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e) -> p) where+  sName_        k = forall_  >>= \a -> sName_   $ \b c d e -> k (a, b, c, d, e)+  sName (s:ss)  k = forall s >>= \a -> sName ss $ \b c d e -> k (a, b, c, d, e)+  sName []      k = sName_ k++-- 6 Tuple input+instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> p) where+  sName_        k = forall_  >>= \a -> sName_   $ \b c d e f -> k (a, b, c, d, e, f)+  sName (s:ss)  k = forall s >>= \a -> sName ss $ \b c d e f -> k (a, b, c, d, e, f)+  sName []      k = sName_ k++-- 7 Tuple input+instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SymWord g, SExecutable p) => SExecutable ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> p) where+  sName_        k = forall_  >>= \a -> sName_   $ \b c d e f g -> k (a, b, c, d, e, f, g)+  sName (s:ss)  k = forall s >>= \a -> sName ss $ \b c d e f g -> k (a, b, c, d, e, f, g)+  sName []      k = sName_ k
+ Data/SBV/Core/Floating.hs view
@@ -0,0 +1,446 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Core.Floating+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Implementation of floating-point operations mapping to SMT-Lib2 floats+-----------------------------------------------------------------------------++{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.SBV.Core.Floating (+         IEEEFloating(..), IEEEFloatConvertable(..)+       , sFloatAsSWord32, sDoubleAsSWord64, sWord32AsSFloat, sWord64AsSDouble+       , blastSFloat, blastSDouble+       ) where++import Control.Monad (join)++import qualified Data.Binary.IEEE754 as DB (wordToFloat, wordToDouble, floatToWord, doubleToWord)++import Data.Int            (Int8,  Int16,  Int32,  Int64)+import Data.Word           (Word8, Word16, Word32, Word64)++import Data.SBV.Core.Data+import Data.SBV.Core.Model+import Data.SBV.Core.AlgReals (isExactRational)+import Data.SBV.Utils.Boolean+import Data.SBV.Utils.Numeric++-- | A class of floating-point (IEEE754) operations, some of+-- which behave differently based on rounding modes. Note that unless+-- the rounding mode is concretely RoundNearestTiesToEven, we will+-- not concretely evaluate these, but rather pass down to the SMT solver.+class (SymWord a, RealFloat a) => IEEEFloating a where+  -- | Compute the floating point absolute value.+  fpAbs             ::                  SBV a -> SBV a++  -- | Compute the unary negation. Note that @0 - x@ is not equivalent to @-x@ for floating-point, since @-0@ and @0@ are different.+  fpNeg             ::                  SBV a -> SBV a++  -- | Add two floating point values, using the given rounding mode+  fpAdd             :: SRoundingMode -> SBV a -> SBV a -> SBV a++  -- | Subtract two floating point values, using the given rounding mode+  fpSub             :: SRoundingMode -> SBV a -> SBV a -> SBV a++  -- | Multiply two floating point values, using the given rounding mode+  fpMul             :: SRoundingMode -> SBV a -> SBV a -> SBV a++  -- | Divide two floating point values, using the given rounding mode+  fpDiv             :: SRoundingMode -> SBV a -> SBV a -> SBV a++  -- | Fused-multiply-add three floating point values, using the given rounding mode. @fpFMA x y z = x*y+z@ but with only+  -- one rounding done for the whole operation; not two. Note that we will never concretely evaluate this function since+  -- Haskell lacks an FMA implementation.+  fpFMA             :: SRoundingMode -> SBV a -> SBV a -> SBV a -> SBV a++  -- | Compute the square-root of a float, using the given rounding mode+  fpSqrt            :: SRoundingMode -> SBV a -> SBV a++  -- | Compute the remainder: @x - y * n@, where @n@ is the truncated integer nearest to x/y. The rounding mode+  -- is implicitly assumed to be @RoundNearestTiesToEven@.+  fpRem             ::                  SBV a -> SBV a -> SBV a++  -- | Round to the nearest integral value, using the given rounding mode.+  fpRoundToIntegral :: SRoundingMode -> SBV a -> SBV a++  -- | Compute the minimum of two floats, respects @infinity@ and @NaN@ values+  fpMin             ::                  SBV a -> SBV a -> SBV a++  -- | Compute the maximum of two floats, respects @infinity@ and @NaN@ values+  fpMax             ::                  SBV a -> SBV a -> SBV a++  -- | Are the two given floats exactly the same. That is, @NaN@ will compare equal to itself, @+0@ will /not/ compare+  -- equal to @-0@ etc. This is the object level equality, as opposed to the semantic equality. (For the latter, just use '.=='.)+  fpIsEqualObject   ::                  SBV a -> SBV a -> SBool++  -- | Is the floating-point number a normal value. (i.e., not denormalized.)+  fpIsNormal :: SBV a -> SBool++  -- | Is the floating-point number a subnormal value. (Also known as denormal.)+  fpIsSubnormal :: SBV a -> SBool++  -- | Is the floating-point number 0? (Note that both +0 and -0 will satisfy this predicate.)+  fpIsZero :: SBV a -> SBool++  -- | Is the floating-point number infinity? (Note that both +oo and -oo will satisfy this predicate.)+  fpIsInfinite :: SBV a -> SBool++  -- | Is the floating-point number a NaN value?+  fpIsNaN ::  SBV a -> SBool++  -- | Is the floating-point number negative? Note that -0 satisfies this predicate but +0 does not.+  fpIsNegative :: SBV a -> SBool++  -- | Is the floating-point number positive? Note that +0 satisfies this predicate but -0 does not.+  fpIsPositive :: SBV a -> SBool++  -- | Is the floating point number -0?+  fpIsNegativeZero :: SBV a -> SBool++  -- | Is the floating point number +0?+  fpIsPositiveZero :: SBV a -> SBool++  -- | Is the floating-point number a regular floating point, i.e., not NaN, nor +oo, nor -oo. Normals or denormals are allowed.+  fpIsPoint :: SBV a -> SBool++  -- Default definitions. Minimal complete definition: None! All should be taken care by defaults+  -- Note that we never evaluate FMA concretely, as there's no fma operator in Haskell+  fpAbs              = lift1  FP_Abs             (Just abs)                Nothing+  fpNeg              = lift1  FP_Neg             (Just negate)             Nothing+  fpAdd              = lift2  FP_Add             (Just (+))                . Just+  fpSub              = lift2  FP_Sub             (Just (-))                . Just+  fpMul              = lift2  FP_Mul             (Just (*))                . Just+  fpDiv              = lift2  FP_Div             (Just (/))                . Just+  fpFMA              = lift3  FP_FMA             Nothing                   . Just+  fpSqrt             = lift1  FP_Sqrt            (Just sqrt)               . Just+  fpRem              = lift2  FP_Rem             (Just fpRemH)             Nothing+  fpRoundToIntegral  = lift1  FP_RoundToIntegral (Just fpRoundToIntegralH) . Just+  fpMin              = liftMM FP_Min             (Just fpMinH)             Nothing+  fpMax              = liftMM FP_Max             (Just fpMaxH)             Nothing+  fpIsEqualObject    = lift2B FP_ObjEqual        (Just fpIsEqualObjectH)   Nothing+  fpIsNormal         = lift1B FP_IsNormal        fpIsNormalizedH+  fpIsSubnormal      = lift1B FP_IsSubnormal     isDenormalized+  fpIsZero           = lift1B FP_IsZero          (== 0)+  fpIsInfinite       = lift1B FP_IsInfinite      isInfinite+  fpIsNaN            = lift1B FP_IsNaN           isNaN+  fpIsNegative       = lift1B FP_IsNegative      (\x -> x < 0 ||       isNegativeZero x)+  fpIsPositive       = lift1B FP_IsPositive      (\x -> x >= 0 && not (isNegativeZero x))+  fpIsNegativeZero x = fpIsZero x &&& fpIsNegative x+  fpIsPositiveZero x = fpIsZero x &&& fpIsPositive x+  fpIsPoint        x = bnot (fpIsNaN x ||| fpIsInfinite x)++-- | SFloat instance+instance IEEEFloating Float++-- | SDouble instance+instance IEEEFloating Double++-- | Capture convertability from/to FloatingPoint representations+-- NB. 'fromSFloat' and 'fromSDouble' are underspecified when given+-- when given a @NaN@, @+oo@, or @-oo@ value that cannot be represented+-- in the target domain. For these inputs, we define the result to be +0, arbitrarily.+class IEEEFloatConvertable a where+  fromSFloat  :: SRoundingMode -> SFloat  -> SBV a+  toSFloat    :: SRoundingMode -> SBV a   -> SFloat+  fromSDouble :: SRoundingMode -> SDouble -> SBV a+  toSDouble   :: SRoundingMode -> SBV a   -> SDouble++-- | A generic converter that will work for most of our instances. (But not all!)+genericFPConverter :: forall a r. (SymWord a, HasKind r, SymWord r, Num r) => Maybe (a -> Bool) -> Maybe (SBV a -> SBool) -> (a -> r) -> SRoundingMode -> SBV a -> SBV r+genericFPConverter mbConcreteOK mbSymbolicOK converter rm f+  | Just w <- unliteral f, Just RoundNearestTiesToEven <- unliteral rm, check w+  = literal $ converter w+  | Just symCheck <- mbSymbolicOK+  = ite (symCheck f) result (literal 0)+  | True+  = result+  where result  = SBV (SVal kTo (Right (cache y)))+        check w = maybe True ($ w) mbConcreteOK+        kFrom   = kindOf f+        kTo     = kindOf (undefined :: r)+        y st    = do msw <- sbvToSW st rm+                     xsw <- sbvToSW st f+                     newExpr st kTo (SBVApp (IEEEFP (FP_Cast kFrom kTo msw)) [xsw])++-- | Check that a given float is a point+ptCheck :: IEEEFloating a => Maybe (SBV a -> SBool)+ptCheck = Just fpIsPoint++instance IEEEFloatConvertable Int8 where+  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))+  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)+  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))+  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)++instance IEEEFloatConvertable Int16 where+  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))+  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)+  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))+  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)++instance IEEEFloatConvertable Int32 where+  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))+  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)+  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))+  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)++instance IEEEFloatConvertable Int64 where+  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))+  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)+  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))+  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)++instance IEEEFloatConvertable Word8 where+  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))+  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)+  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))+  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)++instance IEEEFloatConvertable Word16 where+  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))+  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)+  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))+  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)++instance IEEEFloatConvertable Word32 where+  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))+  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)+  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))+  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)++instance IEEEFloatConvertable Word64 where+  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))+  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)+  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))+  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)++instance IEEEFloatConvertable Float where+  fromSFloat _ f = f+  toSFloat   _ f = f+  fromSDouble    = genericFPConverter Nothing Nothing fp2fp+  toSDouble      = genericFPConverter Nothing Nothing fp2fp++instance IEEEFloatConvertable Double where+  fromSFloat      = genericFPConverter Nothing Nothing fp2fp+  toSFloat        = genericFPConverter Nothing Nothing fp2fp+  fromSDouble _ d = d+  toSDouble   _ d = d++instance IEEEFloatConvertable Integer where+  fromSFloat  = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Float -> Integer))+  toSFloat    = genericFPConverter Nothing Nothing (fromRational . fromIntegral)+  fromSDouble = genericFPConverter Nothing ptCheck (fromIntegral . (fpRound0 :: Double -> Integer))+  toSDouble   = genericFPConverter Nothing Nothing (fromRational . fromIntegral)++-- For AlgReal; be careful to only process exact rationals concretely+instance IEEEFloatConvertable AlgReal where+  fromSFloat  = genericFPConverter Nothing                ptCheck (fromRational . fpRatio0)+  toSFloat    = genericFPConverter (Just isExactRational) Nothing (fromRational . toRational)+  fromSDouble = genericFPConverter Nothing                ptCheck (fromRational . fpRatio0)+  toSDouble   = genericFPConverter (Just isExactRational) Nothing (fromRational . toRational)++-- | Concretely evaluate one arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data+concEval1 :: SymWord a => Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> Maybe (SBV a)+concEval1 mbOp mbRm a = do op <- mbOp+                           v  <- unliteral a+                           case join (unliteral `fmap` mbRm) of+                             Nothing                     -> (Just . literal) (op v)+                             Just RoundNearestTiesToEven -> (Just . literal) (op v)+                             _                           -> Nothing++-- | Concretely evaluate two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data+concEval2 :: SymWord a => Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> Maybe (SBV a)+concEval2 mbOp mbRm a b  = do op <- mbOp+                              v1 <- unliteral a+                              v2 <- unliteral b+                              case join (unliteral `fmap` mbRm) of+                                Nothing                     -> (Just . literal) (v1 `op` v2)+                                Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2)+                                _                           -> Nothing++-- | Concretely evaluate a bool producing two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data+concEval2B :: SymWord a => Maybe (a -> a -> Bool) -> Maybe SRoundingMode -> SBV a -> SBV a -> Maybe SBool+concEval2B mbOp mbRm a b  = do op <- mbOp+                               v1 <- unliteral a+                               v2 <- unliteral b+                               case join (unliteral `fmap` mbRm) of+                                 Nothing                     -> (Just . literal) (v1 `op` v2)+                                 Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2)+                                 _                           -> Nothing++-- | Concretely evaluate two arg function, if rounding mode is RoundNearestTiesToEven and we have enough concrete data+concEval3 :: SymWord a => Maybe (a -> a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a -> Maybe (SBV a)+concEval3 mbOp mbRm a b c = do op <- mbOp+                               v1 <- unliteral a+                               v2 <- unliteral b+                               v3 <- unliteral c+                               case join (unliteral `fmap` mbRm) of+                                 Nothing                     -> (Just . literal) (op v1 v2 v3)+                                 Just RoundNearestTiesToEven -> (Just . literal) (op v1 v2 v3)+                                 _                           -> Nothing++-- | Add the converted rounding mode if given as an argument+addRM :: State -> Maybe SRoundingMode -> [SW] -> IO [SW]+addRM _  Nothing   as = return as+addRM st (Just rm) as = do swm <- sbvToSW st rm+                           return (swm : as)++-- | Lift a 1 arg FP-op+lift1 :: SymWord a => FPOp -> Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a+lift1 w mbOp mbRm a+  | Just cv <- concEval1 mbOp mbRm a+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where k    = kindOf a+        r st = do swa  <- sbvToSW st a+                  args <- addRM st mbRm [swa]+                  newExpr st k (SBVApp (IEEEFP w) args)++-- | Lift an FP predicate+lift1B :: SymWord a => FPOp -> (a -> Bool) -> SBV a -> SBool+lift1B w f a+   | Just v <- unliteral a = literal $ f v+   | True                  = SBV $ SVal KBool $ Right $ cache r+   where r st = do swa <- sbvToSW st a+                   newExpr st KBool (SBVApp (IEEEFP w) [swa])+++-- | Lift a 2 arg FP-op+lift2 :: SymWord a => FPOp -> Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a+lift2 w mbOp mbRm a b+  | Just cv <- concEval2 mbOp mbRm a b+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where k    = kindOf a+        r st = do swa  <- sbvToSW st a+                  swb  <- sbvToSW st b+                  args <- addRM st mbRm [swa, swb]+                  newExpr st k (SBVApp (IEEEFP w) args)++-- | Lift min/max: Note that we protect against constant folding if args are alternating sign 0's, since+-- SMTLib is deliberately nondeterministic in this case+liftMM :: (SymWord a, RealFloat a) => FPOp -> Maybe (a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a+liftMM w mbOp mbRm a b+  | Just v1 <- unliteral a+  , Just v2 <- unliteral b+  , not ((isN0 v1 && isP0 v2) || (isP0 v1 && isN0 v2))          -- If not +0/-0 or -0/+0+  , Just cv <- concEval2 mbOp mbRm a b+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where isN0   = isNegativeZero+        isP0 x = x == 0 && not (isN0 x)+        k    = kindOf a+        r st = do swa  <- sbvToSW st a+                  swb  <- sbvToSW st b+                  args <- addRM st mbRm [swa, swb]+                  newExpr st k (SBVApp (IEEEFP w) args)++-- | Lift a 2 arg FP-op, producing bool+lift2B :: SymWord a => FPOp -> Maybe (a -> a -> Bool) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBool+lift2B w mbOp mbRm a b+  | Just cv <- concEval2B mbOp mbRm a b+  = cv+  | True+  = SBV $ SVal KBool $ Right $ cache r+  where r st = do swa  <- sbvToSW st a+                  swb  <- sbvToSW st b+                  args <- addRM st mbRm [swa, swb]+                  newExpr st KBool (SBVApp (IEEEFP w) args)++-- | Lift a 3 arg FP-op+lift3 :: SymWord a => FPOp -> Maybe (a -> a -> a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a -> SBV a -> SBV a+lift3 w mbOp mbRm a b c+  | Just cv <- concEval3 mbOp mbRm a b c+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where k    = kindOf a+        r st = do swa  <- sbvToSW st a+                  swb  <- sbvToSW st b+                  swc  <- sbvToSW st c+                  args <- addRM st mbRm [swa, swb, swc]+                  newExpr st k (SBVApp (IEEEFP w) args)++-- | Convert an 'SFloat' to an 'SWord32', preserving the bit-correspondence. Note that since the+-- representation for @NaN@s are not unique, this function will return a symbolic value when given a+-- concrete @NaN@.+--+-- Implementation note: Since there's no corresponding function in SMTLib for conversion to+-- bit-representation due to partiality, we use a translation trick by allocating a new word variable,+-- converting it to float, and requiring it to be equivalent to the input. In code-generation mode, we simply map+-- it to a simple conversion.+sFloatAsSWord32 :: SFloat -> SWord32+sFloatAsSWord32 fVal+  | Just f <- unliteral fVal, not (isNaN f)+  = literal (DB.floatToWord f)+  | True+  = SBV (SVal w32 (Right (cache y)))+  where w32  = KBounded False 32+        y st | isCodeGenMode st+             = do f <- sbvToSW st fVal+                  newExpr st w32 (SBVApp (IEEEFP (FP_Reinterpret KFloat w32)) [f])+             | True+             = do n   <- internalVariable st w32+                  ysw <- newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret w32 KFloat)) [n])+                  internalConstraint st $ unSBV $ fVal `fpIsEqualObject` SBV (SVal KFloat (Right (cache (\_ -> return ysw))))+                  return n++-- | Convert an 'SDouble' to an 'SWord64', preserving the bit-correspondence. Note that since the+-- representation for @NaN@s are not unique, this function will return a symbolic value when given a+-- concrete @NaN@.+--+-- See the implementation note for 'sFloatAsSWord32', as it applies here as well.+sDoubleAsSWord64 :: SDouble -> SWord64+sDoubleAsSWord64 fVal+  | Just f <- unliteral fVal, not (isNaN f)+  = literal (DB.doubleToWord f)+  | True+  = SBV (SVal w64 (Right (cache y)))+  where w64  = KBounded False 64+        y st | isCodeGenMode st+             = do f <- sbvToSW st fVal+                  newExpr st w64 (SBVApp (IEEEFP (FP_Reinterpret KDouble w64)) [f])+             | True+             = do n   <- internalVariable st w64+                  ysw <- newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret w64 KDouble)) [n])+                  internalConstraint st $ unSBV $ fVal `fpIsEqualObject` SBV (SVal KDouble (Right (cache (\_ -> return ysw))))+                  return n++-- | Extract the sign\/exponent\/mantissa of a single-precision float. The output will have+-- 8 bits in the second argument for exponent, and 23 in the third for the mantissa.+blastSFloat :: SFloat -> (SBool, [SBool], [SBool])+blastSFloat = extract . sFloatAsSWord32+ where extract x = (sTestBit x 31, sExtractBits x [30, 29 .. 23], sExtractBits x [22, 21 .. 0])++-- | Extract the sign\/exponent\/mantissa of a single-precision float. The output will have+-- 11 bits in the second argument for exponent, and 52 in the third for the mantissa.+blastSDouble :: SDouble -> (SBool, [SBool], [SBool])+blastSDouble = extract . sDoubleAsSWord64+ where extract x = (sTestBit x 63, sExtractBits x [62, 61 .. 52], sExtractBits x [51, 50 .. 0])++-- | Reinterpret the bits in a 32-bit word as a single-precision floating point number+sWord32AsSFloat :: SWord32 -> SFloat+sWord32AsSFloat fVal+  | Just f <- unliteral fVal = literal $ DB.wordToFloat f+  | True                     = SBV (SVal KFloat (Right (cache y)))+  where y st = do xsw <- sbvToSW st fVal+                  newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret (kindOf fVal) KFloat)) [xsw])++-- | Reinterpret the bits in a 32-bit word as a single-precision floating point number+sWord64AsSDouble :: SWord64 -> SDouble+sWord64AsSDouble dVal+  | Just d <- unliteral dVal = literal $ DB.wordToDouble d+  | True                     = SBV (SVal KDouble (Right (cache y)))+  where y st = do xsw <- sbvToSW st dVal+                  newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret (kindOf dVal) KDouble)) [xsw])++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
+ Data/SBV/Core/Kind.hs view
@@ -0,0 +1,160 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Core.Kind+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Internal data-structures for the sbv library+-----------------------------------------------------------------------------++{-# LANGUAGE    DefaultSignatures   #-}+{-# LANGUAGE    ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans   #-}++module Data.SBV.Core.Kind (Kind(..), HasKind(..), constructUKind) where++import qualified Data.Generics as G (Data(..), DataType, dataTypeName, dataTypeOf, tyconUQname, dataTypeConstrs, constrFields)++import Data.Int+import Data.Word+import Data.SBV.Core.AlgReals++-- | Kind of symbolic value+data Kind = KBool+          | KBounded !Bool !Int+          | KUnbounded+          | KReal+          | KUserSort String (Either String [String])+          | KFloat+          | KDouble++-- | Helper for Eq/Ord instances below+kindRank :: Kind -> Either Int (Either (Bool, Int) String)+kindRank KBool           = Left 0+kindRank (KBounded  b i) = Right (Left (b, i))+kindRank KUnbounded      = Left 1+kindRank KReal           = Left 2+kindRank (KUserSort s _) = Right (Right s)+kindRank KFloat          = Left 3+kindRank KDouble         = Left 4+{-# INLINE kindRank #-}++-- | We want to equate user-sorts only by name+instance Eq Kind where+  k1 == k2 = kindRank k1 == kindRank k2++-- | We want to order user-sorts only by name+instance Ord Kind where+  k1 `compare` k2 = kindRank k1 `compare` kindRank k2++instance Show Kind where+  show KBool              = "SBool"+  show (KBounded False n) = "SWord" ++ show n+  show (KBounded True n)  = "SInt"  ++ show n+  show KUnbounded         = "SInteger"+  show KReal              = "SReal"+  show (KUserSort s _)    = s+  show KFloat             = "SFloat"+  show KDouble            = "SDouble"++instance Eq  G.DataType where+   a == b = G.tyconUQname (G.dataTypeName a) == G.tyconUQname (G.dataTypeName b)++instance Ord G.DataType where+   a `compare` b = G.tyconUQname (G.dataTypeName a) `compare` G.tyconUQname (G.dataTypeName b)++-- | Does this kind represent a signed quantity?+kindHasSign :: Kind -> Bool+kindHasSign k =+  case k of+    KBool        -> False+    KBounded b _ -> b+    KUnbounded   -> True+    KReal        -> True+    KFloat       -> True+    KDouble      -> True+    KUserSort{}  -> 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 = KUserSort sortName mbEnumFields+  where 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"++-- | A class for capturing values that have a sign and a size (finite or infinite)+-- minimal complete definition: kindOf. This class can be automatically derived+-- for data-types that have a 'Data' instance; this is useful for creating uninterpreted+-- sorts.+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+  isInteger       :: a -> Bool+  isUninterpreted :: 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)"+                  KUserSort s _ -> error $ "SBV.HasKind.intSizeOf: Uninterpreted sort: " ++ s+  isBoolean       x | KBool{}      <- kindOf x = True+                    | True                     = False+  isBounded       x | KBounded{}   <- kindOf x = True+                    | True                     = False+  isReal          x | KReal{}      <- kindOf x = True+                    | True                     = False+  isFloat         x | KFloat{}     <- kindOf x = True+                    | True                     = False+  isDouble        x | KDouble{}    <- kindOf x = True+                    | True                     = False+  isInteger       x | KUnbounded{} <- kindOf x = True+                    | True                     = False+  isUninterpreted x | KUserSort{}  <- kindOf x = True+                    | True                     = False+  showType = show . kindOf++  -- default signature for uninterpreted/enumerated kinds+  default kindOf :: (Read a, G.Data a) => a -> Kind+  kindOf = constructUKind++instance HasKind Bool    where kindOf _ = KBool+instance HasKind Int8    where kindOf _ = KBounded True  8+instance HasKind Word8   where kindOf _ = KBounded False 8+instance HasKind Int16   where kindOf _ = KBounded True  16+instance HasKind Word16  where kindOf _ = KBounded False 16+instance HasKind Int32   where kindOf _ = KBounded True  32+instance HasKind Word32  where kindOf _ = KBounded False 32+instance HasKind Int64   where kindOf _ = KBounded True  64+instance HasKind Word64  where kindOf _ = KBounded False 64+instance HasKind Integer where kindOf _ = KUnbounded+instance HasKind AlgReal where kindOf _ = KReal+instance HasKind Float   where kindOf _ = KFloat+instance HasKind Double  where kindOf _ = KDouble++instance HasKind Kind where+  kindOf = id
+ Data/SBV/Core/Model.hs view
@@ -0,0 +1,1733 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Core.Model+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Instance declarations for our symbolic world+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-orphans   #-}+{-# LANGUAGE TypeSynonymInstances   #-}+{-# LANGUAGE BangPatterns           #-}+{-# LANGUAGE PatternGuards          #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE Rank2Types             #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE DefaultSignatures      #-}++module Data.SBV.Core.Model (+    Mergeable(..), EqSymbolic(..), OrdSymbolic(..), SDivisible(..), Uninterpreted(..), Metric(..), assertSoft, SIntegral+  , ite, iteLazy, sTestBit, sExtractBits, sPopCount, setBitTo, sFromIntegral+  , sShiftLeft, sShiftRight, sRotateLeft, sRotateRight, sSignedShiftArithRight, (.^)+  , allEqual, allDifferent, inRange, sElem, oneIf, blastBE, blastLE, fullAdder, fullMultiplier+  , lsb, msb, genVar, genVar_, forall, forall_, exists, exists_+  , constrain, pConstrain, tactic, sBool, sBools, sWord8, sWord8s, sWord16, sWord16s, sWord32+  , sWord32s, sWord64, sWord64s, sInt8, sInt8s, sInt16, sInt16s, sInt32, sInt32s, sInt64+  , sInt64s, sInteger, sIntegers, sReal, sReals, sFloat, sFloats, sDouble, sDoubles, slet+  , sRealToSInteger, label+  , sAssert+  , liftQRem, liftDMod, symbolicMergeWithKind+  , genLiteral, genFromCW, genMkSymVar+  , isSatisfiableInCurrentPath+  , sbvQuickCheck+  )+  where++import Control.Monad        (when, unless)+import Control.Monad.Reader (ask)+import Control.Monad.Trans  (liftIO)++import GHC.Generics (U1(..), M1(..), (:*:)(..), K1(..))+import qualified GHC.Generics as G+import GHC.Stack.Compat++import Data.Array      (Array, Ix, listArray, elems, bounds, rangeSize)+import Data.Bits       (Bits(..))+import Data.Int        (Int8, Int16, Int32, Int64)+import Data.List       (genericLength, genericIndex, genericTake, unzip4, unzip5, unzip6, unzip7, intercalate)+import Data.Maybe      (fromMaybe)+import Data.Word       (Word8, Word16, Word32, Word64)++import Test.QuickCheck                         (Testable(..), Arbitrary(..))+import qualified Test.QuickCheck.Test    as QC (isSuccess)+import qualified Test.QuickCheck         as QC (quickCheckResult, counterexample)+import qualified Test.QuickCheck.Monadic as QC (monadicIO, run, assert, pre, monitor)+import System.Random++import Data.SBV.Core.AlgReals+import Data.SBV.Core.Data+import Data.SBV.Core.Symbolic+import Data.SBV.Core.Operations++import Data.SBV.Provers.Prover (isVacuous, prove, defaultSMTCfg, internalSATCheck)+import Data.SBV.SMT.SMT        (ThmResult, SatResult(..), showModel)++import Data.SBV.Utils.Boolean++-- | Newer versions of GHC (Starting with 7.8 I think), distinguishes between FiniteBits and Bits classes.+-- We should really use FiniteBitSize for SBV which would make things better. In the interim, just work+-- around pesky warnings..+ghcBitSize :: Bits a => a -> Int+ghcBitSize x = fromMaybe (error "SBV.ghcBitSize: Unexpected non-finite usage!") (bitSizeMaybe x)++mkSymOpSC :: (SW -> SW -> Maybe SW) -> Op -> State -> Kind -> SW -> SW -> IO SW+mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) return (shortCut a b)++mkSymOp :: Op -> State -> Kind -> SW -> SW -> IO SW+mkSymOp = mkSymOpSC (const (const Nothing))++-- Symbolic-Word class instances++-- | Generate a finite symbolic bitvector, named+genVar :: Maybe Quantifier -> Kind -> String -> Symbolic (SBV a)+genVar q k = mkSymSBV q k . Just++-- | Generate a finite symbolic bitvector, unnamed+genVar_ :: Maybe Quantifier -> Kind -> Symbolic (SBV a)+genVar_ q k = mkSymSBV q k Nothing++-- | Generate a finite constant bitvector+genLiteral :: Integral a => Kind -> a -> SBV b+genLiteral k = SBV . SVal k . Left . mkConstCW k++-- | Convert a constant to an integral value+genFromCW :: Integral a => CW -> a+genFromCW (CW _ (CWInteger x)) = fromInteger x+genFromCW c                    = error $ "genFromCW: Unsupported non-integral value: " ++ show c++-- | Generically make a symbolic var+genMkSymVar :: Kind -> Maybe Quantifier -> Maybe String -> Symbolic (SBV a)+genMkSymVar k mbq Nothing  = genVar_ mbq k+genMkSymVar k mbq (Just s) = genVar  mbq k s++-- | Base type of () allows simple construction for uninterpreted types.+instance SymWord ()+instance HasKind ()++instance SymWord Bool where+  mkSymWord  = genMkSymVar KBool+  literal x  = SBV (svBool x)+  fromCW     = cwToBool++instance SymWord Word8 where+  mkSymWord  = genMkSymVar (KBounded False 8)+  literal    = genLiteral  (KBounded False 8)+  fromCW     = genFromCW++instance SymWord Int8 where+  mkSymWord  = genMkSymVar (KBounded True 8)+  literal    = genLiteral  (KBounded True 8)+  fromCW     = genFromCW++instance SymWord Word16 where+  mkSymWord  = genMkSymVar (KBounded False 16)+  literal    = genLiteral  (KBounded False 16)+  fromCW     = genFromCW++instance SymWord Int16 where+  mkSymWord  = genMkSymVar (KBounded True 16)+  literal    = genLiteral  (KBounded True 16)+  fromCW     = genFromCW++instance SymWord Word32 where+  mkSymWord  = genMkSymVar (KBounded False 32)+  literal    = genLiteral  (KBounded False 32)+  fromCW     = genFromCW++instance SymWord Int32 where+  mkSymWord  = genMkSymVar (KBounded True 32)+  literal    = genLiteral  (KBounded True 32)+  fromCW     = genFromCW++instance SymWord Word64 where+  mkSymWord  = genMkSymVar (KBounded False 64)+  literal    = genLiteral  (KBounded False 64)+  fromCW     = genFromCW++instance SymWord Int64 where+  mkSymWord  = genMkSymVar (KBounded True 64)+  literal    = genLiteral  (KBounded True 64)+  fromCW     = genFromCW++instance SymWord Integer where+  mkSymWord  = genMkSymVar KUnbounded+  literal    = SBV . SVal KUnbounded . Left . mkConstCW KUnbounded+  fromCW     = genFromCW++instance SymWord AlgReal where+  mkSymWord  = genMkSymVar KReal+  literal    = SBV . SVal KReal . Left . CW KReal . CWAlgReal+  fromCW (CW _ (CWAlgReal a)) = a+  fromCW c                    = error $ "SymWord.AlgReal: Unexpected non-real value: " ++ show c+  -- AlgReal needs its own definition of isConcretely+  -- to make sure we avoid using unimplementable Haskell functions+  isConcretely (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) p+     | isExactRational v = p v+  isConcretely _ _       = False++instance SymWord Float where+  mkSymWord  = genMkSymVar KFloat+  literal    = SBV . SVal KFloat . Left . CW KFloat . CWFloat+  fromCW (CW _ (CWFloat a)) = a+  fromCW c                  = error $ "SymWord.Float: Unexpected non-float value: " ++ show c+  -- For Float, we conservatively return 'False' for isConcretely. The reason is that+  -- this function is used for optimizations when only one of the argument is concrete,+  -- and in the presence of NaN's it would be incorrect to do any optimization+  isConcretely _ _ = False++instance SymWord Double where+  mkSymWord  = genMkSymVar KDouble+  literal    = SBV . SVal KDouble . Left . CW KDouble . CWDouble+  fromCW (CW _ (CWDouble a)) = a+  fromCW c                   = error $ "SymWord.Double: Unexpected non-double value: " ++ show c+  -- For Double, we conservatively return 'False' for isConcretely. The reason is that+  -- this function is used for optimizations when only one of the argument is concrete,+  -- and in the presence of NaN's it would be incorrect to do any optimization+  isConcretely _ _ = False++------------------------------------------------------------------------------------+-- * Smart constructors for creating symbolic values. These are not strictly+-- necessary, as they are mere aliases for 'symbolic' and 'symbolics', but +-- they nonetheless make programming easier.+------------------------------------------------------------------------------------+-- | Declare an 'SBool'+sBool :: String -> Symbolic SBool+sBool = symbolic++-- | Declare a list of 'SBool's+sBools :: [String] -> Symbolic [SBool]+sBools = symbolics++-- | Declare an 'SWord8'+sWord8 :: String -> Symbolic SWord8+sWord8 = symbolic++-- | Declare a list of 'SWord8's+sWord8s :: [String] -> Symbolic [SWord8]+sWord8s = symbolics++-- | Declare an 'SWord16'+sWord16 :: String -> Symbolic SWord16+sWord16 = symbolic++-- | Declare a list of 'SWord16's+sWord16s :: [String] -> Symbolic [SWord16]+sWord16s = symbolics++-- | Declare an 'SWord32'+sWord32 :: String -> Symbolic SWord32+sWord32 = symbolic++-- | Declare a list of 'SWord32's+sWord32s :: [String] -> Symbolic [SWord32]+sWord32s = symbolics++-- | Declare an 'SWord64'+sWord64 :: String -> Symbolic SWord64+sWord64 = symbolic++-- | Declare a list of 'SWord64's+sWord64s :: [String] -> Symbolic [SWord64]+sWord64s = symbolics++-- | Declare an 'SInt8'+sInt8 :: String -> Symbolic SInt8+sInt8 = symbolic++-- | Declare a list of 'SInt8's+sInt8s :: [String] -> Symbolic [SInt8]+sInt8s = symbolics++-- | Declare an 'SInt16'+sInt16 :: String -> Symbolic SInt16+sInt16 = symbolic++-- | Declare a list of 'SInt16's+sInt16s :: [String] -> Symbolic [SInt16]+sInt16s = symbolics++-- | Declare an 'SInt32'+sInt32 :: String -> Symbolic SInt32+sInt32 = symbolic++-- | Declare a list of 'SInt32's+sInt32s :: [String] -> Symbolic [SInt32]+sInt32s = symbolics++-- | Declare an 'SInt64'+sInt64 :: String -> Symbolic SInt64+sInt64 = symbolic++-- | Declare a list of 'SInt64's+sInt64s :: [String] -> Symbolic [SInt64]+sInt64s = symbolics++-- | Declare an 'SInteger'+sInteger:: String -> Symbolic SInteger+sInteger = symbolic++-- | Declare a list of 'SInteger's+sIntegers :: [String] -> Symbolic [SInteger]+sIntegers = symbolics++-- | Declare an 'SReal'+sReal:: String -> Symbolic SReal+sReal = symbolic++-- | Declare a list of 'SReal's+sReals :: [String] -> Symbolic [SReal]+sReals = symbolics++-- | Declare an 'SFloat'+sFloat :: String -> Symbolic SFloat+sFloat = symbolic++-- | Declare a list of 'SFloat's+sFloats :: [String] -> Symbolic [SFloat]+sFloats = symbolics++-- | Declare an 'SDouble'+sDouble :: String -> Symbolic SDouble+sDouble = symbolic++-- | Declare a list of 'SDouble's+sDoubles :: [String] -> Symbolic [SDouble]+sDoubles = symbolics++-- | Convert an SReal to an SInteger. That is, it computes the+-- largest integer @n@ that satisfies @sIntegerToSReal n <= r@+-- essentially giving us the @floor@.+--+-- For instance, @1.3@ will be @1@, but @-1.3@ will be @-2@.+sRealToSInteger :: SReal -> SInteger+sRealToSInteger x+  | Just i <- unliteral x, isExactRational i+  = literal $ floor (toRational i)+  | True+  = SBV (SVal KUnbounded (Right (cache y)))+  where y st = do xsw <- sbvToSW st x+                  newExpr st KUnbounded (SBVApp (KindCast KReal KUnbounded) [xsw])++-- | label: Label the result of an expression. This is essentially a no-op, but useful as it generates a comment in the generated C/SMT-Lib code.+-- Note that if the argument is a constant, then the label is dropped completely, per the usual constant folding strategy.+label :: SymWord a => String -> SBV a -> SBV a+label m x+   | Just _ <- unliteral x = x+   | True                  = SBV $ SVal k $ Right $ cache r+  where k    = kindOf x+        r st = do xsw <- sbvToSW st x+                  newExpr st k (SBVApp (Label m) [xsw])++-- | Symbolic Equality. Note that we can't use Haskell's 'Eq' class since Haskell insists on returning Bool+-- Comparing symbolic values will necessarily return a symbolic value.+--+-- Minimal complete definition: '.=='+infix 4 .==, ./=+class EqSymbolic a where+  (.==), (./=) :: a -> a -> SBool+  -- minimal complete definition: .==+  x ./= y = bnot (x .== y)++-- | Symbolic Comparisons. Similar to 'Eq', we cannot implement Haskell's 'Ord' class+-- since there is no way to return an 'Ordering' value from a symbolic comparison.+-- Furthermore, 'OrdSymbolic' requires 'Mergeable' to implement if-then-else, for the+-- benefit of implementing symbolic versions of 'max' and 'min' functions.+--+-- Minimal complete definition: '.<'+infix 4 .<, .<=, .>, .>=+class (Mergeable a, EqSymbolic a) => OrdSymbolic a where+  (.<), (.<=), (.>), (.>=) :: a -> a -> SBool+  smin, smax :: a -> a -> a+  -- minimal complete definition: .<+  a .<= b    = a .< b ||| a .== b+  a .>  b    = b .<  a+  a .>= b    = b .<= a+  a `smin` b = ite (a .<= b) a b+  a `smax` b = ite (a .<= b) b a++{- We can't have a generic instance of the form:++instance Eq a => EqSymbolic a where+  x .== y = if x == y then true else false++even if we're willing to allow Flexible/undecidable instances..+This is because if we allow this it would imply EqSymbolic (SBV a);+since (SBV a) has to be Eq as it must be a Num. But this wouldn't be+the right choice obviously; as the Eq instance is bogus for SBV+for natural reasons..+-}++instance EqSymbolic (SBV a) where+  SBV x .== SBV y = SBV (svEqual x y)+  SBV x ./= SBV y = SBV (svNotEqual x y)++instance SymWord a => OrdSymbolic (SBV a) where+  SBV x .<  SBV y = SBV (svLessThan x y)+  SBV x .<= SBV y = SBV (svLessEq x y)+  SBV x .>  SBV y = SBV (svGreaterThan x y)+  SBV x .>= SBV y = SBV (svGreaterEq x y)++-- Bool+instance EqSymbolic Bool where+  x .== y = if x == y then true else false++-- Lists+instance EqSymbolic a => EqSymbolic [a] where+  []     .== []     = true+  (x:xs) .== (y:ys) = x .== y &&& xs .== ys+  _      .== _      = false++instance OrdSymbolic a => OrdSymbolic [a] where+  []     .< []     = false+  []     .< _      = true+  _      .< []     = false+  (x:xs) .< (y:ys) = x .< y ||| (x .== y &&& xs .< ys)++-- Maybe+instance EqSymbolic a => EqSymbolic (Maybe a) where+  Nothing .== Nothing = true+  Just a  .== Just b  = a .== b+  _       .== _       = false++instance (OrdSymbolic a) => OrdSymbolic (Maybe a) where+  Nothing .<  Nothing = false+  Nothing .<  _       = true+  Just _  .<  Nothing = false+  Just a  .<  Just b  = a .< b++-- Either+instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (Either a b) where+  Left a  .== Left b  = a .== b+  Right a .== Right b = a .== b+  _       .== _       = false++instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (Either a b) where+  Left a  .< Left b  = a .< b+  Left _  .< Right _ = true+  Right _ .< Left _  = false+  Right a .< Right b = a .< b++-- 2-Tuple+instance (EqSymbolic a, EqSymbolic b) => EqSymbolic (a, b) where+  (a0, b0) .== (a1, b1) = a0 .== a1 &&& b0 .== b1++instance (OrdSymbolic a, OrdSymbolic b) => OrdSymbolic (a, b) where+  (a0, b0) .< (a1, b1) = a0 .< a1 ||| (a0 .== a1 &&& b0 .< b1)++-- 3-Tuple+instance (EqSymbolic a, EqSymbolic b, EqSymbolic c) => EqSymbolic (a, b, c) where+  (a0, b0, c0) .== (a1, b1, c1) = (a0, b0) .== (a1, b1) &&& c0 .== c1++instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c) => OrdSymbolic (a, b, c) where+  (a0, b0, c0) .< (a1, b1, c1) = (a0, b0) .< (a1, b1) ||| ((a0, b0) .== (a1, b1) &&& c0 .< c1)++-- 4-Tuple+instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d) => EqSymbolic (a, b, c, d) where+  (a0, b0, c0, d0) .== (a1, b1, c1, d1) = (a0, b0, c0) .== (a1, b1, c1) &&& d0 .== d1++instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d) => OrdSymbolic (a, b, c, d) where+  (a0, b0, c0, d0) .< (a1, b1, c1, d1) = (a0, b0, c0) .< (a1, b1, c1) ||| ((a0, b0, c0) .== (a1, b1, c1) &&& d0 .< d1)++-- 5-Tuple+instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e) => EqSymbolic (a, b, c, d, e) where+  (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .== (a1, b1, c1, d1) &&& e0 .== e1++instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e) => OrdSymbolic (a, b, c, d, e) where+  (a0, b0, c0, d0, e0) .< (a1, b1, c1, d1, e1) = (a0, b0, c0, d0) .< (a1, b1, c1, d1) ||| ((a0, b0, c0, d0) .== (a1, b1, c1, d1) &&& e0 .< e1)++-- 6-Tuple+instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f) => EqSymbolic (a, b, c, d, e, f) where+  (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) = (a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) &&& f0 .== f1++instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f) => OrdSymbolic (a, b, c, d, e, f) where+  (a0, b0, c0, d0, e0, f0) .< (a1, b1, c1, d1, e1, f1) =    (a0, b0, c0, d0, e0) .<  (a1, b1, c1, d1, e1)+                                                       ||| ((a0, b0, c0, d0, e0) .== (a1, b1, c1, d1, e1) &&& f0 .< f1)++-- 7-Tuple+instance (EqSymbolic a, EqSymbolic b, EqSymbolic c, EqSymbolic d, EqSymbolic e, EqSymbolic f, EqSymbolic g) => EqSymbolic (a, b, c, d, e, f, g) where+  (a0, b0, c0, d0, e0, f0, g0) .== (a1, b1, c1, d1, e1, f1, g1) = (a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) &&& g0 .== g1++instance (OrdSymbolic a, OrdSymbolic b, OrdSymbolic c, OrdSymbolic d, OrdSymbolic e, OrdSymbolic f, OrdSymbolic g) => OrdSymbolic (a, b, c, d, e, f, g) where+  (a0, b0, c0, d0, e0, f0, g0) .< (a1, b1, c1, d1, e1, f1, g1) =    (a0, b0, c0, d0, e0, f0) .<  (a1, b1, c1, d1, e1, f1)+                                                               ||| ((a0, b0, c0, d0, e0, f0) .== (a1, b1, c1, d1, e1, f1) &&& g0 .< g1)++-- | Symbolic Numbers. This is a simple class that simply incorporates all number like+-- base types together, simplifying writing polymorphic type-signatures that work for all+-- symbolic numbers, such as 'SWord8', 'SInt8' etc. For instance, we can write a generic+-- list-minimum function as follows:+--+-- @+--    mm :: SIntegral a => [SBV a] -> SBV a+--    mm = foldr1 (\a b -> ite (a .<= b) a b)+-- @+--+-- It is similar to the standard 'Integral' class, except ranging over symbolic instances.+class (SymWord a, Num a, Bits a) => SIntegral a++-- 'SIntegral' Instances, including all possible variants except 'Bool', since booleans+-- are not numbers.+instance SIntegral Word8+instance SIntegral Word16+instance SIntegral Word32+instance SIntegral Word64+instance SIntegral Int8+instance SIntegral Int16+instance SIntegral Int32+instance SIntegral Int64+instance SIntegral Integer++-- Boolean combinators+instance Boolean SBool where+  true  = literal True+  false = literal False+  bnot (SBV b) = SBV (svNot b)+  SBV a &&& SBV b = SBV (svAnd a b)+  SBV a ||| SBV b = SBV (svOr a b)+  SBV a <+> SBV b = SBV (svXOr a b)++-- | Returns (symbolic) true if all the elements of the given list are different.+allDifferent :: EqSymbolic a => [a] -> SBool+allDifferent []     = true+allDifferent (x:xs) = bAll (x ./=) xs &&& allDifferent xs++-- | Returns (symbolic) true if all the elements of the given list are the same.+allEqual :: EqSymbolic a => [a] -> SBool+allEqual []     = true+allEqual (x:xs) = bAll (x .==) xs++-- | Returns (symbolic) true if the argument is in range+inRange :: OrdSymbolic a => a -> (a, a) -> SBool+inRange x (y, z) = x .>= y &&& x .<= z++-- | Symbolic membership test+sElem :: EqSymbolic a => a -> [a] -> SBool+sElem x xs = bAny (.== x) xs++-- | Returns 1 if the boolean is true, otherwise 0.+oneIf :: (Num a, SymWord a) => SBool -> SBV a+oneIf t = ite t 1 0++-- | Predicate for optimizing word operations like (+) and (*).+isConcreteZero :: SBV a -> Bool+isConcreteZero (SBV (SVal _     (Left (CW _     (CWInteger n))))) = n == 0+isConcreteZero (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) = isExactRational v && v == 0+isConcreteZero _                                                  = False++-- | Predicate for optimizing word operations like (+) and (*).+isConcreteOne :: SBV a -> Bool+isConcreteOne (SBV (SVal _     (Left (CW _     (CWInteger 1))))) = True+isConcreteOne (SBV (SVal KReal (Left (CW KReal (CWAlgReal v))))) = isExactRational v && v == 1+isConcreteOne _                                                  = False++-- Num instance for symbolic words.+instance (Ord a, Num a, SymWord a) => Num (SBV a) where+  fromInteger = literal . fromIntegral+  SBV x + SBV y = SBV (svPlus x y)+  SBV x * SBV y = SBV (svTimes x y)+  SBV x - SBV y = SBV (svMinus x y)+  -- Abs is problematic for floating point, due to -0; case, so we carefully shuttle it down+  -- to the solver to avoid the can of worms. (Alternative would be to do an if-then-else here.)+  abs (SBV x) = SBV (svAbs x)+  signum a+    -- NB. The following "carefully" tests the number for == 0, as Float/Double's NaN and +/-0+    -- cases would cause trouble with explicit equality tests.+    | hasSign a = ite (a .> z) i+                $ ite (a .< z) (negate i) a+    | True      = ite (a .> z) i a+    where z = genLiteral (kindOf a) (0::Integer)+          i = genLiteral (kindOf a) (1::Integer)+  -- negate is tricky because on double/float -0 is different than 0; so we cannot+  -- just rely on the default definition; which would be 0-0, which is not -0!+  negate (SBV x) = SBV (svUNeg x)++-- | Symbolic exponentiation using bit blasting and repeated squaring.+--+-- N.B. The exponent must be unsigned. Signed exponents will be rejected.+(.^) :: (Mergeable b, Num b, SIntegral e) => b -> SBV e -> b+b .^ e | isSigned e = error "(.^): exponentiation only works with unsigned exponents"+       | True       = product $ zipWith (\use n -> ite use n 1)+                                        (blastLE e)+                                        (iterate (\x -> x*x) b)++instance (SymWord a, Fractional a) => Fractional (SBV a) where+  fromRational  = literal . fromRational+  SBV x / sy@(SBV y) | div0 = ite (sy .== 0) 0 res+                     | True = res+       where res  = SBV (svDivide x y)+             -- Identify those kinds where we have a div-0 equals 0 exception+             div0 = case kindOf sy of+                      KFloat        -> False+                      KDouble       -> False+                      KReal         -> True+                      -- Following two 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@KUserSort{} -> 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.+instance (SymWord 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++-- | Lift a 1 arg FP-op, using sRNE default+lift1F :: SymWord a => FPOp -> (a -> a) -> SBV a -> SBV a+lift1F w op a+  | Just v <- unliteral a+  = literal $ op v+  | True+  = SBV $ SVal k $ Right $ cache r+  where k    = kindOf a+        r st = do swa  <- sbvToSW st a+                  swm  <- sbvToSW st sRNE+                  newExpr st k (SBVApp (IEEEFP w) [swm, swa])++-- | Lift a float/double unary function, only over constants+lift1FNS :: (SymWord a, Floating a) => String -> (a -> a) -> SBV a -> SBV a+lift1FNS nm f sv+  | Just v <- unliteral sv = literal $ f v+  | True                   = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv)++-- | Lift a float/double binary function, only over constants+lift2FNS :: (SymWord a, Floating a) => String -> (a -> a -> a) -> SBV a -> SBV a -> SBV a+lift2FNS nm f sv1 sv2+  | Just v1 <- unliteral sv1+  , Just v2 <- unliteral sv2 = literal $ f v1 v2+  | True                     = error $ "SBV." ++ nm ++ ": not supported for symbolic values of type " ++ show (kindOf sv1)++-- NB. In the optimizations below, use of -1 is valid as+-- -1 has all bits set to True for both signed and unsigned values+instance (Num a, Bits a, SymWord a) => Bits (SBV a) where+  SBV x .&. SBV y    = SBV (svAnd x y)+  SBV x .|. SBV y    = SBV (svOr x y)+  SBV x `xor` SBV y  = SBV (svXOr x y)+  complement (SBV x) = SBV (svNot x)+  bitSize  x         = intSizeOf x+  bitSizeMaybe x     = Just $ intSizeOf x+  isSigned x         = hasSign x+  bit i              = 1 `shiftL` i+  setBit        x i  = x .|. genLiteral (kindOf x) (bit i :: Integer)+  clearBit      x i  = x .&. genLiteral (kindOf x) (complement (bit i) :: Integer)+  complementBit x i  = x `xor` genLiteral (kindOf x) (bit i :: Integer)+  shiftL  (SBV x) i  = SBV (svShl x i)+  shiftR  (SBV x) i  = SBV (svShr x i)+  rotateL (SBV x) i  = SBV (svRol x i)+  rotateR (SBV x) i  = SBV (svRor x i)+  -- NB. testBit is *not* implementable on non-concrete symbolic words+  x `testBit` i+    | SBV (SVal _ (Left (CW _ (CWInteger n)))) <- x+    = testBit n i+    | True+    = error $ "SBV.testBit: Called on symbolic value: " ++ show x ++ ". Use sTestBit instead."+  -- NB. popCount is *not* implementable on non-concrete symbolic words+  popCount x+    | SBV (SVal _ (Left (CW (KBounded _ w) (CWInteger n)))) <- x+    = popCount (n .&. (bit w - 1))+    | True+    = error $ "SBV.popCount: Called on symbolic value: " ++ show x ++ ". Use sPopCount instead."++-- | Replacement for 'testBit'. Since 'testBit' requires a 'Bool' to be returned,+-- we cannot implement it for symbolic words. Index 0 is the least-significant bit.+sTestBit :: SBV a -> Int -> SBool+sTestBit (SBV x) i = SBV (svTestBit x i)++-- | Variant of 'sTestBit', where we want to extract multiple bit positions.+sExtractBits :: SBV a -> [Int] -> [SBool]+sExtractBits x = map (sTestBit x)++-- | Replacement for 'popCount'. Since 'popCount' returns an 'Int', we cannot implement+-- it for symbolic words. Here, we return an 'SWord8', which can overflow when used on+-- quantities that have more than 255 bits. Currently, that's only the 'SInteger' type+-- that SBV supports, all other types are safe. Even with 'SInteger', this will only+-- overflow if there are at least 256-bits set in the number, and the smallest such+-- number is 2^256-1, which is a pretty darn big number to worry about for practical+-- purposes. In any case, we do not support 'sPopCount' for unbounded symbolic integers,+-- as the only possible implementation wouldn't symbolically terminate. So the only overflow+-- issue is with really-really large concrete 'SInteger' values.+sPopCount :: (Num a, Bits a, SymWord a) => SBV a -> SWord8+sPopCount x+  | isReal x          = error "SBV.sPopCount: Called on a real value" -- can't really happen due to types, but being overcautious+  | isConcrete x      = go 0 x+  | not (isBounded x) = error "SBV.sPopCount: Called on an infinite precision symbolic value"+  | True              = sum [ite b 1 0 | b <- blastLE x]+  where -- concrete case+        go !c 0 = c+        go !c w = go (c+1) (w .&. (w-1))++-- | Generalization of 'setBit' based on a symbolic boolean. Note that 'setBit' and+-- 'clearBit' are still available on Symbolic words, this operation comes handy when+-- the condition to set/clear happens to be symbolic.+setBitTo :: (Num a, Bits a, SymWord a) => SBV a -> Int -> SBool -> SBV a+setBitTo x i b = ite b (setBit x i) (clearBit x i)++-- | Conversion between integral-symbolic values, akin to Haskell's fromIntegral+sFromIntegral :: forall a b. (Integral a, HasKind a, Num a, SymWord a, HasKind b, Num b, SymWord b) => SBV a -> SBV b+sFromIntegral x+  | isReal x+  = error "SBV.sFromIntegral: Called on a real value" -- can't really happen due to types, but being overcautious+  | Just v <- unliteral x+  = literal (fromIntegral v)+  | True+  = result+  where result = SBV (SVal kTo (Right (cache y)))+        kFrom  = kindOf x+        kTo    = kindOf (undefined :: b)+        y st   = do xsw <- sbvToSW st x+                    newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsw])++-- | Generalization of 'shiftL', when the shift-amount is symbolic. Since Haskell's+-- 'shiftL' only takes an 'Int' as the shift amount, it cannot be used when we have+-- a symbolic amount to shift with. The first argument should be a bounded quantity.+sShiftLeft :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a+sShiftLeft x i+  | not (isBounded x)+  = error "SBV.sShiftRight: Shifted amount should be a bounded quantity!"+  | True+  = ite (i .< 0)+        (select [x `shiftR` k | k <- [0 .. ghcBitSize x - 1]] z (-i))+        (select [x `shiftL` k | k <- [0 .. ghcBitSize x - 1]] z   i )+  where z = genLiteral (kindOf x) (0::Integer)++-- | Generalization of 'shiftR', when the shift-amount is symbolic. Since Haskell's+-- 'shiftR' only takes an 'Int' as the shift amount, it cannot be used when we have+-- a symbolic amount to shift with. The first argument should be a bounded quantity.+--+-- NB. If the shiftee is signed, then this is an arithmetic shift; otherwise it's logical,+-- following the usual Haskell convention. See 'sSignedShiftArithRight' for a variant+-- that explicitly uses the msb as the sign bit, even for unsigned underlying types.+sShiftRight :: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a+sShiftRight x i+  | not (isBounded x)+  = error "SBV.sShiftRight: Shifted amount should be a bounded quantity!"+  | True+  = ite (i .< 0)+        (select [x `shiftL` k | k <- [0 .. ghcBitSize x - 1]] z (-i))+        (select [x `shiftR` k | k <- [0 .. ghcBitSize x - 1]] z   i )+  where z = genLiteral (kindOf x) (0::Integer)++-- | Arithmetic shift-right with a symbolic unsigned shift amount. This is equivalent+-- to 'sShiftRight' when the argument is signed. However, if the argument is unsigned,+-- then it explicitly treats its msb as a sign-bit, and uses it as the bit that+-- gets shifted in. Useful when using the underlying unsigned bit representation to implement+-- custom signed operations. Note that there is no direct Haskell analogue of this function.+sSignedShiftArithRight:: (SIntegral a, SIntegral b) => SBV a -> SBV b -> SBV a+sSignedShiftArithRight x i+  | isSigned i = error "sSignedShiftArithRight: shift amount should be unsigned"+  | isSigned x = sShiftRight x i+  | True       = ite (msb x)+                     (complement (sShiftRight (complement x) i))+                     (sShiftRight x i)++-- | Generalization of 'rotateL', when the shift-amount is symbolic. Since Haskell's+-- 'rotateL' only takes an 'Int' as the shift amount, it cannot be used when we have+-- a symbolic amount to shift with. The first argument should be a bounded quantity.+sRotateLeft :: (SIntegral a, SIntegral b, SDivisible (SBV b)) => SBV a -> SBV b -> SBV a+sRotateLeft x i+  | not (isBounded x)+  = sShiftLeft x i+  | isBounded i && bit si <= toInteger sx    -- wrap-around not possible+  = ite (i .< 0)+        (select [x `rotateR` k | k <- [0 .. bit si - 1]] z (-i))+        (select [x `rotateL` k | k <- [0 .. bit si - 1]] z   i )+  | True+  = ite (i .< 0)+        (select [x `rotateR` k | k <- [0 .. sx     - 1]] z ((-i) `sRem` n))+        (select [x `rotateL` k | k <- [0 .. sx     - 1]] z (  i  `sRem` n))+    where sx = ghcBitSize x+          si = ghcBitSize i+          z  = genLiteral (kindOf x) (0::Integer)+          n  = genLiteral (kindOf i) (toInteger sx)++-- | Generalization of 'rotateR', when the shift-amount is symbolic. Since Haskell's+-- 'rotateR' only takes an 'Int' as the shift amount, it cannot be used when we have+-- a symbolic amount to shift with. The first argument should be a bounded quantity.+sRotateRight :: (SIntegral a, SIntegral b, SDivisible (SBV b)) => SBV a -> SBV b -> SBV a+sRotateRight x i+  | not (isBounded x)+  = sShiftRight x i+  | isBounded i && bit si <= toInteger sx   -- wrap-around not possible+  = ite (i .< 0)+        (select [x `rotateL` k | k <- [0 .. bit si - 1]] z (-i))+        (select [x `rotateR` k | k <- [0 .. bit si - 1]] z   i)+  | True+  = ite (i .< 0)+        (select [x `rotateL` k | k <- [0 .. sx     - 1]] z ((-i) `sRem` n))+        (select [x `rotateR` k | k <- [0 .. sx     - 1]] z (  i  `sRem` n))+    where sx = ghcBitSize x+          si = ghcBitSize i+          z  = genLiteral (kindOf x) (0::Integer)+          n  = genLiteral (kindOf i) (toInteger sx)++-- | Full adder. Returns the carry-out from the addition.+--+-- N.B. Only works for unsigned types. Signed arguments will be rejected.+fullAdder :: SIntegral a => SBV a -> SBV a -> (SBool, SBV a)+fullAdder a b+  | isSigned a = error "fullAdder: only works on unsigned numbers"+  | True       = (a .> s ||| b .> s, s)+  where s = a + b++-- | Full multiplier: Returns both the high-order and the low-order bits in a tuple,+-- thus fully accounting for the overflow.+--+-- N.B. Only works for unsigned types. Signed arguments will be rejected.+--+-- N.B. The higher-order bits are determined using a simple shift-add multiplier,+-- thus involving bit-blasting. It'd be naive to expect SMT solvers to deal efficiently+-- with properties involving this function, at least with the current state of the art.+fullMultiplier :: SIntegral a => SBV a -> SBV a -> (SBV a, SBV a)+fullMultiplier a b+  | isSigned a = error "fullMultiplier: only works on unsigned numbers"+  | True       = (go (ghcBitSize a) 0 a, a*b)+  where go 0 p _ = p+        go n p x = let (c, p')  = ite (lsb x) (fullAdder p b) (false, p)+                       (o, p'') = shiftIn c p'+                       (_, x')  = shiftIn o x+                   in go (n-1) p'' x'+        shiftIn k v = (lsb v, mask .|. (v `shiftR` 1))+           where mask = ite k (bit (ghcBitSize v - 1)) 0++-- | Little-endian blasting of a word into its bits. Also see the 'FromBits' class.+blastLE :: (Num a, Bits a, SymWord a) => SBV a -> [SBool]+blastLE x+ | isReal x          = error "SBV.blastLE: Called on a real value"+ | not (isBounded x) = error "SBV.blastLE: Called on an infinite precision value"+ | True              = map (sTestBit x) [0 .. intSizeOf x - 1]++-- | Big-endian blasting of a word into its bits. Also see the 'FromBits' class.+blastBE :: (Num a, Bits a, SymWord a) => SBV a -> [SBool]+blastBE = reverse . blastLE++-- | Least significant bit of a word, always stored at index 0.+lsb :: SBV a -> SBool+lsb x = sTestBit x 0++-- | Most significant bit of a word, always stored at the last position.+msb :: (Num a, Bits a, SymWord a) => SBV a -> SBool+msb x+ | isReal x          = error "SBV.msb: Called on a real value"+ | not (isBounded x) = error "SBV.msb: Called on an infinite precision value"+ | True              = sTestBit x (intSizeOf x - 1)++-- Enum instance. These instances are suitable for use with concrete values,+-- and will be less useful for symbolic values around. Note that `fromEnum` requires+-- a concrete argument for obvious reasons. Other variants (succ, pred, [x..]) etc are similarly+-- limited. While symbolic variants can be defined for many of these, they will just diverge+-- as final sizes cannot be determined statically.+instance (Show a, Bounded a, Integral a, Num a, SymWord a) => Enum (SBV a) where+  succ x+    | v == (maxBound :: a) = error $ "Enum.succ{" ++ showType x ++ "}: tried to take `succ' of maxBound"+    | True                 = fromIntegral $ v + 1+    where v = enumCvt "succ" x+  pred x+    | v == (minBound :: a) = error $ "Enum.pred{" ++ showType x ++ "}: tried to take `pred' of minBound"+    | True                 = fromIntegral $ v - 1+    where v = enumCvt "pred" x+  toEnum x+    | xi < fromIntegral (minBound :: a) || xi > fromIntegral (maxBound :: a)+    = error $ "Enum.toEnum{" ++ showType r ++ "}: " ++ show x ++ " is out-of-bounds " ++ show (minBound :: a, maxBound :: a)+    | True+    = r+    where xi :: Integer+          xi = fromIntegral x+          r  :: SBV a+          r  = fromIntegral x+  fromEnum x+     | r < fromIntegral (minBound :: Int) || r > fromIntegral (maxBound :: Int)+     = error $ "Enum.fromEnum{" ++ showType x ++ "}:  value " ++ show r ++ " is outside of Int's bounds " ++ show (minBound :: Int, maxBound :: Int)+     | True+     = fromIntegral r+    where r :: Integer+          r = enumCvt "fromEnum" x+  enumFrom x = map fromIntegral [xi .. fromIntegral (maxBound :: a)]+     where xi :: Integer+           xi = enumCvt "enumFrom" x+  enumFromThen x y+     | yi >= xi  = map fromIntegral [xi, yi .. fromIntegral (maxBound :: a)]+     | True      = map fromIntegral [xi, yi .. fromIntegral (minBound :: a)]+       where xi, yi :: Integer+             xi = enumCvt "enumFromThen.x" x+             yi = enumCvt "enumFromThen.y" y+  enumFromThenTo x y z = map fromIntegral [xi, yi .. zi]+       where xi, yi, zi :: Integer+             xi = enumCvt "enumFromThenTo.x" x+             yi = enumCvt "enumFromThenTo.y" y+             zi = enumCvt "enumFromThenTo.z" z++-- | Helper function for use in enum operations+enumCvt :: (SymWord a, Integral a, Num b) => String -> SBV a -> b+enumCvt w x = case unliteral x of+                Nothing -> error $ "Enum." ++ w ++ "{" ++ showType x ++ "}: Called on symbolic value " ++ show x+                Just v  -> fromIntegral v++-- | The 'SDivisible' class captures the essence of division.+-- Unfortunately we cannot use Haskell's 'Integral' class since the 'Real'+-- and 'Enum' superclasses are not implementable for symbolic bit-vectors.+-- However, 'quotRem' and 'divMod' makes perfect sense, and the 'SDivisible' class captures+-- this operation. One issue is how division by 0 behaves. The verification+-- technology requires total functions, and there are several design choices+-- here. We follow Isabelle/HOL approach of assigning the value 0 for division+-- by 0. Therefore, we impose the following pair of laws:+--+-- @+--      x `sQuotRem` 0 = (0, x)+--      x `sDivMod`  0 = (0, x)+-- @+--+-- Note that our instances implement this law even when @x@ is @0@ itself.+--+-- NB. 'quot' truncates toward zero, while 'div' truncates toward negative infinity.+--+-- Minimal complete definition: 'sQuotRem', 'sDivMod'+class SDivisible a where+  sQuotRem :: a -> a -> (a, a)+  sDivMod  :: a -> a -> (a, a)+  sQuot    :: a -> a -> a+  sRem     :: a -> a -> a+  sDiv     :: a -> a -> a+  sMod     :: a -> a -> a++  x `sQuot` y = fst $ x `sQuotRem` y+  x `sRem`  y = snd $ x `sQuotRem` y+  x `sDiv`  y = fst $ x `sDivMod`  y+  x `sMod`  y = snd $ x `sDivMod`  y++instance SDivisible Word64 where+  sQuotRem x 0 = (0, x)+  sQuotRem x y = x `quotRem` y+  sDivMod  x 0 = (0, x)+  sDivMod  x y = x `divMod` y++instance SDivisible Int64 where+  sQuotRem x 0 = (0, x)+  sQuotRem x y = x `quotRem` y+  sDivMod  x 0 = (0, x)+  sDivMod  x y = x `divMod` y++instance SDivisible Word32 where+  sQuotRem x 0 = (0, x)+  sQuotRem x y = x `quotRem` y+  sDivMod  x 0 = (0, x)+  sDivMod  x y = x `divMod` y++instance SDivisible Int32 where+  sQuotRem x 0 = (0, x)+  sQuotRem x y = x `quotRem` y+  sDivMod  x 0 = (0, x)+  sDivMod  x y = x `divMod` y++instance SDivisible Word16 where+  sQuotRem x 0 = (0, x)+  sQuotRem x y = x `quotRem` y+  sDivMod  x 0 = (0, x)+  sDivMod  x y = x `divMod` y++instance SDivisible Int16 where+  sQuotRem x 0 = (0, x)+  sQuotRem x y = x `quotRem` y+  sDivMod  x 0 = (0, x)+  sDivMod  x y = x `divMod` y++instance SDivisible Word8 where+  sQuotRem x 0 = (0, x)+  sQuotRem x y = x `quotRem` y+  sDivMod  x 0 = (0, x)+  sDivMod  x y = x `divMod` y++instance SDivisible Int8 where+  sQuotRem x 0 = (0, x)+  sQuotRem x y = x `quotRem` y+  sDivMod  x 0 = (0, x)+  sDivMod  x y = x `divMod` y++instance SDivisible Integer where+  sQuotRem x 0 = (0, x)+  sQuotRem x y = x `quotRem` y+  sDivMod  x 0 = (0, x)+  sDivMod  x y = x `divMod` y++instance SDivisible CW where+  sQuotRem a b+    | CWInteger x <- cwVal a, CWInteger y <- cwVal b+    = let (r1, r2) = sQuotRem x y in (normCW a{ cwVal = CWInteger r1 }, normCW b{ cwVal = CWInteger r2 })+  sQuotRem a b = error $ "SBV.sQuotRem: impossible, unexpected args received: " ++ show (a, b)+  sDivMod a b+    | CWInteger x <- cwVal a, CWInteger y <- cwVal b+    = let (r1, r2) = sDivMod x y in (normCW a { cwVal = CWInteger r1 }, normCW b { cwVal = CWInteger r2 })+  sDivMod a b = error $ "SBV.sDivMod: impossible, unexpected args received: " ++ show (a, b)++instance SDivisible SWord64 where+  sQuotRem = liftQRem+  sDivMod  = liftDMod++instance SDivisible SInt64 where+  sQuotRem = liftQRem+  sDivMod  = liftDMod++instance SDivisible SWord32 where+  sQuotRem = liftQRem+  sDivMod  = liftDMod++instance SDivisible SInt32 where+  sQuotRem = liftQRem+  sDivMod  = liftDMod++instance SDivisible SWord16 where+  sQuotRem = liftQRem+  sDivMod  = liftDMod++instance SDivisible SInt16 where+  sQuotRem = liftQRem+  sDivMod  = liftDMod++instance SDivisible SWord8 where+  sQuotRem = liftQRem+  sDivMod  = liftDMod++instance SDivisible SInt8 where+  sQuotRem = liftQRem+  sDivMod  = liftDMod++-- | Lift 'QRem' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which+-- holds even when @x@ is @0@ itself.+liftQRem :: SymWord a => SBV a -> SBV a -> (SBV a, SBV a)+liftQRem x y+  | isConcreteZero x+  = (x, x)+  | isConcreteOne y+  = (x, z)+{-------------------------------+ - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed;+ - and also is problematic around the minBound.. So, we refrain from that optimization+  | isConcreteOnes y+  = (-x, z)+--------------------------------}+  | True+  = ite (y .== z) (z, x) (qr x y)+  where qr (SBV (SVal sgnsz (Left a))) (SBV (SVal _ (Left b))) = let (q, r) = sQuotRem a b in (SBV (SVal sgnsz (Left q)), SBV (SVal sgnsz (Left r)))+        qr a@(SBV (SVal sgnsz _))      b                       = (SBV (SVal sgnsz (Right (cache (mk Quot)))), SBV (SVal sgnsz (Right (cache (mk Rem)))))+                where mk o st = do sw1 <- sbvToSW st a+                                   sw2 <- sbvToSW st b+                                   mkSymOp o st sgnsz sw1 sw2+        z = genLiteral (kindOf x) (0::Integer)++-- | Lift 'DMod' to symbolic words. Division by 0 is defined s.t. @x/0 = 0@; which+-- holds even when @x@ is @0@ itself. Essentially, this is conversion from quotRem+-- (truncate to 0) to divMod (truncate towards negative infinity)+liftDMod :: (SymWord a, Num a, SDivisible (SBV a)) => SBV a -> SBV a -> (SBV a, SBV a)+liftDMod x y+  | isConcreteZero x+  = (x, x)+  | isConcreteOne y+  = (x, z)+{-------------------------------+ - N.B. The seemingly innocuous variant when y == -1 only holds if the type is signed;+ - and also is problematic around the minBound.. So, we refrain from that optimization+  | isConcreteOnes y+  = (-x, z)+--------------------------------}+  | True+  = ite (y .== z) (z, x) $ ite (signum r .== negate (signum y)) (q-i, r+y) qr+ where qr@(q, r) = x `sQuotRem` y+       z = genLiteral (kindOf x) (0::Integer)+       i = genLiteral (kindOf x) (1::Integer)++-- SInteger instance for quotRem/divMod are tricky!+-- SMT-Lib only has Euclidean operations, but Haskell+-- uses "truncate to 0" for quotRem, and "truncate to negative infinity" for divMod.+-- So, we cannot just use the above liftings directly.+instance SDivisible SInteger where+  sDivMod = liftDMod+  sQuotRem x y+    | not (isSymbolic x || isSymbolic y)+    = liftQRem x y+    | True+    = ite (y .== 0) (0, x) (qE+i, rE-i*y)+    where (qE, rE) = liftQRem x y   -- for integers, this is euclidean due to SMTLib semantics+          i = ite (x .>= 0 ||| rE .== 0) 0+            $ ite (y .>  0)              1 (-1)++-- Quickcheck interface++-- The Arbitrary instance for SFunArray returns an array initialized+-- to an arbitrary element+instance (SymWord b, Arbitrary b) => Arbitrary (SFunArray a b) where+  arbitrary = arbitrary >>= \r -> return $ SFunArray (const r)++instance (SymWord a, Arbitrary a) => Arbitrary (SBV a) where+  arbitrary = literal `fmap` arbitrary++-- |  Symbolic conditionals are modeled by the 'Mergeable' class, describing+-- how to merge the results of an if-then-else call with a symbolic test. SBV+-- provides all basic types as instances of this class, so users only need+-- to declare instances for custom data-types of their programs as needed.+--+-- A 'Mergeable' instance may be automatically derived for a custom data-type+-- with a single constructor where the type of each field is an instance of+-- 'Mergeable', such as a record of symbolic values. Users only need to add+-- 'G.Generic' and 'Mergeable' to the @deriving@ clause for the data-type. See+-- 'Data.SBV.Examples.Puzzles.U2Bridge.Status' for an example and an+-- illustration of what the instance would look like if written by hand.+--+-- The function 'select' is a total-indexing function out of a list of choices+-- with a default value, simulating array/list indexing. It's an n-way generalization+-- of the 'ite' function.+--+-- Minimal complete definition: None, if the type is instance of 'Generic'. Otherwise+-- 'symbolicMerge'. Note that most types subject to merging are likely to be+-- trivial instances of 'Generic'.+class Mergeable a where+   -- | Merge two values based on the condition. The first argument states+   -- whether we force the then-and-else branches before the merging, at the+   -- word level. This is an efficiency concern; one that we'd rather not+   -- make but unfortunately necessary for getting symbolic simulation+   -- working efficiently.+   symbolicMerge :: Bool -> SBool -> a -> a -> a+   -- | Total indexing operation. @select xs default index@ is intuitively+   -- the same as @xs !! index@, except it evaluates to @default@ if @index@+   -- underflows/overflows.+   select :: (SymWord b, Num b) => [a] -> a -> SBV b -> a+   -- NB. Earlier implementation of select used the binary-search trick+   -- on the index to chop down the search space. While that is a good trick+   -- in general, it doesn't work for SBV since we do not have any notion of+   -- "concrete" subwords: If an index is symbolic, then all its bits are+   -- symbolic as well. So, the binary search only pays off only if the indexed+   -- list is really humongous, which is not very common in general. (Also,+   -- for the case when the list is bit-vectors, we use SMT tables anyhow.)+   select xs err ind+    | isReal   ind = bad "real"+    | isFloat  ind = bad "float"+    | isDouble ind = bad "double"+    | hasSign  ind = ite (ind .< 0) err (walk xs ind err)+    | True         =                     walk xs ind err+    where bad w = error $ "SBV.select: unsupported " ++ w ++ " valued select/index expression"+          walk []     _ acc = acc+          walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc)++   -- Default implementation for 'symbolicMerge' if the type is 'Generic'+   default symbolicMerge :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a+   symbolicMerge = symbolicMergeDefault+++-- | If-then-else. This is by definition 'symbolicMerge' with both+-- branches forced. This is typically the desired behavior, but also+-- see 'iteLazy' should you need more laziness.+ite :: Mergeable a => SBool -> a -> a -> a+ite t a b+  | Just r <- unliteral t = if r then a else b+  | True                  = symbolicMerge True t a b++-- | A Lazy version of ite, which does not force its arguments. This might+-- cause issues for symbolic simulation with large thunks around, so use with+-- care.+iteLazy :: Mergeable a => SBool -> a -> a -> a+iteLazy t a b+  | Just r <- unliteral t = if r then a else b+  | True                  = symbolicMerge False t a b++-- | Symbolic assert. Check that the given boolean condition is always true in the given path. The+-- optional first argument can be used to provide call-stack info via GHC's location facilities.+sAssert :: Maybe CallStack -> String -> SBool -> SBV a -> SBV a+sAssert cs msg cond x = SBV $ SVal k $ Right $ cache r+  where k     = kindOf x+        r st  = do xsw <- sbvToSW st x+                   let pc = getPathCondition st+                       -- We're checking if there are any cases where the path-condition holds, but not the condition+                       -- Any violations of this, should be signaled, i.e., whenever the following formula is satisfiable+                       mustNeverHappen = pc &&& bnot cond+                   cnd <- sbvToSW st mustNeverHappen+                   addAssertion st cs msg cnd+                   return xsw++-- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make+-- sure they do not evaluate to the same result. This should only be used for internal purposes;+-- as default definitions provided should suffice in many cases. (i.e., End users should+-- only need to define 'symbolicMerge' when needed; which should be rare to start with.)+symbolicMergeWithKind :: Kind -> Bool -> SBool -> SBV a -> SBV a -> SBV a+symbolicMergeWithKind k force (SBV t) (SBV a) (SBV b) = SBV (svSymbolicMerge k force t a b)++instance SymWord a => Mergeable (SBV a) where+    symbolicMerge force t x y+    -- Carefully use the kindOf instance to avoid strictness issues.+       | force = symbolicMergeWithKind (kindOf x)                True  t x y+       | True  = symbolicMergeWithKind (kindOf (undefined :: a)) False t x y+    -- Custom version of select that translates to SMT-Lib tables at the base type of words+    select xs err ind+      | SBV (SVal _ (Left c)) <- ind = case cwVal c of+                                         CWInteger i -> if i < 0 || i >= genericLength xs+                                                        then err+                                                        else xs `genericIndex` i+                                         _           -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"+    select xsOrig err ind = xs `seq` SBV (SVal kElt (Right (cache r)))+      where kInd = kindOf ind+            kElt = kindOf err+            -- Based on the index size, we need to limit the elements. For instance if the index is 8 bits, but there+            -- are 257 elements, that last element will never be used and we can chop it of..+            xs   = case kindOf ind of+                     KBounded False i -> genericTake ((2::Integer) ^ (fromIntegral i     :: Integer)) xsOrig+                     KBounded True  i -> genericTake ((2::Integer) ^ (fromIntegral (i-1) :: Integer)) xsOrig+                     KUnbounded       -> xsOrig+                     _                -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"+            r st  = do sws <- mapM (sbvToSW st) xs+                       swe <- sbvToSW st err+                       if all (== swe) sws  -- off-chance that all elts are the same. Note that this also correctly covers the case when list is empty.+                          then return swe+                          else do idx <- getTableIndex st kInd kElt sws+                                  swi <- sbvToSW st ind+                                  let len = length xs+                                  -- NB. No need to worry here that the index might be < 0; as the SMTLib translation takes care of that automatically+                                  newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) [])++-- Unit+instance Mergeable () where+   symbolicMerge _ _ _ _ = ()+   select _ _ _ = ()++-- Mergeable instances for List/Maybe/Either/Array are useful, but can+-- throw exceptions if there is no structural matching of the results+-- It's a question whether we should really keep them..++-- Lists+instance Mergeable a => Mergeable [a] where+  symbolicMerge f t xs ys+    | lxs == lys = zipWith (symbolicMerge f t) xs ys+    | True       = error $ "SBV.Mergeable.List: No least-upper-bound for lists of differing size " ++ show (lxs, lys)+    where (lxs, lys) = (length xs, length ys)++-- Maybe+instance Mergeable a => Mergeable (Maybe a) where+  symbolicMerge _ _ Nothing  Nothing  = Nothing+  symbolicMerge f t (Just a) (Just b) = Just $ symbolicMerge f t a b+  symbolicMerge _ _ a b = error $ "SBV.Mergeable.Maybe: No least-upper-bound for " ++ show (k a, k b)+      where k Nothing = "Nothing"+            k _       = "Just"++-- Either+instance (Mergeable a, Mergeable b) => Mergeable (Either a b) where+  symbolicMerge f t (Left a)  (Left b)  = Left  $ symbolicMerge f t a b+  symbolicMerge f t (Right a) (Right b) = Right $ symbolicMerge f t a b+  symbolicMerge _ _ a b = error $ "SBV.Mergeable.Either: No least-upper-bound for " ++ show (k a, k b)+     where k (Left _)  = "Left"+           k (Right _) = "Right"++-- Arrays+instance (Ix a, Mergeable b) => Mergeable (Array a b) where+  symbolicMerge f t a b+    | ba == bb = listArray ba (zipWith (symbolicMerge f t) (elems a) (elems b))+    | True     = error $ "SBV.Mergeable.Array: No least-upper-bound for rangeSizes" ++ show (k ba, k bb)+    where [ba, bb] = map bounds [a, b]+          k = rangeSize++-- Functions+instance Mergeable b => Mergeable (a -> b) where+  symbolicMerge f t g h x = symbolicMerge f t (g x) (h x)+  {- Following definition, while correct, is utterly inefficient. Since the+     application is delayed, this hangs on to the inner list and all the+     impending merges, even when ind is concrete. Thus, it's much better to+     simply use the default definition for the function case.+  -}+  -- select xs err ind = \x -> select (map ($ x) xs) (err x) ind++-- 2-Tuple+instance (Mergeable a, Mergeable b) => Mergeable (a, b) where+  symbolicMerge f t (i0, i1) (j0, j1) = (i i0 j0, i i1 j1)+    where i a b = symbolicMerge f t a b+  select xs (err1, err2) ind = (select as err1 ind, select bs err2 ind)+    where (as, bs) = unzip xs++-- 3-Tuple+instance (Mergeable a, Mergeable b, Mergeable c) => Mergeable (a, b, c) where+  symbolicMerge f t (i0, i1, i2) (j0, j1, j2) = (i i0 j0, i i1 j1, i i2 j2)+    where i a b = symbolicMerge f t a b+  select xs (err1, err2, err3) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind)+    where (as, bs, cs) = unzip3 xs++-- 4-Tuple+instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => Mergeable (a, b, c, d) where+  symbolicMerge f t (i0, i1, i2, i3) (j0, j1, j2, j3) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3)+    where i a b = symbolicMerge f t a b+  select xs (err1, err2, err3, err4) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind)+    where (as, bs, cs, ds) = unzip4 xs++-- 5-Tuple+instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => Mergeable (a, b, c, d, e) where+  symbolicMerge f t (i0, i1, i2, i3, i4) (j0, j1, j2, j3, j4) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4)+    where i a b = symbolicMerge f t a b+  select xs (err1, err2, err3, err4, err5) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind)+    where (as, bs, cs, ds, es) = unzip5 xs++-- 6-Tuple+instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f) => Mergeable (a, b, c, d, e, f) where+  symbolicMerge f t (i0, i1, i2, i3, i4, i5) (j0, j1, j2, j3, j4, j5) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4, i i5 j5)+    where i a b = symbolicMerge f t a b+  select xs (err1, err2, err3, err4, err5, err6) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind, select fs err6 ind)+    where (as, bs, cs, ds, es, fs) = unzip6 xs++-- 7-Tuple+instance (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e, Mergeable f, Mergeable g) => Mergeable (a, b, c, d, e, f, g) where+  symbolicMerge f t (i0, i1, i2, i3, i4, i5, i6) (j0, j1, j2, j3, j4, j5, j6) = (i i0 j0, i i1 j1, i i2 j2, i i3 j3, i i4 j4, i i5 j5, i i6 j6)+    where i a b = symbolicMerge f t a b+  select xs (err1, err2, err3, err4, err5, err6, err7) ind = (select as err1 ind, select bs err2 ind, select cs err3 ind, select ds err4 ind, select es err5 ind, select fs err6 ind, select gs err7 ind)+    where (as, bs, cs, ds, es, fs, gs) = unzip7 xs++-- Arbitrary product types, using GHC.Generics+--+-- NB: Because of the way GHC.Generics works, the implementation of+-- symbolicMerge' is recursive. The derived instance for @data T a = T a a a a@+-- resembles that for (a, (a, (a, a))), not the flat 4-tuple (a, a, a, a). This+-- difference should have no effect in practice. Note also that, unlike the+-- hand-rolled tuple instances, the generic instance does not provide a custom+-- 'select' implementation, and so does not benefit from the SMT-table+-- implementation in the 'SBV a' instance.++-- | Not exported. Symbolic merge using the generic representation provided by+-- 'G.Generics'.+symbolicMergeDefault :: (G.Generic a, GMergeable (G.Rep a)) => Bool -> SBool -> a -> a -> a+symbolicMergeDefault force t x y = G.to $ symbolicMerge' force t (G.from x) (G.from y)++-- | Not exported. Used only in 'symbolicMergeDefault'. Instances are provided for+-- the generic representations of product types where each element is Mergeable.+class GMergeable f where+  symbolicMerge' :: Bool -> SBool -> f a -> f a -> f a++instance GMergeable U1 where+  symbolicMerge' _ _ _ _ = U1++instance (Mergeable c) => GMergeable (K1 i c) where+  symbolicMerge' force t (K1 x) (K1 y) = K1 $ symbolicMerge force t x y++instance (GMergeable f) => GMergeable (M1 i c f) where+  symbolicMerge' force t (M1 x) (M1 y) = M1 $ symbolicMerge' force t x y++instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where+  symbolicMerge' force t (x1 :*: y1) (x2 :*: y2) = symbolicMerge' force t x1 x2 :*: symbolicMerge' force t y1 y2++-- Bounded instances+instance (SymWord a, Bounded a) => Bounded (SBV a) where+  minBound = literal minBound+  maxBound = literal maxBound++-- Arrays++-- SArrays are both "EqSymbolic" and "Mergeable"+instance EqSymbolic (SArray a b) where+  (SArray a) .== (SArray b) = SBV (eqSArr a b)++-- When merging arrays; we'll ignore the force argument. This is arguably+-- the right thing to do as we've too many things and likely we want to keep it efficient.+instance SymWord b => Mergeable (SArray a b) where+  symbolicMerge _ = mergeArrays++-- SFunArrays are only "Mergeable". Although a brute+-- force equality can be defined, any non-toy instance+-- will suffer from efficiency issues; so we don't define it+instance SymArray SFunArray where+  newArray _                                  = newArray_ -- the name is irrelevant in this case+  newArray_     mbiVal                        = declNewSFunArray mbiVal+  readArray     (SFunArray f)                 = f+  resetArray    (SFunArray _) a               = SFunArray $ const a+  writeArray    (SFunArray f) a b             = SFunArray (\a' -> ite (a .== a') b (f a'))+  mergeArrays t (SFunArray g)   (SFunArray h) = SFunArray (\x -> ite t (g x) (h x))++-- When merging arrays; we'll ignore the force argument. This is arguably+-- the right thing to do as we've too many things and likely we want to keep it efficient.+instance SymWord b => Mergeable (SFunArray a b) where+  symbolicMerge _ = mergeArrays++-- | Uninterpreted constants and functions. An uninterpreted constant is+-- a value that is indexed by its name. The only property the prover assumes+-- about these values are that they are equivalent to themselves; i.e., (for+-- functions) they return the same results when applied to same arguments.+-- We support uninterpreted-functions as a general means of black-box'ing+-- operations that are /irrelevant/ for the purposes of the proof; i.e., when+-- the proofs can be performed without any knowledge about the function itself.+--+-- Minimal complete definition: 'sbvUninterpret'. However, most instances in+-- practice are already provided by SBV, so end-users should not need to define their+-- own instances.+class Uninterpreted a where+  -- | Uninterpret a value, receiving an object that can be used instead. Use this version+  -- when you do not need to add an axiom about this value.+  uninterpret :: String -> a+  -- | Uninterpret a value, only for the purposes of code-generation. For execution+  -- and verification the value is used as is. For code-generation, the alternate+  -- definition is used. This is useful when we want to take advantage of native+  -- libraries on the target languages.+  cgUninterpret :: String -> [String] -> a -> a+  -- | Most generalized form of uninterpretation, this function should not be needed+  -- by end-user-code, but is rather useful for the library development.+  sbvUninterpret :: Maybe ([String], a) -> String -> a++  -- minimal complete definition: 'sbvUninterpret'+  uninterpret             = sbvUninterpret Nothing+  cgUninterpret nm code v = sbvUninterpret (Just (code, v)) nm++-- Plain constants+instance HasKind a => Uninterpreted (SBV a) where+  sbvUninterpret mbCgData nm+     | Just (_, v) <- mbCgData = v+     | True                    = SBV $ SVal ka $ Right $ cache result+    where ka = kindOf (undefined :: a)+          result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st v+                    | True = do newUninterpreted st nm (SBVType [ka]) (fst `fmap` mbCgData)+                                newExpr st ka $ SBVApp (Uninterpreted nm) []++-- Functions of one argument+instance (SymWord b, HasKind a) => Uninterpreted (SBV b -> SBV a) where+  sbvUninterpret mbCgData nm = f+    where f arg0+           | Just (_, v) <- mbCgData, isConcrete arg0+           = v arg0+           | True+           = SBV $ SVal ka $ Right $ cache result+           where ka = kindOf (undefined :: a)+                 kb = kindOf (undefined :: b)+                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0)+                           | True = do newUninterpreted st nm (SBVType [kb, ka]) (fst `fmap` mbCgData)+                                       sw0 <- sbvToSW st arg0+                                       mapM_ forceSWArg [sw0]+                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0]++-- Functions of two arguments+instance (SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV c -> SBV b -> SBV a) where+  sbvUninterpret mbCgData nm = f+    where f arg0 arg1+           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1+           = v arg0 arg1+           | True+           = SBV $ SVal ka $ Right $ cache result+           where ka = kindOf (undefined :: a)+                 kb = kindOf (undefined :: b)+                 kc = kindOf (undefined :: c)+                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1)+                           | True = do newUninterpreted st nm (SBVType [kc, kb, ka]) (fst `fmap` mbCgData)+                                       sw0 <- sbvToSW st arg0+                                       sw1 <- sbvToSW st arg1+                                       mapM_ forceSWArg [sw0, sw1]+                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1]++-- Functions of three arguments+instance (SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV d -> SBV c -> SBV b -> SBV a) where+  sbvUninterpret mbCgData nm = f+    where f arg0 arg1 arg2+           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2+           = v arg0 arg1 arg2+           | True+           = SBV $ SVal ka $ Right $ cache result+           where ka = kindOf (undefined :: a)+                 kb = kindOf (undefined :: b)+                 kc = kindOf (undefined :: c)+                 kd = kindOf (undefined :: d)+                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2)+                           | True = do newUninterpreted st nm (SBVType [kd, kc, kb, ka]) (fst `fmap` mbCgData)+                                       sw0 <- sbvToSW st arg0+                                       sw1 <- sbvToSW st arg1+                                       sw2 <- sbvToSW st arg2+                                       mapM_ forceSWArg [sw0, sw1, sw2]+                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2]++-- Functions of four arguments+instance (SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where+  sbvUninterpret mbCgData nm = f+    where f arg0 arg1 arg2 arg3+           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3+           = v arg0 arg1 arg2 arg3+           | True+           = SBV $ SVal ka $ Right $ cache result+           where ka = kindOf (undefined :: a)+                 kb = kindOf (undefined :: b)+                 kc = kindOf (undefined :: c)+                 kd = kindOf (undefined :: d)+                 ke = kindOf (undefined :: e)+                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3)+                           | True = do newUninterpreted st nm (SBVType [ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)+                                       sw0 <- sbvToSW st arg0+                                       sw1 <- sbvToSW st arg1+                                       sw2 <- sbvToSW st arg2+                                       sw3 <- sbvToSW st arg3+                                       mapM_ forceSWArg [sw0, sw1, sw2, sw3]+                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3]++-- Functions of five arguments+instance (SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where+  sbvUninterpret mbCgData nm = f+    where f arg0 arg1 arg2 arg3 arg4+           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4+           = v arg0 arg1 arg2 arg3 arg4+           | True+           = SBV $ SVal ka $ Right $ cache result+           where ka = kindOf (undefined :: a)+                 kb = kindOf (undefined :: b)+                 kc = kindOf (undefined :: c)+                 kd = kindOf (undefined :: d)+                 ke = kindOf (undefined :: e)+                 kf = kindOf (undefined :: f)+                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4)+                           | True = do newUninterpreted st nm (SBVType [kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)+                                       sw0 <- sbvToSW st arg0+                                       sw1 <- sbvToSW st arg1+                                       sw2 <- sbvToSW st arg2+                                       sw3 <- sbvToSW st arg3+                                       sw4 <- sbvToSW st arg4+                                       mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4]+                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4]++-- Functions of six arguments+instance (SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted (SBV g -> SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where+  sbvUninterpret mbCgData nm = f+    where f arg0 arg1 arg2 arg3 arg4 arg5+           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4, isConcrete arg5+           = v arg0 arg1 arg2 arg3 arg4 arg5+           | True+           = SBV $ SVal ka $ Right $ cache result+           where ka = kindOf (undefined :: a)+                 kb = kindOf (undefined :: b)+                 kc = kindOf (undefined :: c)+                 kd = kindOf (undefined :: d)+                 ke = kindOf (undefined :: e)+                 kf = kindOf (undefined :: f)+                 kg = kindOf (undefined :: g)+                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4 arg5)+                           | True = do newUninterpreted st nm (SBVType [kg, kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)+                                       sw0 <- sbvToSW st arg0+                                       sw1 <- sbvToSW st arg1+                                       sw2 <- sbvToSW st arg2+                                       sw3 <- sbvToSW st arg3+                                       sw4 <- sbvToSW st arg4+                                       sw5 <- sbvToSW st arg5+                                       mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4, sw5]+                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4, sw5]++-- Functions of seven arguments+instance (SymWord h, SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a)+            => Uninterpreted (SBV h -> SBV g -> SBV f -> SBV e -> SBV d -> SBV c -> SBV b -> SBV a) where+  sbvUninterpret mbCgData nm = f+    where f arg0 arg1 arg2 arg3 arg4 arg5 arg6+           | Just (_, v) <- mbCgData, isConcrete arg0, isConcrete arg1, isConcrete arg2, isConcrete arg3, isConcrete arg4, isConcrete arg5, isConcrete arg6+           = v arg0 arg1 arg2 arg3 arg4 arg5 arg6+           | True+           = SBV $ SVal ka $ Right $ cache result+           where ka = kindOf (undefined :: a)+                 kb = kindOf (undefined :: b)+                 kc = kindOf (undefined :: c)+                 kd = kindOf (undefined :: d)+                 ke = kindOf (undefined :: e)+                 kf = kindOf (undefined :: f)+                 kg = kindOf (undefined :: g)+                 kh = kindOf (undefined :: h)+                 result st | Just (_, v) <- mbCgData, inProofMode st = sbvToSW st (v arg0 arg1 arg2 arg3 arg4 arg5 arg6)+                           | True = do newUninterpreted st nm (SBVType [kh, kg, kf, ke, kd, kc, kb, ka]) (fst `fmap` mbCgData)+                                       sw0 <- sbvToSW st arg0+                                       sw1 <- sbvToSW st arg1+                                       sw2 <- sbvToSW st arg2+                                       sw3 <- sbvToSW st arg3+                                       sw4 <- sbvToSW st arg4+                                       sw5 <- sbvToSW st arg5+                                       sw6 <- sbvToSW st arg6+                                       mapM_ forceSWArg [sw0, sw1, sw2, sw3, sw4, sw5, sw6]+                                       newExpr st ka $ SBVApp (Uninterpreted nm) [sw0, sw1, sw2, sw3, sw4, sw5, sw6]++-- Uncurried functions of two arguments+instance (SymWord c, SymWord b, HasKind a) => Uninterpreted ((SBV c, SBV b) -> SBV a) where+  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc2 `fmap` mbCgData) nm in uncurry f+    where uc2 (cs, fn) = (cs, curry fn)++-- Uncurried functions of three arguments+instance (SymWord d, SymWord c, SymWord b, HasKind a) => Uninterpreted ((SBV d, SBV c, SBV b) -> SBV a) where+  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc3 `fmap` mbCgData) nm in \(arg0, arg1, arg2) -> f arg0 arg1 arg2+    where uc3 (cs, fn) = (cs, \a b c -> fn (a, b, c))++-- Uncurried functions of four arguments+instance (SymWord e, SymWord d, SymWord c, SymWord b, HasKind a)+            => Uninterpreted ((SBV e, SBV d, SBV c, SBV b) -> SBV a) where+  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc4 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3) -> f arg0 arg1 arg2 arg3+    where uc4 (cs, fn) = (cs, \a b c d -> fn (a, b, c, d))++-- Uncurried functions of five arguments+instance (SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a)+            => Uninterpreted ((SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where+  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc5 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4) -> f arg0 arg1 arg2 arg3 arg4+    where uc5 (cs, fn) = (cs, \a b c d e -> fn (a, b, c, d, e))++-- Uncurried functions of six arguments+instance (SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a)+            => Uninterpreted ((SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where+  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc6 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4, arg5) -> f arg0 arg1 arg2 arg3 arg4 arg5+    where uc6 (cs, fn) = (cs, \a b c d e f -> fn (a, b, c, d, e, f))++-- Uncurried functions of seven arguments+instance (SymWord h, SymWord g, SymWord f, SymWord e, SymWord d, SymWord c, SymWord b, HasKind a)+            => Uninterpreted ((SBV h, SBV g, SBV f, SBV e, SBV d, SBV c, SBV b) -> SBV a) where+  sbvUninterpret mbCgData nm = let f = sbvUninterpret (uc7 `fmap` mbCgData) nm in \(arg0, arg1, arg2, arg3, arg4, arg5, arg6) -> f arg0 arg1 arg2 arg3 arg4 arg5 arg6+    where uc7 (cs, fn) = (cs, \a b c d e f g -> fn (a, b, c, d, e, f, g))++-- | Adding arbitrary constraints. When adding constraints, one has to be careful about+-- making sure they are not inconsistent. The function 'isVacuous' can be use for this purpose.+-- Here is an example. Consider the following predicate:+--+-- >>> let pred = do { x <- forall "x"; constrain $ x .< x; return $ x .>= (5 :: SWord8) }+--+-- This predicate asserts that all 8-bit values are larger than 5, subject to the constraint that the+-- values considered satisfy @x .< x@, i.e., they are less than themselves. Since there are no values that+-- satisfy this constraint, the proof will pass vacuously:+--+-- >>> prove pred+-- Q.E.D.+--+-- We can use 'isVacuous' to make sure to see that the pass was vacuous:+--+-- >>> isVacuous pred+-- True+--+-- While the above example is trivial, things can get complicated if there are multiple constraints with+-- non-straightforward relations; so if constraints are used one should make sure to check the predicate+-- is not vacuously true. Here's an example that is not vacuous:+--+--  >>> let pred' = do { x <- forall "x"; constrain $ x .> 6; return $ x .>= (5 :: SWord8) }+--+-- This time the proof passes as expected:+--+--  >>> prove pred'+--  Q.E.D.+--+-- And the proof is not vacuous:+--+--  >>> isVacuous pred'+--  False+constrain :: SBool -> Symbolic ()+constrain c = addConstraint Nothing c (bnot c)++-- | Adding a probabilistic constraint. The 'Double' argument is the probability+-- threshold. Probabilistic constraints are useful for 'genTest' and 'quickCheck'+-- calls where we restrict our attention to /interesting/ parts of the input domain.+pConstrain :: Double -> SBool -> Symbolic ()+pConstrain t c = addConstraint (Just t) c (bnot c)++-- | Provide a tactic for the solver engine+tactic :: Tactic SBool -> Symbolic ()+tactic t = addSValTactic $ unSBV `fmap` t++-- | Introduce a soft assertion, with an optional penalty+assertSoft :: String -> SBool -> Penalty -> Symbolic ()+assertSoft nm o p = addSValOptGoal $ unSBV `fmap` AssertSoft nm o p++-- | Class of metrics we can optimize for. Currently,+-- bounded signed/unsigned bit-vectors, unbounded integers,+-- and algebraic reals can be optimized. (But not, say, SFloat, SDouble, or SBool.)+-- Minimal complete definition: minimize/maximize.+--+-- A good reference on these features is given in the following paper:+-- <http://www.easychair.org/publications/download/Z_-_Maximal_Satisfaction_with_Z3>.+class Metric a where+  -- | Minimize a named metric+  minimize :: String -> a -> Symbolic ()++  -- | Maximize a named metric+  maximize :: String -> a -> Symbolic ()++instance Metric SWord8   where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o)+instance Metric SWord16  where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o)+instance Metric SWord32  where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o)+instance Metric SWord64  where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o)+instance Metric SInt8    where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o)+instance Metric SInt16   where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o)+instance Metric SInt32   where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o)+instance Metric SInt64   where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o)+instance Metric SInteger where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o)+instance Metric SReal    where minimize nm o = addSValOptGoal (unSBV `fmap` Minimize nm o); maximize nm o = addSValOptGoal (unSBV `fmap` Maximize nm o)++-- Quickcheck interface on symbolic-booleans..+instance Testable SBool where+  property (SBV (SVal _ (Left b))) = property (cwToBool b)+  property s                       = error $ "Cannot quick-check in the presence of uninterpreted constants! (" ++ show s ++ ")"++instance Testable (Symbolic SBool) where+   property prop = QC.monadicIO $ do (cond, r, tvals) <- QC.run (newStdGen >>= test)+                                     QC.pre cond+                                     unless (r || null tvals) $ QC.monitor (QC.counterexample (complain tvals))+                                     QC.assert r+     where test g = do (r, Result{resTraces=tvals, resConsts=cs, resConstraints=cstrs, resUIConsts=unints}) <- runSymbolic' (Concrete g) prop+                       let cval = fromMaybe (error "Cannot quick-check in the presence of uninterpeted constants!") . (`lookup` cs)+                           cond = all (cwToBool . cval) cstrs+                       case map fst unints of+                         [] -> case unliteral r of+                                 Nothing -> noQC [show r]+                                 Just b  -> return (cond, b, tvals)+                         us -> noQC us+           complain qcInfo = showModel defaultSMTCfg (SMTModel [] qcInfo)+           noQC us         = error $ "Cannot quick-check in the presence of uninterpreted constants: " ++ intercalate ", " us++-- | Quick check an SBV property. Note that a regular 'quickCheck' call will work just as+-- well. Use this variant if you want to receive the boolean result.+sbvQuickCheck :: Symbolic SBool -> IO Bool+sbvQuickCheck prop = QC.isSuccess `fmap` QC.quickCheckResult prop++-- Quickcheck interface on dynamically-typed values. A run-time check+-- ensures that the value has boolean type.+instance Testable (Symbolic SVal) where+  property m = property $ do s <- m+                             when (kindOf s /= KBool) $ error "Cannot quickcheck non-boolean value"+                             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://ittc.ku.edu/~andygill/paper.php?label=DSLExtract09>).+-- 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.+slet :: forall a b. (HasKind a, HasKind b) => SBV a -> (SBV a -> SBV b) -> SBV b+slet x f = SBV $ SVal k $ Right $ cache r+    where k    = kindOf (undefined :: b)+          r st = do xsw <- sbvToSW st x+                    let xsbv = SBV $ SVal (kindOf x) (Right (cache (const (return xsw))))+                        res  = f xsbv+                    sbvToSW st res++-- | Check if a boolean condition is satisfiable in the current state. This function can be useful in contexts where an+-- interpreter implemented on top of SBV needs to decide if a particular stae (represented by the boolean) is reachable+-- in the current if-then-else paths implied by the 'ite' calls. Returns Nothing if not satisfiable, otherwise the+-- satisfying model.+isSatisfiableInCurrentPath :: SBool -> Symbolic (Maybe SatResult)+isSatisfiableInCurrentPath cond = do+       st <- ask+       let cfg  = fromMaybe defaultSMTCfg (getSBranchRunConfig st)+           msg  = when (verbose cfg) . putStrLn . ("** " ++)+           pc   = getPathCondition st+       check <- liftIO $ internalSATCheck cfg (pc &&& cond) st "isSatisfiableInCurrentPath: Checking satisfiability"+       let res = case check of+                   SatResult Satisfiable{}     -> True+                   SatResult (Unsatisfiable _) -> False+                   _                           -> error $ "isSatisfiableInCurrentPath: Unexpected external result: " ++ show check+       res `seq` liftIO $ msg $ "isSatisfiableInCurrentPath: Conclusion: " ++ if res then "Satisfiable" else "Unsatisfiable"+       return $ if res then Just check+                       else Nothing++-- We use 'isVacuous' and 'prove' only for the "test" section in this file, and GHC complains about that. So, this shuts it up.+__unused :: a+__unused = error "__unused" (isVacuous :: SBool -> IO Bool) (prove :: SBool -> IO ThmResult)++{-# ANN module   ("HLint: ignore Reduce duplication" :: String)#-}+{-# ANN module   ("HLint: ignore Eta reduce" :: String)        #-}
+ Data/SBV/Core/Operations.hs view
@@ -0,0 +1,807 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Core.Operations+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Constructors and basic operations on symbolic values+-----------------------------------------------------------------------------++{-# LANGUAGE BangPatterns #-}++module Data.SBV.Core.Operations+  (+  -- ** Basic constructors+    svTrue, svFalse, svBool+  , svInteger, svFloat, svDouble, svReal, svEnumFromThenTo+  -- ** Basic destructors+  , svAsBool, svAsInteger, svNumerator, svDenominator+  -- ** Basic operations+  , svPlus, svTimes, svMinus, svUNeg, svAbs+  , svDivide, svQuot, svRem+  , svEqual, svNotEqual+  , svLessThan, svGreaterThan, svLessEq, svGreaterEq+  , svAnd, svOr, svXOr, svNot+  , svShl, svShr, svRol, svRor+  , svExtract, svJoin+  , svUninterpreted+  , svIte, svLazyIte, svSymbolicMerge+  , svSelect+  , svSign, svUnsign, svSetBit, svWordFromBE, svWordFromLE+  , svExp, svFromIntegral+  -- ** Derived operations+  , svToWord1, svFromWord1, svTestBit+  , svShiftLeft, svShiftRight+  , svRotateLeft, svRotateRight+  , svBlastLE, svBlastBE+  , svAddConstant, svIncrement, svDecrement+  )+  where++import Data.Bits (Bits(..))+import Data.List (genericIndex, genericLength, genericTake)++import Data.SBV.Core.AlgReals+import Data.SBV.Core.Kind+import Data.SBV.Core.Concrete+import Data.SBV.Core.Symbolic++import Data.Ratio++--------------------------------------------------------------------------------+-- Basic constructors++-- | Boolean True.+svTrue :: SVal+svTrue = SVal KBool (Left trueCW)++-- | Boolean False.+svFalse :: SVal+svFalse = SVal KBool (Left falseCW)++-- | Convert from a Boolean.+svBool :: Bool -> SVal+svBool b = if b then svTrue else svFalse++-- | Convert from an Integer.+svInteger :: Kind -> Integer -> SVal+svInteger k n = SVal k (Left $! mkConstCW k n)++-- | Convert from a Float+svFloat :: Float -> SVal+svFloat f = SVal KFloat (Left $! CW KFloat (CWFloat f))++-- | Convert from a Float+svDouble :: Double -> SVal+svDouble d = SVal KDouble (Left $! CW KDouble (CWDouble d))++-- | Convert from a Rational+svReal :: Rational -> SVal+svReal d = SVal KReal (Left $! CW KReal (CWAlgReal (fromRational d)))++--------------------------------------------------------------------------------+-- Basic destructors++-- | Extract a bool, by properly interpreting the integer stored.+svAsBool :: SVal -> Maybe Bool+svAsBool (SVal _ (Left cw)) = Just (cwToBool cw)+svAsBool _                  = Nothing++-- | Extract an integer from a concrete value.+svAsInteger :: SVal -> Maybe Integer+svAsInteger (SVal _ (Left (CW _ (CWInteger n)))) = Just n+svAsInteger _                                    = Nothing++-- | Grab the numerator of an SReal, if available+svNumerator :: SVal -> Maybe Integer+svNumerator (SVal KReal (Left (CW KReal (CWAlgReal (AlgRational True r))))) = Just $ numerator r+svNumerator _                                                               = Nothing++-- | Grab the denominator of an SReal, if available+svDenominator :: SVal -> Maybe Integer+svDenominator (SVal KReal (Left (CW KReal (CWAlgReal (AlgRational True r))))) = Just $ denominator r+svDenominator _                                                               = Nothing++-------------------------------------------------------------------------------------+-- | Constructing [x, y, .. z] and [x .. y]. Only works when all arguments are concrete and integral and the result is guaranteed finite+-- Note that the it isn't "obviously" clear why the following works; after all we're doing the construction over Integer's and mapping+-- it back to other types such as SIntN/SWordN. The reason is that the values we receive are guaranteed to be in their domains; and thus+-- the lifting to Integers preserves the bounds; and then going back is just fine. So, things like @[1, 5 .. 200] :: [SInt8]@ work just+-- fine (end evaluate to empty list), since we see @[1, 5 .. -56]@ in the @Integer@ domain. Also note the explicit check for @s /= f@+-- below to make sure we don't stutter and produce an infinite list.+svEnumFromThenTo :: SVal -> Maybe SVal -> SVal -> Maybe [SVal]+svEnumFromThenTo bf mbs bt+  | Just bs <- mbs, Just f <- svAsInteger bf, Just s <- svAsInteger bs, Just t <- svAsInteger bt, s /= f = Just $ map (svInteger (kindOf bf)) [f, s .. t]+  | Nothing <- mbs, Just f <- svAsInteger bf,                           Just t <- svAsInteger bt         = Just $ map (svInteger (kindOf bf)) [f    .. t]+  | True                                                                                                 = Nothing++-------------------------------------------------------------------------------------+-- Basic operations++-- | Addition.+svPlus :: SVal -> SVal -> SVal+svPlus x y+  | isConcreteZero x = y+  | isConcreteZero y = x+  | True             = liftSym2 (mkSymOp Plus) rationalCheck (+) (+) (+) (+) x y++-- | Multiplication.+svTimes :: SVal -> SVal -> SVal+svTimes x y+  | isConcreteZero x = x+  | isConcreteZero y = y+  | isConcreteOne x  = y+  | isConcreteOne y  = x+  | True             = liftSym2 (mkSymOp Times) rationalCheck (*) (*) (*) (*) x y++-- | Subtraction.+svMinus :: SVal -> SVal -> SVal+svMinus x y+  | isConcreteZero y = x+  | True             = liftSym2 (mkSymOp Minus) rationalCheck (-) (-) (-) (-) x y++-- | Unary minus.+svUNeg :: SVal -> SVal+svUNeg = liftSym1 (mkSymOp1 UNeg) negate negate negate negate++-- | Absolute value.+svAbs :: SVal -> SVal+svAbs = liftSym1 (mkSymOp1 Abs) abs abs abs abs++-- | Division.+svDivide :: SVal -> SVal -> SVal+svDivide = liftSym2 (mkSymOp Quot) rationalCheck (/) die (/) (/)+   where -- should never happen+         die = error "impossible: integer valued data found in Fractional instance"++-- | Exponentiation.+svExp :: SVal -> SVal -> SVal+svExp b e | hasSign (kindOf e) = error "svExp: exponentiation only works with unsigned exponents"+          | True               = prod $ zipWith (\use n -> svIte use n one)+                                                (svBlastLE e)+                                                (iterate (\x -> svTimes x x) b)+         where prod = foldr svTimes one+               one  = svInteger (kindOf b) 1++-- | Bit-blast: Little-endian. Assumes the input is a bit-vector.+svBlastLE :: SVal -> [SVal]+svBlastLE x = map (svTestBit x) [0 .. intSizeOf x - 1]++-- | Set a given bit at index+svSetBit :: SVal -> Int -> SVal+svSetBit x i = x `svXOr` svInteger (kindOf x) (bit i :: Integer)++-- | Bit-blast: Big-endian. Assumes the input is a bit-vector.+svBlastBE :: SVal -> [SVal]+svBlastBE = reverse . svBlastLE++-- | Un-bit-blast from big-endian representation to a word of the right size.+-- The input is assumed to be unsigned.+svWordFromLE :: [SVal] -> SVal+svWordFromLE bs = go zero 0 bs+  where zero = svInteger (KBounded False (length bs)) 0+        go !acc _  []     = acc+        go !acc !i (x:xs) = go (svIte x (svSetBit acc i) acc) (i+1) xs++-- | Un-bit-blast from little-endian representation to a word of the right size.+-- The input is assumed to be unsigned.+svWordFromBE :: [SVal] -> SVal+svWordFromBE = svWordFromLE . reverse++-- | Add a constant value:+svAddConstant :: Integral a => SVal -> a -> SVal+svAddConstant x i = x `svPlus` svInteger (kindOf x) (fromIntegral i)++-- | Increment:+svIncrement :: SVal -> SVal+svIncrement x = svAddConstant x (1::Integer)++-- | Decrement:+svDecrement :: SVal -> SVal+svDecrement x = svAddConstant x (-1 :: Integer)++-- | Quotient: Overloaded operation whose meaning depends on the kind at which+-- it is used: For unbounded integers, it corresponds to the SMT-Lib+-- "div" operator ("Euclidean" division, which always has a+-- non-negative remainder). For unsigned bitvectors, it is "bvudiv";+-- and for signed bitvectors it is "bvsdiv", which rounds toward zero.+-- All operations have unspecified semantics in case @y = 0@.+svQuot :: SVal -> SVal -> SVal+svQuot x y+  | isConcreteZero x = x+  | isConcreteOne y  = x+  | True             = liftSym2 (mkSymOp Quot) nonzeroCheck+                                (noReal "quot") quot' (noFloat "quot") (noDouble "quot") x y+  where+    quot' a b | kindOf x == KUnbounded = div a (abs b) * signum b+              | otherwise              = quot a b++-- | Remainder: Overloaded operation whose meaning depends on the kind at which+-- it is used: For unbounded integers, it corresponds to the SMT-Lib+-- "mod" operator (always non-negative). For unsigned bitvectors, it+-- is "bvurem"; and for signed bitvectors it is "bvsrem", which rounds+-- toward zero (sign of remainder matches that of @x@). All operations+-- have unspecified semantics in case @y = 0@.+svRem :: SVal -> SVal -> SVal+svRem x y+  | isConcreteZero x = x+  | isConcreteOne y  = svInteger (kindOf x) 0+  | True             = liftSym2 (mkSymOp Rem) nonzeroCheck+                                (noReal "rem") rem' (noFloat "rem") (noDouble "rem") x y+  where+    rem' a b | kindOf x == KUnbounded = mod a (abs b)+             | otherwise              = rem a b++-- | Optimize away x == true and x /= false to x; otherwise just do eqOpt+eqOptBool :: Op -> SW -> SW -> SW -> Maybe SW+eqOptBool op w x y+  | k == KBool && op == Equal    && x == trueSW  = Just y         -- true  .== y     --> y+  | k == KBool && op == Equal    && y == trueSW  = Just x         -- x     .== true  --> x+  | k == KBool && op == NotEqual && x == falseSW = Just y         -- false ./= y     --> y+  | k == KBool && op == NotEqual && y == falseSW = Just x         -- x     ./= false --> x+  | True                                         = eqOpt w x y    -- fallback+  where k = swKind x++-- | Equality.+svEqual :: SVal -> SVal -> SVal+svEqual = liftSym2B (mkSymOpSC (eqOptBool Equal trueSW) Equal) rationalCheck (==) (==) (==) (==) (==)++-- | Inequality.+svNotEqual :: SVal -> SVal -> SVal+svNotEqual = liftSym2B (mkSymOpSC (eqOptBool NotEqual falseSW) NotEqual) rationalCheck (/=) (/=) (/=) (/=) (/=)++-- | Less than.+svLessThan :: SVal -> SVal -> SVal+svLessThan x y+  | isConcreteMax x = svFalse+  | isConcreteMin y = svFalse+  | True            = liftSym2B (mkSymOpSC (eqOpt falseSW) LessThan) rationalCheck (<) (<) (<) (<) (uiLift "<" (<)) x y++-- | Greater than.+svGreaterThan :: SVal -> SVal -> SVal+svGreaterThan x y+  | isConcreteMin x = svFalse+  | isConcreteMax y = svFalse+  | True            = liftSym2B (mkSymOpSC (eqOpt falseSW) GreaterThan) rationalCheck (>) (>) (>) (>) (uiLift ">"  (>)) x y++-- | Less than or equal to.+svLessEq :: SVal -> SVal -> SVal+svLessEq x y+  | isConcreteMin x = svTrue+  | isConcreteMax y = svTrue+  | True            = liftSym2B (mkSymOpSC (eqOpt trueSW) LessEq) rationalCheck (<=) (<=) (<=) (<=) (uiLift "<=" (<=)) x y++-- | Greater than or equal to.+svGreaterEq :: SVal -> SVal -> SVal+svGreaterEq x y+  | isConcreteMax x = svTrue+  | isConcreteMin y = svTrue+  | True            = liftSym2B (mkSymOpSC (eqOpt trueSW) GreaterEq) rationalCheck (>=) (>=) (>=) (>=) (uiLift ">=" (>=)) x y++-- | Bitwise and.+svAnd :: SVal -> SVal -> SVal+svAnd x y+  | isConcreteZero x = x+  | isConcreteOnes x = y+  | isConcreteZero y = y+  | isConcreteOnes y = x+  | True             = liftSym2 (mkSymOpSC opt And) (const (const True)) (noReal ".&.") (.&.) (noFloat ".&.") (noDouble ".&.") x y+  where opt a b+          | a == falseSW || b == falseSW = Just falseSW+          | a == trueSW                  = Just b+          | b == trueSW                  = Just a+          | True                         = Nothing++-- | Bitwise or.+svOr :: SVal -> SVal -> SVal+svOr x y+  | isConcreteZero x = y+  | isConcreteOnes x = x+  | isConcreteZero y = x+  | isConcreteOnes y = y+  | True             = liftSym2 (mkSymOpSC opt Or) (const (const True))+                       (noReal ".|.") (.|.) (noFloat ".|.") (noDouble ".|.") x y+  where opt a b+          | a == trueSW || b == trueSW = Just trueSW+          | a == falseSW               = Just b+          | b == falseSW               = Just a+          | True                       = Nothing++-- | Bitwise xor.+svXOr :: SVal -> SVal -> SVal+svXOr x y+  | isConcreteZero x = y+  | isConcreteOnes x = svNot y+  | isConcreteZero y = x+  | isConcreteOnes y = svNot x+  | True             = liftSym2 (mkSymOpSC opt XOr) (const (const True))+                       (noReal "xor") xor (noFloat "xor") (noDouble "xor") x y+  where opt a b+          | a == b && swKind a == KBool = Just falseSW+          | a == falseSW                = Just b+          | b == falseSW                = Just a+          | True                        = Nothing++-- | Bitwise complement.+svNot :: SVal -> SVal+svNot = liftSym1 (mkSymOp1SC opt Not)+                 (noRealUnary "complement") complement+                 (noFloatUnary "complement") (noDoubleUnary "complement")+  where opt a+          | a == falseSW = Just trueSW+          | a == trueSW  = Just falseSW+          | True         = Nothing++-- | Shift left by a constant amount. Translates to the "bvshl"+-- operation in SMT-Lib.+svShl :: SVal -> Int -> SVal+svShl x i+  | i < 0   = svShr x (-i)+  | i == 0  = x+  | True    = liftSym1 (mkSymOp1 (Shl i))+                       (noRealUnary "shiftL") (`shiftL` i)+                       (noFloatUnary "shiftL") (noDoubleUnary "shiftL") x++-- | Shift right by a constant amount. Translates to either "bvlshr"+-- (logical shift right) or "bvashr" (arithmetic shift right) in+-- SMT-Lib, depending on whether @x@ is a signed bitvector.+svShr :: SVal -> Int -> SVal+svShr x i+  | i < 0   = svShl x (-i)+  | i == 0  = x+  | True    = liftSym1 (mkSymOp1 (Shr i))+                       (noRealUnary "shiftR") (`shiftR` i)+                       (noFloatUnary "shiftR") (noDoubleUnary "shiftR") x++-- | Rotate-left, by a constant+svRol :: SVal -> Int -> SVal+svRol x i+  | i < 0   = svRor x (-i)+  | i == 0  = x+  | True    = case kindOf x of+                KBounded _ sz -> liftSym1 (mkSymOp1 (Rol (i `mod` sz)))+                                          (noRealUnary "rotateL") (rot True sz i)+                                          (noFloatUnary "rotateL") (noDoubleUnary "rotateL") x+                _ -> svShl x i   -- for unbounded Integers, rotateL is the same as shiftL in Haskell++-- | Rotate-right, by a constant+svRor :: SVal -> Int -> SVal+svRor x i+  | i < 0   = svRol x (-i)+  | i == 0  = x+  | True    = case kindOf x of+                KBounded _ sz -> liftSym1 (mkSymOp1 (Ror (i `mod` sz)))+                                          (noRealUnary "rotateR") (rot False sz i)+                                          (noFloatUnary "rotateR") (noDoubleUnary "rotateR") x+                _ -> svShr x i   -- for unbounded integers, rotateR is the same as shiftR in Haskell++-- | Generic rotation. Since the underlying representation is just Integers, rotations has to be+-- careful on the bit-size.+rot :: Bool -> Int -> Int -> Integer -> Integer+rot toLeft sz amt x+  | sz < 2 = x+  | True   = norm x y' `shiftL` y  .|. norm (x `shiftR` y') y+  where (y, y') | toLeft = (amt `mod` sz, sz - y)+                | True   = (sz - y', amt `mod` sz)+        norm v s = v .&. ((1 `shiftL` s) - 1)++-- | Extract bit-sequences.+svExtract :: Int -> Int -> SVal -> SVal+svExtract i j x@(SVal (KBounded s _) _)+  | i < j+  = SVal k (Left $! CW k (CWInteger 0))+  | SVal _ (Left (CW _ (CWInteger v))) <- x+  = SVal k (Left $! normCW (CW k (CWInteger (v `shiftR` j))))+  | True+  = SVal k (Right (cache y))+  where k = KBounded s (i - j + 1)+        y st = do sw <- svToSW st x+                  newExpr st k (SBVApp (Extract i j) [sw])+svExtract _ _ _ = error "extract: non-bitvector type"++-- | Join two words, by concataneting+svJoin :: SVal -> SVal -> SVal+svJoin x@(SVal (KBounded s i) a) y@(SVal (KBounded _ j) b)+  | i == 0 = y+  | j == 0 = x+  | Left (CW _ (CWInteger m)) <- a, Left (CW _ (CWInteger n)) <- b+  = SVal k (Left $! CW k (CWInteger (m `shiftL` j .|. n)))+  | True+  = SVal k (Right (cache z))+  where+    k = KBounded s (i + j)+    z st = do xsw <- svToSW st x+              ysw <- svToSW st y+              newExpr st k (SBVApp Join [xsw, ysw])+svJoin _ _ = error "svJoin: non-bitvector type"++-- | Uninterpreted constants and functions. An uninterpreted constant is+-- a value that is indexed by its name. The only property the prover assumes+-- about these values are that they are equivalent to themselves; i.e., (for+-- functions) they return the same results when applied to same arguments.+-- We support uninterpreted-functions as a general means of black-box'ing+-- operations that are /irrelevant/ for the purposes of the proof; i.e., when+-- the proofs can be performed without any knowledge about the function itself.+svUninterpreted :: Kind -> String -> Maybe [String] -> [SVal] -> SVal+svUninterpreted k nm code args = SVal k $ Right $ cache result+  where result st = do let ty = SBVType (map kindOf args ++ [k])+                       newUninterpreted st nm ty code+                       sws <- mapM (svToSW st) args+                       mapM_ forceSWArg sws+                       newExpr st k $ SBVApp (Uninterpreted nm) sws++-- | If-then-else. This one will force branches.+svIte :: SVal -> SVal -> SVal -> SVal+svIte t a b = svSymbolicMerge (kindOf a) True t a b++-- | Lazy If-then-else. This one will delay forcing the branches unless it's really necessary.+svLazyIte :: Kind -> SVal -> SVal -> SVal -> SVal+svLazyIte k t a b = svSymbolicMerge k False t a b++-- | Merge two symbolic values, at kind @k@, possibly @force@'ing the branches to make+-- sure they do not evaluate to the same result.+svSymbolicMerge :: Kind -> Bool -> SVal -> SVal -> SVal -> SVal+svSymbolicMerge k force t a b+  | Just r <- svAsBool t+  = if r then a else b+  | force, rationalSBVCheck a b, areConcretelyEqual a b+  = a+  | True+  = SVal k $ Right $ cache c+  where c st = do swt <- svToSW st t+                  case () of+                    () | swt == trueSW  -> svToSW st a       -- these two cases should never be needed as we expect symbolicMerge to be+                    () | swt == falseSW -> svToSW st b       -- called with symbolic tests, but just in case..+                    () -> do {- It is tempting to record the choice of the test expression here as we branch down to the 'then' and 'else' branches. That is,+                                when we evaluate 'a', we can make use of the fact that the test expression is True, and similarly we can use the fact that it+                                is False when b is evaluated. In certain cases this can cut down on symbolic simulation significantly, for instance if+                                repetitive decisions are made in a recursive loop. Unfortunately, the implementation of this idea is quite tricky, due to+                                our sharing based implementation. As the 'then' branch is evaluated, we will create many expressions that are likely going+                                to be "reused" when the 'else' branch is executed. But, it would be *dead wrong* to share those values, as they were "cached"+                                under the incorrect assumptions. To wit, consider the following:++                                   foo x y = ite (y .== 0) k (k+1)+                                     where k = ite (y .== 0) x (x+1)++                                When we reduce the 'then' branch of the first ite, we'd record the assumption that y is 0. But while reducing the 'then' branch, we'd+                                like to share 'k', which would evaluate (correctly) to 'x' under the given assumption. When we backtrack and evaluate the 'else'+                                branch of the first ite, we'd see 'k' is needed again, and we'd look it up from our sharing map to find (incorrectly) that its value+                                is 'x', which was stored there under the assumption that y was 0, which no longer holds. Clearly, this is unsound.++                                A sound implementation would have to precisely track which assumptions were active at the time expressions get shared. That is,+                                in the above example, we should record that the value of 'k' was cached under the assumption that 'y' is 0. While sound, this+                                approach unfortunately leads to significant loss of valid sharing when the value itself had nothing to do with the assumption itself.+                                To wit, consider:++                                   foo x y = ite (y .== 0) k (k+1)+                                     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,+                                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+                                than blindly recording all the assumptions present at that time. SBV's symbolic simulation engine clearly has all the info needed to do this+                                properly, but the implementation is not straightforward at all. For each subexpression, we would need to chase down its dependencies+                                transitively, which can require a lot of scanning of the generated program causing major slow-down; thus potentially defeating the+                                whole purpose of sharing in the first place.++                                Design choice: Keep it simple, and simply do not track the assumption at all. This will maximize sharing, at the cost of evaluating+                                unreachable branches. I think the simplicity is more important at this point than efficiency.++                                Also note that the user can avoid most such issues by properly combining if-then-else's with common conditions together. That is, the+                                first program above should be written like this:++                                  foo x y = ite (y .== 0) x (x+2)++                                In general, the following transformations should be done whenever possible:++                                  ite e1 (ite e1 e2 e3) e4  --> ite e1 e2 e4+                                  ite e1 e2 (ite e1 e3 e4)  --> ite e1 e2 e4++                                This is in accordance with the general rule-of-thumb stating conditionals should be avoided as much as possible. However, we might prefer+                                the following:++                                  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.+                             -}+                             let sta = st `extendSValPathCondition` svAnd t+                             let stb = st `extendSValPathCondition` svAnd (svNot t)+                             swa <- svToSW sta a -- evaluate 'then' branch+                             swb <- svToSW stb b -- evaluate 'else' branch+                             case () of               -- merge:+                               () | swa == swb                      -> return swa+                               () | swa == trueSW && swb == falseSW -> return swt+                               () | swa == falseSW && swb == trueSW -> newExpr st k (SBVApp Not [swt])+                               ()                                   -> newExpr st k (SBVApp Ite [swt, swa, swb])++-- | Total indexing operation. @svSelect xs default index@ is+-- intuitively the same as @xs !! index@, except it evaluates to+-- @default@ if @index@ overflows. Translates to SMT-Lib tables.+svSelect :: [SVal] -> SVal -> SVal -> SVal+svSelect xs err ind+  | SVal _ (Left c) <- ind =+    case cwVal c of+      CWInteger i -> if i < 0 || i >= genericLength xs+                     then err+                     else xs `genericIndex` i+      _           -> error $ "SBV.select: unsupported " ++ show (kindOf ind) ++ " valued select/index expression"+svSelect xsOrig err ind = xs `seq` SVal kElt (Right (cache r))+  where+    kInd = kindOf ind+    kElt = kindOf err+    -- Based on the index size, we need to limit the elements. For+    -- instance if the index is 8 bits, but there are 257 elements,+    -- that last element will never be used and we can chop it off.+    xs = case kInd of+           KBounded False i -> genericTake ((2::Integer) ^ i) xsOrig+           KBounded True  i -> genericTake ((2::Integer) ^ (i-1)) xsOrig+           KUnbounded       -> xsOrig+           _                -> error $ "SBV.select: unsupported " ++ show kInd ++ " valued select/index expression"+    r st = do sws <- mapM (svToSW st) xs+              swe <- svToSW st err+              if all (== swe) sws  -- off-chance that all elts are the same+                 then return swe+                 else do idx <- getTableIndex st kInd kElt sws+                         swi <- svToSW st ind+                         let len = length xs+                         -- NB. No need to worry here that the index+                         -- might be < 0; as the SMTLib translation+                         -- takes care of that automatically+                         newExpr st kElt (SBVApp (LkUp (idx, kInd, kElt, len) swi swe) [])++svChangeSign :: Bool -> SVal -> SVal+svChangeSign s x+  | Just n <- svAsInteger x = svInteger k n+  | True                    = SVal k (Right (cache y))+  where+    k = KBounded s (intSizeOf x)+    y st = do xsw <- svToSW st x+              newExpr st k (SBVApp (Extract (intSizeOf x - 1) 0) [xsw])++-- | Convert a symbolic bitvector from unsigned to signed.+svSign :: SVal -> SVal+svSign = svChangeSign True++-- | Convert a symbolic bitvector from signed to unsigned.+svUnsign :: SVal -> SVal+svUnsign = svChangeSign False++-- | Convert a symbolic bitvector from one integral kind to another.+svFromIntegral :: Kind -> SVal -> SVal+svFromIntegral kTo x+  | Just v <- svAsInteger x+  = svInteger kTo v+  | True+  = result+  where result = SVal kTo (Right (cache y))+        kFrom  = kindOf x+        y st   = do xsw <- svToSW st x+                    newExpr st kTo (SBVApp (KindCast kFrom kTo) [xsw])++--------------------------------------------------------------------------------+-- Derived operations++-- | Convert an SVal from kind Bool to an unsigned bitvector of size 1.+svToWord1 :: SVal -> SVal+svToWord1 b = svSymbolicMerge k True b (svInteger k 1) (svInteger k 0)+  where k = KBounded False 1++-- | Convert an SVal from a bitvector of size 1 (signed or unsigned) to kind Bool.+svFromWord1 :: SVal -> SVal+svFromWord1 x = svNotEqual x (svInteger k 0)+  where k = kindOf x++-- | Test the value of a bit. Note that we do an extract here+-- as opposed to masking and checking against zero, as we found+-- extraction to be much faster with large bit-vectors.+svTestBit :: SVal -> Int -> SVal+svTestBit x i+  | i < intSizeOf x = svFromWord1 (svExtract i i x)+  | True            = svFalse++-- | Generalization of 'svShl', where the shift-amount is symbolic.+-- The first argument should be a bounded quantity.+svShiftLeft :: SVal -> SVal -> SVal+svShiftLeft x i+  | not (isBounded x)+  = error "SBV.svShiftLeft: Shifted amount should be a bounded quantity!"+  | True+  = svIte (svLessThan i zi)+          (svSelect [svShr x k | k <- [0 .. intSizeOf x - 1]] z (svUNeg i))+          (svSelect [svShl x k | k <- [0 .. intSizeOf x - 1]] z         i)+  where z  = svInteger (kindOf x) 0+        zi = svInteger (kindOf i) 0++-- | Generalization of 'svShr', where the shift-amount is symbolic.+-- The first argument should be a bounded quantity.+--+-- NB. If the shiftee is signed, then this is an arithmetic shift;+-- otherwise it's logical.+svShiftRight :: SVal -> SVal -> SVal+svShiftRight x i+  | not (isBounded x)+  = error "SBV.svShiftLeft: Shifted amount should be a bounded quantity!"+  | True+  = svIte (svLessThan i zi)+          (svSelect [svShl x k | k <- [0 .. intSizeOf x - 1]] z (svUNeg i))+          (svSelect [svShr x k | k <- [0 .. intSizeOf x - 1]] z         i)+  where z  = svInteger (kindOf x) 0+        zi = svInteger (kindOf i) 0++-- | Generalization of 'svRol', where the rotation amount is symbolic.+-- The first argument should be a bounded quantity.+svRotateLeft :: SVal -> SVal -> SVal+svRotateLeft x i+  | not (isBounded x)+  = svShiftLeft x i+  | isBounded i && bit si <= toInteger sx            -- wrap-around not possible+  = svIte (svLessThan i zi)+          (svSelect [x `svRor` k | k <- [0 .. bit si - 1]] z (svUNeg i))+          (svSelect [x `svRol` k | k <- [0 .. bit si - 1]] z         i)+  | True+  = svIte (svLessThan i zi)+          (svSelect [x `svRor` k | k <- [0 .. sx     - 1]] z (svUNeg i `svRem` n))+          (svSelect [x `svRol` k | k <- [0 .. sx     - 1]] z (       i `svRem` n))+    where sx = intSizeOf x+          si = intSizeOf i+          z  = svInteger (kindOf x) 0+          zi = svInteger (kindOf i) 0+          n  = svInteger (kindOf i) (toInteger sx)++-- | Generalization of 'svRor', where the rotation amount is symbolic.+-- The first argument should be a bounded quantity.+svRotateRight :: SVal -> SVal -> SVal+svRotateRight x i+  | not (isBounded x)+  = svShiftRight x i+  | isBounded i && bit si <= toInteger sx                   -- wrap-around not possible+  = svIte (svLessThan i zi)+          (svSelect [x `svRol` k | k <- [0 .. bit si - 1]] z (svUNeg i))+          (svSelect [x `svRor` k | k <- [0 .. bit si - 1]] z         i)+  | True+  = svIte (svLessThan i zi)+          (svSelect [x `svRol` k | k <- [0 .. sx     - 1]] z (svUNeg i `svRem` n))+          (svSelect [x `svRor` k | k <- [0 .. sx     - 1]] z (       i `svRem` n))+    where sx = intSizeOf x+          si = intSizeOf i+          z  = svInteger (kindOf x) 0+          zi = svInteger (kindOf i) 0+          n  = svInteger (kindOf i) (toInteger sx)++--------------------------------------------------------------------------------+-- Utility functions++noUnint  :: (Maybe Int, String) -> a+noUnint x = error $ "Unexpected operation called on uninterpreted/enumerated value: " ++ show x++noUnint2 :: (Maybe Int, String) -> (Maybe Int, String) -> a+noUnint2 x y = error $ "Unexpected binary operation called on uninterpreted/enumerated values: " ++ show (x, y)++liftSym1 :: (State -> Kind -> SW -> IO SW) -> (AlgReal -> AlgReal) -> (Integer -> Integer) -> (Float -> Float) -> (Double -> Double) -> SVal -> SVal+liftSym1 _   opCR opCI opCF opCD   (SVal k (Left a)) = SVal k . Left  $! mapCW opCR opCI opCF opCD noUnint a+liftSym1 opS _    _    _    _    a@(SVal k _)        = SVal k $ Right $ cache c+   where c st = do swa <- svToSW st a+                   opS st k swa++liftSW2 :: (State -> Kind -> SW -> SW -> IO SW) -> Kind -> SVal -> SVal -> Cached SW+liftSW2 opS k a b = cache c+  where c st = do sw1 <- svToSW st a+                  sw2 <- svToSW st b+                  opS st k sw1 sw2++liftSym2 :: (State -> Kind -> SW -> SW -> IO SW) -> (CW -> CW -> Bool) -> (AlgReal -> AlgReal -> AlgReal) -> (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> (Double -> Double -> Double) -> SVal -> SVal -> SVal+liftSym2 _   okCW opCR opCI opCF opCD   (SVal k (Left a)) (SVal _ (Left b)) | okCW a b = SVal k . Left  $! mapCW2 opCR opCI opCF opCD noUnint2 a b+liftSym2 opS _    _    _    _    _    a@(SVal k _)        b                            = SVal k $ Right $  liftSW2 opS k a b++liftSym2B :: (State -> Kind -> SW -> SW -> IO SW) -> (CW -> CW -> Bool) -> (AlgReal -> AlgReal -> Bool) -> (Integer -> Integer -> Bool) -> (Float -> Float -> Bool) -> (Double -> Double -> Bool) -> ((Maybe Int, String) -> (Maybe Int, String) -> Bool) -> SVal -> SVal -> SVal+liftSym2B _   okCW opCR opCI opCF opCD opUI (SVal _ (Left a)) (SVal _ (Left b)) | okCW a b = svBool (liftCW2 opCR opCI opCF opCD opUI a b)+liftSym2B opS _    _    _    _    _    _    a                 b                            = SVal KBool $ Right $ liftSW2 opS KBool a b++mkSymOpSC :: (SW -> SW -> Maybe SW) -> Op -> State -> Kind -> SW -> SW -> IO SW+mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) return (shortCut a b)++mkSymOp :: Op -> State -> Kind -> SW -> SW -> IO SW+mkSymOp = mkSymOpSC (const (const Nothing))++mkSymOp1SC :: (SW -> Maybe SW) -> Op -> State -> Kind -> SW -> IO SW+mkSymOp1SC shortCut op st k a = maybe (newExpr st k (SBVApp op [a])) return (shortCut a)++mkSymOp1 :: Op -> State -> Kind -> SW -> IO SW+mkSymOp1 = mkSymOp1SC (const Nothing)++-- | eqOpt says the references are to the same SW, thus we can optimize. Note that+-- we explicitly disallow KFloat/KDouble here. Why? Because it's *NOT* true that+-- NaN == NaN, NaN >= NaN, and so-forth. So, we have to make sure we don't optimize+-- floats and doubles, in case the argument turns out to be NaN.+eqOpt :: SW -> SW -> SW -> Maybe SW+eqOpt w x y = case swKind x of+                KFloat  -> Nothing+                KDouble -> Nothing+                _       -> if x == y then Just w else Nothing++-- For uninterpreted/enumerated values, we carefully lift through the constructor index for comparisons:+uiLift :: String -> (Int -> Int -> Bool) -> (Maybe Int, String) -> (Maybe Int, String) -> Bool+uiLift _ cmp (Just i, _) (Just j, _) = i `cmp` j+uiLift w _   a           b           = error $ "Data.SBV.Core.Operations: Impossible happened while trying to lift " ++ w ++ " over " ++ show (a, b)++-- | Predicate for optimizing word operations like (+) and (*).+isConcreteZero :: SVal -> Bool+isConcreteZero (SVal _     (Left (CW _     (CWInteger n)))) = n == 0+isConcreteZero (SVal KReal (Left (CW KReal (CWAlgReal v)))) = isExactRational v && v == 0+isConcreteZero _                                            = False++-- | Predicate for optimizing word operations like (+) and (*).+isConcreteOne :: SVal -> Bool+isConcreteOne (SVal _     (Left (CW _     (CWInteger 1)))) = True+isConcreteOne (SVal KReal (Left (CW KReal (CWAlgReal v)))) = isExactRational v && v == 1+isConcreteOne _                                            = False++-- | Predicate for optimizing bitwise operations.+isConcreteOnes :: SVal -> Bool+isConcreteOnes (SVal _ (Left (CW (KBounded b w) (CWInteger n)))) = n == if b then -1 else bit w - 1+isConcreteOnes (SVal _ (Left (CW KUnbounded     (CWInteger n)))) = n == -1+isConcreteOnes (SVal _ (Left (CW KBool          (CWInteger n)))) = n == 1+isConcreteOnes _                                                 = False++-- | Predicate for optimizing comparisons.+isConcreteMax :: SVal -> Bool+isConcreteMax (SVal _ (Left (CW (KBounded False w) (CWInteger n)))) = n == bit w - 1+isConcreteMax (SVal _ (Left (CW (KBounded True  w) (CWInteger n)))) = n == bit (w - 1) - 1+isConcreteMax (SVal _ (Left (CW KBool              (CWInteger n)))) = n == 1+isConcreteMax _                                                     = False++-- | Predicate for optimizing comparisons.+isConcreteMin :: SVal -> Bool+isConcreteMin (SVal _ (Left (CW (KBounded False _) (CWInteger n)))) = n == 0+isConcreteMin (SVal _ (Left (CW (KBounded True  w) (CWInteger n)))) = n == - bit (w - 1)+isConcreteMin (SVal _ (Left (CW KBool              (CWInteger n)))) = n == 0+isConcreteMin _                                                     = False++-- | Predicate for optimizing conditionals.+areConcretelyEqual :: SVal -> SVal -> Bool+areConcretelyEqual (SVal _ (Left a)) (SVal _ (Left b)) = a == b+areConcretelyEqual _                       _           = False++-- | Most operations on concrete rationals require a compatibility check to avoid faulting+-- on algebraic reals.+rationalCheck :: CW -> CW -> Bool+rationalCheck a b = case (cwVal a, cwVal b) of+                     (CWAlgReal x, CWAlgReal y) -> isExactRational x && isExactRational y+                     _                          -> True++-- | Quot/Rem operations require a nonzero check on the divisor.+--+nonzeroCheck :: CW -> CW -> Bool+nonzeroCheck _ b = cwVal b /= CWInteger 0++-- | Same as rationalCheck, except for SBV's+rationalSBVCheck :: SVal -> SVal -> Bool+rationalSBVCheck (SVal KReal (Left a)) (SVal KReal (Left b)) = rationalCheck a b+rationalSBVCheck _                     _                     = True++noReal :: String -> AlgReal -> AlgReal -> AlgReal+noReal o a b = error $ "SBV.AlgReal." ++ o ++ ": Unexpected arguments: " ++ show (a, b)++noFloat :: String -> Float -> Float -> Float+noFloat o a b = error $ "SBV.Float." ++ o ++ ": Unexpected arguments: " ++ show (a, b)++noDouble :: String -> Double -> Double -> Double+noDouble o a b = error $ "SBV.Double." ++ o ++ ": Unexpected arguments: " ++ show (a, b)++noRealUnary :: String -> AlgReal -> AlgReal+noRealUnary o a = error $ "SBV.AlgReal." ++ o ++ ": Unexpected argument: " ++ show a++noFloatUnary :: String -> Float -> Float+noFloatUnary o a = error $ "SBV.Float." ++ o ++ ": Unexpected argument: " ++ show a++noDoubleUnary :: String -> Double -> Double+noDoubleUnary o a = error $ "SBV.Double." ++ o ++ ": Unexpected argument: " ++ show a++{-# ANN svIte     ("HLint: ignore Eta reduce" :: String)         #-}+{-# ANN svLazyIte ("HLint: ignore Eta reduce" :: String)         #-}+{-# ANN module    ("HLint: ignore Reduce duplication" :: String) #-}
+ Data/SBV/Core/Splittable.hs view
@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Core.Splittable+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Implementation of bit-vector concatanetation and splits+-----------------------------------------------------------------------------++{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances   #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE BangPatterns           #-}++module Data.SBV.Core.Splittable (Splittable(..), FromBits(..), checkAndConvert) where++import Data.Bits (Bits(..))+import Data.Word (Word8, Word16, Word32, Word64)++import Data.SBV.Core.Operations+import Data.SBV.Core.Data+import Data.SBV.Core.Model++infixr 5 #+-- | Splitting an @a@ into two @b@'s and joining back.+-- Intuitively, @a@ is a larger bit-size word than @b@, typically double.+-- The 'extend' operation captures embedding of a @b@ value into an @a@+-- without changing its semantic value.+--+-- Minimal complete definition: All, no defaults.+class Splittable a b | b -> a where+  split  :: a -> (b, b)+  (#)    :: b -> b -> a+  extend :: b -> a++genSplit :: (Integral a, Num b) => Int -> a -> (b, b)+genSplit ss x = (fromIntegral ((ix `shiftR` ss) .&. mask), fromIntegral (ix .&. mask))+  where ix = toInteger x+        mask = 2 ^ ss - 1++genJoin :: (Integral b, Num a) => Int -> b -> b -> a+genJoin ss x y = fromIntegral ((ix `shiftL` ss) .|. iy)+  where ix = toInteger x+        iy = toInteger y++-- concrete instances+instance Splittable Word64 Word32 where+  split = genSplit 32+  (#)   = genJoin  32+  extend b = 0 # b++instance Splittable Word32 Word16 where+  split = genSplit 16+  (#)   = genJoin  16+  extend b = 0 # b++instance Splittable Word16 Word8 where+  split = genSplit 8+  (#)   = genJoin  8+  extend b = 0 # b++-- symbolic instances+instance Splittable SWord64 SWord32 where+  split (SBV x) = (SBV (svExtract 63 32 x), SBV (svExtract 31 0 x))+  SBV a # SBV b = SBV (svJoin a b)+  extend b = 0 # b++instance Splittable SWord32 SWord16 where+  split (SBV x) = (SBV (svExtract 31 16 x), SBV (svExtract 15 0 x))+  SBV a # SBV b = SBV (svJoin a b)+  extend b = 0 # b++instance Splittable SWord16 SWord8 where+  split (SBV x) = (SBV (svExtract 15 8 x), SBV (svExtract 7 0 x))+  SBV a # SBV b = SBV (svJoin a b)+  extend b = 0 # b++-- | Unblasting a value from symbolic-bits. The bits can be given little-endian+-- or big-endian. For a signed number in little-endian, we assume the very last bit+-- is the sign digit. This is a bit awkward, but it is more consistent with the "reverse" view of+-- little-big-endian representations+--+-- Minimal complete definition: 'fromBitsLE'+class FromBits a where+ fromBitsLE, fromBitsBE :: [SBool] -> a+ fromBitsBE = fromBitsLE . reverse++-- | Construct a symbolic word from its bits given in little-endian+fromBinLE :: (Num a, Bits a, SymWord a) => [SBool] -> SBV a+fromBinLE = go 0 0+  where go !acc _  []     = acc+        go !acc !i (x:xs) = go (ite x (setBit acc i) acc) (i+1) xs++-- | Perform a sanity check that we should receive precisely the same+-- number of bits as required by the resulting type. The input is little-endian+checkAndConvert :: (Num a, Bits a, SymWord a) => Int -> [SBool] -> SBV a+checkAndConvert sz xs+  | sz /= l+  = error $ "SBV.fromBits.SWord" ++ ssz ++ ": Expected " ++ ssz ++ " elements, got: " ++ show l+  | True+  = fromBinLE xs+  where l   = length xs+        ssz = show sz++instance FromBits SBool where+ fromBitsLE [x] = x+ fromBitsLE xs  = error $ "SBV.fromBits.SBool: Expected 1 element, got: " ++ show (length xs)++instance FromBits SWord8  where fromBitsLE = checkAndConvert  8+instance FromBits SInt8   where fromBitsLE = checkAndConvert  8+instance FromBits SWord16 where fromBitsLE = checkAndConvert 16+instance FromBits SInt16  where fromBitsLE = checkAndConvert 16+instance FromBits SWord32 where fromBitsLE = checkAndConvert 32+instance FromBits SInt32  where fromBitsLE = checkAndConvert 32+instance FromBits SWord64 where fromBitsLE = checkAndConvert 64+instance FromBits SInt64  where fromBitsLE = checkAndConvert 64
+ Data/SBV/Core/Symbolic.hs view
@@ -0,0 +1,1275 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Core.Symbolic+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Symbolic values+-----------------------------------------------------------------------------++{-# LANGUAGE    GeneralizedNewtypeDeriving #-}+{-# LANGUAGE    TypeSynonymInstances       #-}+{-# LANGUAGE    TypeOperators              #-}+{-# LANGUAGE    MultiParamTypeClasses      #-}+{-# LANGUAGE    ScopedTypeVariables        #-}+{-# LANGUAGE    FlexibleInstances          #-}+{-# LANGUAGE    PatternGuards              #-}+{-# LANGUAGE    NamedFieldPuns             #-}+{-# LANGUAGE    DeriveDataTypeable         #-}+{-# LANGUAGE    DeriveFunctor              #-}+{-# LANGUAGE    CPP                        #-}+{-# OPTIONS_GHC -fno-warn-orphans          #-}++module Data.SBV.Core.Symbolic+  ( NodeId(..)+  , SW(..), swKind, trueSW, falseSW+  , Op(..), FPOp(..)+  , Quantifier(..), needsExistentials+  , RoundingMode(..)+  , SBVType(..), newUninterpreted, addAxiom+  , SVal(..)+  , svMkSymVar+  , ArrayContext(..), ArrayInfo+  , svToSW, svToSymSW, forceSWArg+  , SBVExpr(..), newExpr, isCodeGenMode+  , Cached, cache, uncache+  , ArrayIndex, uncacheAI+  , NamedSymVar+  , getSValPathCondition, extendSValPathCondition+  , getTableIndex+  , SBVPgm(..), Symbolic, runSymbolic, runSymbolic', State+  , inProofMode, SBVRunMode(..), Result(..)+  , Logic(..), SMTLibLogic(..)+  , addAssertion, addSValConstraint, internalConstraint, internalVariable+  , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension+  , SolverCapabilities(..)+  , extractSymbolicSimulationState+  , OptimizeStyle(..), Objective(..), Penalty(..), objectiveName, addSValOptGoal+  , Tactic(..), addSValTactic, isParallelCaseAnywhere+  , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), SMTEngine, getSBranchRunConfig+  , outputSVal+  , mkSValUserSort+  , SArr(..), readSArr, resetSArr, writeSArr, mergeSArr, newSArr, eqSArr+  ) where++import Control.DeepSeq      (NFData(..))+import Control.Monad        (when, unless)+import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)+import Control.Monad.Trans  (MonadIO, liftIO)+import Data.Char            (isAlpha, isAlphaNum, toLower)+import Data.IORef           (IORef, newIORef, modifyIORef, readIORef, writeIORef)+import Data.List            (intercalate, sortBy)+import Data.Maybe           (isJust, fromJust, fromMaybe)++import GHC.Stack.Compat++import qualified Data.Generics as G    (Data(..))+import qualified Data.IntMap   as IMap (IntMap, empty, size, toAscList, lookup, insert, insertWith)+import qualified Data.Map      as Map  (Map, empty, toList, size, insert, lookup)+import qualified Data.Set      as Set  (Set, empty, toList, insert)+import qualified Data.Foldable as F    (toList)+import qualified Data.Sequence as S    (Seq, empty, (|>))++import System.Mem.StableName+import System.Random++import Data.SBV.Core.Kind+import Data.SBV.Core.Concrete+import Data.SBV.SMT.SMTLibNames+import Data.SBV.Utils.TDiff(Timing)++import Prelude ()+import Prelude.Compat++-- | A symbolic node id+newtype NodeId = NodeId Int deriving (Eq, Ord)++-- | A symbolic word, tracking it's signedness and size.+data SW = SW !Kind !NodeId deriving (Eq, Ord)++instance HasKind SW where+  kindOf (SW k _) = k++instance Show SW where+  show (SW _ (NodeId n))+    | n < 0 = "s_" ++ show (abs n)+    | True  = 's' : show n++-- | Kind of a symbolic word.+swKind :: SW -> Kind+swKind (SW k _) = k++-- | Forcing an argument; this is a necessary evil to make sure all the arguments+-- to an uninterpreted function and sBranch test conditions are evaluated before called;+-- the semantics of uinterpreted functions is necessarily strict; deviating from Haskell's+forceSWArg :: SW -> IO ()+forceSWArg (SW k n) = k `seq` n `seq` return ()++-- | Constant False as an SW. Note that this value always occupies slot -2.+falseSW :: SW+falseSW = SW KBool $ NodeId (-2)++-- | Constant True as an SW. Note that this value always occupies slot -1.+trueSW :: SW+trueSW  = SW KBool $ NodeId (-1)++-- | Symbolic operations+data Op = Plus+        | Times+        | Minus+        | UNeg+        | Abs+        | Quot+        | Rem+        | Equal+        | NotEqual+        | LessThan+        | GreaterThan+        | LessEq+        | GreaterEq+        | Ite+        | And+        | Or+        | XOr+        | Not+        | Shl Int+        | Shr Int+        | Rol Int+        | Ror Int+        | Extract Int Int                       -- Extract i j: extract bits i to j. Least significant bit is 0 (big-endian)+        | Join                                  -- Concat two words to form a bigger one, in the order given+        | LkUp (Int, Kind, Kind, Int) !SW !SW   -- (table-index, arg-type, res-type, length of the table) index out-of-bounds-value+        | ArrEq   Int Int                       -- Array equality+        | ArrRead Int+        | KindCast Kind Kind+        | Uninterpreted String+        | Label String                          -- Essentially no-op; useful for code generation to emit comments.+        | IEEEFP FPOp                           -- Floating-point ops, categorized separately+        deriving (Eq, Ord)++-- | Floating point operations+data FPOp = FP_Cast        Kind Kind SW   -- From-Kind, To-Kind, RoundingMode. This is "value" conversion+          | FP_Reinterpret Kind Kind      -- From-Kind, To-Kind. This is bit-reinterpretation using IEEE-754 interchange format+          | FP_Abs+          | FP_Neg+          | FP_Add+          | FP_Sub+          | FP_Mul+          | FP_Div+          | FP_FMA+          | FP_Sqrt+          | FP_Rem+          | FP_RoundToIntegral+          | FP_Min+          | FP_Max+          | FP_ObjEqual+          | FP_IsNormal+          | FP_IsSubnormal+          | FP_IsZero+          | FP_IsInfinite+          | FP_IsNaN+          | FP_IsNegative+          | FP_IsPositive+          deriving (Eq, Ord)++-- | Note that the show instance maps to the SMTLib names. We need to make sure+-- this mapping stays correct through SMTLib changes. The only exception+-- is FP_Cast; where we handle different source/origins explicitly later on.+instance Show FPOp where+   show (FP_Cast f t r)      = "(FP_Cast: " ++ show f ++ " -> " ++ show t ++ ", using RM [" ++ show r ++ "])"+   show (FP_Reinterpret f t) = case (f, t) of+                                  (KBounded False 32, KFloat)  -> "(_ to_fp 8 24)"+                                  (KBounded False 64, KDouble) -> "(_ to_fp 11 53)"+                                  _                            -> error $ "SBV.FP_Reinterpret: Unexpected conversion: " ++ show f ++ " to " ++ show t+   show FP_Abs               = "fp.abs"+   show FP_Neg               = "fp.neg"+   show FP_Add               = "fp.add"+   show FP_Sub               = "fp.sub"+   show FP_Mul               = "fp.mul"+   show FP_Div               = "fp.div"+   show FP_FMA               = "fp.fma"+   show FP_Sqrt              = "fp.sqrt"+   show FP_Rem               = "fp.rem"+   show FP_RoundToIntegral   = "fp.roundToIntegral"+   show FP_Min               = "fp.min"+   show FP_Max               = "fp.max"+   show FP_ObjEqual          = "="+   show FP_IsNormal          = "fp.isNormal"+   show FP_IsSubnormal       = "fp.isSubnormal"+   show FP_IsZero            = "fp.isZero"+   show FP_IsInfinite        = "fp.isInfinite"+   show FP_IsNaN             = "fp.isNaN"+   show FP_IsNegative        = "fp.isNegative"+   show FP_IsPositive        = "fp.isPositive"++-- | Show instance for 'Op'. Note that this is largely for debugging purposes, not used+-- for being read by any tool.+instance Show Op where+  show (Shl i) = "<<"  ++ show i+  show (Shr i) = ">>"  ++ show i+  show (Rol i) = "<<<" ++ show i+  show (Ror i) = ">>>" ++ show i+  show (Extract i j) = "choose [" ++ show i ++ ":" ++ show j ++ "]"+  show (LkUp (ti, at, rt, l) i e)+        = "lookup(" ++ tinfo ++ ", " ++ show i ++ ", " ++ show e ++ ")"+        where tinfo = "table" ++ show ti ++ "(" ++ show at ++ " -> " ++ show rt ++ ", " ++ show l ++ ")"+  show (ArrEq i j)       = "array_" ++ show i ++ " == array_" ++ show j+  show (ArrRead i)       = "select array_" ++ show i+  show (KindCast fr to)  = "cast_" ++ show fr ++ "_" ++ show to+  show (Uninterpreted i) = "[uninterpreted] " ++ i+  show (Label s)         = "[label] " ++ s+  show (IEEEFP w)        = show w+  show op+    | Just s <- op `lookup` syms = s+    | True                       = error "impossible happened; can't find op!"+    where syms = [ (Plus, "+"), (Times, "*"), (Minus, "-"), (UNeg, "-"), (Abs, "abs")+                 , (Quot, "quot")+                 , (Rem,  "rem")+                 , (Equal, "=="), (NotEqual, "/=")+                 , (LessThan, "<"), (GreaterThan, ">"), (LessEq, "<="), (GreaterEq, ">=")+                 , (Ite, "if_then_else")+                 , (And, "&"), (Or, "|"), (XOr, "^"), (Not, "~")+                 , (Join, "#")+                 ]++-- | Quantifiers: forall or exists. Note that we allow+-- arbitrary nestings.+data Quantifier = ALL | EX deriving Eq++-- | Are there any existential quantifiers?+needsExistentials :: [Quantifier] -> Bool+needsExistentials = (EX `elem`)++-- | A simple type for SBV computations, used mainly for uninterpreted constants.+-- We keep track of the signedness/size of the arguments. A non-function will+-- have just one entry in the list.+newtype SBVType = SBVType [Kind]+             deriving (Eq, Ord)++instance Show SBVType where+  show (SBVType []) = error "SBV: internal error, empty SBVType"+  show (SBVType xs) = intercalate " -> " $ map show xs++-- | A symbolic expression+data SBVExpr = SBVApp !Op ![SW]+             deriving (Eq, Ord)++-- | To improve hash-consing, take advantage of commutative operators by+-- reordering their arguments.+reorder :: SBVExpr -> SBVExpr+reorder s = case s of+              SBVApp op [a, b] | isCommutative op && a > b -> SBVApp op [b, a]+              _ -> s+  where isCommutative :: Op -> Bool+        isCommutative o = o `elem` [Plus, Times, Equal, NotEqual, And, Or, XOr]++-- | Show instance for 'SBVExpr'. Again, only for debugging purposes.+instance Show SBVExpr where+  show (SBVApp Ite [t, a, b]) = unwords ["if", show t, "then", show a, "else", show b]+  show (SBVApp (Shl i) [a])   = unwords [show a, "<<", show i]+  show (SBVApp (Shr i) [a])   = unwords [show a, ">>", show i]+  show (SBVApp (Rol i) [a])   = unwords [show a, "<<<", show i]+  show (SBVApp (Ror i) [a])   = unwords [show a, ">>>", show i]+  show (SBVApp op  [a, b])    = unwords [show a, show op, show b]+  show (SBVApp op  args)      = unwords (show op : map show args)++-- | A program is a sequence of assignments+newtype SBVPgm = SBVPgm {pgmAssignments :: S.Seq (SW, SBVExpr)}++-- | 'NamedSymVar' pairs symbolic words and user given/automatically generated names+type NamedSymVar = (SW, String)++-- | Style of optimization+data OptimizeStyle = Lexicographic -- ^ Objectives are optimized in the order given, earlier objectives have higher priority. This is the default.+                   | Independent   -- ^ Each objective is optimized independently.+                   | Pareto        -- ^ Objectives are optimized according to pareto front: That is, no objective can be made better without making some other worse.+                   deriving (Eq, Show)++-- | Penalty for a soft-assertion. The default penalty is @1@, with all soft-assertions belonging+-- to the same objective goal. A positive weight and an optional group can be provided by using+-- the 'Penalty' constructor.+data Penalty = DefaultPenalty                  -- ^ Default: Penalty of @1@ and no group attached+             | Penalty Rational (Maybe String) -- ^ Penalty with a weight and an optional group+             deriving Show++-- | Objective of optimization. We can minimize, maximize, or give a soft assertion with a penalty+-- for not satisfying it.+data Objective a = Minimize   String a         -- ^ Minimize this metric+                 | Maximize   String a         -- ^ Maximize this metric+                 | AssertSoft String a Penalty -- ^ A soft assertion, with an associated penalty+                 deriving (Show, Functor)++-- | The name of the objective+objectiveName :: Objective a -> String+objectiveName (Minimize   s _)   = s+objectiveName (Maximize   s _)   = s+objectiveName (AssertSoft s _ _) = s++-- | Solver tactic+data Tactic a = CaseSplit          Bool [(String, a, [Tactic a])]  -- ^ Case-split, with implicit coverage. Bool says whether we should be verbose.+              | CheckCaseVacuity   Bool                            -- ^ Should the case-splits be checked for vacuity? (Default: True.)+              | ParallelCase                                       -- ^ Run case-splits in parallel. (Default: Sequential.)+              | CheckConstrVacuity Bool                            -- ^ Should "constraints" be checked for vacuity? (Default: False.)+              | StopAfter          Int                             -- ^ Time-out given to solver, in seconds.+              | CheckUsing         String                          -- ^ Invoke with check-sat-using command, instead of check-sat+              | UseLogic           Logic                           -- ^ Use this logic, a custom one can be specified too+              | UseSolver          SMTConfig                       -- ^ Use this solver (z3, yices, etc.)+              | OptimizePriority   OptimizeStyle                   -- ^ Use this style for optimize calls. (Default: Lexicographic)+              deriving (Show, Functor)++instance NFData OptimizeStyle where+   rnf x = x `seq` ()++instance NFData Penalty where+   rnf DefaultPenalty  = ()+   rnf (Penalty p mbs) = rnf p `seq` rnf mbs `seq` ()++instance NFData a => NFData (Objective a) where+   rnf (Minimize   s a)   = rnf s `seq` rnf a `seq` ()+   rnf (Maximize   s a)   = rnf s `seq` rnf a `seq` ()+   rnf (AssertSoft s a p) = rnf s `seq` rnf a `seq` rnf p `seq` ()++instance NFData a => NFData (Tactic a) where+   rnf (CaseSplit   b l)      = rnf b `seq` rnf l `seq` ()+   rnf (CheckCaseVacuity b)   = rnf b `seq` ()+   rnf ParallelCase           = ()+   rnf (CheckConstrVacuity b) = rnf b `seq` ()+   rnf (StopAfter        i)   = rnf i `seq` ()+   rnf (CheckUsing       s)   = rnf s `seq` ()+   rnf (UseLogic         l)   = rnf l `seq` ()+   rnf (UseSolver        s)   = rnf s `seq` ()+   rnf (OptimizePriority s)   = rnf s `seq` ()++-- | Is there a parallel-case anywhere?+isParallelCaseAnywhere :: Tactic a -> Bool+isParallelCaseAnywhere ParallelCase{}   = True+isParallelCaseAnywhere (CaseSplit _ cs) = or [any isParallelCaseAnywhere t | (_, _, t) <- cs]+isParallelCaseAnywhere _                = False++-- | Result of running a symbolic computation+data Result = Result { reskinds       :: Set.Set Kind                            -- ^ kinds used in the program+                     , resTraces      :: [(String, CW)]                          -- ^ quick-check counter-example information (if any)+                     , resUISegs      :: [(String, [String])]                    -- ^ uninterpeted code segments+                     , resInputs      :: [(Quantifier, NamedSymVar)]             -- ^ inputs (possibly existential)+                     , resConsts      :: [(SW, CW)]                              -- ^ constants+                     , resTables      :: [((Int, Kind, Kind), [SW])]             -- ^ tables (automatically constructed) (tableno, index-type, result-type) elts+                     , resArrays      :: [(Int, ArrayInfo)]                      -- ^ arrays (user specified)+                     , resUIConsts    :: [(String, SBVType)]                     -- ^ uninterpreted constants+                     , resAxioms      :: [(String, [String])]                    -- ^ axioms+                     , resAsgns       :: SBVPgm                                  -- ^ assignments+                     , resConstraints :: [SW]                                    -- ^ additional constraints (boolean)+                     , resTactics     :: [Tactic SW]                             -- ^ User given tactics+                     , resGoals       :: [Objective (SW, SW)]                    -- ^ User specified optimization goals+                     , resAssertions  :: [(String, Maybe CallStack, SW)]         -- ^ assertions+                     , resOutputs     :: [SW]                                    -- ^ outputs+                     }++-- | Show instance for 'Result'. Only for debugging purposes.+instance Show Result where+  show (Result _ _ _ _ cs _ _ [] [] _ [] _ _ _ [r])+    | Just c <- r `lookup` cs+    = show c+  show (Result kinds _ cgs is cs ts as uis axs xs cstrs tacs goals asserts os) = intercalate "\n" $+                   (if null usorts then [] else "SORTS" : map ("  " ++) usorts)+                ++ ["INPUTS"]+                ++ map shn is+                ++ ["CONSTANTS"]+                ++ map shc cs+                ++ ["TABLES"]+                ++ map sht ts+                ++ ["ARRAYS"]+                ++ map sha as+                ++ ["UNINTERPRETED CONSTANTS"]+                ++ map shui uis+                ++ ["USER GIVEN CODE SEGMENTS"]+                ++ concatMap shcg cgs+                ++ ["AXIOMS"]+                ++ map shax axs+                ++ ["TACTICS"]+                ++ map show tacs+                ++ ["GOALS"]+                ++ map show goals+                ++ ["DEFINE"]+                ++ map (\(s, e) -> "  " ++ shs s ++ " = " ++ show e) (F.toList (pgmAssignments xs))+                ++ ["CONSTRAINTS"]+                ++ map (("  " ++) . show) cstrs+                ++ ["ASSERTIONS"]+                ++ map (("  "++) . shAssert) asserts+                ++ ["OUTPUTS"]+                ++ map (("  " ++) . show) os+    where usorts = [sh s t | KUserSort s t <- Set.toList kinds]+                   where sh s (Left   _) = s+                         sh s (Right es) = s ++ " (" ++ intercalate ", " es ++ ")"+          shs sw = show sw ++ " :: " ++ show (swKind sw)+          sht ((i, at, rt), es)  = "  Table " ++ show i ++ " : " ++ show at ++ "->" ++ show rt ++ " = " ++ show es+          shc (sw, cw) = "  " ++ show sw ++ " = " ++ show cw+          shcg (s, ss) = ("Variable: " ++ s) : map ("  " ++) ss+          shn (q, (sw, nm)) = "  " ++ ni ++ " :: " ++ show (swKind sw) ++ ex ++ alias+            where ni = show sw+                  ex | q == ALL = ""+                     | True     = ", existential"+                  alias | ni == nm = ""+                        | True     = ", aliasing " ++ show nm+          sha (i, (nm, (ai, bi), ctx)) = "  " ++ ni ++ " :: " ++ show ai ++ " -> " ++ show bi ++ alias+                                       ++ "\n     Context: "     ++ show ctx+            where ni = "array_" ++ show i+                  alias | ni == nm = ""+                        | True     = ", aliasing " ++ show nm+          shui (nm, t) = "  [uninterpreted] " ++ nm ++ " :: " ++ show t+          shax (nm, ss) = "  -- user defined axiom: " ++ nm ++ "\n  " ++ intercalate "\n  " ss+          shAssert (nm, stk, p) = "  -- assertion: " ++ nm ++ " " ++ maybe "[No location]"+#if MIN_VERSION_base(4,9,0)+                prettyCallStack+#else+                showCallStack+#endif+                stk ++ ": " ++ show p++-- | The context of a symbolic array as created+data ArrayContext = ArrayFree (Maybe SW)     -- ^ A new array, with potential initializer for each cell+                  | ArrayReset Int SW        -- ^ An array created from another array by fixing each element to another value+                  | ArrayMutate Int SW SW    -- ^ An array created by mutating another array at a given cell+                  | ArrayMerge  SW Int Int   -- ^ An array created by symbolically merging two other arrays++instance Show ArrayContext where+  show (ArrayFree Nothing)  = " initialized with random elements"+  show (ArrayFree (Just s)) = " initialized with " ++ show s ++ " :: " ++ show (swKind s)+  show (ArrayReset i s)     = " reset array_" ++ show i ++ " with " ++ show s ++ " :: " ++ show (swKind s)+  show (ArrayMutate i a b)  = " cloned from array_" ++ show i ++ " with " ++ show a ++ " :: " ++ show (swKind a) ++ " |-> " ++ show b ++ " :: " ++ show (swKind b)+  show (ArrayMerge s i j)   = " merged arrays " ++ show i ++ " and " ++ show j ++ " on condition " ++ show s++-- | Expression map, used for hash-consing+type ExprMap   = Map.Map SBVExpr SW++-- | Constants are stored in a map, for hash-consing. The bool is needed to tell -0 from +0, sigh+type CnstMap   = Map.Map (Bool, CW) SW++-- | Kinds used in the program; used for determining the final SMT-Lib logic to pick+type KindSet = Set.Set Kind++-- | Tables generated during a symbolic run+type TableMap  = Map.Map (Kind, Kind, [SW]) Int++-- | Representation for symbolic arrays+type ArrayInfo = (String, (Kind, Kind), ArrayContext)++-- | Arrays generated during a symbolic run+type ArrayMap  = IMap.IntMap ArrayInfo++-- | Uninterpreted-constants generated during a symbolic run+type UIMap     = Map.Map String SBVType++-- | Code-segments for Uninterpreted-constants, as given by the user+type CgMap     = Map.Map String [String]++-- | Cached values, implementing sharing+type Cache a   = IMap.IntMap [(StableName (State -> IO a), a)]++-- | Different means of running a symbolic piece of code+data SBVRunMode = Proof (Bool, SMTConfig) -- ^ Fully Symbolic, proof mode.+                | CodeGen                 -- ^ Code generation mode.+                | Concrete StdGen         -- ^ Concrete simulation mode. The StdGen is for the pConstrain acceptance in cross runs.++-- | Is this a concrete run? (i.e., quick-check or test-generation like)+isConcreteMode :: State -> Bool+isConcreteMode State{runMode} = case runMode of+                                  Concrete{} -> True+                                  Proof{}    -> False+                                  CodeGen    -> False++-- | Is this a CodeGen run? (i.e., generating code)+isCodeGenMode :: State -> Bool+isCodeGenMode State{runMode} = case runMode of+                                 Concrete{} -> False+                                 Proof{}    -> False+                                 CodeGen    -> True++-- | The state of the symbolic interpreter+data State  = State { runMode      :: SBVRunMode+                    , pathCond     :: SVal                             -- ^ kind KBool+                    , rStdGen      :: IORef StdGen+                    , rCInfo       :: IORef [(String, CW)]+                    , rctr         :: IORef Int+                    , rUsedKinds   :: IORef KindSet+                    , rinps        :: IORef [(Quantifier, NamedSymVar)]+                    , rConstraints :: IORef [SW]+                    , routs        :: IORef [SW]+                    , rtblMap      :: IORef TableMap+                    , spgm         :: IORef SBVPgm+                    , rconstMap    :: IORef CnstMap+                    , rexprMap     :: IORef ExprMap+                    , rArrayMap    :: IORef ArrayMap+                    , rUIMap       :: IORef UIMap+                    , rCgMap       :: IORef CgMap+                    , raxioms      :: IORef [(String, [String])]+                    , rTacs        :: IORef [Tactic SW]+                    , rOptGoals    :: IORef [Objective (SW, SW)]+                    , rAsserts     :: IORef [(String, Maybe CallStack, SW)]+                    , rSWCache     :: IORef (Cache SW)+                    , rAICache     :: IORef (Cache Int)+                    }++-- | Get the current path condition+getSValPathCondition :: State -> SVal+getSValPathCondition = pathCond++-- | Extend the path condition with the given test value.+extendSValPathCondition :: State -> (SVal -> SVal) -> State+extendSValPathCondition st f = st{pathCond = f (pathCond st)}++-- | Are we running in proof mode?+inProofMode :: State -> Bool+inProofMode s = case runMode s of+                  Proof{}    -> True+                  CodeGen    -> False+                  Concrete{} -> False++-- | If in proof mode, get the underlying configuration (used for 'sBranch')+getSBranchRunConfig :: State -> Maybe SMTConfig+getSBranchRunConfig st = case runMode st of+                           Proof (_, s)  -> Just s+                           _             -> Nothing++-- | The "Symbolic" value. Either a constant (@Left@) or a symbolic+-- value (@Right Cached@). Note that caching is essential for making+-- sure sharing is preserved.+data SVal = SVal !Kind !(Either CW (Cached SW))++instance HasKind SVal where+  kindOf (SVal k _) = k++-- | Show instance for 'SVal'. Not particularly "desirable", but will do if needed+-- NB. We do not show the type info on constant KBool values, since there's no+-- implicit "fromBoolean" applied to Booleans in Haskell; and thus a statement+-- of the form "True :: SBool" is just meaningless. (There should be a fromBoolean!)+instance Show SVal where+  show (SVal KBool (Left c))  = showCW False c+  show (SVal k     (Left c))  = showCW False c ++ " :: " ++ show k+  show (SVal k     (Right _)) =         "<symbolic> :: " ++ show k++-- | Equality constraint on SBV values. Not desirable since we can't really compare two+-- symbolic values, but will do.+instance Eq SVal where+  SVal _ (Left a) == SVal _ (Left b) = a == b+  a == b = error $ "Comparing symbolic bit-vectors; Use (.==) instead. Received: " ++ show (a, b)+  SVal _ (Left a) /= SVal _ (Left b) = a /= b+  a /= b = error $ "Comparing symbolic bit-vectors; Use (./=) instead. Received: " ++ show (a, b)++-- | Increment the variable counter+incCtr :: State -> IO Int+incCtr s = do ctr <- readIORef (rctr s)+              let i = ctr + 1+              i `seq` writeIORef (rctr s) i+              return ctr++-- | Generate a random value, for quick-check and test-gen purposes+throwDice :: State -> IO Double+throwDice st = do g <- readIORef (rStdGen st)+                  let (r, g') = randomR (0, 1) g+                  writeIORef (rStdGen st) g'+                  return r++-- | Create a new uninterpreted symbol, possibly with user given code+newUninterpreted :: State -> String -> SBVType -> Maybe [String] -> IO ()+newUninterpreted st nm t mbCode+  | null nm || not enclosed && (not (isAlpha (head nm)) || not (all validChar (tail nm)))+  = error $ "Bad uninterpreted constant name: " ++ show nm ++ ". Must be a valid identifier."+  | True = do+        uiMap <- readIORef (rUIMap st)+        case nm `Map.lookup` uiMap of+          Just t' -> when (t /= t') $ error $  "Uninterpreted constant " ++ show nm ++ " used at incompatible types\n"+                                            ++ "      Current type      : " ++ show t ++ "\n"+                                            ++ "      Previously used at: " ++ show t'+          Nothing -> do modifyIORef (rUIMap st) (Map.insert nm t)+                        when (isJust mbCode) $ modifyIORef (rCgMap st) (Map.insert nm (fromJust mbCode))+  where validChar x = isAlphaNum x || x `elem` "_"+        enclosed    = head nm == '|' && last nm == '|' && length nm > 2 && not (any (`elem` "|\\") (tail (init nm)))++-- | Add a new sAssert based constraint+addAssertion :: State -> Maybe CallStack -> String -> SW -> IO ()+addAssertion st cs msg cond = modifyIORef (rAsserts st) ((msg, cs, cond):)++-- | Create an internal variable, which acts as an input but isn't visible to the user.+-- Such variables are existentially quantified in a SAT context, and universally quantified+-- in a proof context.+internalVariable :: State -> Kind -> IO SW+internalVariable st k = do (sw, nm) <- newSW st k+                           let q = case runMode st of+                                     Proof (True,  _) -> EX+                                     _                -> ALL+                           modifyIORef (rinps st) ((q, (sw, "__internal_sbv_" ++ nm)):)+                           return sw+{-# INLINE internalVariable #-}++-- | Create a new SW+newSW :: State -> Kind -> IO (SW, String)+newSW st k = do ctr <- incCtr st+                let sw = SW k (NodeId ctr)+                registerKind st k+                return (sw, 's' : show ctr)+{-# INLINE newSW #-}++-- | Register a new kind with the system, used for uninterpreted sorts+registerKind :: State -> Kind -> IO ()+registerKind st k+  | KUserSort sortName _ <- k, map toLower sortName `elem` smtLibReservedNames+  = error $ "SBV: " ++ show sortName ++ " is a reserved sort; please use a different name."+  | True+  = modifyIORef (rUsedKinds st) (Set.insert k)++-- | Create a new constant; hash-cons as necessary+-- NB. For each constant, we also store weather it's negative-0 or not,+-- as otherwise +0 == -0 and thus we'd confuse those entries. That's a+-- bummer as we incur an extra boolean for this rare case, but it's simple+-- and hopefully we don't generate a ton of constants in general.+newConst :: State -> CW -> IO SW+newConst st c = do+  constMap <- readIORef (rconstMap st)+  let key = (isNeg0 (cwVal c), c)+  case key `Map.lookup` constMap of+    Just sw -> return sw+    Nothing -> do let k = kindOf c+                  (sw, _) <- newSW st k+                  modifyIORef (rconstMap st) (Map.insert key sw)+                  return sw+  where isNeg0 (CWFloat  f) = isNegativeZero f+        isNeg0 (CWDouble d) = isNegativeZero d+        isNeg0 _            = False+{-# INLINE newConst #-}++-- | Create a new table; hash-cons as necessary+getTableIndex :: State -> Kind -> Kind -> [SW] -> IO Int+getTableIndex st at rt elts = do+  let key = (at, rt, elts)+  tblMap <- readIORef (rtblMap st)+  case key `Map.lookup` tblMap of+    Just i -> return i+    _      -> do let i = Map.size tblMap+                 modifyIORef (rtblMap st) (Map.insert key i)+                 return i++-- | Create a new expression; hash-cons as necessary+newExpr :: State -> Kind -> SBVExpr -> IO SW+newExpr st k app = do+   let e = reorder app+   exprMap <- readIORef (rexprMap st)+   case e `Map.lookup` exprMap of+     Just sw -> return sw+     Nothing -> do (sw, _) <- newSW st k+                   modifyIORef (spgm st)     (\(SBVPgm xs) -> SBVPgm (xs S.|> (sw, e)))+                   modifyIORef (rexprMap st) (Map.insert e sw)+                   return sw+{-# INLINE newExpr #-}++-- | Convert a symbolic value to a symbolic-word+svToSW :: State -> SVal -> IO SW+svToSW st (SVal _ (Left c))  = newConst st c+svToSW st (SVal _ (Right f)) = uncache f st++-- | Convert a symbolic value to an SW, inside the Symbolic monad+svToSymSW :: SVal -> Symbolic SW+svToSymSW sbv = do st <- ask+                   liftIO $ svToSW st sbv++-------------------------------------------------------------------------+-- * Symbolic Computations+-------------------------------------------------------------------------+-- | A Symbolic computation. Represented by a reader monad carrying the+-- state of the computation, layered on top of IO for creating unique+-- references to hold onto intermediate results.+newtype Symbolic a = Symbolic (ReaderT State IO a)+                   deriving (Applicative, Functor, Monad, MonadIO, MonadReader State)++-- | 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 existential for SAT calls and universal for everything else.+-- @randomCW@ is used for generating random values for this variable+-- when used for 'quickCheck' purposes.+svMkSymVar :: Maybe Quantifier -> Kind -> Maybe String -> Symbolic SVal+svMkSymVar mbQ k mbNm = do+        st <- ask+        let q = case (mbQ, runMode st) of+                  (Just x,  _)                -> x   -- user given, just take it+                  (Nothing, Concrete{})       -> ALL -- concrete simulation, pick universal+                  (Nothing, Proof (True,  _)) -> EX  -- sat mode, pick existential+                  (Nothing, Proof (False, _)) -> ALL -- proof mode, pick universal+                  (Nothing, CodeGen)          -> ALL -- code generation, pick universal+        case runMode st of+          Concrete _ | q == EX -> case mbNm of+                                    Nothing -> error $ "Cannot quick-check in the presence of existential variables, type: " ++ show k+                                    Just nm -> error $ "Cannot quick-check in the presence of existential variable " ++ nm ++ " :: " ++ show k+          Concrete _           -> do cw <- liftIO (randomCW k)+                                     liftIO $ modifyIORef (rCInfo st) ((fromMaybe "_" mbNm, cw):)+                                     return (SVal k (Left cw))+          _          -> do (sw, internalName) <- liftIO $ newSW st k+                           let nm = fromMaybe internalName mbNm+                           introduceUserName st nm k q sw++-- | Create a properly quantified variable of a user defined sort. Only valid+-- in proof contexts.+mkSValUserSort :: Kind -> Maybe Quantifier -> Maybe String -> Symbolic SVal+mkSValUserSort k mbQ mbNm = do+        st <- ask+        let (KUserSort sortName _) = k+        liftIO $ registerKind st k+        let q = case (mbQ, runMode st) of+                  (Just x,  _)                -> x+                  (Nothing, Proof (True,  _)) -> EX+                  (Nothing, Proof (False, _)) -> ALL+                  (Nothing, CodeGen)          -> error $ "SBV: Uninterpreted sort " ++ sortName ++ " can not be used in code-generation mode."+                  (Nothing, Concrete{})       -> error $ "SBV: Uninterpreted sort " ++ sortName ++ " can not be used in concrete simulation mode."+        ctr <- liftIO $ incCtr st+        let sw = SW k (NodeId ctr)+            nm = fromMaybe ('s':show ctr) mbNm+        introduceUserName st nm k q sw++-- | Introduce a new user name. We die if repeated.+introduceUserName :: State -> String -> Kind -> Quantifier -> SW -> Symbolic SVal+introduceUserName st nm k q sw = do is <- liftIO $ readIORef (rinps st)+                                    if nm `elem` [n | (_, (_, n)) <- is]+                                       then error $ "SBV: Repeated user given name: " ++ show nm ++ ". Please use unique names."+                                       else do liftIO $ modifyIORef (rinps st) ((q, (sw, nm)):)+                                               return $ SVal k $ Right $ cache (const (return sw))++-- | 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.+-- A separate formalization of SMT-Lib would be very useful here.+addAxiom :: String -> [String] -> Symbolic ()+addAxiom nm ax = do+        st <- ask+        liftIO $ modifyIORef (raxioms st) ((nm, ax) :)++-- | Run a symbolic computation in Proof mode and return a 'Result'. The boolean+-- argument indicates if this is a sat instance or not.+runSymbolic :: (Bool, SMTConfig) -> Symbolic a -> IO Result+runSymbolic m c = snd `fmap` runSymbolic' (Proof m) c++-- | Run a symbolic computation, and return a extra value paired up with the 'Result'+runSymbolic' :: SBVRunMode -> Symbolic a -> IO (a, Result)+runSymbolic' currentRunMode (Symbolic c) = do+   ctr       <- newIORef (-2) -- start from -2; False and True will always occupy the first two elements+   cInfo     <- newIORef []+   pgm       <- newIORef (SBVPgm S.empty)+   emap      <- newIORef Map.empty+   cmap      <- newIORef Map.empty+   inps      <- newIORef []+   outs      <- newIORef []+   tables    <- newIORef Map.empty+   arrays    <- newIORef IMap.empty+   uis       <- newIORef Map.empty+   cgs       <- newIORef Map.empty+   axioms    <- newIORef []+   swCache   <- newIORef IMap.empty+   aiCache   <- newIORef IMap.empty+   usedKinds <- newIORef Set.empty+   cstrs     <- newIORef []+   tacs      <- newIORef []+   optGoals  <- newIORef []+   asserts   <- newIORef []+   rGen      <- case currentRunMode of+                  Concrete g -> newIORef g+                  _          -> newStdGen >>= newIORef+   let st = State { runMode      = currentRunMode+                  , pathCond     = SVal KBool (Left trueCW)+                  , rStdGen      = rGen+                  , rCInfo       = cInfo+                  , rctr         = ctr+                  , rUsedKinds   = usedKinds+                  , rinps        = inps+                  , routs        = outs+                  , rtblMap      = tables+                  , spgm         = pgm+                  , rconstMap    = cmap+                  , rArrayMap    = arrays+                  , rexprMap     = emap+                  , rUIMap       = uis+                  , rCgMap       = cgs+                  , raxioms      = axioms+                  , rSWCache     = swCache+                  , rAICache     = aiCache+                  , rConstraints = cstrs+                  , rTacs        = tacs+                  , rOptGoals    = optGoals+                  , rAsserts     = asserts+                  }+   _ <- newConst st falseCW -- s(-2) == falseSW+   _ <- newConst st trueCW  -- s(-1) == trueSW+   r <- runReaderT c st+   res <- extractSymbolicSimulationState st+   return (r, res)++-- | Grab the program from a running symbolic simulation state. This is useful for internal purposes, for+-- instance when implementing 'sBranch'.+extractSymbolicSimulationState :: State -> IO Result+extractSymbolicSimulationState st@State{ spgm=pgm, rinps=inps, routs=outs, rtblMap=tables, rArrayMap=arrays, rUIMap=uis, raxioms=axioms+                                       , rAsserts=asserts, rUsedKinds=usedKinds, rCgMap=cgs, rCInfo=cInfo, rConstraints=cstrs+                                       , rTacs=tacs, rOptGoals=optGoals } = do+   SBVPgm rpgm  <- readIORef pgm+   inpsO <- reverse `fmap` readIORef inps+   outsO <- reverse `fmap` readIORef outs+   let swap  (a, b)              = (b, a)+       swapc ((_, a), b)         = (b, a)+       cmp   (a, _) (b, _)       = a `compare` b+       arrange (i, (at, rt, es)) = ((i, at, rt), es)+   cnsts <- (sortBy cmp . map swapc . Map.toList) `fmap` readIORef (rconstMap st)+   tbls  <- (map arrange . sortBy cmp . map swap . Map.toList) `fmap` readIORef tables+   arrs  <- IMap.toAscList `fmap` readIORef arrays+   unint <- Map.toList `fmap` readIORef uis+   axs   <- reverse `fmap` readIORef axioms+   knds  <- readIORef usedKinds+   cgMap <- Map.toList `fmap` readIORef cgs+   traceVals  <- reverse `fmap` readIORef cInfo+   extraCstrs <- reverse `fmap` readIORef cstrs+   tactics    <- reverse `fmap` readIORef tacs+   goals      <- reverse `fmap` readIORef optGoals+   assertions <- reverse `fmap` readIORef asserts+   return $ Result knds traceVals cgMap inpsO cnsts tbls arrs unint axs (SBVPgm rpgm) extraCstrs tactics goals assertions outsO++-- | Handling constraints+imposeConstraint :: SVal -> Symbolic ()+imposeConstraint c = do st <- ask+                        case runMode st of+                          CodeGen -> error "SBV: constraints are not allowed in code-generation"+                          _       -> liftIO $ internalConstraint st c++-- | Require a boolean condition to be true in the state. Only used for internal purposes.+internalConstraint :: State -> SVal -> IO ()+internalConstraint st b = do v <- svToSW st b+                             modifyIORef (rConstraints st) (v:)++-- | Add a tactic+addSValTactic :: Tactic SVal -> Symbolic ()+addSValTactic tac = do st <- ask+                       let walk (CaseSplit b cs)       = let app (nm, v, ts) = do ts' <- mapM walk ts+                                                                                  v' <- svToSW st v+                                                                                  return (nm, v', ts')+                                                         in CaseSplit b `fmap` mapM app cs+                           walk ParallelCase           = return   ParallelCase+                           walk (CheckCaseVacuity b)   = return $ CheckCaseVacuity b+                           walk (StopAfter i)          = return $ StopAfter  i+                           walk (CheckConstrVacuity b) = return $ CheckConstrVacuity b+                           walk (CheckUsing s)         = return $ CheckUsing s+                           walk (UseLogic   l)         = return $ UseLogic   l+                           walk (UseSolver  s)         = return $ UseSolver  s+                           walk (OptimizePriority s)   = return $ OptimizePriority s+                       tac' <- liftIO $ walk tac+                       liftIO $ modifyIORef (rTacs st) (tac':)++-- | Add an optimization goal+addSValOptGoal :: Objective SVal -> Symbolic ()+addSValOptGoal obj = do st <- ask++                        -- create the tracking variable here for the metric+                        let mkGoal nm orig = do origSW  <- liftIO $ svToSW st orig+                                                track   <- svMkSymVar (Just EX) (kindOf orig) (Just nm)+                                                trackSW <- liftIO $ svToSW st track+                                                return (origSW, trackSW)++                        let walk (Minimize   nm v)     = Minimize nm              `fmap` mkGoal nm v+                            walk (Maximize   nm v)     = Maximize nm              `fmap` mkGoal nm v+                            walk (AssertSoft nm v mbP) = flip (AssertSoft nm) mbP `fmap` mkGoal nm v++                        obj' <- walk obj+                        liftIO $ modifyIORef (rOptGoals st) (obj' :)++-- | Add a constraint with a given probability+addSValConstraint :: Maybe Double -> SVal -> SVal -> Symbolic ()+addSValConstraint Nothing  c _  = imposeConstraint c+addSValConstraint (Just t) c c'+  | t < 0 || t > 1+  = error $ "SBV: pConstrain: Invalid probability threshold: " ++ show t ++ ", must be in [0, 1]."+  | True+  = do st <- ask+       unless (isConcreteMode st) $ error "SBV: pConstrain only allowed in 'genTest' or 'quickCheck' contexts."+       case () of+         () | t > 0 && t < 1 -> liftIO (throwDice st) >>= \d -> imposeConstraint (if d <= t then c else c')+            | t > 0          -> imposeConstraint c+            | True           -> imposeConstraint c'++-- | Mark an interim result as an output. Useful when constructing Symbolic programs+-- that return multiple values, or when the result is programmatically computed.+outputSVal :: SVal -> Symbolic ()+outputSVal (SVal _ (Left c)) = do+  st <- ask+  sw <- liftIO $ newConst st c+  liftIO $ modifyIORef (routs st) (sw:)+outputSVal (SVal _ (Right f)) = do+  st <- ask+  sw <- liftIO $ uncache f st+  liftIO $ modifyIORef (routs st) (sw:)++---------------------------------------------------------------------------------+-- * Symbolic Arrays+---------------------------------------------------------------------------------++-- | Arrays implemented in terms of SMT-arrays: <http://smtlib.cs.uiowa.edu/theories-ArraysEx.shtml>+--+--   * Maps directly to SMT-lib arrays+--+--   * Reading from an unintialized value is OK and yields an unspecified result+--+--   * Can check for equality of these arrays+--+--   * Cannot quick-check theorems using @SArr@ values+--+--   * Typically slower as it heavily relies on SMT-solving for the array theory+--++data SArr = SArr (Kind, Kind) (Cached ArrayIndex)++-- | Read the array element at @a@+readSArr :: SArr -> SVal -> SVal+readSArr (SArr (_, bk) f) a = SVal bk $ Right $ cache r+  where r st = do arr <- uncacheAI f st+                  i   <- svToSW st a+                  newExpr st bk (SBVApp (ArrRead arr) [i])++-- | Reset all the elements of the array to the value @b@+resetSArr :: SArr -> SVal -> SArr+resetSArr (SArr ainfo f) b = SArr ainfo $ cache g+  where g st = do amap <- readIORef (rArrayMap st)+                  val <- svToSW st b+                  i <- uncacheAI f st+                  let j = IMap.size amap+                  j `seq` modifyIORef (rArrayMap st) (IMap.insert j ("array_" ++ show j, ainfo, ArrayReset i val))+                  return j++-- | Update the element at @a@ to be @b@+writeSArr :: SArr -> SVal -> SVal -> SArr+writeSArr (SArr ainfo f) a b = SArr ainfo $ cache g+  where g st = do arr  <- uncacheAI f st+                  addr <- svToSW st a+                  val  <- svToSW st b+                  amap <- readIORef (rArrayMap st)+                  let j = IMap.size amap+                  j `seq` modifyIORef (rArrayMap st) (IMap.insert j ("array_" ++ show j, ainfo, ArrayMutate arr addr val))+                  return j++-- | Merge two given arrays on the symbolic condition+-- Intuitively: @mergeArrays cond a b = if cond then a else b@.+-- Merging pushes the if-then-else choice down on to elements+mergeSArr :: SVal -> SArr -> SArr -> SArr+mergeSArr t (SArr ainfo a) (SArr _ b) = SArr ainfo $ cache h+  where h st = do ai <- uncacheAI a st+                  bi <- uncacheAI b st+                  ts <- svToSW st t+                  amap <- readIORef (rArrayMap st)+                  let k = IMap.size amap+                  k `seq` modifyIORef (rArrayMap st) (IMap.insert k ("array_" ++ show k, ainfo, ArrayMerge ts ai bi))+                  return k++-- | Create a named new array, with an optional initial value+newSArr :: (Kind, Kind) -> (Int -> String) -> Maybe SVal -> Symbolic SArr+newSArr ainfo mkNm mbInit = do+    st <- ask+    amap <- liftIO $ readIORef $ rArrayMap st+    let i = IMap.size amap+        nm = mkNm i+    actx <- liftIO $ case mbInit of+                       Nothing   -> return $ ArrayFree Nothing+                       Just ival -> svToSW st ival >>= \sw -> return $ ArrayFree (Just sw)+    liftIO $ modifyIORef (rArrayMap st) (IMap.insert i (nm, ainfo, actx))+    return $ SArr ainfo $ cache $ const $ return i++-- | Compare two arrays for equality+eqSArr :: SArr -> SArr -> SVal+eqSArr (SArr _ a) (SArr _ b) = SVal KBool $ Right $ cache c+  where c st = do ai <- uncacheAI a st+                  bi <- uncacheAI b st+                  newExpr st KBool (SBVApp (ArrEq ai bi) [])++---------------------------------------------------------------------------------+-- * Cached values+---------------------------------------------------------------------------------++-- | We implement a peculiar caching mechanism, applicable to the use case in+-- implementation of SBV's.  Whenever we do a state based computation, we do+-- not want to keep on evaluating it in the then-current state. That will+-- produce essentially a semantically equivalent value. Thus, we want to run+-- it only once, and reuse that result, capturing the sharing at the Haskell+-- 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+-- this technique: <http://ittc.ku.edu/~andygill/paper.php?label=DSLExtract09>+--+-- Note that this is *not* a general memo utility!+newtype Cached a = Cached (State -> IO a)++-- | Cache a state-based computation+cache :: (State -> IO a) -> Cached a+cache = Cached++-- | Uncache a previously cached computation+uncache :: Cached SW -> State -> IO SW+uncache = uncacheGen rSWCache++-- | An array index is simple an int value+type ArrayIndex = Int++-- | Uncache, retrieving array indexes+uncacheAI :: Cached ArrayIndex -> State -> IO ArrayIndex+uncacheAI = uncacheGen rAICache++-- | Generic uncaching. Note that this is entirely safe, since we do it in the IO monad.+uncacheGen :: (State -> IORef (Cache a)) -> Cached a -> State -> IO a+uncacheGen getCache (Cached f) st = do+        let rCache = getCache st+        stored <- readIORef rCache+        sn <- f `seq` makeStableName f+        let h = hashStableName sn+        case maybe Nothing (sn `lookup`) (h `IMap.lookup` stored) of+          Just r  -> return r+          Nothing -> do r <- f st+                        r `seq` modifyIORef rCache (IMap.insertWith (++) h [(sn, r)])+                        return r++-- | Representation of SMTLib Program versions. As of June 2015, we're dropping support+-- for SMTLib1, and supporting SMTLib2 only. We keep this data-type around in case+-- SMTLib3 comes along and we want to support 2 and 3 simultaneously.+data SMTLibVersion = SMTLib2+                   deriving (Bounded, Enum, Eq, Show)++-- | The extension associated with the version+smtLibVersionExtension :: SMTLibVersion -> String+smtLibVersionExtension SMTLib2 = "smt2"++-- | Representation of an SMT-Lib program. In between pre and post goes the refuted models+data SMTLibPgm = SMTLibPgm SMTLibVersion [String]++instance NFData SMTLibVersion where rnf a               = a `seq` ()+instance NFData SMTLibPgm     where rnf (SMTLibPgm v p) = rnf v `seq` rnf p `seq` ()++instance Show SMTLibPgm where+  show (SMTLibPgm _ pre) = intercalate "\n" pre++-- Other Technicalities..+instance NFData CW where+  rnf (CW x y) = x `seq` y `seq` ()++instance NFData GeneralizedCW where+  rnf (ExtendedCW e) = e `seq` ()+  rnf (RegularCW  c) = c `seq` ()++#if MIN_VERSION_base(4,9,0)+#else+-- Can't really force this, but not a big deal+instance NFData CallStack where+  rnf _ = ()+#endif++instance NFData Result where+  rnf (Result kindInfo qcInfo cgs inps consts tbls arrs uis axs pgm cstr tacs goals asserts outs)+        = rnf kindInfo `seq` rnf qcInfo  `seq` rnf cgs  `seq` rnf inps+                       `seq` rnf consts  `seq` rnf tbls `seq` rnf arrs+                       `seq` rnf uis     `seq` rnf axs  `seq` rnf pgm+                       `seq` rnf cstr    `seq` rnf tacs `seq` rnf goals+                       `seq` rnf asserts `seq` rnf outs+instance NFData Kind         where rnf a          = seq a ()+instance NFData ArrayContext where rnf a          = seq a ()+instance NFData SW           where rnf a          = seq a ()+instance NFData SBVExpr      where rnf a          = seq a ()+instance NFData Quantifier   where rnf a          = seq a ()+instance NFData SBVType      where rnf a          = seq a ()+instance NFData SBVPgm       where rnf a          = seq a ()+instance NFData (Cached a)   where rnf (Cached f) = f `seq` ()+instance NFData SVal         where rnf (SVal x y) = rnf x `seq` rnf y `seq` ()++instance NFData SMTResult where+  rnf Unsatisfiable{}    = ()+  rnf (Satisfiable _ xs) = rnf xs `seq` ()+  rnf (SatExtField _ xs) = rnf xs `seq` ()+  rnf (Unknown _     xs) = rnf xs `seq` ()+  rnf (ProofError _  xs) = rnf xs `seq` ()+  rnf TimeOut{}          = ()++instance NFData SMTModel where+  rnf (SMTModel objs assocs) = rnf objs `seq` rnf assocs `seq` ()++instance NFData SMTScript where+  rnf (SMTScript b m) = rnf b `seq` rnf m `seq` ()++-- | SMT-Lib logics. If left unspecified SBV will pick the logic based on what it determines is needed. However, the+-- user can override this choice using the 'useLogic' parameter to the configuration. This is especially handy if+-- one is experimenting with custom logics that might be supported on new solvers. See <http://smtlib.cs.uiowa.edu/logics.shtml>+-- for the official list.+data SMTLibLogic+  = AUFLIA    -- ^ Formulas over the theory of linear integer arithmetic and arrays extended with free sort and function symbols but restricted to arrays with integer indices and values.+  | AUFLIRA   -- ^ Linear formulas with free sort and function symbols over one- and two-dimentional arrays of integer index and real value.+  | AUFNIRA   -- ^ Formulas with free function and predicate symbols over a theory of arrays of arrays of integer index and real value.+  | LRA       -- ^ Linear formulas in linear real arithmetic.+  | QF_ABV    -- ^ Quantifier-free formulas over the theory of bitvectors and bitvector arrays.+  | QF_AUFBV  -- ^ Quantifier-free formulas over the theory of bitvectors and bitvector arrays extended with free sort and function symbols.+  | QF_AUFLIA -- ^ Quantifier-free linear formulas over the theory of integer arrays extended with free sort and function symbols.+  | QF_AX     -- ^ Quantifier-free formulas over the theory of arrays with extensionality.+  | QF_BV     -- ^ Quantifier-free formulas over the theory of fixed-size bitvectors.+  | QF_IDL    -- ^ Difference Logic over the integers. Boolean combinations of inequations of the form x - y < b where x and y are integer variables and b is an integer constant.+  | QF_LIA    -- ^ Unquantified linear integer arithmetic. In essence, Boolean combinations of inequations between linear polynomials over integer variables.+  | QF_LRA    -- ^ Unquantified linear real arithmetic. In essence, Boolean combinations of inequations between linear polynomials over real variables.+  | QF_NIA    -- ^ Quantifier-free integer arithmetic.+  | QF_NRA    -- ^ Quantifier-free real arithmetic.+  | QF_RDL    -- ^ Difference Logic over the reals. In essence, Boolean combinations of inequations of the form x - y < b where x and y are real variables and b is a rational constant.+  | QF_UF     -- ^ Unquantified formulas built over a signature of uninterpreted (i.e., free) sort and function symbols.+  | QF_UFBV   -- ^ Unquantified formulas over bitvectors with uninterpreted sort function and symbols.+  | QF_UFIDL  -- ^ Difference Logic over the integers (in essence) but with uninterpreted sort and function symbols.+  | QF_UFLIA  -- ^ Unquantified linear integer arithmetic with uninterpreted sort and function symbols.+  | QF_UFLRA  -- ^ Unquantified linear real arithmetic with uninterpreted sort and function symbols.+  | QF_UFNRA  -- ^ Unquantified non-linear real arithmetic with uninterpreted sort and function symbols.+  | QF_UFNIRA -- ^ Unquantified non-linear real integer arithmetic with uninterpreted sort and function symbols.+  | UFLRA     -- ^ Linear real arithmetic with uninterpreted sort and function symbols.+  | UFNIA     -- ^ Non-linear integer arithmetic with uninterpreted sort and function symbols.+  | QF_FPBV   -- ^ Quantifier-free formulas over the theory of floating point numbers, arrays, and bit-vectors.+  | QF_FP     -- ^ Quantifier-free formulas over the theory of floating point numbers.+  deriving Show++-- | NFData instance for SMTLibLogic+instance NFData SMTLibLogic where+   rnf x = x `seq` ()++-- | Chosen logic for the solver+data Logic = PredefinedLogic SMTLibLogic  -- ^ Use one of the logics as defined by the standard+           | CustomLogic     String       -- ^ Use this name for the logic++instance Show Logic where+  show (PredefinedLogic l) = show l+  show (CustomLogic     s) = s++-- | NFData instance for Logic+instance NFData Logic where+  rnf (PredefinedLogic l) = rnf l+  rnf (CustomLogic s)     = rnf s `seq` ()++-- | Translation tricks needed for specific capabilities afforded by each solver+data SolverCapabilities = SolverCapabilities {+         capSolverName              :: String               -- ^ Name of the solver+       , mbDefaultLogic             :: Bool -> Maybe String -- ^ set-logic string to use in case not automatically determined (if any). If Bool is True, then reals are present.+       , supportsMacros             :: Bool                 -- ^ Does the solver understand SMT-Lib2 macros?+       , supportsProduceModels      :: Bool                 -- ^ Does the solver understand produce-models option setting+       , supportsQuantifiers        :: Bool                 -- ^ Does the solver understand SMT-Lib2 style quantifiers?+       , supportsUninterpretedSorts :: Bool                 -- ^ Does the solver understand SMT-Lib2 style uninterpreted-sorts+       , supportsUnboundedInts      :: Bool                 -- ^ Does the solver support unbounded integers?+       , supportsReals              :: Bool                 -- ^ Does the solver support reals?+       , supportsFloats             :: Bool                 -- ^ Does the solver support single-precision floating point numbers?+       , supportsDoubles            :: Bool                 -- ^ Does the solver support double-precision floating point numbers?+       , supportsOptimization       :: Bool                 -- ^ Does the solver support optimization routines?+       }++-- | Rounding mode to be used for the IEEE floating-point operations.+-- Note that Haskell's default is 'RoundNearestTiesToEven'. If you use+-- a different rounding mode, then the counter-examples you get may not+-- match what you observe in Haskell.+data RoundingMode = RoundNearestTiesToEven  -- ^ Round to nearest representable floating point value.+                                            -- If precisely at half-way, pick the even number.+                                            -- (In this context, /even/ means the lowest-order bit is zero.)+                  | RoundNearestTiesToAway  -- ^ Round to nearest representable floating point value.+                                            -- If precisely at half-way, pick the number further away from 0.+                                            -- (That is, for positive values, pick the greater; for negative values, pick the smaller.)+                  | RoundTowardPositive     -- ^ Round towards positive infinity. (Also known as rounding-up or ceiling.)+                  | RoundTowardNegative     -- ^ Round towards negative infinity. (Also known as rounding-down or floor.)+                  | RoundTowardZero         -- ^ Round towards zero. (Also known as truncation.)+                  deriving (Eq, Ord, Show, Read, G.Data, Bounded, Enum)++-- | 'RoundingMode' kind+instance HasKind RoundingMode++-- | Solver configuration. See also 'z3', 'yices', 'cvc4', 'boolector', 'mathSAT', etc. which are instantiations of this type for those solvers, with+-- reasonable defaults. In particular, custom configuration can be created by varying those values. (Such as @z3{verbose=True}@.)+--+-- Most fields are self explanatory. The notion of precision for printing algebraic reals stems from the fact that such values does+-- not necessarily have finite decimal representations, and hence we have to stop printing at some depth. It is important to+-- emphasize that such values always have infinite precision internally. The issue is merely with how we print such an infinite+-- precision value on the screen. The field 'printRealPrec' controls the printing precision, by specifying the number of digits after+-- the decimal point. The default value is 16, but it can be set to any positive integer.+--+-- When printing, SBV will add the suffix @...@ at the and of a real-value, if the given bound is not sufficient to represent the real-value+-- exactly. Otherwise, the number will be written out in standard decimal notation. Note that SBV will always print the whole value if it+-- is precise (i.e., if it fits in a finite number of digits), regardless of the precision limit. The limit only applies if the representation+-- of the real value is not finite, i.e., if it is not rational.+--+-- The 'printBase' field can be used to print numbers in base 2, 10, or 16. If base 2 or 16 is used, then floating-point values will+-- be printed in their internal memory-layout format as well, which can come in handy for bit-precise analysis.+data SMTConfig = SMTConfig {+         verbose        :: Bool           -- ^ Debug mode+       , timing         :: Timing         -- ^ Print timing information on how long different phases took (construction, solving, etc.)+       , sBranchTimeOut :: Maybe Int      -- ^ How much time to give to the solver for each call of 'sBranch' check. (In seconds. Default: No limit.)+       , timeOut        :: Maybe Int      -- ^ How much time to give to the solver. (In seconds. Default: No limit.)+       , printBase      :: Int            -- ^ Print integral literals in this base (2, 10, and 16 are supported.)+       , printRealPrec  :: Int            -- ^ Print algebraic real values with this precision. (SReal, default: 16)+       , solverTweaks   :: [String]       -- ^ Additional lines of script to give to the solver (user specified)+       , optimizeArgs   :: [String]       -- ^ Additional commands to pass before check-sat is issued+       , satCmd         :: String         -- ^ Usually "(check-sat)". However, users might tweak it based on solver characteristics.+       , isNonModelVar  :: String -> Bool -- ^ When constructing a model, ignore variables whose name satisfy this predicate. (Default: (const False), i.e., don't ignore anything)+       , smtFile        :: Maybe FilePath -- ^ If Just, the generated SMT script will be put in this file (for debugging purposes mostly)+       , smtLibVersion  :: SMTLibVersion  -- ^ What version of SMT-lib we use for the tool+       , solver         :: SMTSolver      -- ^ The actual SMT solver.+       , roundingMode   :: RoundingMode   -- ^ Rounding mode to use for floating-point conversions+       , useLogic       :: Maybe Logic    -- ^ If Nothing, pick automatically. Otherwise, either use the given one, or use the custom string.+       }++-- We're just seq'ing top-level here, it shouldn't really matter. (i.e., no need to go deeper.)+instance NFData SMTConfig where+  rnf SMTConfig{} = ()++instance Show SMTConfig where+  show = show . solver++-- | A model, as returned by a solver+data SMTModel = SMTModel {+        modelObjectives :: [(String, GeneralizedCW)]  -- ^ Mapping of symbolic values to objective values.+     ,  modelAssocs     :: [(String, CW)]             -- ^ Mapping of symbolic values to constants.+     }+     deriving Show++-- | The result of an SMT solver call. Each constructor is tagged with+-- the 'SMTConfig' that created it so that further tools can inspect it+-- and build layers of results, if needed. For ordinary uses of the library,+-- this type should not be needed, instead use the accessor functions on+-- it. (Custom Show instances and model extractors.)+data SMTResult = Unsatisfiable SMTConfig            -- ^ Unsatisfiable+               | Satisfiable   SMTConfig SMTModel   -- ^ Satisfiable with model+               | SatExtField   SMTConfig SMTModel   -- ^ Prover returned a model, but in an extension field containing Infinite/epsilon+               | Unknown       SMTConfig SMTModel   -- ^ Prover returned unknown, with a potential (possibly bogus) model+               | ProofError    SMTConfig [String]   -- ^ Prover errored out+               | TimeOut       SMTConfig            -- ^ Computation timed out (see the 'timeout' combinator)++-- | A script, to be passed to the solver.+data SMTScript = SMTScript {+          scriptBody  :: String        -- ^ Initial feed+        , scriptModel :: Maybe String  -- ^ Optional continuation script, if the result is sat+        }++-- | An SMT engine+type SMTEngine = SMTConfig                     -- ^ current configuration+               -> Bool                         -- ^ is sat?+               -> Maybe (OptimizeStyle, Int)   -- ^ if optimizing, the style and #of objectives+               -> [(Quantifier, NamedSymVar)]  -- ^ quantified inputs+               -> [Either SW (SW, [SW])]       -- ^ skolem map+               -> String                       -- ^ program+               -> IO [SMTResult]++-- | Solvers that SBV is aware of+data Solver = Z3+            | Yices+            | Boolector+            | CVC4+            | MathSAT+            | ABC+            deriving (Show, Enum, Bounded)++-- | An SMT solver+data SMTSolver = SMTSolver {+         name           :: Solver             -- ^ The solver in use+       , executable     :: String             -- ^ The path to its executable+       , options        :: [String]           -- ^ Options to provide to the solver+       , engine         :: SMTEngine          -- ^ The solver engine, responsible for interpreting solver output+       , capabilities   :: SolverCapabilities -- ^ Various capabilities of the solver+       }++instance Show SMTSolver where+   show = show . name++{-# ANN type FPOp   ("HLint: ignore Use camelCase" :: String) #-}
Data/SBV/Dynamic.hs view
@@ -83,12 +83,12 @@   -- * Model extraction    -- ** Inspecting proof results-  , ThmResult(..), SatResult(..), SafeResult(..), AllSatResult(..), SMTResult(..)+  , ThmResult(..), SatResult(..), AllSatResult(..), SafeResult(..), OptimizeResult(..), SMTResult(..)    -- ** Programmable model extraction   , genParse, getModel, getModelDictionary   -- * SMT Interface: Configurations and solvers-  , SMTConfig(..), SMTLibVersion(..), SMTLibLogic(..), Logic(..), OptimizeOpts(..), Solver(..), SMTSolver(..), boolector, cvc4, yices, z3, mathSAT, abc, defaultSolverConfig, sbvCurrentSolver, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers+  , SMTConfig(..), SMTLibVersion(..), SMTLibLogic(..), Logic(..), Solver(..), SMTSolver(..), boolector, cvc4, yices, z3, mathSAT, abc, defaultSolverConfig, sbvCurrentSolver, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers    -- * Symbolic computations   , outputSVal@@ -122,10 +122,10 @@  import Data.Map (Map) -import Data.SBV.BitVectors.Kind-import Data.SBV.BitVectors.Concrete-import Data.SBV.BitVectors.Symbolic-import Data.SBV.BitVectors.Operations+import Data.SBV.Core.Kind+import Data.SBV.Core.Concrete+import Data.SBV.Core.Symbolic+import Data.SBV.Core.Operations  import Data.SBV.Compilers.CodeGen   ( SBVCodeGen@@ -138,18 +138,17 @@   ) import Data.SBV.Compilers.C    (compileToC, compileToCLib) import Data.SBV.Provers.Prover (boolector, cvc4, yices, z3, mathSAT, abc, defaultSMTCfg)-import Data.SBV.SMT.SMT        (ThmResult(..), SatResult(..), SafeResult(..), AllSatResult(..), genParse)-import Data.SBV.Tools.Optimize (OptimizeOpts(..))+import Data.SBV.SMT.SMT        (ThmResult(..), SatResult(..), SafeResult(..), OptimizeResult(..), AllSatResult(..), genParse) import Data.SBV                (sbvCurrentSolver, sbvCheckSolverInstallation, defaultSolverConfig, sbvAvailableSolvers) -import qualified Data.SBV                  as SBV (SBool, proveWithAll, proveWithAny, satWithAll, satWithAny)-import qualified Data.SBV.BitVectors.Data  as SBV (SBV(..))-import qualified Data.SBV.BitVectors.Model as SBV (isSatisfiableInCurrentPath, sbvQuickCheck)-import qualified Data.SBV.Provers.Prover   as SBV (proveWith, satWith, safeWith, allSatWith, compileToSMTLib, generateSMTBenchmarks)-import qualified Data.SBV.SMT.SMT          as SBV (Modelable(getModel, getModelDictionary))+import qualified Data.SBV                as SBV (SBool, proveWithAll, proveWithAny, satWithAll, satWithAny)+import qualified Data.SBV.Core.Data      as SBV (SBV(..))+import qualified Data.SBV.Core.Model     as SBV (isSatisfiableInCurrentPath, sbvQuickCheck)+import qualified Data.SBV.Provers.Prover as SBV (proveWith, satWith, safeWith, allSatWith, compileToSMTLib, generateSMTBenchmarks)+import qualified Data.SBV.SMT.SMT        as SBV (Modelable(getModel, getModelDictionary))  -- | Reduce a condition (i.e., try to concretize it) under the given path-svIsSatisfiableInCurrentPath :: SVal -> Symbolic Bool+svIsSatisfiableInCurrentPath :: SVal -> Symbolic (Maybe SatResult) svIsSatisfiableInCurrentPath = SBV.isSatisfiableInCurrentPath . toSBool  -- | Dynamic variant of quick-check
Data/SBV/Examples/BitPrecise/PrefixSum.hs view
@@ -117,6 +117,8 @@ -- UNINTERPRETED CONSTANTS -- USER GIVEN CODE SEGMENTS -- AXIOMS+-- TACTICS+-- GOALS -- DEFINE --   s8 :: SWord8 = s0 + s1 --   s9 :: SWord8 = s2 + s8@@ -166,6 +168,8 @@ -- UNINTERPRETED CONSTANTS -- USER GIVEN CODE SEGMENTS -- AXIOMS+-- TACTICS+-- GOALS -- DEFINE --   s8 :: SWord8 = s0 + s1 --   s9 :: SWord8 = s2 + s8
Data/SBV/Examples/CodeGeneration/CRC_USB5.hs view
@@ -17,6 +17,7 @@ module Data.SBV.Examples.CodeGeneration.CRC_USB5 where  import Data.SBV+import Data.SBV.Tools.Polynomial  ----------------------------------------------------------------------------- -- * The USB polynomial
Data/SBV/Examples/Crypto/AES.hs view
@@ -29,6 +29,7 @@ module Data.SBV.Examples.Crypto.AES where  import Data.SBV+import Data.SBV.Tools.Polynomial import Data.List (transpose)  -----------------------------------------------------------------------------
Data/SBV/Examples/Crypto/RC4.hs view
@@ -24,6 +24,8 @@ import Data.Maybe (fromJust) import Data.SBV +import Data.SBV.Tools.STree+ ----------------------------------------------------------------------------- -- * Types -----------------------------------------------------------------------------
Data/SBV/Examples/Existentials/CRCPolynomial.hs view
@@ -16,6 +16,7 @@ module Data.SBV.Examples.Existentials.CRCPolynomial where  import Data.SBV+import Data.SBV.Tools.Polynomial  ----------------------------------------------------------------------------- -- * Modeling 48 bit words
+ Data/SBV/Examples/Optimization/LinearOpt.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Examples.Optimization.LinearOpt+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Simple linear optimization example, as found in operations research texts.+-----------------------------------------------------------------------------++module Data.SBV.Examples.Optimization.LinearOpt where++import Data.SBV++-- | Taken from <http://people.brunel.ac.uk/~mastjjb/jeb/or/morelp.html>+--+--    *  maximize 5x1 + 6x2+--       - subject to+--+--          1. x1 + x2 <= 10+--          2. x1 - x2 >= 3+--          3. 5x1 + 4x2 <= 35+--          4. x1 >= 0+--          5. x2 >= 0+--+-- >>> optimize problem+-- Optimal model:+--   x1   =  47 % 9 :: Real+--   x2   =  20 % 9 :: Real+--   goal = 355 % 9 :: Real+problem :: Goal+problem = do [x1, x2] <- mapM sReal ["x1", "x2"]++             constrain $ x1 + x2 .<= 10+             constrain $ x1 - x2 .>= 3+             constrain $ 5*x1 + 4*x2 .<= 35+             constrain $ x1 .>= 0+             constrain $ x2 .>= 0++             maximize "goal" $ 5 * x1 + 6 * x2
+ Data/SBV/Examples/Optimization/Production.hs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Examples.Optimization.Production+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Solves a simple linear optimization problem+-----------------------------------------------------------------------------++module Data.SBV.Examples.Optimization.Production where++import Data.SBV++-- | Taken from <http://people.brunel.ac.uk/~mastjjb/jeb/or/morelp.html>+--+-- A company makes two products (X and Y) using two machines (A and B).+--+--   - Each unit of X that is produced requires 50 minutes processing time on machine+--     A and 30 minutes processing time on machine B.+--+--   - Each unit of Y that is produced requires 24 minutes processing time on machine+--     A and 33 minutes processing time on machine B.+--+--   - At the start of the current week there are 30 units of X and 90 units of Y in stock.+--     Available processing time on machine A is forecast to be 40 hours and on machine B is+--     forecast to be 35 hours.+--+--   - The demand for X in the current week is forecast to be 75 units and for Y is forecast+--     to be 95 units.+--+--   - Company policy is to maximise the combined sum of the units of X and the units of Y+--     in stock at the end of the week.+--+-- How much of each product should we make in the current week?+--+-- We have:+--+-- >>> optimize production+-- Optimal model:+--   X     = 45 :: Integer+--   Y     =  6 :: Integer+--   stock =  1 :: Integer+--+-- That is, we should produce 45 X's and 6 Y's, with the final maximum stock of just 1 expected!+production :: Goal+production = do x <- sInteger "X" -- Units of X produced+                y <- sInteger "Y" -- Units of X produced++                -- Amount of time on machine A and B+                let timeA = 50 * x + 24 * y+                    timeB = 30 * x + 33 * y++                constrain $ timeA .<= 40 * 60+                constrain $ timeB .<= 35 * 60++                -- Amount of product we'll end up with+                let finalX = x + 30+                    finalY = y + 90++                -- Make sure the demands are met:+                constrain $ finalX .>= 75+                constrain $ finalY .>= 95++                -- Policy: Maximize the final stock+                maximize "stock" $ (finalX - 75) + (finalY - 95)
+ Data/SBV/Examples/Optimization/VM.hs view
@@ -0,0 +1,92 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Examples.Optimization.VM+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Solves a VM allocation problem using optimization features+-----------------------------------------------------------------------------++module Data.SBV.Examples.Optimization.VM where++import Data.SBV++-- | True precisely when exactly one of the inputs is+strongMutex :: [SBool] -> SBool+strongMutex []     = false+strongMutex (a:as) = ite a (bnot (bOr as)) (strongMutex as)++-- | The allocation problem. Inspired by: <http://rise4fun.com/z3opt/tutorialcontent/guide#h25>+--+--   - We have three virtual machines (VMs) which require 100, 50 and 15 GB hard disk respectively.+--+--   - There are three servers with capabilities 100, 75 and 200 GB in that order.+--+--   - Find out a way to place VMs into servers in order to+--+--        - Minimize the number of servers used+--+--        - Minimize the operation cost (the servers have fixed daily costs 10, 5 and 20 USD respectively.)+--+-- We have:+--+-- >>> optimize allocate+-- Optimal model:+--   x11         = False :: Bool+--   x12         = False :: Bool+--   x13         =  True :: Bool+--   x21         = False :: Bool+--   x22         = False :: Bool+--   x23         =  True :: Bool+--   x31         = False :: Bool+--   x32         = False :: Bool+--   x33         =  True :: Bool+--   noOfServers =     1 :: Integer+--   cost        =    20 :: Integer+--+-- That is, we should put all the jobs on the third server, for a total cost of 20.+allocate :: Goal+allocate = do+    -- xij means VM i is running on server j+    x1@[x11, x12, x13] <- sBools ["x11", "x12", "x13"]+    x2@[x21, x22, x23] <- sBools ["x21", "x22", "x23"]+    x3@[x31, x32, x33] <- sBools ["x31", "x32", "x33"]++    -- Each job runs on exactly one server+    constrain $ strongMutex x1+    constrain $ strongMutex x2+    constrain $ strongMutex x3++    let need :: [SBool] -> SInteger+        need rs = sum $ zipWith (\r c -> ite r c 0) rs [100, 50, 15]++    -- The capacity on each server is respected+    let capacity1 = need [x11, x21, x31]+        capacity2 = need [x12, x22, x32]+        capacity3 = need [x13, x23, x33]++    constrain $ capacity1 .<= 100+    constrain $ capacity2 .<=  75+    constrain $ capacity3 .<= 200++    -- compute #of servers running:+    let y1 = bOr [x11, x21, x31]+        y2 = bOr [x12, x22, x32]+        y3 = bOr [x13, x23, x33]++        b2n b = ite b 1 0++    let noOfServers = sum $ map b2n [y1, y2, y3]++    -- minimize # of servers+    minimize "noOfServers" (noOfServers :: SInteger)++    -- cost on each server+    let cost1 = ite y1 10 0+        cost2 = ite y2  5 0+        cost3 = ite y3 20 0++    -- minimize the total cost+    minimize "cost" (cost1 + cost2 + cost3 :: SInteger)
Data/SBV/Examples/Polynomials/Polynomials.hs view
@@ -25,6 +25,7 @@ module Data.SBV.Examples.Polynomials.Polynomials where  import Data.SBV+import Data.SBV.Tools.Polynomial  -- | Helper synonym for representing GF(2^8); which are merely 8-bit unsigned words. Largest -- term in such a polynomial has degree 7.
Data/SBV/Examples/Puzzles/Fish.hs view
@@ -104,5 +104,3 @@            ownsFish <- free "fishOwner"           fact1 $ \i -> n i .== ownsFish &&& p i `is` Fish--          return (true :: SBool)
Data/SBV/Internals.hs view
@@ -15,7 +15,7 @@   -- * Running symbolic programs /manually/   Result(..), SBVRunMode(..)   -- * Internal structures useful for low-level programming-  , module Data.SBV.BitVectors.Data+  , module Data.SBV.Core.Data   -- * Operations useful for instantiating SBV type classes   , genLiteral, genFromCW, genMkSymVar, checkAndConvert, genParse, showModel, SMTModel(..), liftQRem, liftDMod   -- * Polynomial operations that operate on bit-vectors@@ -28,13 +28,16 @@   , module Data.SBV.Utils.Numeric   ) where -import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.Model      (genLiteral, genFromCW, genMkSymVar)-import Data.SBV.BitVectors.Splittable (checkAndConvert)-import Data.SBV.BitVectors.Model      (liftQRem, liftDMod)-import Data.SBV.Compilers.C           (compileToC', compileToCLib')+import Data.SBV.Core.Data+import Data.SBV.Core.Model      (genLiteral, genFromCW, genMkSymVar)+import Data.SBV.Core.Splittable (checkAndConvert)+import Data.SBV.Core.Model      (liftQRem, liftDMod)++import Data.SBV.Compilers.C       (compileToC', compileToCLib') import Data.SBV.Compilers.CodeGen-import Data.SBV.SMT.SMT               (genParse, showModel)++import Data.SBV.SMT.SMT (genParse, showModel)+ import Data.SBV.Tools.Polynomial      (ites, mdp, addPoly) import Data.SBV.Utils.Numeric
Data/SBV/Provers/ABC.hs view
@@ -11,7 +11,7 @@  module Data.SBV.Provers.ABC(abc) where -import Data.SBV.BitVectors.Data+import Data.SBV.Core.Data import Data.SBV.SMT.SMT  -- | The description of abc. The default executable is @\"abc\"@,@@ -36,6 +36,7 @@                               , supportsReals              = False                               , supportsFloats             = False                               , supportsDoubles            = False+                              , supportsOptimization       = False                               }          }   where addTimeOut _ _ = error "ABC: Timeout values are not supported"
Data/SBV/Provers/Boolector.hs view
@@ -11,7 +11,7 @@  module Data.SBV.Provers.Boolector(boolector) where -import Data.SBV.BitVectors.Data+import Data.SBV.Core.Data import Data.SBV.SMT.SMT  -- | The description of the Boolector SMT solver@@ -34,6 +34,7 @@                               , supportsReals              = False                               , supportsFloats             = False                               , supportsDoubles            = False+                              , supportsOptimization       = False                               }          }  where addTimeOut o i | i < 0 = error $ "Boolector: Timeout value must be non-negative, received: " ++ show i
Data/SBV/Provers/CVC4.hs view
@@ -13,7 +13,7 @@  module Data.SBV.Provers.CVC4(cvc4) where -import Data.SBV.BitVectors.Data+import Data.SBV.Core.Data import Data.SBV.SMT.SMT  -- | The description of the CVC4 SMT solver@@ -36,6 +36,7 @@                               , supportsReals              = True  -- Not quite the same capability as Z3; but works more or less..                               , supportsFloats             = False                               , supportsDoubles            = False+                              , supportsOptimization       = False                               }          }  where addTimeOut o i | i < 0 = error $ "CVC4: Timeout value must be non-negative, received: " ++ show i
Data/SBV/Provers/MathSAT.hs view
@@ -13,7 +13,7 @@  module Data.SBV.Provers.MathSAT(mathSAT) where -import Data.SBV.BitVectors.Data+import Data.SBV.Core.Data import Data.SBV.SMT.SMT  -- | The description of the MathSAT SMT solver@@ -36,6 +36,7 @@                               , supportsReals              = True                               , supportsFloats             = True                               , supportsDoubles            = True+                              , supportsOptimization       = False                               }          }  where addTimeOut _ _ = error "MathSAT: Timeout values are not supported"
Data/SBV/Provers/Prover.hs view
@@ -1,4 +1,4 @@------------------------------------------------------------------------------+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.SBV.Provers.Prover -- Copyright   :  (c) Levent Erkok@@ -12,18 +12,20 @@ {-# LANGUAGE CPP                  #-} {-# LANGUAGE BangPatterns         #-} {-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE LambdaCase           #-} {-# LANGUAGE NamedFieldPuns       #-} {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE TypeSynonymInstances #-}  module Data.SBV.Provers.Prover (-         SMTSolver(..), SMTConfig(..), Predicate, Provable(..)-       , ThmResult(..), SatResult(..), SafeResult(..), AllSatResult(..), SMTResult(..)+         SMTSolver(..), SMTConfig(..), Predicate, Provable(..), Goal+       , ThmResult(..), SatResult(..), AllSatResult(..), SafeResult(..), OptimizeResult(..), SMTResult(..)        , isSatisfiable, isSatisfiableWith, isTheorem, isTheoremWith        , prove, proveWith        , sat, satWith-       , safe, safeWith, isSafe        , allSat, allSatWith+       , safe, safeWith, isSafe+       , optimize, optimizeWith        , isVacuous, isVacuousWith        , SatModel(..), Modelable(..), displayModels, extractModels        , getModelDictionaries, getModelValues, getModelUninterpretedValues@@ -32,25 +34,32 @@        , internalSATCheck        ) where -import Control.Monad    (when, unless)-import Data.List        (intercalate)-import System.FilePath  (addExtension, splitExtension)-import System.Time      (getClockTime)-import System.IO.Unsafe (unsafeInterleaveIO)+import Data.Char         (isSpace)+import Data.List         (intercalate, nub) +import Control.Monad     (when, unless)+import System.FilePath   (addExtension, splitExtension)+import System.Time       (getClockTime)+import System.IO         (hGetBuffering, hSetBuffering, stdout, hFlush, BufferMode(..))+import System.IO.Unsafe  (unsafeInterleaveIO)++import Control.Concurrent.Async (async, wait, cancel, waitAny, Async)+ import GHC.Stack.Compat #if !MIN_VERSION_base(4,9,0) import GHC.SrcLoc.Compat #endif -import qualified Data.Set as Set (Set, toList)+import qualified Data.Set as Set (toList) -import Data.SBV.BitVectors.Data+import Data.SBV.Core.Data+import Data.SBV.Core.Symbolic import Data.SBV.SMT.SMT import Data.SBV.SMT.SMTLib import Data.SBV.Utils.TDiff  import Control.DeepSeq (rnf)+import Control.Exception (bracket)  import qualified Data.SBV.Provers.Boolector  as Boolector import qualified Data.SBV.Provers.CVC4       as CVC4@@ -70,6 +79,7 @@                                          , solver         = s                                          , solverTweaks   = tweaks                                          , smtLibVersion  = smtVersion+                                         , optimizeArgs   = []                                          , satCmd         = "(check-sat)"                                          , isNonModelVar  = const False  -- i.e., everything is a model-variable by default                                          , roundingMode   = RoundNearestTiesToEven@@ -111,6 +121,10 @@ -- type when necessary. type Predicate = Symbolic SBool +-- | A goal is a symbolic program that returns no values. The idea is that the constraints/min-max+-- goals will serve as appropriate directives for sat/prove calls.+type Goal = Symbolic ()+ -- | A type @a@ is provable if we can turn it into a predicate. -- Note that a predicate can be made from a curried function of arbitrary arity, where -- each element is either a symbolic type or up-to a 7-tuple of symbolic-types. So@@ -255,10 +269,6 @@ sat :: Provable a => a -> IO SatResult sat = satWith defaultSMTCfg --- | Check that all the 'sAssert' calls are safe, equivalent to @'safeWith' 'defaultSMTCfg'@-safe :: SExecutable a => a -> IO [SafeResult]-safe = safeWith defaultSMTCfg- -- | Return all satisfying assignments for a predicate, equivalent to @'allSatWith' 'defaultSMTCfg'@. -- Satisfying assignments are constructed lazily, so they will be available as returned by the solver -- and on demand.@@ -270,8 +280,17 @@ allSat :: Provable a => a -> IO AllSatResult allSat = allSatWith defaultSMTCfg +-- | Optimize a given collection of `Objective`s+optimize :: Provable a => a -> IO OptimizeResult+optimize = optimizeWith defaultSMTCfg++-- | Check that all the 'sAssert' calls are safe, equivalent to @'safeWith' 'defaultSMTCfg'@+safe :: SExecutable a => a -> IO [SafeResult]+safe = safeWith defaultSMTCfg+ -- | Check if the given constraints are satisfiable, equivalent to @'isVacuousWith' 'defaultSMTCfg'@.--- See the function 'constrain' for an example use of 'isVacuous'.+-- See the function 'constrain' for an example use of 'isVacuous'. Also see the 'CheckConstrVacuity'+-- tactic. isVacuous :: Provable a => a -> IO Bool isVacuous = isVacuousWith defaultSMTCfg @@ -325,8 +344,8 @@         let comments = ["Created on " ++ show t]             cvt = case version of                     SMTLib2 -> toSMTLib2-        (_, _, _, _, smtLibPgm) <- simulate cvt defaultSMTCfg isSat comments a-        let out = show smtLibPgm+        SMTProblem{smtLibPgm} <- simulate cvt defaultSMTCfg isSat comments a+        let out = show (smtLibPgm defaultSMTCfg NoCase)         return $ out ++ "\n(check-sat)\n"  -- | Create SMT-Lib benchmarks, for supported versions of SMTLib. The first argument is the basename of the file.@@ -340,18 +359,498 @@                    writeFile fn s                    putStrLn $ "Generated " ++ show v ++ " benchmark " ++ show fn ++ "." +-- | Make sure we're line-buffering if there's going to be parallel calls.+bufferSanity :: Bool -> IO a -> IO a+bufferSanity False a = a+bufferSanity True  a = bracket before after (const a)+  where before = do b <- hGetBuffering stdout+                    hSetBuffering stdout LineBuffering+                    return b+        after b = do hFlush stdout+                     hSetBuffering stdout b+                     hFlush stdout++-- | Make sure sat/prove calls don't have objectives, and optimize does!+objectiveCheck :: Bool -> [Objective a] -> String -> IO ()+objectiveCheck False [] _ = return ()+objectiveCheck False os w = error $ unlines $ ("\n*** Unsupported call to " ++ show w ++ " in the presence of objective(s):")+                                            : [ "***\t" ++ intercalate ", " (map objectiveName os)+                                              , "*** Use \"optimize\" to optimize for these objectives instead of " ++ show w+                                              ]+objectiveCheck True []  w = error $ "*** Unsupported call to " ++ w ++ " when no objectives are present. Use \"sat\" for plain satisfaction"+objectiveCheck True _   _ = return ()++-- | Pick the converter, based on the SMTLib version. Note that+-- we no longer support SMTLib1, so the following is more or less a no-op,+-- but it's good to use it since if we add some other target GHC's pattern-match+-- warning will point us to here.+getConverter :: SMTConfig -> SMTLibConverter+getConverter SMTConfig{smtLibVersion} = case smtLibVersion of+                                          SMTLib2 -> toSMTLib2+ -- | Proves the predicate using the given SMT-solver proveWith :: Provable a => SMTConfig -> a -> IO ThmResult-proveWith config a = simulate cvt config False [] a >>= callSolver False "Checking Theoremhood.." ThmResult config-  where cvt = case smtLibVersion config of-                SMTLib2 -> toSMTLib2+proveWith config a = do simRes@SMTProblem{tactics, objectives} <- simulate (getConverter config) config False [] a+                        objectiveCheck False objectives "prove"+                        let hasPar = any isParallelCaseAnywhere tactics+                        bufferSanity hasPar $ applyTactics config (False, hasPar) (wrap, unwrap) [] tactics objectives $ callSolver False "Checking Theoremhood.." [] mwrap simRes+  where wrap                 = ThmResult+        unwrap (ThmResult r) = r +        mwrap [r] = wrap r+        mwrap xs  = error $ "SBV.proveWith: Backend solver returned a non-singleton answer:\n" ++ show (map ThmResult xs)+ -- | Find a satisfying assignment using the given SMT-solver satWith :: Provable a => SMTConfig -> a -> IO SatResult-satWith config a = simulate cvt config True [] a >>= callSolver True "Checking Satisfiability.." SatResult config-  where cvt = case smtLibVersion config of-                SMTLib2 -> toSMTLib2+satWith config a = do simRes@SMTProblem{tactics, objectives} <- simulate (getConverter config) config True [] a+                      objectiveCheck False objectives "sat"+                      let hasPar = any isParallelCaseAnywhere tactics+                      bufferSanity hasPar $ applyTactics config (True, hasPar) (wrap, unwrap) [] tactics objectives $ callSolver True "Checking Satisfiability.." [] mwrap simRes+  where wrap                 = SatResult+        unwrap (SatResult r) = r +        mwrap [r] = wrap r+        mwrap xs  = error $ "SBV.satWith: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs)++-- | Optimizes the objectives using the given SMT-solver+optimizeWith :: Provable a => SMTConfig -> a -> IO OptimizeResult+optimizeWith config a = do+        msg "Optimizing.."+        sbvPgm@SMTProblem{objectives, tactics} <- simulate (getConverter config) config True [] a++        objectiveCheck True objectives "optimize"++        let hasPar  = any isParallelCaseAnywhere tactics+            style = case nub [s | OptimizePriority s <- tactics] of+                      []  -> Lexicographic+                      [s] -> s+                      ss  -> error $ "SBV: Multiple optimization priorities found: " ++ intercalate ", " (map show ss) ++ ". Please use only one."+++            optimizer = case style of+               Lexicographic -> optLexicographic+               Independent   -> optIndependent+               Pareto        -> optPareto++        optimizer hasPar config sbvPgm++  where msg = when (verbose config) . putStrLn . ("** " ++)++-- | Construct a lexicographic optimization result+optLexicographic :: Bool -> SMTConfig -> SMTProblem -> IO OptimizeResult+optLexicographic hasPar config sbvPgm@SMTProblem{objectives, tactics} = do+        result <- bufferSanity hasPar $ applyTactics config (True, hasPar) (id, id) [] tactics objectives $ callSolver True "Lexicographically optimizing.." [] mwrap sbvPgm+        return $ LexicographicResult result++  where mwrap [r] = r+        mwrap xs  = error $ "SBV.optLexicographic: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs)++-- | Construct an independent optimization result+optIndependent :: Bool -> SMTConfig -> SMTProblem -> IO OptimizeResult+optIndependent hasPar config sbvPgm@SMTProblem{objectives, tactics} = do+        let ns = map objectiveName objectives+        result <- bufferSanity hasPar $ applyTactics config (True, hasPar) (wrap ns, unwrap) [] tactics objectives $ callSolver True "Independently optimizing.." [] mwrap sbvPgm+        return $ IndependentResult result++  where wrap :: [String] -> SMTResult -> [(String, SMTResult)]+        wrap ns r = zip ns (repeat r)++        -- the role of unwrap here is to take the result with more info in case a case-split is+        -- performed and we need to decide in a SAT context.+        unwrap :: [(String, SMTResult)] -> SMTResult+        unwrap xs = case [r | (_, r@Satisfiable{}) <- xs] ++ [r | (_, r@SatExtField{}) <- xs] ++ map snd xs of+                     (r:_) -> r+                     []    -> error "SBV.optIndependent: Impossible happened: Received no results!"++        mwrap xs+         | lobs == lxs = zip (map objectiveName objectives) xs+         | True        = error $ "SBV.optIndependent: Expected " ++ show lobs ++ " objective results, but received: " ++ show lxs ++ ":\n" ++ show (map SatResult xs)+         where lxs  = length xs+               lobs = length objectives++-- | Construct a pareto-front optimization result+optPareto :: Bool -> SMTConfig -> SMTProblem -> IO OptimizeResult+optPareto hasPar config sbvPgm@SMTProblem{objectives, tactics} = do+        result <- bufferSanity hasPar $ applyTactics config (True, hasPar) (wrap, unwrap) [] tactics objectives $ callSolver True "Pareto optimizing.." [] id sbvPgm+        return $ ParetoResult result++  where wrap :: SMTResult -> [SMTResult]+        wrap r = [r]++        -- the role of unwrap here is to take the result with more info in case a case-split is+        -- performed and we need to decide in a SAT context.+        unwrap :: [SMTResult] -> SMTResult+        unwrap xs = case [r | r@Satisfiable{} <- xs] ++ [r | r@SatExtField{} <- xs] ++ xs of+                     (r:_) -> r+                     []    -> error "SBV.optPareto: Impossible happened: Received no results!"++-- | Apply the given tactics to a problem+applyTactics :: SMTConfig                                                       -- ^ Solver configuration+             -> (Bool, Bool)                                                    -- ^ Are we a sat-problem? Do we have anything parallel going on? (Parallel-case split.)+             -> (SMTResult -> res, res -> SMTResult)                            -- ^ Wrapper/unwrapper pair from result to SMT answer+             -> [(String, (String, SW))]                                        -- ^ Level at which we are called. (In case of a nested case-split)+             -> [Tactic SW]                                                     -- ^ Tactics active at this level+             -> [Objective (SW, SW)]                                            -- ^ Optimization goals we have+             -> (SMTConfig -> Maybe (OptimizeStyle, Int) -> CaseCond -> IO res) -- ^ The actual continuation at this point+             -> IO res+applyTactics cfgIn (isSat, hasPar) (wrap, unwrap) levels tactics objectives cont+   = do --+        -- TODO: The management of tactics here is quite adhoc. We should have a better story+        -- Currently, we:+        --+        --      - Perform optimization (which requires sat and no case-splitting)+        --      - Check for vacuity if asked+        --      - Do case-splitting+        --+        -- If we have more interesting tactics, we'll have to come up with a better "proof manager." The current+        -- code is sufficient, however, for the use cases we have now.++        -- check that if we have objectives, then we must be sat and there must be no case-splits+        when (hasObjectives && not isSat)     $ error "SBV: Optimization is only available for sat calls."+        when (hasObjectives && hasCaseSplits) $ error "SBV: Optimization and case-splits are not supported together."++        let mbOptInfo+                | not hasObjectives = Nothing+                | True              = Just (optimizePriority, length objectives)++        if hasObjectives++           then cont (finalOptConfig objectives) mbOptInfo (Opt objectives)++           else do -- Check vacuity if asked. If result is Nothing, it means we're good to go.+                   mbRes <- if not shouldCheckConstrVacuity+                            then return Nothing+                            else constraintVacuityCheck isSat finalConfig mbOptInfo (wrap, unwrap) cont++                   -- Do case split, if vacuity said continue+                   case mbRes of+                     Just r  -> return r+                     Nothing -> if null caseSplits+                                then cont finalConfig mbOptInfo (CasePath (map (snd . snd) levels))+                                else caseSplit finalConfig mbOptInfo shouldCheckCaseVacuity (parallelCase, hasPar) isSat (wrap, unwrap) levels chatty cases cont++  where (caseSplits, checkCaseVacuity, parallelCases, checkConstrVacuity, timeOuts, checkUsing, useLogics, useSolvers, optimizePriorities)+                = foldr (flip classifyTactics) ([], [], [], [], [], [], [], [], []) tactics++        classifyTactics (a, b, c, d, e, f, g, h, i) = \case+                    t@CaseSplit{}           -> (t:a,   b,   c,   d,   e,   f,   g,   h,   i)+                    t@CheckCaseVacuity{}    -> (  a, t:b,   c,   d,   e,   f,   g,   h,   i)+                    t@ParallelCase{}        -> (  a,   b, t:c,   d,   e,   f,   g,   h,   i)+                    t@CheckConstrVacuity{}  -> (  a,   b,   c, t:d,   e,   f,   g,   h,   i)+                    t@StopAfter{}           -> (  a,   b,   c,   d, t:e,   f,   g,   h,   i)+                    t@CheckUsing{}          -> (  a,   b,   c,   d,   e, t:f,   g,   h,   i)+                    t@UseLogic{}            -> (  a,   b,   c,   d,   e,   f, t:g,   h,   i)+                    t@UseSolver{}           -> (  a,   b,   c,   d,   e,   f,   g, t:h,   i)+                    t@OptimizePriority{}    -> (  a,   b,   c,   d,   e,   f,   g,   h, t:i)++        hasObjectives = not $ null objectives++        hasCaseSplits = not $ null cases++        parallelCase = not $ null parallelCases++        optimizePriority = case [s | OptimizePriority s <- optimizePriorities] of+                             []  -> Lexicographic+                             [s] -> s+                             ss  -> error $ "SBV.OptimizePriority: Multiple optimization priorities found, at most one is allowed: " ++ intercalate "," (map show ss)++        shouldCheckCaseVacuity = case [b | CheckCaseVacuity b <- checkCaseVacuity] of+                                   [] -> True   -- default is to check-case-vacuity+                                   bs -> or bs  -- otherwise check vacuity if we're asked to do so++        -- for constraint vacuity, default is *not* to check; so a simple or suffices+        shouldCheckConstrVacuity = or [b | CheckConstrVacuity b <- checkConstrVacuity]++        (chatty, cases) = let (vs, css) = unzip [(v, cs) | CaseSplit v cs <- caseSplits] in (or (verbose cfgIn : vs), concat css)++        grabStops c = case [i | StopAfter i <- timeOuts] of+                        [] -> c+                        xs -> c {timeOut = Just (maximum xs)}++        grabCheckUsing c = case [s | CheckUsing s <- checkUsing] of+                             []  -> c+                             [s] -> c {satCmd = "(check-sat-using " ++ s ++ ")"}+                             ss  -> c {satCmd = "(check-sat-using (then " ++ unwords ss ++ "))"}++        grabUseLogic c = case [l | UseLogic l <- useLogics] of+                           [] -> c+                           ss -> c { useLogic = Just (last ss) }++        configToUse = case [s | UseSolver s <- useSolvers] of+                        []  -> cfgIn+                        [s] -> s+                        ss  -> error $ "SBV.UseSolver: Multiple UseSolver tactics found, at most one is allowed: " ++ intercalate "," (map show ss)++        finalConfig = grabUseLogic . grabCheckUsing . grabStops $ configToUse++        finalOptConfig goals = finalConfig { optimizeArgs  = optimizeArgs finalConfig ++ optimizerDirectives }+            where optimizerDirectives+                        | hasObjectives = map minmax goals ++ style optimizePriority+                        | True          = []++                  minmax (Minimize   _  (_, v))     = "(minimize "    ++ show v ++ ")"+                  minmax (Maximize   _  (_, v))     = "(maximize "    ++ show v ++ ")"+                  minmax (AssertSoft nm (_, v) mbp) = "(assert-soft " ++ show v ++ penalize mbp ++ ")"+                    where penalize DefaultPenalty    = ""+                          penalize (Penalty w mbGrp)+                             | w <= 0         = error $ unlines [ "SBV.AssertSoft: Goal " ++ show nm ++ " is assigned a non-positive penalty: " ++ shw+                                                                , "All soft goals must have > 0 penalties associated."+                                                                ]+                             | True           = " :weight " ++ shw ++ maybe "" group mbGrp+                             where shw = show (fromRational w :: Double)+                          group g = " :id " ++ g++                  style Lexicographic = [] -- default, no option needed+                  style Independent   = ["(set-option :opt.priority box)"]+                  style Pareto        = [ "(set-option :opt.priority pareto)"+                                        , "(set-option :opt.print_model true)"+                                        ]++-- | Implements the "constraint vacuity check" tactic, making sure the calls to "constrain"+-- describe a satisfiable condition. Returns:+--+--    - Nothing if this is a SAT call, as that would be a weird thing to do (we only would care about constraint-vacuity in a proof context),+--    - Nothing if satisfiable: The world is OK, just keep moving+--    - ProofError if unsatisfiable. In this case we found that the constraints given are just bad!+--+-- NB. We'll do a SAT call even if there are *no* constraints! This is OK, as the call will be cheap; and this is an opt-in call. (i.e.,+-- the user asked us to do it explicitly.)+constraintVacuityCheck :: forall res.+                          Bool                                                            -- ^ isSAT?+                       -> SMTConfig                                                       -- ^ config+                       -> Maybe (OptimizeStyle, Int)                                      -- ^ optimization info+                       -> (SMTResult -> res, res -> SMTResult)                            -- ^ wrappers back and forth from final result+                       -> (SMTConfig -> Maybe (OptimizeStyle, Int) -> CaseCond -> IO res) -- ^ continuation+                       -> IO (Maybe res)                                                  -- ^ result, wrapped in Maybe if vacuity fails+constraintVacuityCheck True  _      _ _              _ = return Nothing -- for a SAT check, vacuity is meaningless (what would be the point)?+constraintVacuityCheck False config d (wrap, unwrap) f = do+               res <- f config d CstrVac+               case unwrap res of+                 Satisfiable{} -> return Nothing+                 _             -> return $ Just $ wrap vacuityFailResult+  where vacuityFailResult = ProofError config [ "Constraint vacuity check failed."+                                              , "User given constraints are not satisfiable."+                                              ]++-- | Implements the case-split tactic. Works for both Sat and Proof, hence the quantification on @res@+caseSplit :: forall res.+             SMTConfig                                                       -- ^ Solver config+          -> Maybe (OptimizeStyle, Int)                                      -- ^ Are we optimizing?+          -> Bool                                                            -- ^ Should we check vacuity of cases?+          -> (Bool, Bool)                                                    -- ^ Should we run the cases in parallel? Second bool: Is anything parallel going on?+          -> Bool                                                            -- ^ True if we're sat solving+          -> (SMTResult -> res, res -> SMTResult)                            -- ^ wrapper, unwrapper from sat/proof to the actual result+          -> [(String, (String, SW))]                                        -- ^ Path condition as we reached here. (In a nested case split, First #, then actual name.)+          -> Bool                                                            -- ^ Should we be chatty on the case-splits?+          -> [(String, SW, [Tactic SW])]                                     -- ^ List of cases. Case name, condition, plus further tactics for nested case-splitting etc.+          -> (SMTConfig -> Maybe (OptimizeStyle, Int) -> CaseCond -> IO res) -- ^ The "solver" once we provide it with a problem and a case+          -> IO res+caseSplit config mbOptInfo checkVacuity (runParallel, hasPar) isSAT (wrap, unwrap) level chatty cases cont+     | runParallel = goParallel tasks+     | True        = goSerial   tasks++  where tasks = zip caseNos cases++        lids = map fst level++        noOfCases = length cases+        casePad   = length (show noOfCases)++        tagLength = maximum $ map length $ "Coverage" : [s | (s, _, _) <- cases]+        showTag t = take tagLength (t ++ repeat ' ')++        shCaseId i = let si = show i in replicate (casePad - length si) ' ' ++ si++        caseNos = map shCaseId [(1::Int) .. ]++        tag tagChar = replicate 2 tagChar ++ replicate (2 * length level) tagChar++        mkCaseNameBase s i = "Case "     ++ intercalate "." (lids ++ [i]) ++ ": " ++ showTag s+        mkCovNameBase      = "Coverage " ++ replicate (casePad - 1) ' ' ++ "X"++        mkCaseName tagChar s i = tag tagChar ++ ' ' : mkCaseNameBase s i+        mkCovName  tagChar     = tag tagChar ++ ' ' : mkCovNameBase++        startCase :: Bool -> Maybe (String, String) -> IO ()+        startCase multi mbis+           | not chatty          = return ()+           | Just (i, s) <- mbis = printer $ mkCaseName tagChar s i ++ start+           | True                = printer $ mkCovName  tagChar     ++ start+           where line = multi || hasPar++                 printer | line = putStrLn+                         | True = putStr+                 tagChar | line = '>'+                         | True = '*'+                 start          = " [Started]"++        vacuityMsg :: Maybe Bool -> Bool -> (String, String) -> IO ()+        vacuityMsg mbGood multi (i, s)+           | not chatty = return ()+           | line       = putStrLn $ mkCaseName '=' s i ++ msg+           | True       = printer                          msg+           where line = multi || hasPar+                 printer+                   | failed = putStrLn+                   | True   = putStr+                 (failed, msg) = case mbGood of+                                   Nothing    -> (False, " [Vacuity Skipped]")+                                   Just True  -> (False, " [Vacuity OK]")+                                   Just False -> (True,  " [Vacuity Failed]")++        endCase :: Bool -> Maybe (String, String) -> String -> IO ()+        endCase multi mbis msg+           | not chatty          = return ()+           | not line            = putStrLn $ ' ' : msg+           | Just (i, s) <- mbis = putStrLn $ mkCaseName '<' s i ++ ' ' : msg+           | True                = putStrLn $ mkCovName  '<'     ++ ' ' : msg+           where line = multi || hasPar++        -----------------------------------------------------------------------------------------------------------------+        -- Serial case analysis+        -----------------------------------------------------------------------------------------------------------------+        goSerial :: [(String, (String, SW, [Tactic SW]))] -> IO res+        goSerial []+           -- At the end, we do a coverage call+           = do let multi = runParallel+                startCase multi Nothing+                res <- cont config mbOptInfo (CaseCov (map (snd . snd) level) [c | (_, c, _) <- cases])+                decideSerial multi Nothing (unwrap res) (return res)+        goSerial ((i, (nm, cond, ts)):cs)+           -- Still going down, do a regular call+           = do let multi = not . null $ [() | CaseSplit{} <- ts]+                    mbis  = Just (i, nm)+                startCase multi mbis+                continue <- if isSAT   -- for a SAT check, vacuity is meaningless (what would be the point)?+                            then return True+                            else if checkVacuity+                                 then do res <- cont config mbOptInfo (CaseVac (map (snd . snd) level) cond)+                                         case unwrap res of+                                           Satisfiable{} -> vacuityMsg (Just True)  multi (i, nm) >> return True+                                           _             -> vacuityMsg (Just False) multi (i, nm) >> return False+                                 else vacuityMsg Nothing  multi (i, nm) >> return True+                if continue+                   then do res <- applyTactics config (isSAT, hasPar) (wrap, unwrap) (level ++ [(i, (nm, cond))]) ts [] cont+                           decideSerial multi mbis (unwrap res) (goSerial cs)+                   else return $ wrap $ vacuityFailResult (i, nm)++        vacuityFailResult cur = ProofError config $ [ "Vacuity check failed."+                                                    , "Case constraint not satisfiable. Leading path:"+                                                    ]+                                                 ++ map ("    " ++) (align ([(i, n) | (i, (n, _)) <- level] ++ [cur]))+                                                 ++ ["HINT: Try \"CheckCaseVacuity False\" tactic to ignore case vacuity checks."]+          where align :: [(String, String)] -> [String]+                align path = map join cpath+                  where len = maximum (0 : map (length . fst) cpath)+                        join (c, n) = reverse (take len (reverse c ++ repeat ' ')) ++ ": " ++ n++                        cpath = [(intercalate "." (reverse ls), j) | (ls, j) <- cascade [] path]++                        trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace+                        cascade _     []              = []+                        cascade sofar ((i, j) : rest) = let new = trim i : sofar in (new, j) : cascade new rest++        decideSerial+         | isSAT = decideSerialSAT+         | True  = decideSerialProof++        -- short name+        diag Unsatisfiable{} = "[Unsatisfiable]"+        diag Satisfiable  {} = "[Satisfiable]"+        diag SatExtField  {} = "[Satisfiable in Field Extension]"+        diag Unknown      {} = "[Unknown]"+        diag ProofError   {} = "[ProofError]"+        diag TimeOut      {} = "[TimeOut]"++        -- If we're SAT, we stop at first satisfiable and report back. Otherwise continue.+        -- Note that we also stop if we get a ProofError, as that clearly is not OK+        decideSerialSAT :: Bool -> Maybe (String, String) -> SMTResult -> IO res -> IO res+        decideSerialSAT multi mbis r@Satisfiable{} _ = endCase multi mbis (diag r) >> return (wrap r)+        decideSerialSAT multi mbis r@ProofError{}  _ = endCase multi mbis (diag r) >> return (wrap r)+        decideSerialSAT multi mbis r               k = endCase multi mbis (diag r) >> k++        -- If we're Prove, we stop at first *not* unsatisfiable and report back. Otherwise continue.+        decideSerialProof :: Bool -> Maybe (String, String) -> SMTResult -> IO res -> IO res+        decideSerialProof multi mbis Unsatisfiable{} k = endCase multi mbis "[Proved]" >> k+        decideSerialProof multi mbis r               _ = endCase multi mbis "[Failed]" >> return (wrap r)++        -----------------------------------------------------------------------------------------------------------------+        -- Parallel case analysis+        -----------------------------------------------------------------------------------------------------------------+        goParallel :: [(String, (String, SW, [Tactic SW]))] -> IO res+        goParallel cs = do+             when chatty $ putStrLn $ topName '>' "[Starting]"++             -- Create the case claim:+             let mkTask (i, (nm, cond, ts)) =+                  let caseProof = do continue <- if isSAT   -- for a SAT check, vacuity is meaningless (what would be the point)?+                                                 then return True+                                                 else if checkVacuity+                                                      then do res <- cont config mbOptInfo (CaseVac (map (snd . snd) level) cond)+                                                              case unwrap res of+                                                                Satisfiable{} -> return True+                                                                _             -> return False+                                                      else return True+                                     if continue+                                        then unwrap `fmap` applyTactics config (isSAT, hasPar) (wrap, unwrap) (level ++ [(i, (nm, cond))]) ts [] cont+                                        else return $ vacuityFailResult (i, nm)+                  in (mkCaseNameBase nm i, caseProof)++             -- Create the coverage claim+             let cov = unwrap `fmap` cont config mbOptInfo (CaseCov (map (snd . snd) level) [c | (_, c, _) <- cases])++             (decidingTag, res) <- decideParallel $ map mkTask cs ++ [(mkCovNameBase, cov)]++             let trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace++             let caseMsg+                  | isSAT = satMsg+                  | True  = proofMsg+                  where addTag x = x ++ " (at " ++ trim decidingTag ++ ")"+                        (satMsg, proofMsg) =  case res of+                                                Unsatisfiable{} -> ("[Unsatisfiable]", "[Proved]")+                                                Satisfiable{}   -> (addTag "[Satisfiable]",   addTag "[Failed]")+                                                _               -> let d = diag res in (addTag d, addTag d)++             when chatty $ putStrLn $ topName '<' caseMsg++             return $ wrap res++            where topName c w  = tag c ++ topTag ++ " Parallel case split: " ++ range ++ ": " ++ w++                  topTag = " Case" ++ s ++ intercalate "." lids ++ dot ++ "[1-" ++ show (length cs + 1) ++ "]:"+                    where dot | null lids = ""+                              | True      = "."+                          s   | null cs   = " "+                              | True      = "s "++                  range   = case cs of+                              []  -> "Coverage"+                              [_] -> "One case and coverage"+                              xs  -> show (length xs) ++ " cases and coverage"++        -- Parallel decision:+        --      - If SAT:   Run all cases in parallel and return a SAT result from any. If none-of-them is SAT, then we return the last finishing+        --      - If Prove: Run all cases in parallel and return the last one if all return UNSAT. Otherwise return the first SAT one.+        decideParallel :: [(String, IO SMTResult)] -> IO (String, SMTResult)+        decideParallel caseTasks = mapM try caseTasks >>= pick+          where try (nm, task) = async $ task >>= \r -> return (nm, r)++                pick :: [Async (String, SMTResult)] -> IO (String, SMTResult)+                pick []  = error "SBV.caseSplit.decideParallel: Impossible happened, ran out of proofs!"+                pick [a] = wait a+                pick as  = do (d, r) <- waitAny as+                              let others   = filter (/= d) as+                                  continue = pick others+                                  stop     = mapM_ cancel others >> return r+                              case snd r of+                                Unsatisfiable{} -> continue+                                Satisfiable{}   -> stop+                                SatExtField{}   -> stop+                                ProofError{}    -> stop+                                Unknown{}       -> if isSAT then continue else stop+                                TimeOut{}       -> if isSAT then continue else stop+ -- | Check if any of the assertions can be violated safeWith :: SExecutable a => SMTConfig -> a -> IO [SafeResult] safeWith cfg a = do@@ -360,48 +859,49 @@   where locInfo (Just ps) = Just $ let loc (f, sl) = concat [srcLocFile sl, ":", show (srcLocStartLine sl), ":", show (srcLocStartCol sl), ":", f]                                    in intercalate ",\n " (map loc ps)         locInfo _         = Nothing-        verify res (msg, cs, cond) = do SatResult result <- runProofOn cvt cfg True [] pgm >>= callSolver True msg SatResult cfg+        verify res (msg, cs, cond) = do result <- runProofOn (getConverter cfg) cfg True [] pgm >>= \p -> callSolver True msg [] mwrap p cfg Nothing NoCase                                         return $ SafeResult (locInfo (getCallStack `fmap` cs), msg, result)            where pgm = res { resInputs  = [(EX, n) | (_, n) <- resInputs res]   -- make everything existential                            , resOutputs = [cond]                            }-                 cvt = case smtLibVersion cfg of-                         SMTLib2 -> toSMTLib2+                 mwrap [r] = r+                 mwrap xs  = error $ "SBV.safeWith: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs)  -- | Check if a safe-call was safe or not, turning a 'SafeResult' to a Bool. isSafe :: SafeResult -> Bool isSafe (SafeResult (_, _, result)) = case result of                                        Unsatisfiable{} -> True                                        Satisfiable{}   -> False+                                       SatExtField{}   -> False   -- conservative                                        Unknown{}       -> False   -- conservative                                        ProofError{}    -> False   -- conservative                                        TimeOut{}       -> False   -- conservative --- | Determine if the constraints are vacuous using the given SMT-solver+-- | Determine if the constraints are vacuous using the given SMT-solver. Also see+-- the 'CheckConstrVacuity' tactic. isVacuousWith :: Provable a => SMTConfig -> a -> IO Bool isVacuousWith config a = do-        Result ki tr uic is cs ts as uis ax asgn cstr asserts _ <- runSymbolic (True, config) $ forAll_ a >>= output+        Result ki tr uic is cs ts as uis ax asgn cstr tactics goals asserts _out <- runSymbolic (True, config) $ forAll_ a >>= output         case cstr of            [] -> return False -- no constraints, no need to check            _  -> do let is'  = [(EX, i) | (_, i) <- is] -- map all quantifiers to "exists" for the constraint check-                        res' = Result ki tr uic is' cs ts as uis ax asgn cstr asserts [trueSW]-                        cvt  = case smtLibVersion config of-                                 SMTLib2 -> toSMTLib2-                    SatResult result <- runProofOn cvt config True [] res' >>= callSolver True "Checking Satisfiability.." SatResult config+                        res' = Result ki tr uic is' cs ts as uis ax asgn cstr tactics goals asserts [trueSW]+                    result <- runProofOn (getConverter config) config True [] res' >>= \p -> callSolver True "Checking Vacuity.." [] mwrap p config Nothing NoCase                     case result of                       Unsatisfiable{} -> return True  -- constraints are unsatisfiable!                       Satisfiable{}   -> return False -- constraints are satisfiable!+                      SatExtField{}   -> error "SBV: isVacuous: Solver returned a model in the extension field!"                       Unknown{}       -> error "SBV: isVacuous: Solver returned unknown!"                       ProofError _ ls -> error $ "SBV: isVacuous: error encountered:\n" ++ unlines ls                       TimeOut _       -> error "SBV: isVacuous: time-out."+        where mwrap [r] = r+              mwrap xs  = error $ "SBV.isVacuousWith: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs)  -- | Find all satisfying assignments using the given SMT-solver allSatWith :: Provable a => SMTConfig -> a -> IO AllSatResult allSatWith config p = do-        let converter  = case smtLibVersion config of-                           SMTLib2 -> toSMTLib2         msg "Checking Satisfiability, all solutions.."-        sbvPgm@(qinps, _, ki, _, _) <- simulate converter config True [] p+        sbvPgm@SMTProblem{smtInputs=qinps, kindsUsed=ki} <- simulate (getConverter config) config True [] p         let usorts = [s | us@(KUserSort s _) <- Set.toList ki, isFree us]                 where isFree (KUserSort _ (Left _)) = True                       isFree _                      = False@@ -414,48 +914,66 @@         return $ AllSatResult (w,  results)   where msg = when (verbose config) . putStrLn . ("** " ++)         go sbvPgm = loop-          where loop !n nonEqConsts = do-                  curResult <- invoke nonEqConsts n sbvPgm+          where hasPar = any isParallelCaseAnywhere (tactics sbvPgm)+                loop !n nonEqConsts = do+                  curResult <- invoke nonEqConsts hasPar n sbvPgm                   case curResult of                     Nothing            -> return []                     Just (SatResult r) -> let cont model = do let modelOnlyAssocs = [v | v@(x, _) <- modelAssocs model, not (isNonModelVar config x)]                                                               rest <- unsafeInterleaveIO $ loop (n+1) (modelOnlyAssocs : nonEqConsts)                                                               return (r : rest)                                           in case r of-                                               Satisfiable   _ (SMTModel []) -> return [r]-                                               Unknown       _ (SMTModel []) -> return [r]-                                               ProofError    _ _             -> return [r]-                                               TimeOut       _               -> return []-                                               Unsatisfiable _               -> return []-                                               Satisfiable   _ model         -> cont model-                                               Unknown       _ model         -> cont model-        invoke nonEqConsts n (qinps, skolemMap, _, _, smtLibPgm) = do+                                               -- We are done! This is really how we should always stop.+                                               Unsatisfiable{} -> return []++                                               -- We have a model. If there are bindings, continue; otherwise stop+                                               Satisfiable   _ (SMTModel _ []) -> return [r]+                                               Satisfiable   _ model           -> cont model++                                               -- Satisfied in an extension field. Stop if no new bindings, otherwise continue if all regular.+                                               -- If the model is in the extension, we also stop+                                               SatExtField   _ (SMTModel _ [])       -> return [r]+                                               SatExtField   _ model@(SMTModel [] _) -> cont model+                                               SatExtField{}                         -> return []++                                               -- Something bad happened, we stop here. Note that we treat Unknown as bad too in this context.+                                               Unknown{}    -> return [r]+                                               ProofError{} -> return [r]+                                               TimeOut{}    -> return [r]++        invoke nonEqConsts hasPar n simRes@SMTProblem{smtInputs, tactics, objectives} = do+               objectiveCheck False objectives "allSat"                msg $ "Looking for solution " ++ show n-               case addNonEqConstraints (roundingMode config) qinps nonEqConsts smtLibPgm of-                 Nothing ->  -- no new constraints added, stop+               case addNonEqConstraints (smtLibVersion config) (roundingMode config) smtInputs nonEqConsts of+                 Nothing -> -- no new constraints refuted models, stop                             return Nothing-                 Just finalPgm -> do msg $ "Generated SMTLib program:\n" ++ finalPgm-                                     smtAnswer <- engine (solver config) (updateName (n-1) config) True qinps skolemMap finalPgm-                                     msg "Done.."-                                     return $ Just $ SatResult smtAnswer+                 Just refutedModels -> do++                    let wrap                 = SatResult+                        unwrap (SatResult r) = r++                        mwrap  [r]           = wrap r+                        mwrap xs             = error $ "SBV.allSatWith: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs)++                    res <- bufferSanity hasPar $ applyTactics (updateName (n-1) config) (True, hasPar) (wrap, unwrap) [] tactics objectives+                                               $ callSolver True "Checking Satisfiability.." refutedModels mwrap simRes+                    return $ Just res+         updateName i cfg = cfg{smtFile = upd `fmap` smtFile cfg}                where upd nm = let (b, e) = splitExtension nm in b ++ "_allSat_" ++ show i ++ e -type SMTProblem = ( [(Quantifier, NamedSymVar)]      -- inputs-                  , [Either SW (SW, [SW])]           -- skolem-map-                  , Set.Set Kind                     -- kinds used-                  , [(String, Maybe CallStack, SW)]  -- assertions-                  , SMTLibPgm                        -- SMTLib representation-                  )--callSolver :: Bool -> String -> (SMTResult -> b) -> SMTConfig -> SMTProblem -> IO b-callSolver isSat checkMsg wrap config (qinps, skolemMap, _, _, smtLibPgm) = do+callSolver :: Bool -> String -> [String] -> ([SMTResult] -> b) -> SMTProblem -> SMTConfig -> Maybe (OptimizeStyle, Int) -> CaseCond -> IO b+callSolver isSat checkMsg refutedModels wrap SMTProblem{smtInputs, smtSkolemMap, smtLibPgm} config mbOptInfo caseCond = do        let msg = when (verbose config) . putStrLn . ("** " ++)+           finalPgm = intercalate "\n" (pgm ++ refutedModels) where SMTLibPgm _ pgm = smtLibPgm config caseCond+        msg checkMsg-       let finalPgm = intercalate "\n" (pre ++ post) where SMTLibPgm _ (_, pre, post) = smtLibPgm-       msg $ "Generated SMTLib program:\n" ++ finalPgm-       smtAnswer <- engine (solver config) config isSat qinps skolemMap finalPgm+       msg $ "Generated SMTLib program:\n" ++ (finalPgm ++ intercalate "\n" ("" : optimizeArgs config ++ [satCmd config]))++       smtAnswer <- engine (solver config) config isSat mbOptInfo smtInputs smtSkolemMap finalPgm+        msg "Done.."+        return $ wrap smtAnswer  simulate :: Provable a => SMTLibConverter -> SMTConfig -> Bool -> [String] -> a -> IO SMTProblem@@ -470,10 +988,9 @@  runProofOn :: SMTLibConverter -> SMTConfig -> Bool -> [String] -> Result -> IO SMTProblem runProofOn converter config isSat comments res =-        let isTiming   = timing config-            solverCaps = capabilities (solver config)+        let isTiming = timing config         in case res of-             Result ki _qcInfo _codeSegs is consts tbls arrs uis axs pgm cstrs assertions [o@(SW KBool _)] ->+             Result ki _qcInfo _codeSegs is consts tbls arrs uis axs pgm cstrs tacs goals assertions [o@(SW KBool _)] ->                timeIf isTiming Translation                 $ let skolemMap = skolemize (if isSat then is else map flipQ is)                            where flipQ (ALL, x) = (EX, x)@@ -483,8 +1000,8 @@                                    where go []                   (_,  sofar) = reverse sofar                                          go ((ALL, (v, _)):rest) (us, sofar) = go rest (v:us, Left v : sofar)                                          go ((EX,  (v, _)):rest) (us, sofar) = go rest (us,   Right (v, reverse us) : sofar)-                      smtScript = converter (roundingMode config) (useLogic config) solverCaps ki isSat comments is skolemMap consts tbls arrs uis axs pgm cstrs o-                      result = (is, skolemMap, ki, assertions, smtScript)+                      smtScript = converter ki isSat comments is skolemMap consts tbls arrs uis axs pgm cstrs o+                      result = SMTProblem {smtInputs=is, smtSkolemMap=skolemMap, kindsUsed=ki, smtAsserts=assertions, tactics=tacs, objectives=goals, smtLibPgm=smtScript}                   in rnf smtScript `seq` return result              Result{resOutputs = os} -> case length os of                            0  -> error $ "Impossible happened, unexpected non-outputting result\n" ++ show res@@ -499,12 +1016,15 @@ internalSATCheck cfg condInPath st msg = do    sw <- sbvToSW st condInPath    () <- forceSWArg sw-   Result ki tr uic is cs ts as uis ax asgn cstr assertions _ <- extractSymbolicSimulationState st+   Result ki tr uic is cs ts as uis ax asgn cstr tactics goals assertions _ <- extractSymbolicSimulationState st+    let -- Construct the corresponding sat-checker for the branch. Note that we need to        -- forget about the quantifiers and just use an "exist", as we're looking for a        -- point-satisfiability check here; whatever the original program was.-       pgm = Result ki tr uic [(EX, n) | (_, n) <- is] cs ts as uis ax asgn cstr assertions [sw]-       cvt = case smtLibVersion cfg of-                SMTLib2 -> toSMTLib2-   runProofOn cvt cfg True [] pgm >>= callSolver True msg SatResult cfg+       pgm = Result ki tr uic [(EX, n) | (_, n) <- is] cs ts as uis ax asgn cstr tactics goals assertions [sw]++       mwrap [r] = SatResult r+       mwrap xs  = error $ "SBV.internalSATCheck: Backend solver returned a non-singleton answer:\n" ++ show (map SatResult xs)++   runProofOn (getConverter cfg) cfg True [] pgm >>= \p -> callSolver True msg [] mwrap p cfg Nothing NoCase {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
Data/SBV/Provers/SExpr.hs view
@@ -19,8 +19,8 @@ import Numeric             (readInt, readDec, readHex, fromRat) import Data.Binary.IEEE754 (wordToFloat, wordToDouble) -import Data.SBV.BitVectors.AlgReals-import Data.SBV.BitVectors.Data (nan, infinity, RoundingMode(..))+import Data.SBV.Core.AlgReals+import Data.SBV.Core.Data (nan, infinity, RoundingMode(..))  -- | ADT S-Expression format, suitable for representing get-model output of SMT-Lib data SExpr = ECon    String@@ -77,6 +77,8 @@                 n' | exact = n                    | True  = init n         -- simplify numbers and root-obj values+        cvt (EApp [ECon "to_int",  EReal a])                       = return $ EReal a   -- ignore the "casting"+        cvt (EApp [ECon "to_real", EReal a])                       = return $ EReal a   -- ignore the "casting"         cvt (EApp [ECon "/", EReal a, EReal b])                    = return $ EReal (a / b)         cvt (EApp [ECon "/", EReal a, ENum  b])                    = return $ EReal (a                   / fromInteger (fst b))         cvt (EApp [ECon "/", ENum  a, EReal b])                    = return $ EReal (fromInteger (fst a) /             b      )
Data/SBV/Provers/Yices.hs view
@@ -13,7 +13,7 @@  module Data.SBV.Provers.Yices(yices) where -import Data.SBV.BitVectors.Data+import Data.SBV.Core.Data import Data.SBV.SMT.SMT  -- | The description of the Yices SMT solver@@ -36,6 +36,7 @@                               , supportsReals              = True                               , supportsFloats             = False                               , supportsDoubles            = False+                              , supportsOptimization       = False                               }          }   where addTimeOut _ _ = error "Yices: Timeout values are not supported by Yices"
Data/SBV/Provers/Z3.hs view
@@ -21,12 +21,14 @@ import System.Environment (getEnv) import qualified System.Info as S(os) -import Data.SBV.BitVectors.AlgReals-import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.PrettyNum+import Data.SBV.Core.AlgReals+import Data.SBV.Core.Data+ import Data.SBV.SMT.SMT import Data.SBV.SMT.SMTLib+ import Data.SBV.Utils.Lib (splitArgs)+import Data.SBV.Utils.PrettyNum  -- Choose the correct prefix character for passing options -- TBD: Is there a more foolproof way of determining this?@@ -43,17 +45,37 @@            name           = Z3          , executable     = "z3"          , options        = map (optionPrefix:) ["nw", "in", "smt2"]-         , engine         = \cfg isSat qinps skolemMap pgm -> do++         , engine         = \cfg isSat mbOptInfo qinps skolemMap pgm -> do+                                     execName <-                   getEnv "SBV_Z3"          `C.catch` (\(_ :: C.SomeException) -> return (executable (solver cfg)))                                     execOpts <- (splitArgs `fmap` getEnv "SBV_Z3_OPTIONS") `C.catch` (\(_ :: C.SomeException) -> return (options (solver cfg)))-                                    let cfg' = cfg { solver = (solver cfg) {executable = execName, options = addTimeOut (timeOut cfg) execOpts} }++                                    let cfg'   = cfg { solver = (solver cfg) {executable = execName, options = addTimeOut (timeOut cfg) execOpts} }                                         tweaks = case solverTweaks cfg' of                                                    [] -> ""                                                    ts -> unlines $ "; --- user given solver tweaks ---" : ts ++ ["; --- end of user given tweaks ---"]-                                        dlim = printRealPrec cfg'++                                        dlim     = printRealPrec cfg'                                         ppDecLim = "(set-option :pp.decimal_precision " ++ show dlim ++ ")\n"-                                        script = SMTScript {scriptBody = tweaks ++ ppDecLim ++ pgm, scriptModel = Just (cont (roundingMode cfg) skolemMap)}-                                    standardSolver cfg' script id (ProofError cfg') (interpretSolverOutput cfg' (extractMap isSat qinps))++                                        mkCont     = cont (roundingMode cfg) skolemMap++                                        (nModels, isPareto, mbContScript) =+                                                case mbOptInfo of+                                                  Just (Pareto, _)              -> (1, True,  Nothing)+                                                  Just (Independent, n) | n > 1 -> (n, False, Just (intercalate "\n" (map (mkCont . Just) [0 .. n-1])))+                                                  _                             -> (1, False, Just (mkCont Nothing))++                                        script   = SMTScript {scriptBody = tweaks ++ ppDecLim ++ pgm, scriptModel = mbContScript}++                                        mkResult c em+                                         | isPareto     =               interpretSolverParetoOutput         c em+                                         | nModels == 1 = replicate 1 . interpretSolverOutput               c em+                                         | True         =               interpretSolverOutputMulti  nModels c em++                                    standardSolver cfg' script id (replicate nModels . ProofError cfg') (mkResult cfg' (extractMap isSat qinps))+          , capabilities   = SolverCapabilities {                                   capSolverName              = "Z3"                                 , mbDefaultLogic             = const Nothing@@ -65,20 +87,33 @@                                 , supportsReals              = True                                 , supportsFloats             = True                                 , supportsDoubles            = True+                                , supportsOptimization       = True                                 }          }- where cont rm skolemMap = intercalate "\n" $ concatMap extract skolemMap-        where -- In the skolemMap:+ where cont rm skolemMap mbModelIndex = intercalate "\n" $ wrapModel grabValues+        where grabValues = concatMap extract skolemMap++              modelIndex = case mbModelIndex of+                             Nothing -> ""+                             Just i  -> " :model_index " ++ show i++              wrapModel xs = case mbModelIndex of+                               Just _ -> "(echo \"(sbv_objective_model_marker)\")" : xs+                               _      -> xs++              -- In the skolemMap:               --    * Left's are universals: i.e., the model should be true for               --      any of these. So, we simply "echo 0" for these values.               --    * Right's are existentials. If there are no dependencies (empty list), then we can               --      simply use get-value to extract it's value. Otherwise, we have to apply it to               --      an appropriate number of 0's to get the final value.               extract (Left s)        = ["(echo \"((" ++ show s ++ " " ++ mkSkolemZero rm (kindOf s) ++ "))\")"]-              extract (Right (s, [])) = let g = "(get-value (" ++ show s ++ "))" in getVal (kindOf s) g-              extract (Right (s, ss)) = let g = "(get-value ((" ++ show s ++ concat [' ' : mkSkolemZero rm (kindOf a) | a <- ss] ++ ")))" in getVal (kindOf s) g+              extract (Right (s, [])) = let g = "(get-value (" ++ show s ++ ")" ++ modelIndex ++ ")" in getVal (kindOf s) g+              extract (Right (s, ss)) = let g = "(get-value ((" ++ show s ++ concat [' ' : mkSkolemZero rm (kindOf a) | a <- ss] ++ "))" ++ modelIndex ++ ")" in getVal (kindOf s) g+               getVal KReal g = ["(set-option :pp.decimal false) " ++ g, "(set-option :pp.decimal true)  " ++ g]               getVal _     g = [g]+        addTimeOut Nothing  o   = o        addTimeOut (Just i) o          | i < 0               = error $ "Z3: Timeout value must be non-negative, received: " ++ show i@@ -86,9 +121,12 @@  extractMap :: Bool -> [(Quantifier, NamedSymVar)] -> [String] -> SMTModel extractMap isSat qinps solverLines =-   SMTModel { modelAssocs = map snd $ squashReals $ sortByNodeId $ concatMap (interpretSolverModelLine inps) solverLines }+   SMTModel { modelObjectives = map snd $               sortByNodeId $ concatMap (interpretSolverObjectiveLine inps) solverLines+            , modelAssocs     = map snd $ squashReals $ sortByNodeId $ concatMap (interpretSolverModelLine     inps) solverLines+            }   where sortByNodeId :: [(Int, a)] -> [(Int, a)]         sortByNodeId = sortBy (compare `on` fst)+         inps -- for "sat", display the prefix existentials. For completeness, we will drop              -- only the trailing foralls. Exception: Don't drop anything if it's all a sequence of foralls              | isSat = map snd $ if all (== ALL) (map fst qinps)@@ -96,11 +134,14 @@                                  else reverse $ dropWhile ((== ALL) . fst) $ reverse qinps              -- for "proof", just display the prefix universals              | True  = map snd $ takeWhile ((== ALL) . fst) qinps+         squashReals :: [(Int, (String, CW))] -> [(Int, (String, CW))]         squashReals = concatMap squash . groupBy ((==) `on` fst)           where squash [(i, (n, cw1)), (_, (_, cw2))] = [(i, (n, mergeReals n cw1 cw2))]                 squash xs = xs+                 mergeReals :: String -> CW -> CW -> CW                 mergeReals n (CW KReal (CWAlgReal a)) (CW KReal (CWAlgReal b)) = CW KReal (CWAlgReal (mergeAlgReals (bad n a b) a b))                 mergeReals n a b = bad n a b+                 bad n a b = error $ "SBV.Z3: Cannot merge reals for variable: " ++ n ++ " received: " ++ show (a, b)
Data/SBV/SMT/SMT.hs view
@@ -32,21 +32,24 @@  import qualified Data.Map as M -import Data.SBV.BitVectors.AlgReals-import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.PrettyNum-import Data.SBV.BitVectors.Symbolic   (SMTEngine)-import Data.SBV.SMT.SMTLib            (interpretSolverOutput, interpretSolverModelLine)+import Data.SBV.Core.AlgReals+import Data.SBV.Core.Data+import Data.SBV.Core.Symbolic (SMTEngine)++import Data.SBV.SMT.SMTLib    (interpretSolverOutput, interpretSolverModelLine, interpretSolverObjectiveLine)++import Data.SBV.Utils.PrettyNum import Data.SBV.Utils.Lib             (joinArgs, splitArgs) import Data.SBV.Utils.TDiff  -- | Extract the final configuration from a result resultConfig :: SMTResult -> SMTConfig-resultConfig (Unsatisfiable c) = c-resultConfig (Satisfiable c _) = c-resultConfig (Unknown c _)     = c-resultConfig (ProofError c _)  = c-resultConfig (TimeOut c)       = c+resultConfig (Unsatisfiable c  ) = c+resultConfig (Satisfiable   c _) = c+resultConfig (SatExtField   c _) = c+resultConfig (Unknown       c _) = c+resultConfig (ProofError    c _) = c+resultConfig (TimeOut       c  ) = c  -- | A 'prove' call results in a 'ThmResult' newtype ThmResult    = ThmResult    SMTResult@@ -55,30 +58,35 @@ -- The reason for having a separate 'SatResult' is to have a more meaningful 'Show' instance. newtype SatResult    = SatResult    SMTResult --- | A 'safe' call results in a 'SafeResult'-newtype SafeResult   = SafeResult   (Maybe String, String, SMTResult)- -- | An 'allSat' call results in a 'AllSatResult'. The boolean says whether -- we should warn the user about prefix-existentials. newtype AllSatResult = AllSatResult (Bool, [SMTResult]) +-- | A 'safe' call results in a 'SafeResult'+newtype SafeResult   = SafeResult   (Maybe String, String, SMTResult)++-- | An 'optimize' call results in a 'OptimizeResult'+data OptimizeResult = LexicographicResult SMTResult+                    | ParetoResult        [SMTResult]+                    | IndependentResult   [(String, SMTResult)]+ -- | User friendly way of printing theorem results instance Show ThmResult where   show (ThmResult r) = showSMTResult "Q.E.D."                                      "Unknown"     "Unknown. Potential counter-example:\n"-                                     "Falsifiable" "Falsifiable. Counter-example:\n" r+                                     "Falsifiable" "Falsifiable. 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"     "Unknown. Potential model:\n"-                                     "Satisfiable" "Satisfiable. Model:\n" r+                                     "Satisfiable" "Satisfiable. 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 "Unknown. Potential violating model:\n")-                                                     (tag "Violated") (tag "Violated. Model:\n") r+                                                     (tag "Violated") (tag "Violated. Model:\n") (tag "Violated in an extension field:\n") r         where loc   = maybe "" (++ ": ") mbLoc               tag s = loc ++ msg ++ ": " ++ s @@ -97,11 +105,36 @@                           _ -> "Found " ++ show c ++ " different solutions." ++ uniqueWarn           sh i c = (ok, showSMTResult "Unsatisfiable"                                       "Unknown" "Unknown. Potential model:\n"-                                      ("Solution #" ++ show i ++ ":\nSatisfiable") ("Solution #" ++ show i ++ ":\n") c)+                                      ("Solution #" ++ show i ++ ":\nSatisfiable") ("Solution #" ++ show i ++ ":\n")+                                      ("Solution $" ++ show i ++ " in an extension field:\n")+                                      c)               where ok = case c of                            Satisfiable{} -> True                            _             -> False +-- | Show instance for optimization results+instance Show OptimizeResult where+  show res = case res of+               LexicographicResult r   -> sh id r++               IndependentResult   rs  -> multi "objectives" (map (uncurry shI) rs)++               ParetoResult        [r] -> sh (\s -> "Unique pareto front: " ++ s) r+               ParetoResult        rs  -> multi "pareto optimal values" (zipWith shP [(1::Int)..] rs)++       where multi w [] = "There are no " ++ w ++ " to display models for."+             multi _ xs = intercalate "\n" xs++             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 "Unknown. Potential model:" ++ "\n")+                                    (tag "Optimal with no assignments.")+                                    (tag "Optimal model:" ++ "\n")+                                    (tag "Optimal in an extension field:" ++ "\n")+ -- | Instances of 'SatModel' can be automatically extracted from models returned by the -- solvers. The idea is that the sbv infrastructure provides a stream of 'CW''s (constant-words) -- coming from the solver, and the type @a@ is interpreted based on these constants. Many typical@@ -246,15 +279,19 @@ class Modelable a where   -- | Is there a model?   modelExists :: a -> Bool+   -- | Extract a model, the result is a tuple where the first argument (if True)   -- indicates whether the model was "probable". (i.e., if the solver returned unknown.)   getModel :: SatModel b => a -> Either String (Bool, b)+   -- | Extract a model dictionary. Extract a dictionary mapping the variables to   -- their respective values as returned by the SMT solver. Also see `getModelDictionaries`.   getModelDictionary :: a -> M.Map String CW+   -- | Extract a model value for a given element. Also see `getModelValues`.   getModelValue :: SymWord b => String -> a -> Maybe b   getModelValue v r = fromCW `fmap` (v `M.lookup` getModelDictionary r)+   -- | Extract a representative name for the model value of an uninterpreted kind.   -- This is supposed to correspond to the value as computed internally by the   -- SMT solver; and is unportable from solver to solver. Also see `getModelUninterpretedValues`.@@ -269,6 +306,13 @@                      Right (_, b) -> Just b                      _            -> Nothing +  -- | Extract model objective values, for all optimization goals.+  getModelObjectives :: a -> M.Map String GeneralizedCW++  -- | Extract the value of an objective+  getModelObjectiveValue :: String -> a -> Maybe GeneralizedCW+  getModelObjectiveValue v r = v `M.lookup` getModelObjectives r+ -- | Return all the models from an 'allSat' call, similar to 'extractModel' but -- is suitable for the case of multiple results. extractModels :: SatModel a => AllSatResult -> [a]@@ -291,29 +335,42 @@   getModel           (ThmResult r) = getModel r   modelExists        (ThmResult r) = modelExists r   getModelDictionary (ThmResult r) = getModelDictionary r+  getModelObjectives (ThmResult r) = getModelObjectives r  -- | 'SatResult' as a generic model provider instance Modelable SatResult where   getModel           (SatResult r) = getModel r   modelExists        (SatResult r) = modelExists r   getModelDictionary (SatResult r) = getModelDictionary r+  getModelObjectives (SatResult r) = getModelObjectives r  -- | 'SMTResult' as a generic model provider instance Modelable SMTResult where   getModel (Unsatisfiable _) = Left "SBV.getModel: Unsatisfiable result"+  getModel (Satisfiable _ m) = Right (False, parseModelOut m)+  getModel (SatExtField _ _) = Left "SBV.getModel: The model is in an extension field"   getModel (Unknown _ m)     = Right (True, parseModelOut m)   getModel (ProofError _ s)  = error $ unlines $ "Backend solver complains: " : s   getModel (TimeOut _)       = Left "Timeout"-  getModel (Satisfiable _ m) = Right (False, parseModelOut m)+   modelExists Satisfiable{}   = True   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)     = M.fromList (modelAssocs m)   getModelDictionary (ProofError _ _)  = M.empty   getModelDictionary (TimeOut _)       = M.empty-  getModelDictionary (Satisfiable _ m) = M.fromList (modelAssocs m) +  getModelObjectives (Unsatisfiable _) = M.empty+  getModelObjectives (Satisfiable _ m) = M.fromList (modelObjectives m)+  getModelObjectives (SatExtField _ m) = M.fromList (modelObjectives m)+  getModelObjectives (Unknown _ m)     = M.fromList (modelObjectives m)+  getModelObjectives (ProofError _ _)  = M.empty+  getModelObjectives (TimeOut _)       = M.empty+ -- | Extract a model out, will throw error if parsing is unsuccessful parseModelOut :: SatModel a => SMTModel -> a parseModelOut m = case parseCWs [c | (_, c) <- modelAssocs m] of@@ -332,44 +389,54 @@   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 unkMsgModel satMsg satMsgModel result = case result of-  Unsatisfiable _             -> unsatMsg-  Satisfiable _ (SMTModel []) -> satMsg-  Satisfiable _ m             -> satMsgModel ++ showModel cfg m-  Unknown     _ (SMTModel []) -> unkMsg-  Unknown     _ m             -> unkMsgModel ++ showModel cfg m-  ProofError  _ []            -> "*** An error occurred. No additional information available. Try running in verbose mode"-  ProofError  _ ls            -> "*** An error occurred.\n" ++ intercalate "\n" (map ("***  " ++) ls)-  TimeOut     _               -> "*** Timeout"+showSMTResult :: String -> String -> String -> String -> String -> String -> SMTResult -> String+showSMTResult unsatMsg unkMsg unkMsgModel satMsg satMsgModel satExtMsg result = case result of+  Unsatisfiable _               -> unsatMsg+  Satisfiable _ (SMTModel _ []) -> satMsg+  Satisfiable _ m               -> satMsgModel ++ showModel cfg m+  SatExtField _ (SMTModel b _)  -> satExtMsg   ++ showModelDictionary cfg b+  Unknown     _ (SMTModel _ []) -> unkMsg+  Unknown     _ m               -> unkMsgModel ++ showModel cfg m+  ProofError  _ []              -> "*** An error occurred. No additional information available. Try running in verbose mode"+  ProofError  _ ls              -> "*** An error occurred.\n" ++ intercalate "\n" (map ("***  " ++) ls)+  TimeOut     _                 -> "*** Timeout"  where cfg = resultConfig result  -- | Show a model in human readable form. Ignore bindings to those variables that start -- with "__internal_sbv_" and also those marked as "nonModelVar" in the config; as these are only for internal purposes showModel :: SMTConfig -> SMTModel -> String-showModel cfg model+showModel cfg model = showModelDictionary cfg [(n, RegularCW c) | (n, c) <- modelAssocs model]++-- | Show bindings in a generalized model dictionary, tabulated+showModelDictionary :: SMTConfig -> [(String, GeneralizedCW)] -> String+showModelDictionary cfg allVars    | null allVars    = "[There are no variables bound by the model.]"    | null relevantVars    = "[There are no model-variables bound by the model.]"    | True    = intercalate "\n" . display . map shM $ relevantVars-  where allVars       = modelAssocs model-        relevantVars  = filter (not . ignore) allVars+  where relevantVars  = filter (not . ignore) allVars         ignore (s, _) = "__internal_sbv_" `isPrefixOf` s || isNonModelVar cfg s-        shM (s, v)    = let vs = shCW cfg v in ((length s, s), (vlength vs, vs))++        shM (s, RegularCW v) = let vs = shCW cfg v in ((length s, s), (vlength vs, vs))+        shM (s, other)       = let vs = show other in ((length s, s), (vlength vs, vs))+         display svs   = map line svs            where line ((_, s), (_, v)) = "  " ++ right (nameWidth - length s) s ++ " = " ++ left (valWidth - lTrimRight (valPart v)) v                  nameWidth             = maximum $ 0 : [l | ((l, _), _) <- svs]                  valWidth              = maximum $ 0 : [l | (_, (l, _)) <- svs]+         right p s = s ++ replicate p ' '         left  p s = replicate p ' ' ++ s         vlength s = case dropWhile (/= ':') (reverse (takeWhile (/= '\n') s)) of                       (':':':':r) -> length (dropWhile isSpace r)                       _           -> length s -- conservative+         valPart ""          = ""         valPart (':':':':_) = ""         valPart (x:xs)      = x : valPart xs+         lTrimRight = length . dropWhile isSpace . reverse  -- | Show a constant value, in the user-specified base@@ -439,7 +506,9 @@  -- | A standard post-processor: Reading the lines of solver output and turning it into a model: standardModelExtractor :: Bool -> [(Quantifier, NamedSymVar)] -> [String] -> SMTModel-standardModelExtractor isSat qinps solverLines = SMTModel { modelAssocs = map snd $ sortByNodeId $ concatMap (interpretSolverModelLine inps) solverLines }+standardModelExtractor isSat qinps solverLines = SMTModel { modelObjectives = map snd $ sortByNodeId $ concatMap (interpretSolverObjectiveLine inps) solverLines+                                                          , modelAssocs     = map snd $ sortByNodeId $ concatMap (interpretSolverModelLine     inps) solverLines+                                                          }          where sortByNodeId :: [(Int, a)] -> [(Int, a)]                sortByNodeId = sortBy (compare `on` fst)                inps -- for "sat", display the prefix existentials. For completeness, we will drop@@ -456,20 +525,33 @@                -> ([String] -> Int -> [String])                -> (Bool -> [(Quantifier, NamedSymVar)] -> [String] -> SMTModel, SW -> String -> [String])                -> SMTEngine-standardEngine envName envOptName addTimeOut (extractMap, extractValue) cfg isSat qinps skolemMap pgm = do+standardEngine envName envOptName addTimeOut (extractMap, extractValue) cfg isSat mbOptInfo qinps skolemMap pgm = do++    -- If there's an optimization goal, it better be handled by a custom engine!+    () <- case mbOptInfo of+            Nothing -> return ()+            Just _  -> error $ "SBV.standardEngine: Solver: " ++ show (name (solver cfg)) ++ " doesn't support optimization!"+     execName <-                    getEnv envName     `C.catch` (\(_ :: C.SomeException) -> return (executable (solver cfg)))     execOpts <- (splitArgs `fmap`  getEnv envOptName) `C.catch` (\(_ :: C.SomeException) -> return (options (solver cfg)))+     let cfg'    = cfg {solver = (solver cfg) {executable = execName, options = maybe execOpts (addTimeOut execOpts) (timeOut cfg)}}         tweaks  = case solverTweaks cfg' of                     [] -> ""                     ts -> unlines $ "; --- user given solver tweaks ---" : ts ++ ["; --- end of user given tweaks ---"]+         cont rm = intercalate "\n" $ concatMap extract skolemMap            where extract (Left s)        = extractValue s $ "(echo \"((" ++ show s ++ " " ++ mkSkolemZero rm (kindOf s) ++ "))\")"                  extract (Right (s, [])) = extractValue s $ "(get-value (" ++ show s ++ "))"                  extract (Right (s, ss)) = extractValue s $ "(get-value (" ++ show s ++ concat [' ' : mkSkolemZero rm (kindOf a) | a <- ss] ++ "))"+         script = SMTScript {scriptBody = tweaks ++ pgm, scriptModel = Just (cont (roundingMode cfg))}-    standardSolver cfg' script id (ProofError cfg') (interpretSolverOutput cfg' (extractMap isSat qinps)) +        -- standard engines only return one result ever+        wrap x = [x]++    standardSolver cfg' script id (wrap . ProofError cfg') (wrap . interpretSolverOutput cfg' (extractMap isSat qinps))+ -- | A standard solver interface. If the solver is SMT-Lib compliant, then this function should suffice in -- communicating with it. standardSolver :: SMTConfig -> SMTScript -> (String -> String) -> ([String] -> a) -> ([String] -> a) -> IO a@@ -484,8 +566,8 @@     case smtFile config of       Nothing -> return ()       Just f  -> do msg $ "Saving the generated script in file: " ++ show f-                    writeFile f (scriptBody script)-    contents <- timeIf isTiming (WorkByProver nmSolver) $ pipeProcess config  exec opts script cleanErrs+                    writeFile f (scriptBody script ++ intercalate "\n" ("" : optimizeArgs config ++ [satCmd config]))+    contents <- timeIf isTiming (WorkByProver nmSolver) $ pipeProcess config exec opts script cleanErrs     msg $ nmSolver ++ " output:\n" ++ either id (intercalate "\n") contents     case contents of       Left e   -> return $ failure (lines e)@@ -531,6 +613,7 @@                                                              else (ex,          finalOut ++ "\n" ++ out, err)                 return (send, ask, cleanUp, pid)       let executeSolver = do mapM_ send (lines (scriptBody script))+                             mapM_ send (optimizeArgs cfg)                              response <- case scriptModel script of                                            Nothing -> do send $ satCmd cfg                                                          return Nothing
Data/SBV/SMT/SMTLib.hs view
@@ -9,20 +9,28 @@ -- Conversion of symbolic programs to SMTLib format ----------------------------------------------------------------------------- -module Data.SBV.SMT.SMTLib(SMTLibPgm, SMTLibConverter, toSMTLib2, addNonEqConstraints, interpretSolverOutput, interpretSolverModelLine) where+module Data.SBV.SMT.SMTLib(+          SMTLibPgm+        , SMTLibConverter+        , toSMTLib2+        , addNonEqConstraints+        , interpretSolverOutput+        , interpretSolverOutputMulti+        , interpretSolverParetoOutput+        , interpretSolverModelLine+        , interpretSolverObjectiveLine+        ) where -import Data.Char (isDigit)+import Data.Char (isDigit, isSpace)+import Data.List (isPrefixOf) -import Data.SBV.BitVectors.Data+import Data.SBV.Core.Data import Data.SBV.Provers.SExpr import qualified Data.SBV.SMT.SMTLib2 as SMT2 import qualified Data.Set as Set (Set, member, toList)  -- | An instance of SMT-Lib converter; instantiated for SMT-Lib v1 and v2. (And potentially for newer versions in the future.)-type SMTLibConverter =  RoundingMode                 -- ^ User selected rounding mode to be used for floating point arithmetic-                     -> Maybe Logic                  -- ^ User selected logic to use. If Nothing, pick automatically.-                     -> SolverCapabilities           -- ^ Capabilities of the backend solver targeted-                     -> Set.Set Kind                 -- ^ Kinds used in the problem+type SMTLibConverter =  Set.Set Kind                 -- ^ Kinds used in the problem                      -> Bool                         -- ^ is this a sat problem?                      -> [String]                     -- ^ extra comments to place on top                      -> [(Quantifier, NamedSymVar)]  -- ^ inputs and aliasing names@@ -35,12 +43,14 @@                      -> SBVPgm                       -- ^ assignments                      -> [SW]                         -- ^ extra constraints                      -> SW                           -- ^ output variable+                     -> SMTConfig                    -- ^ configuration+                     -> CaseCond                     -- ^ case analysis                      -> SMTLibPgm  -- | Convert to SMTLib-2 format toSMTLib2 :: SMTLibConverter toSMTLib2 = cvt SMTLib2-  where cvt v roundMode smtLogic solverCaps kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out+  where cvt v kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out config caseSelectors          | KUnbounded `Set.member` kindInfo && not (supportsUnboundedInts solverCaps)          = unsupported "unbounded integers"          | KReal `Set.member` kindInfo  && not (supportsReals solverCaps)@@ -53,67 +63,238 @@          = unsupported "quantifiers"          | not (null sorts) && not (supportsUninterpretedSorts solverCaps)          = unsupported "uninterpreted sorts"+         | needsOptimization && not (supportsOptimization solverCaps)+         = unsupported "optimization routines"+         | not $ null needsUniversalOpt+         = unsupportedAll $ "optimization of universally quantified metric(s): " ++ unwords needsUniversalOpt          | True-         = SMTLibPgm v (aliasTable, pre, post)+         = SMTLibPgm v pgm          where sorts = [s | KUserSort s _ <- Set.toList kindInfo]-               unsupported w = error $ "SBV: Given problem needs " ++ w ++ ", which is not supported by SBV for the chosen solver: " ++ capSolverName solverCaps-               aliasTable  = map (\(_, (x, y)) -> (y, x)) qinps-               converter   = case v of-                               SMTLib2 -> SMT2.cvt-               (pre, post) = converter roundMode smtLogic solverCaps kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out+               solverCaps = capabilities (solver config)+               unsupported w = error $ unlines [ "SBV: Given problem needs " ++ w+                                               , "*** Which is not supported by SBV for the chosen solver: " ++ capSolverName solverCaps+                                               ]+               unsupportedAll w = error $ unlines [ "SBV: Given problem needs " ++ w+                                                  , "*** Which is not supported by SBV."+                                                  ]+               converter    = case v of+                                SMTLib2 -> SMT2.cvt+               pgm = converter kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out config caseSelectors+                needsFloats  = KFloat  `Set.member` kindInfo                needsDoubles = KDouble `Set.member` kindInfo+               (needsOptimization, needsUniversalOpt) = case caseSelectors of+                                                          Opt ss -> let universals   = [s | (ALL, (s, _)) <- qinps]+                                                                        check (x, y) = any (`elem` universals) [x, y]+                                                                        isUniversal (Maximize nm xy) | check xy = [nm]+                                                                        isUniversal (Minimize nm xy) | check xy = [nm]+                                                                        isUniversal _                           = []+                                                                    in  (True,  concatMap isUniversal ss)+                                                          _      -> (False, [])                needsQuantifiers                  | isSat = ALL `elem` quantifiers                  | True  = EX  `elem` quantifiers                  where quantifiers = map fst qinps  -- | Add constraints generated from older models, used for querying new models-addNonEqConstraints :: RoundingMode -> [(Quantifier, NamedSymVar)] -> [[(String, CW)]] -> SMTLibPgm -> Maybe String-addNonEqConstraints rm  qinps cs p@(SMTLibPgm SMTLib2 _) = SMT2.addNonEqConstraints rm qinps cs p+addNonEqConstraints :: SMTLibVersion -> RoundingMode -> [(Quantifier, NamedSymVar)] -> [[(String, CW)]] -> Maybe [String]+addNonEqConstraints SMTLib2 = SMT2.addNonEqConstraints  -- | Interpret solver output based on SMT-Lib standard output responses interpretSolverOutput :: SMTConfig -> ([String] -> SMTModel) -> [String] -> SMTResult interpretSolverOutput cfg _          ("unsat":_)      = Unsatisfiable cfg-interpretSolverOutput cfg extractMap ("unknown":rest) = Unknown       cfg  $ extractMap rest-interpretSolverOutput cfg extractMap ("sat":rest)     = Satisfiable   cfg  $ extractMap rest+interpretSolverOutput cfg extractMap ("unknown":rest) = Unknown       cfg $ extractMap rest+interpretSolverOutput cfg extractMap ("sat":rest)     = classifyModel cfg $ extractMap rest interpretSolverOutput cfg _          ("timeout":_)    = TimeOut       cfg-interpretSolverOutput cfg _          ls               = ProofError    cfg  ls+interpretSolverOutput cfg _          ls               = ProofError    cfg ls +-- | Do we have a regular sat-model, or something in the extension field?+classifyModel :: SMTConfig -> SMTModel -> SMTResult+classifyModel cfg m = case filter (not . isRegularCW . snd) (modelObjectives m) of+                        [] -> Satisfiable cfg m+                        _  -> SatExtField cfg m++-- | Interpret solver output based on SMT-Lib standard output responses, in the case we're expecting multiple objective model values+interpretSolverOutputMulti :: Int -> SMTConfig -> ([String] -> SMTModel) -> [String] -> [SMTResult]+interpretSolverOutputMulti n cfg extractMap outLines+   | degenerate+   = replicate n $ interpretSolverOutput cfg extractMap preModels+   | n /= lms+   = error $ "SBV: Expected " ++ show n ++ " models, received: " ++ show lms ++ ":\n" ++ unlines outLines+   | True+   = map (interpretSolverOutput cfg extractMap) multiModels+  where degenerate = case outLines of+                      ("sat"    :_) -> False+                      ("unknown":_) -> False+                      _             -> True++        (preModels, postModels) = case break (== "(sbv_objective_model_marker)") outLines of+                                    (pre, _:post) -> (pre, post)+                                    r             -> r++        walk [] sofar = reverse sofar+        walk xs sofar = case break (== "(sbv_objective_model_marker)") xs of+                          (g, [])     -> walk []   (g:sofar)+                          (g, _:rest) -> walk rest (g:sofar)++        multiModels = map (preModels ++) (walk postModels [])+        lms         = length multiModels++-- | Interpret solver output based on SMT-Lib pareto-output mode. Unfortunately this is likely to be very Z3 specific, and quite dissimilar+-- to other modes. (A "request" has been filed so we don't have to do this: <https://github.com/Z3Prover/z3/issues/1008>.) In the mean+-- time we try to interpret the Z3 output as well as we can.+interpretSolverParetoOutput :: SMTConfig -> ([String] -> SMTModel) -> [String] -> [SMTResult]+interpretSolverParetoOutput cfg extractMap outLines+  | null outLines+  = cont []+  | not isSAT+  = cont [finalLine : initLines]+  | True+  = groupModels+  where finalLine = last outLines+        initLines = init outLines+        isSAT     = case words finalLine of+                      "sat":_ -> True+                      _       -> False++        cont = map (interpretSolverOutput cfg extractMap)++        -- convert what z3 prints as Pareto output to what we can parse+        -- this is necessarily flaky, but hopefully good enough!+        -- The output is expected to be alternating lines of objectives and models+        groupModels = map grok $ cluster $ filter (not . irrelevant) initLines+        irrelevant  = null . dropWhile isSpace+        cluster (x:y:rest) = (x, y) : cluster rest+        cluster []         = []+        cluster _          = error $ "SBV.pareto: Unable to parse pareto fronts from solver output. Uneven length:\n"+                                   ++ unlines outLines++        grok :: (String, String) -> SMTResult+        grok (obj, ms)+          | "(objectives" `isPrefixOf` dropWhile isSpace obj+          , "(model"      `isPrefixOf` dropWhile isSpace ms+          = classifyModel cfg $ extractMap [obj, ms]+          | True+          = error $  "SBV.pareto: Unable to parse pareto front from solver output:\n"+                  ++ unlines [obj, ms]+                  ++ "SBV.pareto: The bigger context is:"+                  ++ unlines outLines+ -- | Get a counter-example from an SMT-Lib2 like model output line -- This routing is necessarily fragile as SMT solvers tend to print output -- in whatever form they deem convenient for them.. Currently, it's tuned to -- work with Z3 and CVC4; if new solvers are added, we might need to rework -- the logic here. interpretSolverModelLine :: [NamedSymVar] -> String -> [(Int, (String, CW))]-interpretSolverModelLine inps line = either err extract (parseSExpr line)+interpretSolverModelLine inps line = either err (modelValues True inps line) (parseSExpr line)   where err r =  error $  "*** Failed to parse SMT-Lib2 model output from: "                        ++ "*** " ++ show line ++ "\n"                        ++ "*** Reason: " ++ r ++ "\n"-        getInput (ECon v)            = isInput v-        getInput (EApp (ECon v : _)) = isInput v-        getInput _                   = Nothing++identifyInput :: [NamedSymVar] -> SExpr -> Maybe (Int, SW, String)+identifyInput inps = classify+  where classify (ECon v)            = isInput v+        classify (EApp (ECon v : _)) = isInput v+        classify _                   = Nothing+         isInput ('s':v)           | all isDigit v = let inpId :: Int                                 inpId = read v                             in case [(s, nm) | (s@(SW _ (NodeId n)), nm) <-  inps, n == inpId] of                                  []        -> Nothing                                  [(s, nm)] -> Just (inpId, s, nm)-                                 matches -> error $  "SBV.SMTLib2: Cannot uniquely identify value for "+                                 matches -> error $  "SBV.SMTLib: Cannot uniquely identify value for "                                                   ++ 's':v ++ " in "  ++ show matches         isInput _       = Nothing++-- | Turn an sexpr to a binding in our model+modelValues :: Bool -> [NamedSymVar] -> String -> SExpr -> [(Int, (String, CW))]+modelValues errOnUnrecognized inps line = extractModel+  where getInput = identifyInput inps+         getUIIndex (KUserSort  _ (Right xs)) i = i `lookup` zip xs [0..]         getUIIndex _                         _ = Nothing++        -- Lines of the form (model (define-fun s0 () Int 0) ...)+        extractModel (EApp (ECon "model" : rest)) = concatMap extractDefine rest+        extractModel e                            = extract e++        -- Lines of the form (define-fun s0 () Int 0)+        extractDefine (EApp (ECon "define-fun" : nm : EApp [] : ECon _ : rest)) = extract $ EApp [EApp (nm : rest)]+        extractDefine r = error $   "SBV.SMTLib: Cannot extract value from model level define-fun:"+                                ++ "\n\tInput: " ++ show line+                                ++ "\n\tParse: " ++ show r++        -- Lines of the form ((s0 0))         extract (EApp [EApp [v, ENum    i]]) | Just (n, s, nm) <- getInput v                    = [(n, (nm, mkConstCW (kindOf s) (fst i)))]         extract (EApp [EApp [v, EReal   i]]) | Just (n, s, nm) <- getInput v, isReal s          = [(n, (nm, CW KReal (CWAlgReal i)))]++        -- the following is when z3 returns a cast to an int. Inherently dangerous! (but useful)+        extract (EApp [EApp [v, EReal   i]]) | Just (n, _, nm) <- getInput v                    = [(n, (nm, CW KReal (CWAlgReal i)))]+         extract (EApp [EApp [v, ECon    i]]) | Just (n, s, nm) <- getInput v, isUninterpreted s = let k = kindOf s in [(n, (nm, CW k (CWUserSort (getUIIndex k i, i))))]         extract (EApp [EApp [v, EDouble i]]) | Just (n, s, nm) <- getInput v, isDouble s        = [(n, (nm, CW KDouble (CWDouble i)))]         extract (EApp [EApp [v, EFloat  i]]) | Just (n, s, nm) <- getInput v, isFloat s         = [(n, (nm, CW KFloat (CWFloat i)))]+         -- weird lambda app that CVC4 seems to throw out.. logic below derived from what I saw CVC4 print, hopefully sufficient         extract (EApp (EApp (v : EApp (ECon "LAMBDA" : xs) : _) : _)) | Just{} <- getInput v, not (null xs) = extract (EApp [EApp [v, last xs]])-        extract (EApp [EApp (v : r)])      | Just (_, _, nm) <- getInput v = error $   "SBV.SMTLib2: Cannot extract value for " ++ show nm-                                                                                   ++ "\n\tInput: " ++ show line-                                                                                   ++ "\n\tParse: " ++  show r-        extract _                                                          = [] -{-# ANN interpretSolverModelLine  ("HLint: ignore Use elemIndex" :: String) #-}+        extract (EApp [EApp (v : r)])+          | Just (_, _, nm) <- getInput v+          , errOnUnrecognized+          = error $   "SBV.SMTLib: Cannot extract value for " ++ show nm+                   ++ "\n\tInput: " ++ show line+                   ++ "\n\tParse: " ++ show r++        extract _ = []++-- | Similar to reading model-lines but designed for reading objectives.+interpretSolverObjectiveLine :: [NamedSymVar] -> String -> [(Int, (String, GeneralizedCW))]+interpretSolverObjectiveLine inps line = either err extract (parseSExpr line)+  where err r =  error $  "*** Failed to parse SMT-Lib2 model output from: "+                       ++ "*** " ++ show line ++ "\n"+                       ++ "*** Reason: " ++ r ++ "\n"++        getInput = identifyInput inps++        extract :: SExpr -> [(Int, (String, GeneralizedCW))]+        extract (EApp (ECon "objectives" : es)) = concatMap getObjValue es+        extract _                               = []++        getObjValue :: SExpr -> [(Int, (String, GeneralizedCW))]+        getObjValue e = case modelValues False inps line (EApp [e]) of+                          [] -> getUnboundedValues e+                          xs -> [(i, (s, RegularCW v)) | (i, (s, v)) <- xs]++        getUnboundedValues :: SExpr -> [(Int, (String, GeneralizedCW))]+        getUnboundedValues item = go item+          where go (EApp [v, rest]) | Just (n, s, nm) <- getInput v = [(n, (nm, ExtendedCW (toGenCW (kindOf s) (simplify rest))))]+                go _                                                = []++                die r = error $   "SBV.SMTLib: Cannot convert objective value from solver output!"+                             ++ "\n\tInput     : " ++ show line+                             ++ "\n\tParse     : " ++ show r+                             ++ "\n\tItem Parse: " ++ show item++                -- Convert to an extended expression. Hopefully complete!+                toGenCW :: Kind -> SExpr -> ExtCW+                toGenCW k = cvt+                   where cvt (ECon "oo")                    = Infinite  k+                         cvt (ECon "epsilon")               = Epsilon   k+                         cvt (EApp [ECon "interval", x, y]) = Interval  (cvt x) (cvt y)+                         cvt (ENum    (i, _))               = BoundedCW $ mkConstCW k i+                         cvt (EReal   r)                    = BoundedCW $ CW k $ CWAlgReal r+                         cvt (EFloat  f)                    = BoundedCW $ CW k $ CWFloat   f+                         cvt (EDouble d)                    = BoundedCW $ CW k $ CWDouble  d+                         cvt (EApp [ECon "+", x, y])        = AddExtCW (cvt x) (cvt y)+                         cvt (EApp [ECon "*", x, y])        = MulExtCW (cvt x) (cvt y)+                         -- Nothing else should show up, hopefully!+                         cvt e = die e++                -- drop the pesky to_real's that Z3 produces.. Cool but useless.+                simplify :: SExpr -> SExpr+                simplify (EApp [ECon "to_real", n]) = n+                simplify (EApp xs)                  = EApp (map simplify xs)+                simplify e                          = e++{-# ANN modelValues  ("HLint: ignore Use elemIndex" :: String) #-}
Data/SBV/SMT/SMTLib2.hs view
@@ -22,23 +22,22 @@ import qualified Data.IntMap   as IM import qualified Data.Set      as Set -import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.PrettyNum (smtRoundingMode, cwToSMTLib)+import Data.SBV.Core.Data +import Data.SBV.Utils.PrettyNum (smtRoundingMode, cwToSMTLib)+ -- | Add constraints to generate /new/ models. This function is used to query the SMT-solver, while -- disallowing a previous model.-addNonEqConstraints :: RoundingMode -> [(Quantifier, NamedSymVar)] -> [[(String, CW)]] -> SMTLibPgm -> Maybe String-addNonEqConstraints rm qinps allNonEqConstraints (SMTLibPgm _ (aliasTable, pre, post))+addNonEqConstraints :: RoundingMode -> [(Quantifier, NamedSymVar)] -> [[(String, CW)]] -> Maybe [String]+addNonEqConstraints rm qinps allNonEqConstraints   | null allNonEqConstraints-  = Just $ intercalate "\n" $ pre ++ post+  = Just []   | null refutedModel   = Nothing   | True-  = Just $ intercalate "\n" $ pre-    ++ [ "; --- refuted-models ---" ]-    ++ refutedModel-    ++ post+  = Just $ "; --- refuted-models ---" : refutedModel  where refutedModel = concatMap (nonEqs rm . map intName) nonEqConstraints+       aliasTable   = map (\(_, (x, y)) -> (y, x)) qinps        intName (s, c)           | Just sw <- s `lookup` aliasTable = (show sw, c)           | True                             = (s, c)@@ -78,10 +77,7 @@ tbd e = error $ "SBV.SMTLib2: Not-yet-supported: " ++ e  -- | Translate a problem into an SMTLib2 script-cvt :: RoundingMode                 -- ^ User selected rounding mode to be used for floating point arithmetic-    -> Maybe Logic                  -- ^ SMT-Lib logic, if requested by the user-    -> SolverCapabilities           -- ^ capabilities of the current solver-    -> Set.Set Kind                 -- ^ kinds used+cvt :: Set.Set Kind                 -- ^ kinds used     -> Bool                         -- ^ is this a sat problem?     -> [String]                     -- ^ extra comments to place on top     -> [(Quantifier, NamedSymVar)]  -- ^ inputs@@ -94,18 +90,23 @@     -> SBVPgm                       -- ^ assignments     -> [SW]                         -- ^ extra constraints     -> SW                           -- ^ output variable-    -> ([String], [String])-cvt rm smtLogic solverCaps kindInfo isSat comments inputs skolemInps consts tbls arrs uis axs (SBVPgm asgnsSeq) cstrs out = (pre, [])-  where -- the logic is an over-approaximation-        hasInteger     = KUnbounded `Set.member` kindInfo+    -> SMTConfig                    -- ^ configuration+    -> CaseCond                     -- ^ case analysis data+    -> [String]+cvt kindInfo isSat comments inputs skolemInps consts tbls arrs uis axs (SBVPgm asgnsSeq) cstrs out config caseCond = pgm+  where hasInteger     = KUnbounded `Set.member` kindInfo         hasReal        = KReal      `Set.member` kindInfo         hasFloat       = KFloat     `Set.member` kindInfo         hasDouble      = KDouble    `Set.member` kindInfo         hasBVs         = not $ null [() | KBounded{} <- Set.toList kindInfo]         usorts         = [(s, dt) | KUserSort s dt <- Set.toList kindInfo]         hasNonBVArrays = (not . null) [() | (_, (_, (k1, k2), _)) <- arrs, not (isBounded k1 && isBounded k2)]+        rm             = roundingMode config+        solverCaps     = capabilities (solver config)++        -- Determining the logic is surprisingly tricky!         logic-           | Just l <- smtLogic+           | Just l <- useLogic config            = ["(set-logic " ++ show l ++ ") ; NB. User specified."]            | hasDouble || hasFloat    -- NB. We don't check for quantifiers here, we probably should..            = if hasBVs@@ -128,17 +129,19 @@                     | True                     = "A"                 ufs | null uis && null tbls    = ""     -- we represent tables as UFs                     | True                     = "UF"+         getModels           | supportsProduceModels solverCaps = ["(set-option :produce-models true)"]           | True                             = []-        pre  =  ["; Automatically generated by SBV. Do not edit."]++        pgm  =  ["; Automatically generated by SBV. Do not edit."]              ++ map ("; " ++) comments              ++ getModels              ++ logic              ++ [ "; --- uninterpreted sorts ---" ]              ++ concatMap declSort usorts              ++ [ "; --- literal constants ---" ]-             ++ concatMap (declConst (supportsMacros solverCaps)) consts+             ++ concatMap declConst consts              ++ [ "; --- skolem constants ---" ]              ++ [ "(declare-fun " ++ show s ++ " " ++ swFunType ss s ++ ")" ++ userName s | Right (s, ss) <- skolemInps]              ++ [ "; --- constant tables ---" ]@@ -151,49 +154,114 @@              ++ concatMap declUI uis              ++ [ "; --- user given axioms ---" ]              ++ map declAx axs+              ++ [ "; --- formula ---" ]-             ++ [if null foralls-                 then "(assert ; no quantifiers"-                 else "(assert (forall (" ++ intercalate "\n                 "-                                             ["(" ++ show s ++ " " ++ swType s ++ ")" | s <- foralls] ++ ")"]-             ++ map (letAlign . mkLet) asgns-             ++ map letAlign (if null delayedEqualities then [] else ("(and " ++ deH) : map (align 5) deTs)-             ++ [ impAlign (letAlign assertOut) ++ replicate noOfCloseParens ')' ]-        noOfCloseParens = length asgns + (if null foralls then 1 else 2) + (if null delayedEqualities then 0 else 1)+             ++ ["(assert (forall (" ++ intercalate "\n                 "+                                        ["(" ++ show s ++ " " ++ swType s ++ ")" | s <- foralls] ++ ")"+                | not (null foralls)+                ]++             ++ concatMap mkAssign asgns++             ++ delayedAsserts delayedEqualities++             ++ [finalAssert]++        noOfCloseParens+          | null foralls = 0+          | True         = length asgns + 2 + (if null delayedEqualities then 0 else 1)++        foralls    = [s | Left s <- skolemInps]+        forallArgs = concatMap ((" " ++) . show) foralls+         (constTables, skolemTables) = ([(t, d) | (t, Left d) <- allTables], [(t, d) | (t, Right d) <- allTables])         allTables = [(t, genTableData rm skolemMap (not (null foralls), forallArgs) (map fst consts) t) | t <- tbls]         (arrayConstants, allArrayDelayeds) = unzip $ map (declArray (not (null foralls)) (map fst consts) skolemMap) arrs-        delayedEqualities@(~(deH:deTs)) = concatMap snd skolemTables ++ concat allArrayDelayeds-        foralls = [s | Left s <- skolemInps]-        forallArgs = concatMap ((" " ++) . show) foralls-        letAlign s-          | null foralls = "   " ++ s-          | True         = "            " ++ s+        delayedEqualities = concatMap snd skolemTables ++ concat allArrayDelayeds++        delayedAsserts []              = []+        delayedAsserts ds@(deH : deTs)+          | null foralls = map (\s -> "(assert " ++ s ++ ")") ds+          | True         = map letShift (("(and " ++ deH) : map (align 5) deTs)++        letShift = align 12++        finalAssert+          | null foralls = "(assert " ++ assertOut ++ ")"+          | True         = impAlign (letShift assertOut) ++ replicate noOfCloseParens ')'+         impAlign s           | null delayedEqualities = s           | True                   = "     " ++ s+         align n s = replicate n ' ' ++ s-        -- if sat,   we assert cstrs /\ out-        -- if prove, we assert ~(cstrs => out) = cstrs /\ not out++        -- We have:+        --    - cstrs   : Explicitly given constraints (via calls to constrain)+        --    - p1..pn  : The path conditions in a case-split that led us here. This is given in a case-split.+        --    - c1..cm  : All the other case-split constraints for the coverage case. This is in a case-coverage.+        -- if sat:+        --     -- we assert (cstrs /\ (p1 /\ p2 /\ ... /\ pn) /\ ~(c1 \/ c2 \/ .. \/ cm) /\ out)+        --            i.e., cstrs /\ p1 /\ p2 /\ ... /\ pn /\ ~c1 /\ ~c2 /\ ~c3 .. /\ ~cm /\ out+        -- if prove:+        --     -- we assert ~((cstrs /\  (p1 /\ p2 /\ .. /\ pn) /\ ~(c1 \/ c2 \/ .. \/ cm)) => out)+        --            i.e., cstrs /\ p1 /\ p2 /\ .. /\ pn /\ ~c1 /\ ~c2 /\ ~c3 .. /\ ~cm /\ ~out+        -- That is, we always assert all path constraints and path conditions AND+        --     -- negation of the output in a prove+        --     -- output itself in a sat         assertOut-           | null cstrs = o-           | True       = "(and " ++ unwords (map mkConj cstrs ++ [o]) ++ ")"-           where mkConj = cvtSW skolemMap-                 o | isSat =            mkConj out-                   | True  = "(not " ++ mkConj out ++ ")"+           | null cstrs' = o+           | True        = "(and " ++ unwords (cstrs' ++ [o]) ++ ")"+           where cstrs' = map pos cstrs ++ case caseCond of+                                             NoCase         -> []+                                             CasePath ss    -> map pos ss+                                             CaseVac  ss _  -> map pos ss+                                             CaseCov  ss qq -> map pos ss ++ map neg qq+                                             CstrVac        -> []+                                             Opt gs         -> map mkGoal gs++                 o | CstrVac     <- caseCond = pos trueSW -- always a SAT call!+                   | CaseVac _ s <- caseCond = pos s      -- always a SAT call!+                   | isSat                   = pos out+                   | True                    = neg out++                 neg s     = "(not " ++ pos s ++ ")"+                 pos       = cvtSW skolemMap++                 eq (orig, track) = "(= " ++ pos track ++ " " ++ pos orig ++ ")"+                 mkGoal (Minimize   _ ab)   = eq ab+                 mkGoal (Maximize   _ ab)   = eq ab+                 mkGoal (AssertSoft _ ab _) = eq ab+         skolemMap = M.fromList [(s, ss) | Right (s, ss) <- skolemInps, not (null ss)]         tableMap  = IM.fromList $ map mkConstTable constTables ++ map mkSkTable skolemTables           where mkConstTable (((t, _, _), _), _) = (t, "table" ++ show t)                 mkSkTable    (((t, _, _), _), _) = (t, "table" ++ show t ++ forallArgs)         asgns = F.toList asgnsSeq++        mkAssign a+          | null foralls = mkDef a+          | True         = [letShift (mkLet a)]++        mkDef (s, SBVApp (Label m) [e]) = emit (s, cvtSW     skolemMap          e) (Just m)+        mkDef (s, e)                    = emit (s, cvtExp rm skolemMap tableMap e) Nothing+         mkLet (s, SBVApp (Label m) [e]) = "(let ((" ++ show s ++ " " ++ cvtSW     skolemMap          e ++ ")) ; " ++ m         mkLet (s, e)                    = "(let ((" ++ show s ++ " " ++ cvtExp rm skolemMap tableMap e ++ "))"-        declConst useDefFun (s, c)-          | useDefFun = ["(define-fun "   ++ varT ++ " " ++ cvtCW rm c ++ ")"]-          | True      = [ "(declare-fun " ++ varT ++ ")"-                        , "(assert (= "   ++ show s ++ " " ++ cvtCW rm c ++ "))"++        -- does the solver allow define-fun; or do we need declare-fun/assert combo?+        useDefFun = supportsMacros solverCaps++        declConst (s, c) = emit (s, cvtCW rm c) Nothing++        emit (s, def) mbComment+          | useDefFun = ["(define-fun "   ++ varT ++ " " ++ def ++ ")" ++ cmnt]+          | True      = [ "(declare-fun " ++ varT ++ ")" ++ cmnt+                        , "(assert (= "   ++ show s ++ " " ++ def ++ "))"                         ]           where varT = show s ++ " " ++ swFunType [] s+                cmnt = maybe "" (" ; " ++) mbComment+         userName s = case s `lookup` map snd inputs of                         Just u  | show s /= u -> " ; tracks user variable " ++ show u                         _ -> ""
Data/SBV/SMT/SMTLibNames.hs view
@@ -22,4 +22,7 @@                         , "assert", "check-sat", "check-sat-assuming", "declare-const", "declare-fun", "declare-sort", "define-fun", "define-fun-rec"                         , "define-sort", "echo", "exit", "get-assertions", "get-assignment", "get-info", "get-model", "get-option", "get-proof", "get-unsat-assumptions"                         , "get-unsat-core", "get-value", "pop", "push", "reset", "reset-assertions", "set-info", "set-logic", "set-option"+                        --+                        -- The following are most likely Z3 specific+                        , "interval", "assert-soft"                         ]
Data/SBV/Tools/ExpectedValue.hs view
@@ -10,13 +10,19 @@ -----------------------------------------------------------------------------  {-# LANGUAGE PatternGuards #-}-module Data.SBV.Tools.ExpectedValue (expectedValue, expectedValueWith) where+module Data.SBV.Tools.ExpectedValue (+        -- * Computing expected values+        expectedValue+      , expectedValueWith+      )+      where  import Control.DeepSeq (rnf)+import Control.Monad   (unless) import System.Random   (newStdGen, StdGen) import Numeric -import Data.SBV.BitVectors.Data+import Data.SBV.Core.Data  -- | Generalized version of 'expectedValue', allowing the user to specify the -- warm-up count and the convergence factor. Maximum iteration count can also@@ -38,7 +44,8 @@                         let v' = zipWith (+) v t                         rnf v' `seq` warmup (n-1) v'         runOnce :: StdGen -> IO [Integer]-        runOnce g = do (_, Result _ _ _ _ cs _ _ _ _ _ cstrs _ os) <- runSymbolic' (Concrete g) (m >>= output)+        runOnce g = do (_, Result _ _ _ _ cs _ _ _ _ _ cstrs _ goals _ os) <- runSymbolic' (Concrete g) (m >>= output)+                       unless (null goals) $ error "SBV.expectedValue: Cannot compute expected-values in the presence of optimization goals!"                        let cval o = case o `lookup` cs of                                       Nothing -> error "SBV.expectedValue: Cannot compute expected-values in the presence of uninterpreted constants!"                                       Just cw -> case (kindOf cw, cwVal cw) of
Data/SBV/Tools/GenTest.hs view
@@ -9,7 +9,10 @@ -- Test generation from symbolic programs ----------------------------------------------------------------------------- -module Data.SBV.Tools.GenTest (genTest, TestVectors, getTestValues, renderTest, TestStyle(..)) where+module Data.SBV.Tools.GenTest (+        -- * Test case generation+        genTest, TestVectors, getTestValues, renderTest, TestStyle(..)+        ) where  import Data.Bits     (testBit) import Data.Char     (isAlpha, toUpper)@@ -18,10 +21,11 @@ import Data.Maybe    (fromMaybe) import System.Random -import Data.SBV.BitVectors.AlgReals-import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.PrettyNum+import Data.SBV.Core.AlgReals+import Data.SBV.Core.Data +import Data.SBV.Utils.PrettyNum+ -- | Type of test vectors (abstract) newtype TestVectors = TV [([CW], [CW])] @@ -42,7 +46,7 @@          | True   = do g <- newStdGen                        t <- tc g                        gen (i+1) (t:sofar)-        tc g = do (_, Result _ tvals _ _ cs _ _ _ _ _ cstrs _ os) <- runSymbolic' (Concrete g) (m >>= output)+        tc g = do (_, Result _ tvals _ _ cs _ _ _ _ _ cstrs _ _ _ os) <- runSymbolic' (Concrete g) (m >>= output)                   let cval = fromMaybe (error "Cannot generate tests in the presence of uninterpeted constants!") . (`lookup` cs)                       cond = all (cwToBool . cval) cstrs                   if cond
− Data/SBV/Tools/Optimize.hs 
@@ -1,108 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Tools.Optimize--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ SMT based optimization--------------------------------------------------------------------------------{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Data.SBV.Tools.Optimize (OptimizeOpts(..), optimize, optimizeWith, minimize, minimizeWith, maximize, maximizeWith) where--import Data.Maybe (fromJust)--import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.Model (OrdSymbolic(..), EqSymbolic(..))-import Data.SBV.Provers.Prover   (satWith, defaultSMTCfg)-import Data.SBV.SMT.SMT          (SatModel, getModel)-import Data.SBV.Utils.Boolean---- | Optimizer configuration. Note that iterative and quantified approaches are in general not interchangeable.--- For instance, iterative solutions will loop infinitely when there is no optimal value, but quantified solutions--- can handle such problems. Of course, quantified problems are harder for SMT solvers, naturally.-data OptimizeOpts = Iterative  Bool   -- ^ Iteratively search. if True, it will be reporting progress-                  | Quantified        -- ^ Use quantifiers---- | Symbolic optimization. Generalization on 'minimize' and 'maximize' that allows arbitrary--- cost functions and comparisons.-optimizeWith :: (SatModel a, SymWord a, Show a, SymWord c, Show c)-             => SMTConfig                         -- ^ SMT configuration-             -> OptimizeOpts                      -- ^ Optimization options-             -> (SBV c -> SBV c -> SBool)         -- ^ comparator-             -> ([SBV a] -> SBV c)                -- ^ cost function-             -> Int                               -- ^ how many elements?-             -> ([SBV a] -> SBool)                -- ^ validity constraint-             -> IO (Maybe [a])-optimizeWith cfg (Iterative chatty) = iterOptimize chatty cfg-optimizeWith cfg Quantified         = quantOptimize cfg---- | Variant of 'optimizeWith' using the default solver. See 'optimizeWith' for parameter descriptions.-optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => OptimizeOpts -> (SBV c -> SBV c -> SBool) -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])-optimize = optimizeWith defaultSMTCfg---- | Variant of 'maximize' allowing the use of a user specified solver. See 'optimizeWith' for parameter descriptions.-maximizeWith :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => SMTConfig -> OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])-maximizeWith cfg opts = optimizeWith cfg opts (.>=)---- | Maximizes a cost function with respect to a constraint. Examples:------   >>> maximize Quantified sum 3 (bAll (.< (10 :: SInteger)))---   Just [9,9,9]-maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])-maximize = maximizeWith defaultSMTCfg---- | Variant of 'minimize' allowing the use of a user specified solver. See 'optimizeWith' for parameter descriptions.-minimizeWith :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => SMTConfig -> OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])-minimizeWith cfg opts = optimizeWith cfg opts (.<=)---- | Minimizes a cost function with respect to a constraint. Examples:------   >>> minimize Quantified sum 3 (bAll (.> (10 :: SInteger)))---   Just [11,11,11]-minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])-minimize = minimizeWith defaultSMTCfg---- | Optimization using quantifiers-quantOptimize :: (SatModel a, SymWord a) => SMTConfig -> (SBV c -> SBV c -> SBool) -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])-quantOptimize cfg cmp cost n valid = do-           m <- satWith cfg $ do xs <- mkExistVars  n-                                 ys <- mkForallVars n-                                 return $ valid xs &&& (valid ys ==> cost xs `cmp` cost ys)-           case getModel m of-              Right (True, _)  -> error "SBV: Backend solver reported \"unknown\""-              Right (False, a) -> return $ Just a-              Left _           -> return Nothing---- | Optimization using iteration-iterOptimize :: (SatModel a, Show a, SymWord a, Show c, SymWord c) =>  Bool -> SMTConfig -> (SBV c -> SBV c -> SBool) -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])-iterOptimize chatty cfg cmp cost n valid = do-        msg "Trying to find a satisfying solution."-        m <- satWith cfg $ valid `fmap` mkExistVars n-        case getModel m of-          Left _ -> do msg "No satisfying solutions found."-                       return Nothing-          Right (True, _)  -> error "SBV: Backend solver reported \"unknown\""-          Right (False, a) -> do msg $ "First solution found: " ++ show a-                                 let c = cost (map literal a)-                                 msg $ "Initial value is    : " ++ show (fromJust (unliteral c))-                                 msg "Starting iterative search."-                                 go (1::Int) a c-  where msg m | chatty = putStrLn $ "*** " ++ m-              | True   = return ()-        go i curSol curCost = do-                msg $ "Round " ++ show i ++ " ****************************"-                m <- satWith cfg $ do xs <- mkExistVars n-                                      return $ let c = cost xs in valid xs &&& (c `cmp` curCost &&& c ./= curCost)-                case getModel m of-                  Left _ -> do msg "The current solution is optimal. Terminating search."-                               return $ Just curSol-                  Right (True, _)  -> error "SBV: Backend solver reported \"unknown\""-                  Right (False, a) -> do msg $ "Solution: " ++ show a-                                         let c = cost (map literal a)-                                         msg $ "Value   : " ++ show (fromJust (unliteral c))-                                         go (i+1) a c
Data/SBV/Tools/Polynomial.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Module      :  Data.SBV.BitVectors.Polynomials+-- Module      :  Data.SBV.Core.Polynomials -- Copyright   :  (c) Levent Erkok -- License     :  BSD3 -- Maintainer  :  erkokl@gmail.com@@ -14,16 +14,20 @@ {-# LANGUAGE PatternGuards        #-} {-# LANGUAGE TypeSynonymInstances #-} -module Data.SBV.Tools.Polynomial (Polynomial(..), crc, crcBV, ites, mdp, addPoly) where+module Data.SBV.Tools.Polynomial (+        -- * Polynomial arithmetic and CRCs+        Polynomial(..), crc, crcBV, ites, mdp, addPoly+        ) where  import Data.Bits  (Bits(..)) import Data.List  (genericTake) import Data.Maybe (fromJust, fromMaybe) import Data.Word  (Word8, Word16, Word32, Word64) -import Data.SBV.BitVectors.Data-import Data.SBV.BitVectors.Model-import Data.SBV.BitVectors.Splittable+import Data.SBV.Core.Data+import Data.SBV.Core.Model+import Data.SBV.Core.Splittable+ import Data.SBV.Utils.Boolean  -- | Implements polynomial addition, multiplication, division, and modulus operations
+ Data/SBV/Tools/STree.hs view
@@ -0,0 +1,75 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Tools.STree+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Implementation of full-binary symbolic trees, providing logarithmic+-- time access to elements. Both reads and writes are supported.+-----------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}++module Data.SBV.Tools.STree (STree, readSTree, writeSTree, mkSTree) where++import Data.Bits (Bits(..))++import Data.SBV.Core.Data+import Data.SBV.Core.Model++-- | A symbolic tree containing values of type e, indexed by+-- elements of type i. Note that these are full-trees, and their+-- their shapes remain constant. There is no API provided that+-- can change the shape of the tree. These structures are useful+-- when dealing with data-structures that are indexed with symbolic+-- values where access time is important. 'STree' structures provide+-- logarithmic time reads and writes.+type STree i e = STreeInternal (SBV i) (SBV e)++-- Internal representation, not exposed to the user+data STreeInternal i e = SLeaf e                        -- NB. parameter 'i' is phantom+                       | SBin  (STreeInternal i e) (STreeInternal i e)+                       deriving Show++instance (SymWord e, Mergeable (SBV e)) => Mergeable (STree i e) where+  symbolicMerge f b (SLeaf i)  (SLeaf j)    = SLeaf (symbolicMerge f b i j)+  symbolicMerge f b (SBin l r) (SBin l' r') = SBin  (symbolicMerge f b l l') (symbolicMerge f b r r')+  symbolicMerge _ _ _          _            = error "SBV.STree.symbolicMerge: Impossible happened while merging states"++-- | Reading a value. We bit-blast the index and descend down the full tree+-- according to bit-values.+readSTree :: (Num i, Bits i, SymWord i, SymWord e) => STree i e -> SBV i -> SBV e+readSTree s i = walk (blastBE i) s+  where walk []     (SLeaf v)  = v+        walk (b:bs) (SBin l r) = ite b (walk bs r) (walk bs l)+        walk _      _          = error $ "SBV.STree.readSTree: Impossible happened while reading: " ++ show i++-- | Writing a value, similar to how reads are done. The important thing is that the tree+-- representation keeps updates to a minimum.+writeSTree :: (Mergeable (SBV e), Num i, Bits i, SymWord i, SymWord e) => STree i e -> SBV i -> SBV e -> STree i e+writeSTree s i j = walk (blastBE i) s+  where walk []     _          = SLeaf j+        walk (b:bs) (SBin l r) = SBin (ite b l (walk bs l)) (ite b (walk bs r) r)+        walk _      _          = error $ "SBV.STree.writeSTree: Impossible happened while reading: " ++ show i++-- | Construct the fully balanced initial tree using the given values.+mkSTree :: forall i e. HasKind i => [SBV e] -> STree i e+mkSTree ivals+  | isReal (undefined :: i)+  = error "SBV.STree.mkSTree: Cannot build a real-valued sized tree"+  | not (isBounded (undefined :: i))+  = error "SBV.STree.mkSTree: Cannot build an infinitely large tree"+  | reqd /= given+  = error $ "SBV.STree.mkSTree: Required " ++ show reqd ++ " elements, received: " ++ show given+  | True+  = go ivals+  where reqd = 2 ^ intSizeOf (undefined :: i)+        given = length ivals+        go []  = error "SBV.STree.mkSTree: Impossible happened, ran out of elements"+        go [l] = SLeaf l+        go ns  = let (l, r) = splitAt (length ns `div` 2) ns in SBin (go l) (go r)
+ Data/SBV/Utils/PrettyNum.hs view
@@ -0,0 +1,296 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Utils.PrettyNum+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Number representations in hex/bin+-----------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Data.SBV.Utils.PrettyNum (+        PrettyNum(..), readBin, shex, shexI, sbin, sbinI+      , showCFloat, showCDouble, showHFloat, showHDouble+      , showSMTFloat, showSMTDouble, smtRoundingMode, cwToSMTLib, mkSkolemZero+      ) where++import Data.Char  (ord, intToDigit)+import Data.Int   (Int8, Int16, Int32, Int64)+import Data.List  (isPrefixOf)+import Data.Maybe (fromJust, fromMaybe, listToMaybe)+import Data.Ratio (numerator, denominator)+import Data.Word  (Word8, Word16, Word32, Word64)+import Numeric    (showIntAtBase, showHex, readInt)++import Data.Numbers.CrackNum (floatToFP, doubleToFP)++import Data.SBV.Core.Data+import Data.SBV.Core.AlgReals (algRealToSMTLib2)++-- | PrettyNum class captures printing of numbers in hex and binary formats; also supporting negative numbers.+--+-- Minimal complete definition: 'hexS' and 'binS'+class PrettyNum a where+  -- | Show a number in hexadecimal (starting with @0x@ and type.)+  hexS :: a -> String+  -- | Show a number in binary (starting with @0b@ and type.)+  binS :: a -> String+  -- | Show a number in hex, without prefix, or types.+  hex :: a -> String+  -- | Show a number in bin, without prefix, or types.+  bin :: a -> String++-- Why not default methods? Because defaults need "Integral a" but Bool is not..+instance PrettyNum Bool where+  {hexS = show; binS = show; hex = show; bin = show}+instance PrettyNum Word8 where+  {hexS = shex True True (False,8) ; binS = sbin True True (False,8) ; hex = shex False False (False,8) ; bin = sbin False False (False,8) ;}+instance PrettyNum Int8 where+  {hexS = shex True True (True,8)  ; binS = sbin True True (True,8)  ; hex = shex False False (True,8)  ; bin = sbin False False (True,8)  ;}+instance PrettyNum Word16 where+  {hexS = shex True True (False,16); binS = sbin True True (False,16); hex = shex False False (False,16); bin = sbin False False (False,16);}+instance PrettyNum Int16  where+  {hexS = shex True True (True,16);  binS = sbin True True (True,16) ; hex = shex False False (True,16);  bin = sbin False False (True,16) ;}+instance PrettyNum Word32 where+  {hexS = shex True True (False,32); binS = sbin True True (False,32); hex = shex False False (False,32); bin = sbin False False (False,32);}+instance PrettyNum Int32  where+  {hexS = shex True True (True,32);  binS = sbin True True (True,32) ; hex = shex False False (True,32);  bin = sbin False False (True,32) ;}+instance PrettyNum Word64 where+  {hexS = shex True True (False,64); binS = sbin True True (False,64); hex = shex False False (False,64); bin = sbin False False (False,64);}+instance PrettyNum Int64  where+  {hexS = shex True True (True,64);  binS = sbin True True (True,64) ; hex = shex False False (True,64);  bin = sbin False False (True,64) ;}+instance PrettyNum Integer where+  {hexS = shexI True True; binS = sbinI True True; hex = shexI False False; bin = sbinI False False;}++instance PrettyNum CW where+  hexS cw | isUninterpreted cw = show cw ++ " :: " ++ show (kindOf cw)+          | isBoolean cw       = hexS (cwToBool cw) ++ " :: Bool"+          | isFloat cw         = let CWFloat  f  = cwVal cw in show f ++ " :: Float\n"  ++ show (floatToFP f)+          | isDouble cw        = let CWDouble d  = cwVal cw in show d ++ " :: Double\n" ++ show (doubleToFP d)+          | isReal cw          = let CWAlgReal w = cwVal cw in show w ++ " :: Real"+          | not (isBounded cw) = let CWInteger w = cwVal cw in shexI True True w+          | True               = let CWInteger w = cwVal cw in shex  True True (hasSign cw, intSizeOf cw) w++  binS cw | isUninterpreted cw = show cw  ++ " :: " ++ show (kindOf cw)+          | isBoolean cw       = binS (cwToBool cw)  ++ " :: Bool"+          | isFloat cw         = let CWFloat  f  = cwVal cw in show f ++ " :: Float\n"  ++ show (floatToFP f)+          | isDouble cw        = let CWDouble d  = cwVal cw in show d ++ " :: Double\n" ++ show (doubleToFP d)+          | isReal cw          = let CWAlgReal w = cwVal cw in show w ++ " :: Real"+          | not (isBounded cw) = let CWInteger w = cwVal cw in sbinI True True w+          | True               = let CWInteger w = cwVal cw in sbin  True True (hasSign cw, intSizeOf cw) w++  hex cw | isUninterpreted cw = show cw+         | isBoolean cw       = hexS (cwToBool cw) ++ " :: Bool"+         | isFloat cw         = let CWFloat  f  = cwVal cw in show f+         | isDouble cw        = let CWDouble d  = cwVal cw in show d+         | isReal cw          = let CWAlgReal w = cwVal cw in show w+         | not (isBounded cw) = let CWInteger w = cwVal cw in shexI False False w+         | True               = let CWInteger w = cwVal cw in shex  False False (hasSign cw, intSizeOf cw) w++  bin cw | isUninterpreted cw = show cw+         | isBoolean cw       = binS (cwToBool cw) ++ " :: Bool"+         | isFloat cw         = let CWFloat  f  = cwVal cw in show f+         | isDouble cw        = let CWDouble d  = cwVal cw in show d+         | isReal cw          = let CWAlgReal w = cwVal cw in show w+         | not (isBounded cw) = let CWInteger w = cwVal cw in sbinI False False w+         | True               = let CWInteger w = cwVal cw in sbin  False False (hasSign cw, intSizeOf cw) w++instance (SymWord a, PrettyNum a) => PrettyNum (SBV a) where+  hexS s = maybe (show s) (hexS :: a -> String) $ unliteral s+  binS s = maybe (show s) (binS :: a -> String) $ unliteral s+  hex  s = maybe (show s) (hex  :: a -> String) $ unliteral s+  bin  s = maybe (show s) (bin  :: a -> String) $ unliteral s++-- | Show as a hexadecimal value. First bool controls whether type info is printed+-- while the second boolean controls wether 0x prefix is printed. The tuple is+-- the signedness and the bit-length of the input. The length of the string+-- will /not/ depend on the value, but rather the bit-length.+shex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String+shex shType shPre (signed, size) a+ | a < 0+ = "-" ++ pre ++ pad l (s16 (abs (fromIntegral a :: Integer)))  ++ t+ | True+ = pre ++ pad l (s16 a) ++ t+ where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size+         | True   = ""+       pre | shPre = "0x"+           | True  = ""+       l = (size + 3) `div` 4++-- | Show as a hexadecimal value, integer version. Almost the same as shex above+-- except we don't have a bit-length so the length of the string will depend+-- on the actual value.+shexI :: Bool -> Bool -> Integer -> String+shexI shType shPre a+ | a < 0+ = "-" ++ pre ++ s16 (abs a)  ++ t+ | True+ = pre ++ s16 a ++ t+ where t | shType = " :: Integer"+         | True   = ""+       pre | shPre = "0x"+           | True  = ""++-- | Similar to 'shex'; except in binary.+sbin :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String+sbin shType shPre (signed,size) a+ | a < 0+ = "-" ++ pre ++ pad size (s2 (abs (fromIntegral a :: Integer)))  ++ t+ | True+ = pre ++ pad size (s2 a) ++ t+ where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size+         | True   = ""+       pre | shPre = "0b"+           | True  = ""++-- | Similar to 'shexI'; except in binary.+sbinI :: Bool -> Bool -> Integer -> String+sbinI shType shPre a+ | a < 0+ = "-" ++ pre ++ s2 (abs a) ++ t+ | True+ =  pre ++ s2 a ++ t+ where t | shType = " :: Integer"+         | True   = ""+       pre | shPre = "0b"+           | True  = ""++-- | Pad a string to a given length. If the string is longer, then we don't drop anything.+pad :: Int -> String -> String+pad l s = replicate (l - length s) '0' ++ s++-- | Binary printer+s2 :: (Show a, Integral a) => a -> String+s2  v = showIntAtBase 2 dig v "" where dig = fromJust . flip lookup [(0, '0'), (1, '1')]++-- | Hex printer+s16 :: (Show a, Integral a) => a -> String+s16 v = showHex v ""++-- | A more convenient interface for reading binary numbers, also supports negative numbers+readBin :: Num a => String -> a+readBin ('-':s) = -(readBin s)+readBin s = case readInt 2 isDigit cvt s' of+              [(a, "")] -> a+              _         -> error $ "SBV.readBin: Cannot read a binary number from: " ++ show s+  where cvt c = ord c - ord '0'+        isDigit = (`elem` "01")+        s' | "0b" `isPrefixOf` s = drop 2 s+           | True                = s++-- | A version of show for floats that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included.+showCFloat :: Float -> String+showCFloat f+   | isNaN f             = "((float) NAN)"+   | isInfinite f, f < 0 = "((float) (-INFINITY))"+   | isInfinite f        = "((float) INFINITY)"+   | True                = show f ++ "F"++-- | A version of show for doubles that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included.+showCDouble :: Double -> String+showCDouble f+   | isNaN f             = "((double) NAN)"+   | isInfinite f, f < 0 = "((double) (-INFINITY))"+   | isInfinite f        = "((double) INFINITY)"+   | True                = show f++-- | A version of show for floats that generates correct Haskell literals for nan/infinite+showHFloat :: Float -> String+showHFloat f+   | isNaN f             = "((0/0) :: Float)"+   | isInfinite f, f < 0 = "((-1/0) :: Float)"+   | isInfinite f        = "((1/0) :: Float)"+   | True                = show f++-- | A version of show for doubles that generates correct Haskell literals for nan/infinite+showHDouble :: Double -> String+showHDouble d+   | isNaN d             = "((0/0) :: Double)"+   | isInfinite d, d < 0 = "((-1/0) :: Double)"+   | isInfinite d        = "((1/0) :: Double)"+   | True                = show d++-- | A version of show for floats that generates correct SMTLib literals using the rounding mode+showSMTFloat :: RoundingMode -> Float -> String+showSMTFloat rm f+   | isNaN f             = as "NaN"+   | isInfinite f, f < 0 = as "-oo"+   | isInfinite f        = as "+oo"+   | isNegativeZero f    = as "-zero"+   | f == 0              = as "+zero"+   | True                = "((_ to_fp 8 24) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational f) ++ ")"+   where as s = "(_ " ++ s ++ " 8 24)"++-- | A version of show for doubles that generates correct SMTLib literals using the rounding mode+showSMTDouble :: RoundingMode -> Double -> String+showSMTDouble rm d+   | isNaN d             = as "NaN"+   | isInfinite d, d < 0 = as "-oo"+   | isInfinite d        = as "+oo"+   | isNegativeZero d    = as "-zero"+   | d == 0              = as "+zero"+   | True                = "((_ to_fp 11 53) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational d) ++ ")"+   where as s = "(_ " ++ s ++ " 11 53)"++-- | Show a rational in SMTLib format+toSMTLibRational :: Rational -> String+toSMTLibRational r+   | n < 0+   = "(- (/ "  ++ show (abs n) ++ " " ++ show d ++ "))"+   | True+   = "(/ " ++ show n ++ " " ++ show d ++ ")"+  where n = numerator r+        d = denominator r++-- | Convert a rounding mode to the format SMT-Lib2 understands.+smtRoundingMode :: RoundingMode -> String+smtRoundingMode RoundNearestTiesToEven = "roundNearestTiesToEven"+smtRoundingMode RoundNearestTiesToAway = "roundNearestTiesToAway"+smtRoundingMode RoundTowardPositive    = "roundTowardPositive"+smtRoundingMode RoundTowardNegative    = "roundTowardNegative"+smtRoundingMode RoundTowardZero        = "roundTowardZero"++-- | Convert a CW to an SMTLib2 compliant value+cwToSMTLib :: RoundingMode -> CW -> String+cwToSMTLib rm x+  | isBoolean       x, CWInteger  w      <- cwVal x = if w == 0 then "false" else "true"+  | isUninterpreted x, CWUserSort (_, s) <- cwVal x = roundModeConvert s+  | isReal          x, CWAlgReal  r      <- cwVal x = algRealToSMTLib2 r+  | isFloat         x, CWFloat    f      <- cwVal x = showSMTFloat  rm f+  | isDouble        x, CWDouble   d      <- cwVal x = showSMTDouble rm d+  | not (isBounded x), CWInteger  w      <- cwVal x = if w >= 0 then show w else "(- " ++ show (abs w) ++ ")"+  | not (hasSign x)  , CWInteger  w      <- cwVal x = smtLibHex (intSizeOf x) w+  -- signed numbers (with 2's complement representation) is problematic+  -- since there's no way to put a bvneg over a positive number to get minBound..+  -- Hence, we punt and use binary notation in that particular case+  | hasSign x        , CWInteger  w      <- cwVal x = if w == negate (2 ^ intSizeOf x)+                                                      then mkMinBound (intSizeOf x)+                                                      else negIf (w < 0) $ smtLibHex (intSizeOf x) (abs w)+  | True = error $ "SBV.cvtCW: Impossible happened: Kind/Value disagreement on: " ++ show (kindOf x, x)+  where roundModeConvert s = fromMaybe s (listToMaybe [smtRoundingMode m | m <- [minBound .. maxBound] :: [RoundingMode], show m == s])+        -- Carefully code hex numbers, SMTLib is picky about lengths of hex constants. For the time+        -- being, SBV only supports sizes that are multiples of 4, but the below code is more robust+        -- in case of future extensions to support arbitrary sizes.+        smtLibHex :: Int -> Integer -> String+        smtLibHex 1  v = "#b" ++ show v+        smtLibHex sz v+          | sz `mod` 4 == 0 = "#x" ++ pad (sz `div` 4) (showHex v "")+          | True            = "#b" ++ pad sz (showBin v "")+           where showBin = showIntAtBase 2 intToDigit+        negIf :: Bool -> String -> String+        negIf True  a = "(bvneg " ++ a ++ ")"+        negIf False a = a+        -- anamoly at the 2's complement min value! Have to use binary notation here+        -- as there is no positive value we can provide to make the bvneg work.. (see above)+        mkMinBound :: Int -> String+        mkMinBound i = "#b1" ++ replicate (i-1) '0'++-- | Create a skolem 0 for the kind+mkSkolemZero :: RoundingMode -> Kind -> String+mkSkolemZero _ (KUserSort _ (Right (f:_))) = f+mkSkolemZero _ (KUserSort s _)             = error $ "SBV.mkSkolemZero: Unexpected uninterpreted sort: " ++ s+mkSkolemZero rm k                          = cwToSMTLib rm (mkConstCW k (0::Integer))
SBVUnitTest/Examples/CRC/CCITT.hs view
@@ -12,6 +12,7 @@ module Examples.CRC.CCITT where  import Data.SBV+import Data.SBV.Tools.Polynomial  -- We don't have native support for 48 bits in Data.SBV -- So, represent as 32 high-bits and 16 low
SBVUnitTest/Examples/CRC/CCITT_Unidir.hs view
@@ -13,6 +13,7 @@ module Examples.CRC.CCITT_Unidir where  import Data.SBV+import Data.SBV.Tools.Polynomial  -- We don't have native support for 48 bits in Data.SBV -- So, represent as 32 high-bits and 16 low
SBVUnitTest/Examples/CRC/GenPoly.hs view
@@ -12,6 +12,7 @@ module Examples.CRC.GenPoly where  import Data.SBV+import Data.SBV.Tools.Polynomial  -- We don't have native support for 48 bits in Data.SBV -- So, represent as 32 high-bits and 16 low
SBVUnitTest/Examples/CRC/USB5.hs view
@@ -12,6 +12,7 @@ module Examples.CRC.USB5 where  import Data.SBV+import Data.SBV.Tools.Polynomial  newtype SWord11 = S11 SWord16
SBVUnitTest/GoldFiles/auf-1.gold view
@@ -14,6 +14,8 @@   [uninterpreted] f :: SWord32 -> SWord64 USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s4 :: SWord32 = s0 + s3   s5 :: SBool = s1 == s4
SBVUnitTest/GoldFiles/basic-2_1.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 + s1   s3 :: SWord8 = s1 - s0
SBVUnitTest/GoldFiles/basic-2_2.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 * s0   s3 :: SWord8 = s1 - s2
SBVUnitTest/GoldFiles/basic-2_3.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 + s1   s3 :: SWord8 = s2 * s2
SBVUnitTest/GoldFiles/basic-2_4.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 + s1   s3 :: SWord8 = s2 * s2
SBVUnitTest/GoldFiles/basic-3_1.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 + s1   s3 :: SWord8 = s0 - s1
SBVUnitTest/GoldFiles/basic-3_2.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 * s0   s3 :: SWord8 = s1 * s1
SBVUnitTest/GoldFiles/basic-3_3.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 + s1   s3 :: SWord8 = s2 * s2
SBVUnitTest/GoldFiles/basic-3_4.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 + s1   s3 :: SWord8 = s2 * s2
SBVUnitTest/GoldFiles/basic-3_5.gold view
@@ -10,6 +10,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s3 :: SWord8 = s0 + s2 CONSTRAINTS
SBVUnitTest/GoldFiles/basic-4_1.gold view
@@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s1 :: SWord8 = s0 + s0   s2 :: SWord8 = s0 - s0
SBVUnitTest/GoldFiles/basic-4_2.gold view
@@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s1 :: SWord8 = s0 * s0   s2 :: SWord8 = s1 - s1
SBVUnitTest/GoldFiles/basic-4_3.gold view
@@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s1 :: SWord8 = s0 + s0   s2 :: SWord8 = s1 * s1
SBVUnitTest/GoldFiles/basic-4_4.gold view
@@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s1 :: SWord8 = s0 + s0   s2 :: SWord8 = s1 * s1
SBVUnitTest/GoldFiles/basic-4_5.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 + s1 CONSTRAINTS
SBVUnitTest/GoldFiles/basic-5_1.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 + s0   s3 :: SWord8 = s0 - s0
SBVUnitTest/GoldFiles/basic-5_2.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 * s0   s3 :: SWord8 = s2 - s2
SBVUnitTest/GoldFiles/basic-5_3.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 + s0   s3 :: SWord8 = s2 * s2
SBVUnitTest/GoldFiles/basic-5_4.gold view
@@ -9,6 +9,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SWord8 = s0 + s0   s3 :: SWord8 = s2 * s2
SBVUnitTest/GoldFiles/basic-5_5.gold view
@@ -10,6 +10,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s3 :: SWord8 = s0 + s2 CONSTRAINTS
SBVUnitTest/GoldFiles/ccitt.gold view
@@ -81,6 +81,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s4 :: SBool = s0 == s2   s5 :: SBool = s1 == s3
SBVUnitTest/GoldFiles/coins.gold view
@@ -22,6 +22,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s2 :: SBool = s0 == s1   s4 :: SBool = s0 == s3
SBVUnitTest/GoldFiles/counts.gold view
@@ -29,6 +29,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s11 :: SBool = s9 < s10   s13 :: SBool = s9 == s12
SBVUnitTest/GoldFiles/crcPolyExist.gold view
@@ -16,6 +16,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s5 :: SWord1 = choose [0:0] s0   s7 :: SBool = s5 /= s6
SBVUnitTest/GoldFiles/iteTest1.gold view
@@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE CONSTRAINTS ASSERTIONS
SBVUnitTest/GoldFiles/iteTest2.gold view
@@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE CONSTRAINTS ASSERTIONS
SBVUnitTest/GoldFiles/iteTest3.gold view
@@ -8,6 +8,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE CONSTRAINTS ASSERTIONS
SBVUnitTest/GoldFiles/legato.gold view
@@ -22,6 +22,8 @@ UNINTERPRETED CONSTANTS USER GIVEN CODE SEGMENTS AXIOMS+TACTICS+GOALS DEFINE   s10 :: SBool = s0 /= s2   s11 :: SBool = s0 /= s4
SBVUnitTest/SBVBasicTests.hs view
@@ -27,13 +27,12 @@ import Paths_sbv        (getDataDir, version)  import SBVTestCollection    (allTestCases)-import SBVUnitTestBuildTime (buildTime)  testCollection :: [(String, SBVTestSuite)] testCollection = [(n, s) | (n, False, s) <- allTestCases]  main :: IO ()-main = do putStrLn $ "*** SBVBasicTester, version: " ++ showVersion version ++ ", time stamp: " ++ buildTime+main = do putStrLn $ "*** SBVBasicTester, version: " ++ showVersion version           d <- getDataDir            run $ d </> "SBVUnitTest" </> "GoldFiles"
SBVUnitTest/SBVUnitTest.hs view
@@ -24,11 +24,10 @@ import SBVTest              (SBVTestSuite(..), generateGoldCheck) import Paths_sbv            (getDataDir, version) -import SBVUnitTestBuildTime (buildTime) import SBVTestCollection    (allTestCases)  main :: IO ()-main = do putStrLn $ "*** SBVUnitTester, version: " ++ showVersion version ++ ", time stamp: " ++ buildTime+main = do putStrLn $ "*** SBVUnitTester, version: " ++ showVersion version           tgts <- getArgs           case tgts of             [x] | x `elem` ["-h", "--help", "-?"]
− SBVUnitTest/SBVUnitTestBuildTime.hs 
@@ -1,5 +0,0 @@--- Auto-generated, don't edit-module SBVUnitTestBuildTime (buildTime) where--buildTime :: String-buildTime = "Mon Jan 30 16:59:33 PST 2017"
SBVUnitTest/TestSuite/Basics/ArithSolver.hs view
@@ -12,7 +12,6 @@ -----------------------------------------------------------------------------  {-# LANGUAGE Rank2Types    #-}-{-# LANGUAGE TupleSections #-}  module TestSuite.Basics.ArithSolver(testSuite) where
SBVUnitTest/TestSuite/Crypto/RC4.hs view
@@ -12,6 +12,7 @@ module TestSuite.Crypto.RC4(testSuite) where  import Data.SBV+import Data.SBV.Tools.STree import Data.SBV.Examples.Crypto.RC4  import SBVTest
sbv.cabal view
@@ -1,5 +1,5 @@ Name:          sbv-Version:       5.15+Version:       6.0 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@@ -61,6 +61,10 @@                   , Data.SBV.Bridge.ABC                   , Data.SBV.Dynamic                   , Data.SBV.Internals+                  , Data.SBV.Tools.ExpectedValue+                  , Data.SBV.Tools.GenTest+                  , Data.SBV.Tools.Polynomial+                  , Data.SBV.Tools.STree                   , Data.SBV.Examples.BitPrecise.BitTricks                   , Data.SBV.Examples.BitPrecise.Legato                   , Data.SBV.Examples.BitPrecise.MergeSort@@ -83,6 +87,9 @@                   , Data.SBV.Examples.Misc.NoDiv0                   , Data.SBV.Examples.Misc.Word4                   , Data.SBV.Examples.Polynomials.Polynomials+                  , Data.SBV.Examples.Optimization.LinearOpt+                  , Data.SBV.Examples.Optimization.Production+                  , Data.SBV.Examples.Optimization.VM                   , Data.SBV.Examples.Puzzles.Birthday                   , Data.SBV.Examples.Puzzles.Coins                   , Data.SBV.Examples.Puzzles.Counts@@ -100,17 +107,15 @@                   , Data.SBV.Examples.Uninterpreted.Shannon                   , Data.SBV.Examples.Uninterpreted.Sort                   , Data.SBV.Examples.Uninterpreted.UISortAllSat-  Other-modules   : Data.SBV.BitVectors.AlgReals-                  , Data.SBV.BitVectors.Concrete-                  , Data.SBV.BitVectors.Data-                  , Data.SBV.BitVectors.Kind-                  , Data.SBV.BitVectors.Model-                  , Data.SBV.BitVectors.Operations-                  , Data.SBV.BitVectors.PrettyNum-                  , Data.SBV.BitVectors.Floating-                  , Data.SBV.BitVectors.Splittable-                  , Data.SBV.BitVectors.STree-                  , Data.SBV.BitVectors.Symbolic+  Other-modules   : Data.SBV.Core.AlgReals+                  , Data.SBV.Core.Concrete+                  , Data.SBV.Core.Data+                  , Data.SBV.Core.Kind+                  , Data.SBV.Core.Model+                  , Data.SBV.Core.Operations+                  , Data.SBV.Core.Floating+                  , Data.SBV.Core.Splittable+                  , Data.SBV.Core.Symbolic                   , Data.SBV.Compilers.C                   , Data.SBV.Compilers.CodeGen                   , Data.SBV.SMT.SMT@@ -125,14 +130,11 @@                   , Data.SBV.Provers.Z3                   , Data.SBV.Provers.MathSAT                   , Data.SBV.Provers.ABC-                  , Data.SBV.Tools.ExpectedValue-                  , Data.SBV.Tools.GenTest-                  , Data.SBV.Tools.Optimize-                  , Data.SBV.Tools.Polynomial                   , Data.SBV.Utils.Boolean                   , Data.SBV.Utils.Numeric                   , Data.SBV.Utils.TDiff                   , Data.SBV.Utils.Lib+                  , Data.SBV.Utils.PrettyNum                   , GHC.SrcLoc.Compat                   , GHC.Stack.Compat @@ -148,8 +150,7 @@                 , HUnit, directory, filepath, process, syb, sbv, data-binary-ieee754   Hs-Source-Dirs  : SBVUnitTest   main-is         : SBVUnitTest.hs-  Other-modules   : SBVUnitTestBuildTime-                  , SBVTest+  Other-modules   : SBVTest                   , SBVTestCollection                   , Examples.Arrays.Memory                   , Examples.Basics.BasicTests