packages feed

sbv 7.6 → 7.7

raw patch · 206 files changed

+11558/−6173 lines, 206 filesdep +tasty-quickcheck

Dependencies added: tasty-quickcheck

Files

CHANGES.md view
@@ -1,8 +1,64 @@ * Hackage: <http://hackage.haskell.org/package/sbv> * GitHub:  <http://leventerkok.github.com/sbv/> -* Latest Hackage released version: 7.6, 2018-03-18+* Latest Hackage released version: 7.7, 2018-04-29 +### Version 7.7, Released 2018-04-29++  * Add support for Symbolic characters ('SChar') and strings ('SString'.)+    Thanks to Joel Burget for the initial implementation.+    +    The 'SChar' type currently corresponds to the Latin-1 character+    set, and is thus a subset of the Haskell 'Char' type. This is+    due to the current limitations in SMT-solvers. However, there+    is a pending SMTLib proposal to support unicode, and SBV will track+    these changes to have full unicode support: For further details+    see: http://smtlib.cs.uiowa.edu/theories-UnicodeStrings.shtml++    The 'SString' type is the type of symbolic strings, consisting+    of characters from the Latin-1 character set currently, just+    like the planned 'SChar' improvements. Note that an 'SString'+    is *not* simply a list of 'SChar' values: It is a symbolic+    type of its own and is processed as a single item. Conversions+    from list of characters is possible (via the 'implode' function).+    In the other direction, one cannot generally 'explode' a string,+    since it may be of arbitrary length and thus we would not know+    what concrete list to map it to. This is a bit unlike Haskell,+    but the differences dissipate quickly in general, and the power+    of being able to deal with a string as a symbolic entity on its+    own opens up many verification possibilities.++    Note that currently only Z3 and CVC4 has support for this logic,+    and they do differ in some details. Various character/string+    operations are supported, including length, concatenation,+    regular-expression matching, substrig operations, recognizers, etc.+    If you use this logic, you are likely to find bugs in solvers themselves+    as support is rather new: Please report.++  * If unsat-core extraction is enabled, SBV now returns the unsat-core+    directly with in a solver result. Thanks to Ara Adkins for the+    suggestion.++  * Add 'observe'. This function allows internal expressions to be+    given values, which will be part of the satisfyin model or+    the counter-example upon model construction. Useful for tracking+    expected/returned values. Also works with quickCheck.++  * Revamp Haddock documentation, hopefully easier to follow now.++  * Slightly modify the generated-C headers by removing whitespace.+    This allows for certain "lint" rules to pass when SBV generated+    code is used in conjunction with a larger code base. Thanks+    to Greg Horn for the pull request.++  * Improve implementation of 'svExp' to match that of '.^', making+    it more defined when the exponent is constant. Thanks to Brian+    Huffman for the patch.++  * Export the underlying polynomial representation for algorithmic+    reals from the Internals module for further user processing.+    Thanks  to Jan Path for the patch.+ ### Version 7.6, Released 2018-03-18    * GHC 8.4.1 compatibility: Work around compilation issues. SBV@@ -18,7 +74,7 @@   * Remove obsolote references to tactics in a few haddock comments. Thanks     to Matthew Pickering for reporting. -  * Added logic 'Logic_NONE', to be used in cases where SBV should not+  * Added logic Logic_NONE, to be used in cases where SBV should not     try to set the logic. This is useful when there is no viable value to     set, and the back-end solver doesn't understand the SMT-Lib convention     of using "ALL" as the logic name. (One example of this is the Yices
Data/SBV.hs view
@@ -48,6 +48,8 @@ -- --   * 'SDouble': IEEE-754 double-precision floating point values --+--   * 'SString', 'RegExp': Strings and regular expressions+-- --   * 'SArray', 'SFunArray': Flat arrays of symbolic values. -- --   * Symbolic polynomials over GF(2^n), polynomial arithmetic, and CRCs.@@ -59,7 +61,7 @@ -- -- The user can construct ordinary Haskell programs using these types, which behave -- very similar to their concrete counterparts. In particular these types belong to the--- standard classes 'Num', 'Bits', custom versions of 'Eq' ('EqSymbolic') +-- standard classes 'Num', 'Bits', custom versions of 'Eq' ('EqSymbolic') -- and 'Ord' ('OrdSymbolic'), along with several other custom classes for simplifying -- programming with symbolic values. The framework takes full advantage of Haskell's type -- inference to avoid many common mistakes.@@ -116,105 +118,128 @@ {-# OPTIONS_GHC -fno-warn-orphans  #-}  module Data.SBV (-  -- * Programming with symbolic values   -- $progIntro -  -- ** Symbolic types+  -- * Symbolic types -  -- *** Symbolic bit-    SBool-  -- *** Unsigned symbolic bit-vectors+  -- ** Booleans+    SBool, oneIf+  -- *** The Boolean class+  , Boolean(..)+  -- *** Logical operations+  , bAnd, bOr, bAny, bAll+  -- ** Bit-vectors+  -- *** Unsigned bit-vectors   , SWord8, SWord16, SWord32, SWord64-  -- *** Signed symbolic bit-vectors+  -- *** Signed bit-vectors   , SInt8, SInt16, SInt32, SInt64-  -- *** Signed unbounded integers+  -- ** Unbounded integers   -- $unboundedLimitations   , SInteger-  -- *** Floating point numbers+  -- ** Floating point numbers   -- $floatingPoints   , SFloat, SDouble-  -- *** Signed algebraic reals+  -- ** Algebraic reals   -- $algReals   , SReal, AlgReal, sRealToSInteger+  -- ** Strings and Regular Expressions+  -- $strings+  , SString, SChar, (.++), (.!!)+  -- * Arrays of symbolic values+  , SymArray(..), SArray, SFunArray, mkSFunArray -  -- ** Creating a symbolic variable+  -- * Creating symbolic values+  -- ** Single value   -- $createSym-  , sBool, sWord8, sWord16, sWord32, sWord64, sInt8, sInt16, sInt32, sInt64, sInteger, sReal, sFloat, sDouble+  , sBool, sWord8, sWord16, sWord32, sWord64, sInt8, sInt16, sInt32, sInt64, sInteger, sReal, sFloat, sDouble, sChar, sString -  -- ** Creating a list of symbolic variables+  -- ** List of values   -- $createSyms-  , sBools, sWord8s, sWord16s, sWord32s, sWord64s, sInt8s, sInt16s, sInt32s, sInt64s, sIntegers, sReals, sFloats, sDoubles--  -- *** Abstract SBV type-  , SBV, HasKind(..), Kind(..)-  -- *** Arrays of symbolic values-  , SymArray(..), SArray, SFunArray, mkSFunArray--  -- ** Operations on symbolic values-  -- *** Word level-  , sShiftLeft, sShiftRight, sRotateLeft, sRotateRight, sSignedShiftArithRight, sFromIntegral, oneIf-  , label--  -- *** Exponentiation-  , (.^)-  -- *** Splitting, joining, and extending-  , Splittable(..)+  , sBools, sWord8s, sWord16s, sWord32s, sWord64s, sInt8s, sInt16s, sInt32s, sInt64s, sIntegers, sReals, sFloats, sDoubles, sChars, sStrings -  -- ** Conditionals: Mergeable values+  -- * Symbolic Equality and Comparisons+  , EqSymbolic(..), OrdSymbolic(..), Equality(..)+  -- * Conditionals: Mergeable values   , Mergeable(..), ite, iteLazy -  -- ** Symbolic integral numbers+  -- * Symbolic integral numbers   , SIntegral-  -- ** Symbolic finite bits-  , SFiniteBits(..)-  -- ** Division+  -- * Division and Modulus   , SDivisible(..)-  -- ** The Boolean class-  , Boolean(..)-  -- *** Generalizations of boolean operations-  , bAnd, bOr, bAny, bAll+  -- * Bit-vector operations+  -- ** Conversions+  , sFromIntegral+  -- ** Shifts and rotates+  -- $shiftRotate+  , sShiftLeft, sShiftRight, sRotateLeft, sRotateRight, sSignedShiftArithRight+  -- ** Finite bit-vector operations+  , SFiniteBits(..)+  -- ** Splitting, joining, and extending+  , Splittable(..)+  -- ** Exponentiation+  , (.^)+  -- * IEEE-floating point numbers+  , IEEEFloating(..), RoundingMode(..), SRoundingMode, nan, infinity, sNaN, sInfinity+  -- ** Rounding modes+  , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero, sRNE, sRNA, sRTP, sRTN, sRTZ+  -- ** Conversion to/from floats+  , IEEEFloatConvertable(..)+  -- ** Bit-pattern conversions+  , sFloatAsSWord32, sWord32AsSFloat, sDoubleAsSWord64, sWord64AsSDouble, blastSFloat, blastSDouble +  -- * Enumerations+  -- $enumerations+  , mkSymbolicEnumeration+   -- * Uninterpreted sorts, constants, and functions   -- $uninterpreted   , Uninterpreted(..), addAxiom -  -- * Symbolic Equality and Comparisons-  , EqSymbolic(..), OrdSymbolic(..), Equality(..)-+  -- * Properties, proofs, and satisfiability+  -- $proveIntro+  -- $noteOnNestedQuantifiers+  -- $multiIntro+  , Predicate, Goal, Provable(..), solve   -- * Constraints   -- $constrainIntro-  , constrain, namedConstraint+  -- ** General constraints+  -- $generalConstraints+  , constrain++  -- ** Constraint Vacuity+  -- $constraintVacuity++  -- ** Named constraints+  -- $namedConstraints+  , namedConstraint++  -- ** Unsat cores+  -- $unsatCores+   -- ** Cardinality constraints   -- $cardIntro   , pbAtMost, pbAtLeast, pbExactly, pbLe, pbGe, pbEq, pbMutexed, pbStronglyMutexed -  -- * Enumerations-  -- $enumerations-  , mkSymbolicEnumeration--  -- * Properties, proofs, satisfiability, and safety-  -- $proveIntro-  -- $noteOnNestedQuantifiers-  -- $multiIntro-  , Predicate, Goal, Provable(..)-  -- ** Checking safety+  -- * Checking safety   -- $safeIntro   , sAssert, isSafe, SExecutable(..)-  -- ** Satisfying a sequence of boolean conditions-  , solve -  -- ** Quick-checking+  -- * Quick-checking   , sbvQuickCheck -  -- * Running a symbolic computation-  , runSMT, runSMTWith--  -- * Solver exceptions-  , SMTException(..)-   -- * Optimization   -- $optiIntro-  , OptimizeStyle(..), Penalty(..), Objective(..), minimize, maximize, assertSoft++  -- ** Multiple optimization goals+  -- $multiOpt+  , OptimizeStyle(..)+  -- ** Objectives+  , Objective(..), Metric(..)+  -- ** Soft assumptions+  -- $softAssertions+  , assertSoft , Penalty(..)+  -- ** Field extensions+  -- | If an optimization results in an infinity/epsilon value, the returned `CW` value will be in the corresponding extension field.   , ExtCW(..), GeneralizedCW(..)    -- * Model extraction@@ -224,25 +249,31 @@   -- $resultTypes   , ThmResult(..), SatResult(..), AllSatResult(..), SafeResult(..), OptimizeResult(..), SMTResult(..) -  -- * IEEE-floating point numbers-  , IEEEFloating(..), IEEEFloatConvertable(..), RoundingMode(..), SRoundingMode, nan, infinity, sNaN, sInfinity-  -- ** Rounding modes-  , sRoundNearestTiesToEven, sRoundNearestTiesToAway, sRoundTowardPositive, sRoundTowardNegative, sRoundTowardZero, sRNE, sRNA, sRTP, sRTN, sRTZ-  -- ** Bit-pattern conversions-  , sFloatAsSWord32, sWord32AsSFloat, sDoubleAsSWord64, sWord64AsSDouble, blastSFloat, blastSDouble+  -- ** Observing expressions+  -- $observeInternal+  , observe    -- ** Programmable model extraction   -- $programmableExtraction   , SatModel(..), Modelable(..), displayModels, extractModels   , getModelDictionaries, getModelValues, getModelUninterpretedValues -  -- * SMT Interface: Configurations and solvers+  -- * SMT Interface   , SMTConfig(..), Timing(..), SMTLibVersion(..), Solver(..), SMTSolver(..)-  , boolector, cvc4, yices, z3, mathSAT, abc, defaultSolverConfig, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers+  -- ** Controlling verbosity+  -- $verbosity++  -- ** Solvers+  , boolector, cvc4, yices, z3, mathSAT, abc+  -- ** Configurations+  , defaultSolverConfig, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers   , setLogic, setOption, setInfo, setTimeOut+  -- ** Solver exceptions+  , SMTException(..) -  -- * Symbolic computations-  , Symbolic, output, SymWord(..)+  -- * Abstract SBV type+  , SBV, HasKind(..), Kind(..), SymWord(..)+  , Symbolic, label, output, runSMT, runSMTWith    -- * Module exports   -- $moduleExportIntro@@ -262,6 +293,7 @@ import Data.SBV.Core.Model import Data.SBV.Core.Floating import Data.SBV.Core.Splittable+import Data.SBV.String ((.++), (.!!))  import Data.SBV.Provers.Prover @@ -404,11 +436,9 @@ Haskell programs, not AST's built out of pieces of syntax.) This provides for an integrated feel of the system, one of the original design goals for SBV. -= Incremental mode: Queries--SBV provides a wide variety of ways to utilize SMT-solvers, without requiring the user to+Incremental query mode: SBV provides a wide variety of ways to utilize SMT-solvers, without requiring the user to deal with the solvers themselves. While this mode is convenient, advanced users might need-access to the underlying solver, using the SMTLib language. For such use cases, SBV allows+access to the underlying solver at a lower level. For such use cases, SBV allows users to have an interactive session: The user can issue commands to the solver, inspect the values/results, and formulate new constraints. This advanced feature is available through the "Data.SBV.Control" module, where most SMTLib features are made available via a typed-API.@@ -424,12 +454,13 @@ -}  {- $multiIntro+=== Using multiple solvers On a multi-core machine, it might be desirable to try a given property using multiple SMT solvers, using parallel threads. Even with machines with single-cores, threading can be helpful if you want to try out multiple-solvers but do not know which one would work the best for the problem at hand ahead of time. -The functions in this section allow proving/satisfiability-checking with multiple+SBV allows proving/satisfiability-checking with multiple backends at the same time. Each function comes in two variants, one that returns the results from all solvers, the other that returns the fastest one. @@ -483,7 +514,7 @@ If required, the user can pass a 'CallStack' through the first argument to 'sAssert', which will be used by SBV to print a diagnostic info to pinpoint the failure. -Also see "Data.SBV.Examples.Misc.NoDiv0" for the classic div-by-zero example.+Also see "Documentation.SBV.Examples.Misc.NoDiv0" for the classic div-by-zero example. -}  @@ -502,7 +533,7 @@   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). -  For instance, a call of the form +  For instance, a call of the form         @ 'minimize' "name-of-goal" $ x + 2*y @ @@ -539,8 +570,15 @@   As usual, the programmatic API can be used to extract the values of objectives and model-values ('getModelObjectives',   'getModelAssignment', etc.) to access these values and program with them further. -== Multiple optimization goals+  The following examples illustrate the use of basic optimization routines: +     * "Documentation.SBV.Examples.Optimization.LinearOpt": Simple linear-optimization example.+     * "Documentation.SBV.Examples.Optimization.Production": Scheduling machines in a shop+     * "Documentation.SBV.Examples.Optimization.VM": Scheduling virtual-machines in a data-center+-}++{- $multiOpt+   Multiple goals can be specified, using the same syntax. In this case, the user gets to pick what style of   optimization to perform, by passing the relevant 'OptimizeStyle' as the first argument to 'optimize'. @@ -558,8 +596,9 @@       in number, so if 'Nothing' is used, there is a potential for infinitely waiting for the SBV-solver interaction       to finish. (If you suspect this might be the case, run in 'verbose' mode to see the interaction and       put a limiting factor appropriately.)+-} -== Soft Assertions+{- $softAssertions    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*.@@ -588,13 +627,6 @@   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@@ -669,6 +701,21 @@ by Rummer and Wahl: <http://www.philipp.ruemmer.org/publications/smt-fpa.pdf>. -} +{- $strings+Support for strings (intial version contributed by Joel Burget) adds support for QF_S logic,+described here: <https://rise4fun.com/z3/tutorialcontent/sequences>. Note that this logic+is still not part of official SMTLib (as of March 2018), so it should be considered+experimental.++See "Data.SBV.Char", "Data.SBV.String", "Data.SBV.RegExp" for further related functions.+-}++{- $shiftRotate+Symbolic words (both signed and unsigned) are an instance of Haskell's 'Bits' class, so regular+bitwise operations are automatically available for them. Shifts and rotates, however, require+specialized type-signatures since Haskell insists on an 'Int' second argument for them.+-}+ {- $constrainIntro A constraint is a means for restricting the input domain of a formula. Here's a simple example:@@ -709,7 +756,9 @@   * In a 'genTest' call: Similar to 'quickCheck' and 'prove': If a constraint     does not hold, the input value is ignored and is not included in the test     set.+-} +{- $generalConstraints A good use case (in fact the motivating use case) for 'constrain' is attaching a constraint to a 'forall' or 'exists' variable at the time of its creation. Also, the conjunctive semantics for 'sat' and the implicative@@ -732,22 +781,9 @@ Also note that this semantics imply that test case generation ('genTest') and quick-check can take arbitrarily long in the presence of constraints, if the random input values generated rarely satisfy the constraints. (As an extreme case, consider @'constrain' 'false'@.)--=== Named constraints and unsat cores--Constraints can be given names:--  @ 'namedConstraint' "a is at least 5" $ a .>= 5@--Such constraints are useful when used in conjunction with 'getUnsatCore' function-where the backend solver can be queried to obtain an unsat core in case the constraints are unsatisfiable.-This feature is enabled by the following option:--   @ setOption $ ProduceUnsatCores True @--See "Data.SBV.Examples.Misc.UnsatCore" for an example use case.+-} -=== Constraint vacuity+{- $constraintVacuity  When adding constraints, one has to be careful about making sure they are not inconsistent. The function 'isVacuous' can be use for this purpose.@@ -782,14 +818,25 @@       >>> isVacuous pred'      False+-} -=== Checking for vacuity+{- $namedConstraints -As we discussed 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.+Constraints can be given names:++  @ 'namedConstraint' "a is at least 5" $ a .>= 5@ -} +{- $unsatCores+Named constraints are useful when used in conjunction with 'getUnsatCore' function+where the backend solver can be queried to obtain an unsat core in case the constraints are unsatisfiable.+This feature is enabled by the following option:++   @ setOption $ ProduceUnsatCores True @++See "Documentation.SBV.Examples.Misc.UnsatCore" for an example use case.+-}+ {- $uninterpreted Users can introduce new uninterpreted sorts simply by defining a data-type in Haskell and registering it as such. The following example demonstrates:@@ -798,7 +845,7 @@      data B = B () deriving (Eq, Ord, Show, Read, Data, SymWord, HasKind, SatModel)   @ -(Note that you'll also need to use the language pragmas @DeriveDataTypeable@, @DeriveAnyClass@, and import @Data.Generics@ for the above to work.) +(Note that you'll also need to use the language pragmas @DeriveDataTypeable@, @DeriveAnyClass@, and import @Data.Generics@ for the above to work.)  This is all it takes to introduce 'B' as an uninterpreted sort in SBV, which makes the type @SBV B@ automagically become available as the type of symbolic values that ranges over 'B' values. Note that the @()@ argument is important to distinguish it from enumerations, which will be@@ -857,7 +904,7 @@ Note that the result is properly typed as @X@ elements; these are not mere strings. So, in a 'getModelAssignment' scenario, the user can recover actual elements of the domain and program further with those values as usual. -See "Data.SBV.Examples.Misc.Enumerate" for an extended example on how to use symbolic enumerations.+See "Documentation.SBV.Examples.Misc.Enumerate" for an extended example on how to use symbolic enumerations. -}  {- $noteOnNestedQuantifiers@@ -897,6 +944,44 @@ produce better translations to SMTLib for more efficient solving of cardinality constraints, assuming the backend solver supports them. Currently, only Z3 supports pseudo-booleans directly. For all other solvers, SBV will translate these to equivalent terms that do not require special functions.+-}++{- $verbosity++SBV provides various levels of verbosity to aid in debugging, by using the 'SMTConfig' fields:++  * ['verbose'] Print on stdout a shortened account of what is sent/received. This is specifically trimmed to reduce noise+    and is good for quick debugging. The output is not supposed to be machine-readable.+  * ['redirectVerbose'] Send the verbose output to a file. Note that you still have to set `verbose=True` for redirection to+    take effect. Otherwise, the output is the same as what you would see in `verbose`.+  * ['transcript'] Produce a file that is valid SMTLib2 format, containing everything sent and received. In particular, one can+    directly feed this file to the SMT-solver outside of the SBV since it is machine-readable. This is good for offline analysis+    situations, where you want to have a full account of what happened. For instance, it will print time-stamps at every interaction+    point, so you can see how long each command took.+-}++{- $observeInternal++The 'observe' command can be used to trace values of arbitrary expressions during a 'sat', 'prove', or perhaps more+importantly, in a 'quickCheck' call. This is useful for, for instance, recording expected/obtained expressions as a symbolic program is executing.++>>> :{+prove $ do a1 <- free "i1"+           a2 <- free "i2"+           let spec, res :: SWord8+               spec = a1 + a2+               res  = ite (a1 .== 12 &&& a2 .== 22)   -- insert a malicious bug!+                          1+                          (a1 + a2)+           observe "Expected" spec+           observe "Result"   res+           return $ spec .== res+:}+Falsifiable. Counter-example:+  i1       = 12 :: Word8+  i2       = 22 :: Word8+  Expected = 34 :: Word8+  Result   =  1 :: Word8 -}  {-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-}
+ Data/SBV/Char.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.Char+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- A collection of character utilities, follows the namings+-- in "Data.Char" and is intended to be imported qualified.+-- Also, it is recommended you use the @OverloadedStrings@+-- extension to allow literal strings to be used as+-- symbolic-strings when working with symbolic characters+-- and strings.+--+-- Note that currently 'SChar' type only covers Latin1 (i.e., the first 256+-- characters), as opposed to Haskell's Unicode character support. However,+-- there is a pending SMTLib proposal to extend this set to Unicode, at+-- which point we will update these functions to match the implementations.+-- For details, see: <http://smtlib.cs.uiowa.edu/theories-UnicodeStrings.shtml>+-----------------------------------------------------------------------------++module Data.SBV.Char (+        -- * Occurrence in a string+        elem, notElem+        -- * Conversion to\/from 'SInteger'+        , ord, chr+        -- * Conversion to upper\/lower case+        , toLower, toUpper+        -- * Converting digits to ints and back+        , digitToInt, intToDigit+        -- * Character classification+        , isControl, isSpace, isLower, isUpper, isAlpha, isAlphaNum, isPrint, isDigit, isOctDigit, isHexDigit, isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator+        -- * Subranges+        , isAscii, isLatin1, isAsciiLetter, isAsciiUpper, isAsciiLower+        ) where++import Prelude hiding (elem, notElem)+import qualified Prelude as P++import Data.SBV.Core.Data+import Data.SBV.Core.Model+import Data.SBV.Utils.Boolean++import qualified Data.Char as C++import Data.SBV.String (isInfixOf, charToStr)++-- For doctest use only+--+-- $setup+-- >>> import Data.SBV.Provers.Prover (prove, sat)+-- >>> :set -XOverloadedStrings++-- | Is the character in the string?+--+-- >>> :set -XOverloadedStrings+-- >>> prove $ \c -> c `elem` charToStr c+-- Q.E.D.+-- >>> prove $ \c -> bnot (c `elem` "")+-- Q.E.D.+elem :: SChar -> SString -> SBool+c `elem` s+ | Just cs <- unliteral s, Just cc <- unliteral c+ = literal (cc `P.elem` cs)+ | Just cs <- unliteral s                            -- If only the second string is concrete, element-wise checking is still much better!+ = bAny (c .==) $ map literal cs+ | True+ = charToStr c `isInfixOf` s++-- | Is the character not in the string?+--+-- >>> prove $ \c s -> c `elem` s <=> bnot (c `notElem` s)+-- Q.E.D.+notElem :: SChar -> SString -> SBool+c `notElem` s = bnot (c `elem` s)++-- | The 'ord' of a character.+ord :: SChar -> SInteger+ord c+ | Just cc <- unliteral c+ = literal (fromIntegral (C.ord cc))+ | True+ = SBV $ SVal kTo $ Right $ cache r+ where kFrom = KBounded False 8+       kTo   = KUnbounded+       r st = do csw <- sbvToSW st c+                 newExpr st kTo (SBVApp (KindCast kFrom kTo) [csw])++-- | Conversion from an integer to a character.+--+-- >>> prove $ \x -> 0 .<= x &&& x .< 256 ==> ord (chr x) .== x+-- Q.E.D.+-- >>> prove $ \x -> chr (ord x) .== x+-- Q.E.D.+chr :: SInteger -> SChar+chr w+ | Just cw <- unliteral w+ = literal (C.chr (fromIntegral cw))+ | True+ = SBV $ SVal KChar $ Right $ cache r+ where w8 :: SWord8+       w8 = sFromIntegral w+       r st = do SW _ n <- sbvToSW st w8+                 return $ SW KChar n++-- | Convert to lower-case.+--+-- >>> prove $ \c -> toLower (toLower c) .== toLower c+-- Q.E.D.+-- >>> prove $ \c -> isLower c ==> toLower (toUpper c) .== c+-- Q.E.D.+toLower :: SChar -> SChar+toLower c = ite (isUpper c) (chr (ord c + 32)) c++-- | Convert to upper-case. N.B. There are three special cases!+--+--   * The character \223 is special. It corresponds to the German Eszett, it is considered lower-case,+--     and furthermore it's upper-case maps back to itself within our character-set. So, we leave it+--     untouched.+--+--   * The character \181 maps to upper-case \924, which is beyond our character set. We leave it+--     untouched. (This is the A with an acute accent.)+--+--   * The character \255 maps to upper-case \376, which is beyond our character set. We leave it+--     untouched. (This is the non-breaking space character.)+--+-- >>> prove $ \c -> toUpper (toUpper c) .== toUpper c+-- Q.E.D.+-- >>> prove $ \c -> isUpper c ==> toUpper (toLower c) .== c+-- Q.E.D.+toUpper :: SChar -> SChar+toUpper c = ite (isLower c &&& c `notElem` "\181\223\255") (chr (ord c - 32)) c++-- | Convert a digit to an integer. Works for hexadecimal digits too. If the input isn't a digit,+-- then return -1.+--+-- >>> prove $ \c -> isDigit c ||| isHexDigit c ==> digitToInt c .>= 0 &&& digitToInt c .<= 15+-- Q.E.D.+-- >>> prove $ \c -> bnot (isDigit c ||| isHexDigit c) ==> digitToInt c .== -1+-- Q.E.D.+digitToInt :: SChar -> SInteger+digitToInt c = ite (uc `elem` "0123456789") (sFromIntegral (o - ord (literal '0')))+             $ ite (uc `elem` "ABCDEF")     (sFromIntegral (o - ord (literal 'A') + 10))+             $ -1+  where uc = toUpper c+        o  = ord uc++-- | Convert an an integer to a digit, inverse of 'digitToInt'. If the integer is out of+-- bounds, we return the arbitrarily chosen space character. Note that for hexadecimal+-- letters, we return the corresponding lowercase letter.+--+-- >>> prove $ \i -> i .>= 0 &&& i .<= 15 ==> digitToInt (intToDigit i) .== i+-- Q.E.D.+-- >>> prove $ \i -> i .<  0 ||| i .>  15 ==> digitToInt (intToDigit i) .== -1+-- Q.E.D.+-- >>> prove $ \c -> digitToInt c .== -1 <=> intToDigit (digitToInt c) .== literal ' '+-- Q.E.D.+intToDigit :: SInteger -> SChar+intToDigit i = ite (i .>=  0 &&& i .<=  9) (chr (sFromIntegral i + ord (literal '0')))+             $ ite (i .>= 10 &&& i .<= 15) (chr (sFromIntegral i + ord (literal 'a') - 10))+             $ literal ' '++-- | Is this a control character? Control characters are essentially the non-printing characters.+isControl :: SChar -> SBool+isControl = (`elem` controls)+  where controls = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\a\b\t\n\v\f\r\SO\SI\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\EM\SUB\ESC\FS\GS\RS\US\DEL\128\129\130\131\132\133\134\135\136\137\138\139\140\141\142\143\144\145\146\147\148\149\150\151\152\153\154\155\156\157\158\159"++-- | Is this white-space? That is, one of "\t\n\v\f\r \160".+isSpace :: SChar -> SBool+isSpace = (`elem` spaces)+  where spaces = "\t\n\v\f\r \160"++-- | Is this a lower-case character?+--+-- >>> prove $ \c -> isUpper c ==> isLower (toLower c)+-- Q.E.D.+isLower :: SChar -> SBool+isLower = (`elem` lower)+  where lower = "abcdefghijklmnopqrstuvwxyz\181\223\224\225\226\227\228\229\230\231\232\233\234\235\236\237\238\239\240\241\242\243\244\245\246\248\249\250\251\252\253\254\255"++-- | Is this an upper-case character?+--+-- >>> prove $ \c -> bnot (isLower c &&& isUpper c)+-- Q.E.D.+isUpper :: SChar -> SBool+isUpper = (`elem` upper)+  where upper = "ABCDEFGHIJKLMNOPQRSTUVWXYZ\192\193\194\195\196\197\198\199\200\201\202\203\204\205\206\207\208\209\210\211\212\213\214\216\217\218\219\220\221\222"++-- | Is this an alphabet character? That is lower-case, upper-case and title-case letters, plus letters of caseless scripts and modifiers letters.+isAlpha :: SChar -> SBool+isAlpha = (`elem` alpha)+  where alpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\170\181\186\192\193\194\195\196\197\198\199\200\201\202\203\204\205\206\207\208\209\210\211\212\213\214\216\217\218\219\220\221\222\223\224\225\226\227\228\229\230\231\232\233\234\235\236\237\238\239\240\241\242\243\244\245\246\248\249\250\251\252\253\254\255"++-- | Is this an 'isAlpha' or 'isNumber'.+--+-- >>> prove $ \c -> isAlphaNum c <=> isAlpha c ||| isNumber c+-- Q.E.D.+isAlphaNum :: SChar -> SBool+isAlphaNum c = isAlpha c ||| isNumber c++-- | Is this a printable character? Essentially the complement of 'isControl', with one+-- exception. The Latin-1 character \173 is neither control nor printable. Go figure.+--+-- >>> prove $ \c -> c .== literal '\173' ||| isControl c <=> bnot (isPrint c)+-- Q.E.D.+isPrint :: SChar -> SBool+isPrint c = c ./= literal '\173' &&& bnot (isControl c)++-- | Is this an ASCII digit, i.e., one of @0@..@9@. Note that this is a subset of 'isNumber'+--+-- >>> prove $ \c -> isDigit c ==> isNumber c+-- Q.E.D.+isDigit :: SChar -> SBool+isDigit = (`elem` "0123456789")++-- | Is this an Octal digit, i.e., one of @0@..@7@.+--+-- >>> prove $ \c -> isOctDigit c ==> isDigit c+-- Q.E.D.+isOctDigit :: SChar -> SBool+isOctDigit = (`elem` "01234567")++-- | Is this a Hex digit, i.e, one of @0@..@9@, @a@..@f@, @A@..@F@.+--+-- >>> prove $ \c -> isHexDigit c ==> isAlphaNum c+-- Q.E.D.+isHexDigit :: SChar -> SBool+isHexDigit = (`elem` "0123456789abcdefABCDEF")++-- | Is this an alphabet character. Note that this function is equivalent to 'isAlpha'.+--+-- >>> prove $ \c -> isLetter c <=> isAlpha c+-- Q.E.D.+isLetter :: SChar -> SBool+isLetter = isAlpha++-- | Is this a mark? Note that the Latin-1 subset doesn't have any marks; so this function+-- is simply constant false for the time being.+--+-- >>> prove $ bnot . isMark+-- Q.E.D.+isMark :: SChar -> SBool+isMark = const false++-- | Is this a number character? Note that this set contains not only the digits, but also+-- the codes for a few numeric looking characters like 1/2 etc. Use 'isDigit' for the digits @0@ through @9@.+isNumber :: SChar -> SBool+isNumber = (`elem` "0123456789\178\179\185\188\189\190")++-- | Is this a punctuation mark?+isPunctuation :: SChar -> SBool+isPunctuation = (`elem` "!\"#%&'()*,-./:;?@[\\]_{}\161\167\171\182\183\187\191")++-- | Is this a symbol?+isSymbol :: SChar -> SBool+isSymbol = (`elem` "$+<=>^`|~\162\163\164\165\166\168\169\172\174\175\176\177\180\184\215\247")++-- | Is this a separator?+--+-- >>> prove $ \c -> isSeparator c ==> isSpace c+-- Q.E.D.+isSeparator :: SChar -> SBool+isSeparator = (`elem` " \160")++-- | Is this an ASCII character, i.e., the first 128 characters.+isAscii :: SChar -> SBool+isAscii c = ord c .< 128++-- | Is this a Latin1 character? Note that this function is always true since 'SChar' corresponds+-- precisely to Latin1 for the time being.+--+-- >>> prove isLatin1+-- Q.E.D.+isLatin1 :: SChar -> SBool+isLatin1 = const true++-- | Is this an ASCII letter?+--+-- >>> prove $ \c -> isAsciiLetter c <=> isAsciiUpper c ||| isAsciiLower c+-- Q.E.D.+isAsciiLetter :: SChar -> SBool+isAsciiLetter c = isAsciiUpper c ||| isAsciiLower c++-- | Is this an ASCII Upper-case letter? i.e., @A@ thru @Z@+--+-- >>> prove $ \c -> isAsciiUpper c <=> ord c .>= ord (literal 'A') &&& ord c .<= ord (literal 'Z')+-- Q.E.D.+-- >>> prove $ \c -> isAsciiUpper c <=> isAscii c &&& isUpper c+-- Q.E.D.+isAsciiUpper :: SChar -> SBool+isAsciiUpper = (`elem` literal ['A' .. 'Z'])++-- | Is this an ASCII Lower-case letter? i.e., @a@ thru @z@+--+-- >>> prove $ \c -> isAsciiLower c <=> ord c .>= ord (literal 'a') &&& ord c .<= ord (literal 'z')+-- Q.E.D.+-- >>> prove $ \c -> isAsciiLower c <=> isAscii c &&& isLower c+-- Q.E.D.+isAsciiLower :: SChar -> SBool+isAsciiLower = (`elem` literal ['a' .. 'z'])
Data/SBV/Compilers/C.hs view
@@ -183,6 +183,8 @@                      KReal         -> specF (fromJust (cgReal cfg))                      KFloat        -> specF CgFloat                      KDouble       -> specF CgDouble+                     KString       -> text "%s"+                     KChar         -> text "%c"                      KUserSort s _ -> die $ "uninterpreted sort: " ++ s   where spec :: (Bool, Int) -> Doc         spec (False,  1) = text "%d"@@ -213,6 +215,8 @@ mkConst _   (CW KBool            (CWInteger i)) = showSizedConst i (False, 1) mkConst _   (CW KFloat           (CWFloat f))   = text $ showCFloat f mkConst _   (CW KDouble          (CWDouble d))  = text $ showCDouble d+mkConst _   (CW KString          (CWString s))  = text $ show s+mkConst _   (CW KChar            (CWChar c))    = text $ show c mkConst _   cw                                  = die $ "mkConst: " ++ show cw  showSizedConst :: Integer -> (Bool, Int) -> Doc@@ -295,13 +299,13 @@   $$ text "typedef double SDouble;"   $$ text ""   $$ text "/* Unsigned bit-vectors */"-  $$ text "typedef uint8_t  SWord8 ;"+  $$ text "typedef uint8_t  SWord8;"   $$ text "typedef uint16_t SWord16;"   $$ text "typedef uint32_t SWord32;"   $$ text "typedef uint64_t SWord64;"   $$ text ""   $$ text "/* Signed bit-vectors */"-  $$ text "typedef int8_t  SInt8 ;"+  $$ text "typedef int8_t  SInt8;"   $$ text "typedef int16_t SInt16;"   $$ text "typedef int32_t SInt32;"   $$ text "typedef int64_t SInt64;"@@ -408,10 +412,14 @@  -- | 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 _uis _axioms (SBVPgm asgns) cstrs origAsserts _) inVars outVars mbRet extDecls+genCProg cfg fn proto (Result kindInfo _tvals _ovals cgs ins preConsts tbls arrs _uis _axioms (SBVPgm asgns) cstrs 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."+  | KString `Set.member` kindInfo+  = error "SBV->C: Strings are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"+  | KChar `Set.member` kindInfo+  = error "SBV->C: Characters are currently not supported by the C compiler. Please get in touch if you'd like support for this feature!"   | isNothing (cgReal cfg) && KReal `Set.member` kindInfo   = error $ "SBV->C: SReal values are not supported by the C compiler."           ++ "\nUse 'cgSRealType' to specify a custom type for SReal representation."@@ -462,6 +470,8 @@                 where len KReal{}             = 5                       len KFloat{}            = 6 -- SFloat                       len KDouble{}           = 7 -- SDouble+                      len KString{}           = 7 -- SString+                      len KChar{}             = 5 -- SChar                       len KUnbounded{}        = 8                       len KBool               = 5 -- SBool                       len (KBounded False n)  = 5 + length (show n) -- SWordN@@ -493,7 +503,7 @@        isAlive (_, _)           = True         genIO :: Bool -> (Bool, (String, CgVal)) -> [Doc]-       genIO True  (alive, (cNm, CgAtomic sw)) = [declSW typeWidth sw  <+> text "=" <+> text cNm P.<> semi             | alive]+       genIO True  (alive, (cNm, CgAtomic sw)) = [declSW typeWidth sw  <+> text "=" <+> text cNm P.<> semi               | alive]        genIO False (alive, (cNm, CgAtomic sw)) = [text "*" P.<> text cNm <+> text "=" <+> showSW cfg consts sw P.<> semi | alive]        genIO isInp (_,     (cNm, CgArray sws)) = zipWith genElt sws [(0::Int)..]          where genElt sw i@@ -711,6 +721,8 @@                                                KReal           -> die "array index with real value"                                                KFloat          -> die "array index with float value"                                                KDouble         -> die "array index with double value"+                                               KString         -> die "array index with string value"+                                               KChar           -> die "array index with character value"                                                KUnbounded      -> case cgInteger cfg of                                                                     Nothing -> (True, True) -- won't matter, it'll be rejected later                                                                     Just i  -> (True, canOverflow True i)
Data/SBV/Control.hs view
@@ -234,11 +234,11 @@  For other examples see: -  - "Data.SBV.Examples.Queries.AllSat": Simulating SBV's 'allSat' using queries.-  - "Data.SBV.Examples.Queries.CaseSplit": Performing a case-split during a query.-  - "Data.SBV.Examples.Queries.Enums": Using enumerations in queries.-  - "Data.SBV.Examples.Queries.FourFours": Solution to a fun arithmetic puzzle, coded using queries.-  - "Data.SBV.Examples.Queries.GuessNumber": The famous number guessing game.-  - "Data.SBV.Examples.Queries.UnsatCore": Extracting unsat-cores using queries.-  - "Data.SBV.Examples.Queries.Interpolants": Extracting interpolants using queries.+  - "Documentation.SBV.Examples.Queries.AllSat": Simulating SBV's 'allSat' using queries.+  - "Documentation.SBV.Examples.Queries.CaseSplit": Performing a case-split during a query.+  - "Documentation.SBV.Examples.Queries.Enums": Using enumerations in queries.+  - "Documentation.SBV.Examples.Queries.FourFours": Solution to a fun arithmetic puzzle, coded using queries.+  - "Documentation.SBV.Examples.Queries.GuessNumber": The famous number guessing game.+  - "Documentation.SBV.Examples.Queries.UnsatCore": Extracting unsat-cores using queries.+  - "Documentation.SBV.Examples.Queries.Interpolants": Extracting interpolants using queries. -}
Data/SBV/Control/Query.hs view
@@ -199,9 +199,9 @@ getSMTResult = do cfg <- getConfig                   cs  <- checkSat                   case cs of-                    Unsat -> return $ Unsatisfiable cfg-                    Sat   -> Satisfiable cfg <$> getModel-                    Unk   -> Unknown     cfg <$> getUnknownReason+                    Unsat -> Unsatisfiable cfg <$> getUnsatCoreIfRequested+                    Sat   -> Satisfiable   cfg <$> getModel+                    Unk   -> Unknown       cfg <$> getUnknownReason  -- | Classify a model based on whether it has unbound objectives or not. classifyModel :: SMTConfig -> SMTModel -> SMTResult@@ -214,7 +214,7 @@ getLexicographicOptResults = do cfg <- getConfig                                 cs  <- checkSat                                 case cs of-                                  Unsat -> return $ Unsatisfiable cfg+                                  Unsat -> Unsatisfiable cfg <$> getUnsatCoreIfRequested                                   Sat   -> classifyModel cfg <$> getModelWithObjectives                                   Unk   -> Unknown       cfg <$> getUnknownReason    where getModelWithObjectives = do objectiveValues <- getObjectiveValues@@ -227,7 +227,7 @@                                        cs  <- checkSat                                         case cs of-                                         Unsat -> return [(nm, Unsatisfiable cfg) | nm <- objNames]+                                         Unsat -> getUnsatCoreIfRequested >>= \mbUC -> return [(nm, Unsatisfiable cfg mbUC) | nm <- objNames]                                          Sat   -> continue (classifyModel cfg)                                          Unk   -> do ur <- Unknown cfg <$> getUnknownReason                                                      return [(nm, ur) | nm <- objNames]@@ -276,9 +276,10 @@ getModelAtIndex :: Maybe Int -> Query SMTModel getModelAtIndex mbi = do              State{runMode} <- get-             cfg  <- getConfig-             inps <- getQuantifiedInputs-             rm   <- io $ readIORef runMode+             cfg   <- getConfig+             inps  <- getQuantifiedInputs+             obsvs <- getObservables+             rm    <- io $ readIORef runMode              let vars :: [NamedSymVar]                  vars = case rm of                           m@CodeGen         -> error $ "SBV.getModel: Model is not available in mode: " ++ show m@@ -287,10 +288,17 @@                                                let allModelInputs = if isSAT then takeWhile ((/= ALL) . fst) inps                                                                              else takeWhile ((== ALL) . fst) inps +                                                   -- are we inside a quantifier+                                                   insideQuantifier = length allModelInputs < length inps++                                                   -- observables are only meaningful if we're not in a quantified context+                                                   allPrefixObservables | insideQuantifier = []+                                                                        | True             = [(EX, (sw, nm)) | (nm, sw) <- obsvs]+                                                    sortByNodeId :: [NamedSymVar] -> [NamedSymVar]                                                    sortByNodeId = sortBy (compare `on` (\(SW _ n, _) -> n)) -                                               in sortByNodeId [nv | (_, nv@(_, n)) <- allModelInputs, not (isNonModelVar cfg n)]+                                               in sortByNodeId [nv | (_, nv@(_, n)) <- allModelInputs ++ allPrefixObservables, not (isNonModelVar cfg n)]               assocs <- mapM (\(sw, n) -> (n, ) <$> getValueCW mbi sw) vars @@ -470,7 +478,7 @@ -- the conditions lead to a satisfiable result, returns @Just@ that result. If none of them -- do, returns @Nothing@. Note that we automatically generate a coverage case and search -- for it automatically as well. In that latter case, the string returned will be "Coverage".--- The first argument controls printing progress messages  See "Data.SBV.Examples.Queries.CaseSplit"+-- The first argument controls printing progress messages  See "Documentation.SBV.Examples.Queries.CaseSplit" -- for an example use case. caseSplit :: Bool -> [(String, SBool)] -> Query (Maybe (String, SMTResult)) caseSplit printCases cases = do cfg <- getConfig@@ -544,6 +552,14 @@         parse r bad $ \case            EApp es | Just xs <- mapM fromECon es -> return $ map unBar xs            _                                     -> bad r Nothing++-- | Retrieve the unsat core if it was asked for in the configuration+getUnsatCoreIfRequested :: Query (Maybe [String])+getUnsatCoreIfRequested = do+        cfg <- getConfig+        if or [b | ProduceUnsatCores b <- solverSetOptions cfg]+           then Just <$> getUnsatCore+           else return Nothing  -- | Retrieve the proof. Note you must have arranged for -- proofs to be produced first (/via/ @'setOption' $ 'ProduceProofs' 'True'@)
Data/SBV/Control/Types.hs view
@@ -28,7 +28,9 @@ import Control.DeepSeq (NFData(..))  -- | Result of a 'checkSat' or 'checkSatAssuming' call.-data CheckSatResult = Sat | Unsat | Unk+data CheckSatResult = Sat           -- ^ Satisfiable: A model is available, which can be queried with 'Data.SBV.Control.getValue'.+                    | Unsat         -- ^ Unsatisfiable: No model is available. Unsat cores might be obtained via 'Data.SBV.Control.getUnsatCore'.+                    | Unk           -- ^ Unknown: Use 'Data.SBV.Control.getUnknownReason' to obtain an explanation why this might be the case.                     deriving (Eq, Show)  -- | Collectable information from the solver.@@ -181,6 +183,7 @@   | 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.   | QF_FD              -- ^ Quantifier-free finite domains.+  | QF_S               -- ^ Quantifier-free formulas over the theory of strings.   | Logic_ALL          -- ^ The catch-all value.   | Logic_NONE         -- ^ Use this value when you want SBV to simply not set the logic.   | CustomLogic String -- ^ In case you need a really custom string!
Data/SBV/Control/Utils.hs view
@@ -9,18 +9,20 @@ -- Query related utils. ----------------------------------------------------------------------------- -{-# LANGUAGE    BangPatterns          #-}-{-# LANGUAGE    DefaultSignatures     #-}-{-# LANGUAGE    LambdaCase            #-}-{-# LANGUAGE    NamedFieldPuns        #-}-{-# LANGUAGE    ScopedTypeVariables   #-}-{-# LANGUAGE    TupleSections         #-}-{-# OPTIONS_GHC -fno-warn-orphans  #-}+{-# LANGUAGE    BangPatterns         #-}+{-# LANGUAGE    DefaultSignatures    #-}+{-# LANGUAGE    LambdaCase           #-}+{-# LANGUAGE    NamedFieldPuns       #-}+{-# LANGUAGE    ScopedTypeVariables  #-}+{-# LANGUAGE    TupleSections        #-}+{-# LANGUAGE    TypeSynonymInstances #-}+{-# LANGUAGE    FlexibleInstances    #-}+{-# OPTIONS_GHC -fno-warn-orphans    #-}  module Data.SBV.Control.Utils (        io      , ask, send, getValue, getUninterpretedValue, getValueCW, getUnsatAssumptions, SMTValue(..)-     , getQueryState, modifyQueryState, getConfig, getObjectives, getSBVAssertions, getSBVPgm, getQuantifiedInputs+     , getQueryState, modifyQueryState, getConfig, getObjectives, getSBVAssertions, getSBVPgm, getQuantifiedInputs, getObservables      , checkSat, checkSatUsing, getAllSatResult      , inNewContext, freshVar, freshVar_      , parse@@ -34,7 +36,7 @@  import Data.List  (sortBy, elemIndex, partition, groupBy, tails) -import Data.Char     (isPunctuation, isSpace)+import Data.Char     (isPunctuation, isSpace, chr) import Data.Ord      (comparing) import Data.Function (on) @@ -67,6 +69,8 @@ import Data.SBV.SMT.SMTLib  (toIncSMTLib, toSMTLib) import Data.SBV.SMT.Utils   (showTimeoutValue, annotateWithName, alignPlain, debug, mergeSExpr, SMTException(..)) +import Data.SBV.Utils.Lib (qfsToString)+ import Data.SBV.Utils.SExpr import Data.SBV.Control.Types @@ -203,6 +207,30 @@             return r +-- | Send a string to the solver, and return the response. Except, if the response+-- is one of the "ignore" ones, keep querying.+askIgnoring :: String -> [String] -> Query String+askIgnoring s ignoreList = do++           QueryState{queryAsk, queryRetrieveResponse, queryTimeOutValue} <- getQueryState++           case queryTimeOutValue of+             Nothing -> queryDebug ["[SEND] " `alignPlain` s]+             Just i  -> queryDebug ["[SEND, TimeOut: " ++ showTimeoutValue i ++ "] " `alignPlain` s]+           r <- io $ queryAsk queryTimeOutValue s+           queryDebug ["[RECV] " `alignPlain` r]++           let loop currentResponse+                 | currentResponse `notElem` ignoreList+                 = return currentResponse+                 | True+                 = do queryDebug ["[WARN] Previous response is explicitly ignored, beware!"]+                      newResponse <- io $ queryRetrieveResponse queryTimeOutValue+                      queryDebug ["[RECV] " `alignPlain` newResponse]+                      loop newResponse++           loop r+ -- | Send a string to the solver. If the first argument is 'True', we will require -- a "success" response as well. Otherwise, we'll fire and forget. send :: Bool -> String -> Query ()@@ -306,6 +334,16 @@    sexprToVal (ENum (v, _)) = Just (fromIntegral v)    sexprToVal _             = Nothing +instance SMTValue String where+   sexprToVal (ECon s)+     | length s >= 2 && head s == '"' && last s == '"'+     = Just (tail (init s))+   sexprToVal _        = Nothing++instance SMTValue Char where+   sexprToVal (ENum (i, _)) = Just (chr (fromIntegral i))+   sexprToVal _             = Nothing+ -- | Get the value of a term. getValue :: SMTValue a => SBV a -> Query a getValue s = do sw <- inNewContext (`sbvToSW` s)@@ -367,16 +405,24 @@ recoverKindedValue :: Kind -> SExpr -> Maybe CW recoverKindedValue k e = case e of                            ENum    i | isIntegralLike    -> Just $ mkConstCW k (fst i)+                           ENum    i | isChar          k -> Just $ CW KChar    (CWChar    (chr (fromIntegral (fst i))))                            EReal   i | isReal          k -> Just $ CW KReal    (CWAlgReal i)                            EFloat  i | isFloat         k -> Just $ CW KFloat   (CWFloat   i)                            EDouble i | isDouble        k -> Just $ CW KDouble  (CWDouble  i)-                           ECon    i | isUninterpreted k -> Just $ CW k        (CWUserSort (getUIIndex k i, i))+                           ECon    s | isString        k -> Just $ CW KString  (CWString   (interpretString s))+                           ECon    s | isUninterpreted k -> Just $ CW k        (CWUserSort (getUIIndex k s, s))                            _                             -> Nothing   where isIntegralLike = or [f k | f <- [isBoolean, isBounded, isInteger, isReal, isFloat, isDouble]]          getUIIndex (KUserSort  _ (Right xs)) i = i `elemIndex` xs         getUIIndex _                         _ = Nothing +        -- Make sure strings are really strings+        interpretString xs+          | length xs < 2 || head xs /= '"' || last xs /= '"'+          = error $ "Expected a string constant with quotes, received: <" ++ xs ++ ">"+          | True+          = qfsToString $ tail (init xs)  -- | Get the value of a term. If the kind is Real and solver supports decimal approximations, -- we will "squash" the representations.@@ -409,8 +455,11 @@ checkSatUsing :: String -> Query CheckSatResult checkSatUsing cmd = do let bad = unexpected "checkSat" cmd "one of sat/unsat/unknown" Nothing -                       r <- ask cmd+                           -- Sigh.. Ignore some of the pesky warnings. We only do it as an exception here.+                           ignoreList = ["WARNING: optimization with quantified constraints is not supported"] +                       r <- askIgnoring cmd ignoreList+                        parse r bad $ \case ECon "sat"     -> return Sat                                            ECon "unsat"   -> return Unsat                                            ECon "unknown" -> return Unk@@ -429,6 +478,14 @@                           return $ preQs ++ trackers ++ postQs +-- | Get observables, i.e., those explicitly labeled by the user with a call to 'observe'.+getObservables :: Query [(String, SW)]+getObservables = do State{rObservables} <- get++                    rObs <- liftIO $ readIORef rObservables++                    return $ reverse rObs+ -- | Repeatedly issue check-sat, after refuting the previous model. -- The bool is true if the model is unique upto prefix existentials. getAllSatResult :: Query (Bool, Bool, [SMTResult])@@ -618,7 +675,7 @@  -- | Convert a query result to an SMT Problem runProofOn :: SMTConfig -> Bool -> [String] -> Result -> SMTProblem-runProofOn config isSat comments res@(Result ki _qcInfo _codeSegs is consts tbls arrs uis axs pgm cstrs _assertions outputs) =+runProofOn config isSat comments res@(Result ki _qcInfo _observables _codeSegs is consts tbls arrs uis axs pgm cstrs _assertions outputs) =      let flipQ (ALL, x) = (EX,  x)          flipQ (EX,  x) = (ALL, x)
Data/SBV/Core/AlgReals.hs view
@@ -15,6 +15,7 @@  module Data.SBV.Core.AlgReals (              AlgReal(..)+           , AlgRealPoly(..)            , mkPolyReal            , algRealToSMTLib2            , algRealToHaskell@@ -33,9 +34,8 @@ -- | 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+data AlgReal = AlgRational Bool Rational                          -- ^ bool says it's exact (i.e., SMT-solver did not return it with ? at the end.)+             | AlgPolyRoot (Integer,  AlgRealPoly) (Maybe String) -- ^ which root of this polynomial and an approximate decimal representation with given precision, if available  -- | Check wheter a given argument is an exact rational isExactRational :: AlgReal -> Bool@@ -45,7 +45,7 @@ -- | 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)]+newtype AlgRealPoly = AlgRealPoly [(Integer, Integer)]                    deriving (Eq, Ord)  -- | Construct a poly-root real with a given approximate value (either as a decimal, or polynomial-root)@@ -56,7 +56,7 @@       (_, (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+ = AlgPolyRoot (k, AlgRealPoly (normalize coeffs)) Nothing  where normalize :: [(Integer, Integer)] -> [(Integer, Integer)]        normalize = merge . sortBy (flip compare `on` snd)        merge []                     = []@@ -65,8 +65,8 @@          | 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+instance Show AlgRealPoly where+  show (AlgRealPoly 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"]@@ -172,7 +172,7 @@   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 ++ ")"+algRealToSMTLib2 (AlgPolyRoot (i, AlgRealPoly xs) _) = "(root-obj (+ " ++ unwords (concatMap term xs) ++ ") " ++ show i ++ ")"   where term (0, _) = []         term (k, 0) = [coeff k]         term (1, 1) = ["x"]
Data/SBV/Core/Concrete.hs view
@@ -13,9 +13,12 @@   ( module Data.SBV.Core.Concrete   ) where +import Control.Monad (replicateM)+ import Data.Bits import System.Random (randomIO, randomRIO) +import Data.Char (chr) import Data.List (isPrefixOf)  import Data.SBV.Core.Kind@@ -26,49 +29,79 @@            | CWInteger  !Integer              -- ^ bit-vector/unbounded integer            | CWFloat    !Float                -- ^ float            | CWDouble   !Double               -- ^ double+           | CWChar     !Char                 -- ^ character+           | CWString   !String               -- ^ string            | 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+  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+  CWFloat a    == CWFloat b    = a == b+  CWDouble a   == CWDouble b   = a == b+  CWChar   a   == CWChar b     = a == b+  CWString a   == CWString 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+  CWAlgReal a `compare`  CWAlgReal b  = a `algRealStructuralCompare` b+  CWAlgReal _ `compare`  CWInteger _  = LT+  CWAlgReal _ `compare`  CWFloat _    = LT+  CWAlgReal _ `compare`  CWDouble _   = LT+  CWAlgReal _ `compare`  CWChar _     = LT+  CWAlgReal _ `compare`  CWString _   = 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+  CWInteger _ `compare`  CWAlgReal _  = GT+  CWInteger a `compare`  CWInteger b  = a `compare` b+  CWInteger _ `compare`  CWFloat _    = LT+  CWInteger _ `compare`  CWDouble _   = LT+  CWInteger _ `compare`  CWChar _     = LT+  CWInteger _ `compare`  CWString _   = 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+  CWFloat _   `compare`  CWAlgReal _  = GT+  CWFloat _   `compare`  CWInteger _  = GT+  CWFloat a   `compare`  CWFloat b    = a `compare` b+  CWFloat _   `compare`  CWDouble _   = LT+  CWFloat _   `compare`  CWChar _     = LT+  CWFloat _   `compare`  CWString _   = 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+  CWDouble _  `compare`  CWAlgReal _  = GT+  CWDouble _  `compare`  CWInteger _  = GT+  CWDouble _  `compare`  CWFloat _    = GT+  CWDouble a  `compare`  CWDouble b   = a `compare` b+  CWDouble _  `compare`  CWChar _     = LT+  CWDouble _  `compare`  CWString _   = LT+  CWDouble _  `compare`  CWUserSort _ = LT +  CWChar _    `compare`  CWAlgReal _  = GT+  CWChar _    `compare`  CWInteger _  = GT+  CWChar _    `compare`  CWFloat _    = GT+  CWChar _    `compare`  CWDouble _   = GT+  CWChar a    `compare`  CWChar b     = a `compare` b+  CWChar _    `compare`  CWString _   = LT+  CWChar _    `compare`  CWUserSort _ = LT++  CWString _  `compare`  CWAlgReal _  = GT+  CWString _  `compare`  CWInteger _  = GT+  CWString _  `compare`  CWFloat _    = GT+  CWString _  `compare`  CWDouble _   = GT+  CWString _  `compare`  CWChar _     = GT+  CWString a  `compare`  CWString b   = a `compare` b+  CWString _  `compare`  CWUserSort _ = LT+   CWUserSort _ `compare` CWAlgReal _  = GT   CWUserSort _ `compare` CWInteger _  = GT   CWUserSort _ `compare` CWFloat _    = GT   CWUserSort _ `compare` CWDouble _   = GT+  CWUserSort _ `compare` CWChar _     = GT+  CWUserSort _ `compare` CWString _   = GT   CWUserSort a `compare` CWUserSort b = a `compare` b  -- | 'CW' represents a concrete word of a fixed size:@@ -180,41 +213,49 @@ 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+liftCW :: (AlgReal -> b) -> (Integer -> b) -> (Float -> b) -> (Double -> b) -> (Char -> b) -> (String -> 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 _ (CWChar     v)) = f v+liftCW _ _ _ _ _ f _ (CW _ (CWString   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)+liftCW2 :: (AlgReal -> AlgReal -> b) -> (Integer -> Integer -> b) -> (Float -> Float -> b) -> (Double -> Double -> b) -> (Char -> Char -> b) -> (String -> String -> b) -> ((Maybe Int, String) -> (Maybe Int, String) -> b) -> CW -> CW -> b+liftCW2 r i f d c s 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+                              (CWChar a,     CWChar b)     -> c a b+                              (CWString a,   CWString b)   -> s 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)+mapCW :: (AlgReal -> AlgReal) -> (Integer -> Integer) -> (Float -> Float) -> (Double -> Double) -> (Char -> Char) -> (String -> String) -> ((Maybe Int, String) -> (Maybe Int, String)) -> CW -> CW+mapCW r i f d c s 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)+                                                    CWChar     a -> CWChar     (c a)+                                                    CWString   a -> CWString   (s 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)+mapCW2 :: (AlgReal -> AlgReal -> AlgReal) -> (Integer -> Integer -> Integer) -> (Float -> Float -> Float) -> (Double -> Double -> Double) -> (Char -> Char -> Char) -> (String -> String -> String) -> ((Maybe Int, String) -> (Maybe Int, String) -> (Maybe Int, String)) -> CW -> CW -> CW+mapCW2 r i f d c s 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, CWChar     a, CWChar     b) -> normCW $ CW (kindOf x) (CWChar     (c a b))+                            (True, CWString   a, CWString   b) -> normCW $ CW (kindOf x) (CWString   (s 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@@ -228,7 +269,7 @@ -- | 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+showCW shk w               = liftCW show show show show show show snd w ++ kInfo       where kInfo | shk  = " :: " ++ showBaseKind (kindOf w)                   | True = "" @@ -247,6 +288,8 @@ 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 KChar           a = error $ "Unexpected call to mkConstCW (Char) with value: " ++ show (toInteger a)+mkConstCW KString         a = error $ "Unexpected call to mkConstCW (String) with value: " ++ show (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.@@ -259,6 +302,10 @@     KReal         -> CWAlgReal <$> randomIO     KFloat        -> CWFloat   <$> randomIO     KDouble       -> CWDouble  <$> randomIO+    -- TODO: KString/KChar currently only go for 0..255; include unicode?+    KString       -> do l <- randomRIO (0, 100)+                        CWString <$> replicateM l (chr <$> randomRIO (0, 255))+    KChar         -> CWChar . chr <$> randomRIO (0, 255)     KUserSort s _ -> error $ "Unexpected call to randomCWVal with uninterpreted kind: " ++ s   where     bounds :: Bool -> Int -> (Integer, Integer)
Data/SBV/Core/Data.hs view
@@ -23,12 +23,12 @@  module Data.SBV.Core.Data  ( SBool, SWord8, SWord16, SWord32, SWord64- , SInt8, SInt16, SInt32, SInt64, SInteger, SReal, SFloat, SDouble+ , SInt8, SInt16, SInt32, SInt64, SInteger, SReal, SFloat, SDouble, SChar, SString  , 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+ , CW(..), CWVal(..), AlgReal(..), AlgRealPoly, ExtCW(..), GeneralizedCW(..), isRegularCW, cwSameType, cwToBool  , mkConstCW ,liftCW2, mapCW, mapCW2  , SW(..), trueSW, falseSW, trueCW, falseCW, normCW  , SVal(..)@@ -37,7 +37,7 @@  , sbvToSW, sbvToSymSW, forceSWArg  , SBVExpr(..), newExpr  , cache, Cached, uncache, uncacheAI, HasKind(..)- , Op(..), PBOp(..), FPOp(..), NamedSymVar, getTableIndex+ , Op(..), PBOp(..), FPOp(..), StrOp(..), RegExp(..), NamedSymVar, getTableIndex  , SBVPgm(..), Symbolic, runSymbolic, State, getPathCondition, extendPathCondition  , inSMTMode, SBVRunMode(..), Kind(..), Outputtable(..), Result(..)  , SolverContext(..), internalVariable, internalConstraint, isCodeGenMode@@ -130,6 +130,22 @@ -- | IEEE-754 double-precision floating point numbers type SDouble = SBV Double +-- | A symbolic character. Note that, as far as SBV's symbolic strings are concerned, a character+-- is currently an 8-bit unsigned value, corresponding to the ISO-8859-1 (Latin-1) character+-- set: <http://en.wikipedia.org/wiki/ISO/IEC_8859-1>. A Haskell 'Char', on the other hand, is based+-- on unicode. Therefore, there isn't a 1-1 correspondence between a Haskell character and an SBV+-- character for the time being. This limitation is due to the SMT-solvers only supporting this+-- particular subset. However, there is a pending proposal to add support for unicode, and SBV+-- will track these changes to have full unicode support as solvers become available. For+-- details, see: <http://smtlib.cs.uiowa.edu/theories-UnicodeStrings.shtml>+type SChar = SBV Char++-- | A symbolic string. Note that a symbolic string is /not/ a list of symbolic characters,+-- that is, it is not the case that @SString = [SChar]@, unlike what one might expect following+-- Haskell strings. An 'SString' is a symbolic value of its own, of possibly arbitrary length,+-- and internally processed as one unit as opposed to a fixed-length list of characters.+type SString = SBV String+ -- | 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@@ -205,13 +221,13 @@ sRTZ :: SRoundingMode sRTZ = sRoundTowardZero --- Not particularly "desirable," when the value is symbolic, but we do need this--- instance as otherwise we cannot simply evaluate Haskell functions that return--- symbolic values and have their constant values printed easily!+-- | A 'Show' instance is not particularly "desirable," when the value is symbolic,+-- but we do need this instance as otherwise we cannot simply evaluate Haskell functions +-- that return symbolic values and have their constant values printed easily! instance Show (SBV a) where   show (SBV sv) = show sv --- Equality constraint on SBV values. Not desirable since we can't really compare two+-- | Equality constraint on SBV values. Not desirable since we can't really compare two -- symbolic values, but will do. Note that we do need this instance since we want -- Bits as a class for SBV that we implement, which necessiates the Eq class. instance Eq (SBV a) where
Data/SBV/Core/Floating.hs view
@@ -18,8 +18,6 @@        , 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)@@ -249,7 +247,7 @@ 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+                           case unliteral =<< mbRm of                              Nothing                     -> (Just . literal) (op v)                              Just RoundNearestTiesToEven -> (Just . literal) (op v)                              _                           -> Nothing@@ -259,7 +257,7 @@ concEval2 mbOp mbRm a b  = do op <- mbOp                               v1 <- unliteral a                               v2 <- unliteral b-                              case join (unliteral `fmap` mbRm) of+                              case unliteral =<< mbRm of                                 Nothing                     -> (Just . literal) (v1 `op` v2)                                 Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2)                                 _                           -> Nothing@@ -269,7 +267,7 @@ concEval2B mbOp mbRm a b  = do op <- mbOp                                v1 <- unliteral a                                v2 <- unliteral b-                               case join (unliteral `fmap` mbRm) of+                               case unliteral =<< mbRm of                                  Nothing                     -> (Just . literal) (v1 `op` v2)                                  Just RoundNearestTiesToEven -> (Just . literal) (v1 `op` v2)                                  _                           -> Nothing@@ -280,7 +278,7 @@                                v1 <- unliteral a                                v2 <- unliteral b                                v3 <- unliteral c-                               case join (unliteral `fmap` mbRm) of+                               case unliteral =<< mbRm of                                  Nothing                     -> (Just . literal) (op v1 v2 v3)                                  Just RoundNearestTiesToEven -> (Just . literal) (op v1 v2 v3)                                  _                           -> Nothing
Data/SBV/Core/Kind.hs view
@@ -9,9 +9,11 @@ -- Internal data-structures for the sbv library ----------------------------------------------------------------------------- -{-# LANGUAGE    DefaultSignatures   #-}-{-# LANGUAGE    ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans   #-}+{-# LANGUAGE    DefaultSignatures    #-}+{-# LANGUAGE    FlexibleInstances    #-}+{-# LANGUAGE    ScopedTypeVariables  #-}+{-# LANGUAGE    TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans    #-}  module Data.SBV.Core.Kind (Kind(..), HasKind(..), constructUKind) where @@ -29,6 +31,8 @@           | KUserSort String (Either String [String])  -- name. Left: uninterpreted. Right: enum constructors.           | KFloat           | KDouble+          | KChar+          | KString  -- | Helper for Eq/Ord instances below kindRank :: Kind -> Either Int (Either (Bool, Int) String)@@ -39,6 +43,8 @@ kindRank (KUserSort s _) = Right (Right s) kindRank KFloat          = Left 3 kindRank KDouble         = Left 4+kindRank KChar           = Left 5+kindRank KString         = Left 6 {-# INLINE kindRank #-}  -- | We want to equate user-sorts only by name@@ -58,6 +64,8 @@   show (KUserSort s _)    = s   show KFloat             = "SFloat"   show KDouble            = "SDouble"+  show KString            = "SString"+  show KChar              = "SChar"  instance Eq  G.DataType where    a == b = G.tyconUQname (G.dataTypeName a) == G.tyconUQname (G.dataTypeName b)@@ -75,6 +83,8 @@     KReal        -> True     KFloat       -> True     KDouble      -> True+    KString      -> False+    KChar        -> False     KUserSort{}  -> False  -- | Construct an uninterpreted/enumerated kind from a piece of data; we distinguish simple enumerations as those@@ -97,9 +107,10 @@                           _              -> 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.+-- minimal complete definition: kindOf, unless you can take advantage of the default+-- signature: This class can be automatically derived for data-types that have+-- a 'Data' instance; this is useful for creating uninterpreted sorts. So, in+-- reality, end users should almost never need to define any methods. class HasKind a where   kindOf          :: a -> Kind   hasSign         :: a -> Bool@@ -111,6 +122,8 @@   isDouble        :: a -> Bool   isInteger       :: a -> Bool   isUninterpreted :: a -> Bool+  isChar          :: a -> Bool+  isString        :: a -> Bool   showType        :: a -> String   -- defaults   hasSign x = kindHasSign (kindOf x)@@ -121,6 +134,8 @@                   KReal         -> error "SBV.HasKind.intSizeOf((S)Real)"                   KFloat        -> error "SBV.HasKind.intSizeOf((S)Float)"                   KDouble       -> error "SBV.HasKind.intSizeOf((S)Double)"+                  KString       -> error "SBV.HasKind.intSizeOf((S)Double)"+                  KChar         -> error "SBV.HasKind.intSizeOf((S)Char)"                   KUserSort s _ -> error $ "SBV.HasKind.intSizeOf: Uninterpreted sort: " ++ s   isBoolean       x | KBool{}      <- kindOf x = True                     | True                     = False@@ -136,6 +151,10 @@                     | True                     = False   isUninterpreted x | KUserSort{}  <- kindOf x = True                     | True                     = False+  isString        x | KString{}    <- kindOf x = True+                    | True                     = False+  isChar          x | KChar{}      <- kindOf x = True+                    | True                     = False   showType = show . kindOf    -- default signature for uninterpreted/enumerated kinds@@ -155,6 +174,8 @@ instance HasKind AlgReal where kindOf _ = KReal instance HasKind Float   where kindOf _ = KFloat instance HasKind Double  where kindOf _ = KDouble+instance HasKind Char    where kindOf _ = KChar+instance HasKind String  where kindOf _ = KString  instance HasKind Kind where   kindOf = id
Data/SBV/Core/Model.hs view
@@ -20,11 +20,7 @@ {-# LANGUAGE TypeOperators          #-} {-# LANGUAGE DefaultSignatures      #-} --- Keep GHC quiet.. I wish we can be more specific on these as opposed to module--- level turning of redundant-constraints. Note that his is not needed >= GHC 8.0.2--- since they removed this constraint from -Wall, see: https://ghc.haskell.org/trac/ghc/ticket/10635-{-# OPTIONS_GHC -fno-warn-orphans               #-}-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+{-# OPTIONS_GHC -fno-warn-orphans   #-}  module Data.SBV.Core.Model (     Mergeable(..), EqSymbolic(..), OrdSymbolic(..), SDivisible(..), Uninterpreted(..), Metric(..), assertSoft, SIntegral, SFiniteBits(..)@@ -33,8 +29,8 @@   , pbAtMost, pbAtLeast, pbExactly, pbLe, pbGe, pbEq, pbMutexed, pbStronglyMutexed   , 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+  , sInt64s, sInteger, sIntegers, sReal, sReals, sFloat, sFloats, sDouble, sDoubles, sChar, sChars, sString, sStrings, slet+  , sRealToSInteger, label, observe   , sAssert   , liftQRem, liftDMod, symbolicMergeWithKind   , genLiteral, genFromCW, genMkSymVar@@ -43,18 +39,22 @@   where  import Control.Monad        (when, unless, mplus)+import Control.Monad.Trans  (liftIO)+import Control.Monad.Reader (ask)  import GHC.Generics (U1(..), M1(..), (:*:)(..), K1(..)) import qualified GHC.Generics as G  import GHC.Stack -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 Data.Array  (Array, Ix, listArray, elems, bounds, rangeSize)+import Data.Bits   (Bits(..))+import Data.Char   (toLower, isDigit)+import Data.Int    (Int8, Int16, Int32, Int64)+import Data.List   (genericLength, genericIndex, genericTake, unzip4, unzip5, unzip6, unzip7, intercalate, isPrefixOf)+import Data.Maybe  (fromMaybe)+import Data.String (IsString(..))+import Data.Word   (Word8, Word16, Word32, Word64)  import Test.QuickCheck                         (Testable(..), Arbitrary(..)) import qualified Test.QuickCheck.Test    as QC (isSuccess)@@ -186,9 +186,24 @@   -- and in the presence of NaN's it would be incorrect to do any optimization   isConcretely _ _ = False +instance SymWord String where+  mkSymWord = genMkSymVar KString+  literal   = SBV . SVal KString . Left . CW KString . CWString+  fromCW (CW _ (CWString a)) = a+  fromCW c                   = error $ "SymWord.String: Unexpected non-string value: " ++ show c++instance SymWord Char where+  mkSymWord = genMkSymVar KChar+  literal c = SBV . SVal KChar . Left . CW KChar $ CWChar c+  fromCW (CW _ (CWChar a)) = a+  fromCW c                 = error $ "SymWord.String: Unexpected non-char value: " ++ show c++instance IsString SString where+  fromString = literal+ ------------------------------------------------------------------------------------ -- * Smart constructors for creating symbolic values. These are not strictly--- necessary, as they are mere aliases for 'symbolic' and 'symbolics', but +-- necessary, as they are mere aliases for 'symbolic' and 'symbolics', but -- they nonetheless make programming easier. ------------------------------------------------------------------------------------ -- | Declare an 'SBool'@@ -295,6 +310,22 @@ sDoubles :: [String] -> Symbolic [SDouble] sDoubles = symbolics +-- | Declare an 'SChar'+sChar :: String -> Symbolic SChar+sChar = symbolic++-- | Declare an 'SString'+sString :: String -> Symbolic SString+sString = symbolic++-- | Declare a list of 'SChar's+sChars :: [String] -> Symbolic [SChar]+sChars = symbolics++-- | Declare a list of 'SString's+sStrings :: [String] -> Symbolic [SString]+sStrings = 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@.@@ -319,6 +350,22 @@         r st = do xsw <- sbvToSW st x                   newExpr st k (SBVApp (Label m) [xsw]) +-- | Observe the value of an expression.  Such values are useful in model construction, as they are printed part of a satisfying model, or a+-- counter-example. The same works for quick-check as well. Useful when we want to see intermediate values, or expected/obtained+-- pairs in a particular run.+observe :: SymWord a => String -> SBV a -> Symbolic ()+observe m x+  | null m+  = error "SBV.observe: Bad empty name!"+  | map toLower m `elem` smtLibReservedNames+  = error $ "SBV.observe: The name chosen is reserved, please change it!: " ++ show m+  | "s" `isPrefixOf` m && all isDigit (drop 1 m)+  = error $ "SBV.observe: Names of the form sXXX are internal to SBV, please use a different name: " ++ show m+  | True+  = do st <- ask+       liftIO $ do xsw <- sbvToSW st x+                   recordObservable st 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. infix 4 .==, ./=@@ -336,8 +383,8 @@    -- | Symbolic membership test.   sElem    :: a -> [a] -> SBool+  {-# MINIMAL (.==) #-} -  -- minimal complete definition: .==   x ./= y = bnot (x .== y)    allEqual []     = true@@ -371,7 +418,8 @@   -- | Is the value withing the allowed /inclusive/ range?   inRange    :: a -> (a, a) -> SBool -  -- minimal complete definition: .<+  {-# MINIMAL (.<) #-}+   a .<= b    = a .< b ||| a .== b   a .>  b    = b .<  a   a .>= b    = b .<= a@@ -820,6 +868,8 @@                       k@KBounded{}  -> error $ "Unexpected Fractional case for: " ++ show k                       k@KUnbounded  -> error $ "Unexpected Fractional case for: " ++ show k                       k@KBool       -> error $ "Unexpected Fractional case for: " ++ show k+                      k@KString     -> error $ "Unexpected Fractional case for: " ++ show k+                      k@KChar       -> error $ "Unexpected Fractional case for: " ++ show k                       k@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@@ -901,7 +951,7 @@     | True     = error $ "SBV.popCount: Called on symbolic value: " ++ show x ++ ". Use sPopCount instead." --- | Conversion between integral-symbolic values, akin to Haskell's fromIntegral+-- | 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@@ -1019,7 +1069,7 @@ -- | 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+-- However, 'quotRem' and 'divMod' both make 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@@ -1222,7 +1272,7 @@ -- 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+-- 'Documentation.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@@ -1513,7 +1563,9 @@   -- by end-user-code, but is rather useful for the library development.   sbvUninterpret :: Maybe ([String], a) -> String -> a -  -- minimal complete definition: 'sbvUninterpret'+  {-# MINIMAL sbvUninterpret #-}++  -- defaults:   uninterpret             = sbvUninterpret Nothing   cgUninterpret nm code v = sbvUninterpret (Just (code, v)) nm @@ -1770,22 +1822,26 @@ -- 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 ++ ")"+  property _                       = error "Quick-check: Constant folding produced a symbolic value! Perhaps used a non-reducible expression? Please report!"  instance Testable (Symbolic SBool) where-   property prop = QC.monadicIO $ do (cond, r, tvals) <- QC.run test+   property prop = QC.monadicIO $ do (cond, r, modelVals) <- QC.run test                                      QC.pre cond-                                     unless (r || null tvals) $ QC.monitor (QC.counterexample (complain tvals))+                                     unless (r || null modelVals) $ QC.monitor (QC.counterexample (complain modelVals))                                      QC.assert r-     where test = do (r, Result{resTraces=tvals, resConsts=cs, resConstraints=cstrs, resUIConsts=unints}) <- runSymbolic Concrete prop+     where test = do (r, Result{resTraces=tvals, resObservables=ovals, resConsts=cs, resConstraints=cstrs, resUIConsts=unints}) <- runSymbolic Concrete prop                       let cval = fromMaybe (error "Cannot quick-check in the presence of uninterpeted constants!") . (`lookup` cs)                          cond = all (cwToBool . cval . snd) cstrs +                         getObservable (nm, v) = case v `lookup` cs of+                                                   Just cw -> (nm, cw)+                                                   Nothing -> error $ "Quick-check: Observable " ++ nm ++ " did not reduce to a constant!"+                      case map fst unints of                        [] -> case unliteral r of                                Nothing -> noQC [show r]-                               Just b  -> return (cond, b, tvals)+                               Just b  -> return (cond, b, tvals ++ map getObservable ovals)                        us -> noQC us             complain qcInfo = showModel defaultSMTCfg (SMTModel [] qcInfo)
Data/SBV/Core/Operations.hs view
@@ -15,7 +15,7 @@   (   -- ** Basic constructors     svTrue, svFalse, svBool-  , svInteger, svFloat, svDouble, svReal, svEnumFromThenTo+  , svInteger, svFloat, svDouble, svReal, svEnumFromThenTo, svString, svChar   -- ** Basic destructors   , svAsBool, svAsInteger, svNumerator, svDenominator   -- ** Basic operations@@ -77,6 +77,14 @@ svDouble :: Double -> SVal svDouble d = SVal KDouble (Left $! CW KDouble (CWDouble d)) +-- | Convert from a String+svString :: String -> SVal+svString s = SVal KString (Left $! CW KString (CWString s))++-- | Convert from a Char+svChar :: Char -> SVal+svChar c = SVal KChar (Left $! CW KChar (CWChar c))+ -- | Convert from a Rational svReal :: Rational -> SVal svReal d = SVal KReal (Left $! CW KReal (CWAlgReal (fromRational d)))@@ -158,12 +166,22 @@  -- | 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+svExp b e+  | Just x <- svAsInteger e+  = if x >= 0 then let go n v+                        | n == 0 = one+                        | even n =             go (n `div` 2) (svTimes v v)+                        | True   = svTimes v $ go (n `div` 2) (svTimes v v)+                   in  go x b+              else error $ "svExp: exponentiation: negative exponent: " ++ show x+  | not (isBounded e) || hasSign e+  = error $ "svExp: exponentiation only works with unsigned bounded symbolic exponents, kind: " ++ show (kindOf e)+  | 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]@@ -252,39 +270,39 @@  -- | Equality. svEqual :: SVal -> SVal -> SVal-svEqual = liftSym2B (mkSymOpSC (eqOptBool Equal trueSW) Equal) rationalCheck (==) (==) (==) (==) (==)+svEqual = liftSym2B (mkSymOpSC (eqOptBool Equal trueSW) Equal) rationalCheck (==) (==) (==) (==) (==) (==) (==)  -- | Inequality. svNotEqual :: SVal -> SVal -> SVal-svNotEqual = liftSym2B (mkSymOpSC (eqOptBool NotEqual falseSW) NotEqual) rationalCheck (/=) (/=) (/=) (/=) (/=)+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+  | 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+  | 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+  | 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+  | True            = liftSym2B (mkSymOpSC (eqOpt trueSW) GreaterEq) rationalCheck (>=) (>=) (>=) (>=) (>=) (>=) (uiLift ">=" (>=)) x y  -- | Bitwise and. svAnd :: SVal -> SVal -> SVal@@ -783,8 +801,20 @@ noUnint2 :: (Maybe Int, String) -> (Maybe Int, String) -> a noUnint2 x y = error $ "Unexpected binary operation called on uninterpreted/enumerated values: " ++ show (x, y) +noCharLift :: Char -> a+noCharLift x = error $ "Unexpected operation called on char: " ++ show x++noStringLift :: String -> a+noStringLift x = error $ "Unexpected operation called on string: " ++ show x++noCharLift2 :: Char -> Char -> a+noCharLift2 x y = error $ "Unexpected binary operation called on chars: " ++ show (x, y)++noStringLift2 :: String -> String -> a+noStringLift2 x y = error $ "Unexpected binary operation called on strings: " ++ 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 _   opCR opCI opCF opCD   (SVal k (Left a)) = SVal k . Left  $! mapCW opCR opCI opCF opCD noCharLift noStringLift noUnint a liftSym1 opS _    _    _    _    a@(SVal k _)        = SVal k $ Right $ cache c    where c st = do swa <- svToSW st a                    opS st k swa@@ -796,12 +826,12 @@                   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 _   okCW opCR opCI opCF opCD   (SVal k (Left a)) (SVal _ (Left b)) | okCW a b = SVal k . Left  $! mapCW2 opCR opCI opCF opCD noCharLift2 noStringLift2 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+liftSym2B :: (State -> Kind -> SW -> SW -> IO SW) -> (CW -> CW -> Bool) -> (AlgReal -> AlgReal -> Bool) -> (Integer -> Integer -> Bool) -> (Float -> Float -> Bool) -> (Double -> Double -> Bool) -> (Char -> Char -> Bool) -> (String -> String -> Bool) -> ((Maybe Int, String) -> (Maybe Int, String) -> Bool) -> SVal -> SVal -> SVal+liftSym2B _   okCW opCR opCI opCF opCD opCC opCS opUI (SVal _ (Left a)) (SVal _ (Left b)) | okCW a b = svBool (liftCW2 opCR opCI opCF opCD opCC opCS 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)
Data/SBV/Core/Symbolic.hs view
@@ -27,7 +27,7 @@ module Data.SBV.Core.Symbolic   ( NodeId(..)   , SW(..), swKind, trueSW, falseSW-  , Op(..), PBOp(..), FPOp(..)+  , Op(..), PBOp(..), FPOp(..), StrOp(..), RegExp(..)   , Quantifier(..), needsExistentials   , RoundingMode(..)   , SBVType(..), newUninterpreted, addAxiom@@ -43,7 +43,7 @@   , getTableIndex   , SBVPgm(..), Symbolic, runSymbolic, State(..), withNewIncState, IncState(..), incrementInternalCounter   , inSMTMode, SBVRunMode(..), IStage(..), Result(..)-  , registerKind, registerLabel+  , registerKind, registerLabel, recordObservable   , addAssertion, addNewSMTOption, imposeConstraint, internalConstraint, internalVariable   , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension   , SolverCapabilities(..)@@ -65,6 +65,7 @@ import Data.IORef               (IORef, newIORef, readIORef) import Data.List                (intercalate, sortBy) import Data.Maybe               (isJust, fromJust, fromMaybe)+import Data.String              (IsString(fromString))  import Data.Time (getCurrentTime, UTCTime) @@ -83,7 +84,8 @@ import Data.SBV.Core.Kind import Data.SBV.Core.Concrete import Data.SBV.SMT.SMTLibNames-import Data.SBV.Utils.TDiff(Timing)+import Data.SBV.Utils.TDiff (Timing)+import Data.SBV.Utils.Lib   (stringToQFS)  import Data.SBV.Control.Types @@ -152,6 +154,7 @@         | Label String                          -- Essentially no-op; useful for code generation to emit comments.         | IEEEFP FPOp                           -- Floating-point ops, categorized separately         | PseudoBoolean PBOp                    -- Pseudo-boolean ops, categorized separately+        | StrOp StrOp                           -- String ops, categorized separately         deriving (Eq, Ord)  -- | Floating point operations@@ -218,6 +221,106 @@           | PB_Eq      [Int] Int  -- ^ Exactly k,  with coefficients given. Generalized PB_Exactly           deriving (Eq, Ord, Show) +-- | String operations. Note that we do not define `StrAt` as it translates to `StrSubStr` trivially.+data StrOp = StrConcat       -- ^ Concatenation of one or more strings+           | StrLen          -- ^ String length+           | StrUnit         -- ^ Unit string+           | StrSubstr       -- ^ Retrieves substring of @s@ at @offset@+           | StrIndexOf      -- ^ Retrieves first position of @sub@ in @s@, @-1@ if there are no occurrences+           | StrContains     -- ^ Does @s@ contain the substring @sub@?+           | StrPrefixOf     -- ^ Is @pre@ a prefix of @s@?+           | StrSuffixOf     -- ^ Is @suf@ a suffix of @s@?+           | StrReplace      -- ^ Replace the first occurrence of @src@ by @dst@ in @s@+           | StrStrToNat     -- ^ Retrieve integer encoded by string @s@ (ground rewriting only)+           | StrNatToStr     -- ^ Retrieve string encoded by integer @i@ (ground rewriting only)+           | StrInRe RegExp  -- ^ Check if string is in the regular expression+           deriving (Eq, Ord)++-- | Regular expressions. Note that regular expressions themselves are+-- concrete, but the `match` function from the 'RegExpMatchable' class+-- can check membership against a symbolic string/character. Also, we+-- are preferring a datatype approach here, as opposed to coming up with+-- some string-representation; there are way too many alternatives+-- already so inventing one isn't a priority. Please get in touch if you+-- would like a parser for this type as it might be easier to use.+data RegExp = Literal String       -- ^ Precisely match the given string+            | All                  -- ^ Accept every string+            | None                 -- ^ Accept no strings+            | Range Char Char      -- ^ Accept range of characters+            | Conc  [RegExp]       -- ^ Concatenation+            | KStar RegExp         -- ^ Kleene Star: Zero or more+            | KPlus RegExp         -- ^ Kleene Plus: One or more+            | Opt   RegExp         -- ^ Zero or one+            | Loop  Int Int RegExp -- ^ From @n@ repetitions to @m@ repetitions+            | Union [RegExp]       -- ^ Union of regular expressions+            | Inter RegExp RegExp  -- ^ Intersection of regular expressions+            deriving (Eq, Ord)++-- | With overloaded strings, we can have direct literal regular expressions.+instance IsString RegExp where+  fromString = Literal++-- | Regular expressions as a 'Num' instance. Note that+-- only `+` (union) and `*` (concatenation) make sense.+instance Num RegExp where+  -- flatten the concats to make them simpler+  Conc xs * y = Conc (xs ++ [y])+  x * Conc ys = Conc (x  :  ys)+  x * y       = Conc [x, y]++  -- flatten the unions to make them simpler+  Union xs + y = Union (xs ++ [y])+  x + Union ys = Union (x  : ys)+  x + y        = Union [x, y]++  abs         = error "Num.RegExp: no abs method"+  signum      = error "Num.RegExp: no signum method"++  fromInteger x+    | x == 0    = None+    | x == 1    = Literal ""   -- Unit for concatenation is the empty string+    | True      = error $ "Num.RegExp: Only 0 and 1 makes sense as a reg-exp, no meaning for: " ++ show x++  negate      = error "Num.RegExp: no negate method"++-- | Show instance for `RegExp`. The mapping is done so the outcome matches the+-- SMTLib string reg-exp operations+instance Show RegExp where+  show (Literal s)       = "(str.to.re \"" ++ stringToQFS s ++ "\")"+  show All               = "re.allchar"+  show None              = "re.nostr"+  show (Range ch1 ch2)   = "(re.range \"" ++ stringToQFS [ch1] ++ "\" \"" ++ stringToQFS [ch2] ++ "\")"+  show (Conc [])         = show (1 :: Integer)+  show (Conc [x])        = show x+  show (Conc xs)         = "(re.++ " ++ unwords (map show xs) ++ ")"+  show (KStar r)         = "(re.* " ++ show r ++ ")"+  show (KPlus r)         = "(re.+ " ++ show r ++ ")"+  show (Opt   r)         = "(re.opt " ++ show r ++ ")"+  show (Loop  lo hi r)+     | lo >= 0, hi >= lo = "((_ re.loop " ++ show lo ++ " " ++ show hi ++ ") " ++ show r ++ ")"+     | True              = error $ "Invalid regular-expression Loop with arguments: " ++ show (lo, hi)+  show (Inter r1 r2)     = "(re.inter " ++ show r1 ++ " " ++ show r2 ++ ")"+  show (Union [])        = "re.nostr"+  show (Union [x])       = show x+  show (Union xs)        = "(re.union " ++ unwords (map show xs) ++ ")"++-- | Show instance for `StrOp`. Note that the mapping here is+-- important to match the SMTLib equivalents, see here: <https://rise4fun.com/z3/tutorialcontent/sequences>+instance Show StrOp where+  show StrConcat   = "str.++"+  show StrLen      = "str.len"+  show StrUnit     = "seq.unit"      -- NB. The "seq" prefix is intentional; works uniformly.+  show StrSubstr   = "str.substr"+  show StrIndexOf  = "str.indexof"+  show StrContains = "str.contains"+  show StrPrefixOf = "str.prefixof"+  show StrSuffixOf = "str.suffixof"+  show StrReplace  = "str.replace"+  show StrStrToNat = "str.to.int"    -- NB. SMTLib uses "int" here though only nats are supported+  show StrNatToStr = "int.to.str"    -- NB. SMTLib uses "int" here though only nats are supported+  -- Note the breakage here with respect to argument order. We fix this explicitly later.+  show (StrInRe s) = "str.in.re " ++ show s+ -- Show instance for 'Op'. Note that this is largely for debugging purposes, not used -- for being read by any tool. instance Show Op where@@ -236,6 +339,7 @@   show (Label s)         = "[label] " ++ s   show (IEEEFP w)        = show w   show (PseudoBoolean p) = show p+  show (StrOp s)         = show s   show op     | Just s <- op `lookup` syms = s     | True                       = error "impossible happened; can't find op!"@@ -356,6 +460,7 @@ -- | 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)+                     , resObservables :: [(String, SW)]                                   -- ^ observable expressions (part of the model)                      , resUISegs      :: [(String, [String])]                             -- ^ uninterpeted code segments                      , resInputs      :: ([(Quantifier, NamedSymVar)], [NamedSymVar])     -- ^ inputs (possibly existential) + tracker vars                      , resConsts      :: [(SW, CW)]                                       -- ^ constants@@ -377,7 +482,7 @@   show Result{resConsts=cs, resOutputs=[r]}     | Just c <- r `lookup` cs     = show c-  show (Result kinds _ cgs is cs ts as uis axs xs cstrs asserts os) = intercalate "\n" $+  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 (fst is)@@ -551,6 +656,7 @@                     , runMode      :: IORef SBVRunMode                     , rIncState    :: IORef IncState                     , rCInfo       :: IORef [(String, CW)]+                    , rObservables :: IORef [(String, SW)]                     , rctr         :: IORef Int                     , rUsedKinds   :: IORef KindSet                     , rUsedLbls    :: IORef (Set.Set String)@@ -643,6 +749,10 @@         incState <- readIORef rIncState         R.modifyIORef' (field incState) update +-- | Add an observable+recordObservable :: State -> String -> SW -> IO ()+recordObservable st nm sw = modifyState st rObservables ((nm, sw):) (return ())+ -- | Increment the variable counter incrementInternalCounter :: State -> IO Int incrementInternalCounter st = do ctr <- readIORef (rctr st)@@ -912,6 +1022,7 @@    rm        <- newIORef currentRunMode    ctr       <- newIORef (-2) -- start from -2; False and True will always occupy the first two elements    cInfo     <- newIORef []+   observes  <- newIORef []    pgm       <- newIORef (SBVPgm S.empty)    emap      <- newIORef Map.empty    cmap      <- newIORef Map.empty@@ -937,6 +1048,7 @@                   , pathCond     = SVal KBool (Left trueCW)                   , rIncState    = istate                   , rCInfo       = cInfo+                  , rObservables = observes                   , rctr         = ctr                   , rUsedKinds   = usedKinds                   , rUsedLbls    = usedLbls@@ -975,6 +1087,7 @@ 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+                                       , rObservables=observes                                        } = do    SBVPgm rpgm  <- readIORef pgm    inpsO <- (reverse *** reverse) <$> readIORef inps@@ -991,9 +1104,10 @@    knds  <- readIORef usedKinds    cgMap <- Map.toList <$> readIORef cgs    traceVals  <- reverse <$> readIORef cInfo+   observables <- reverse <$> readIORef observes    extraCstrs <- reverse <$> readIORef cstrs    assertions <- reverse <$> readIORef asserts-   return $ Result knds traceVals cgMap inpsO cnsts tbls arrs unint axs (SBVPgm rpgm) extraCstrs assertions outsO+   return $ Result knds traceVals observables cgMap inpsO cnsts tbls arrs unint axs (SBVPgm rpgm) extraCstrs assertions outsO  -- | Add a new option addNewSMTOption :: SMTOption -> Symbolic ()@@ -1202,11 +1316,12 @@ #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+  rnf (Result kindInfo qcInfo obs cgs inps consts tbls arrs uis axs pgm cstr asserts outs)+        = rnf kindInfo `seq` rnf qcInfo  `seq` rnf obs    `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 ()@@ -1311,11 +1426,11 @@ -- 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 String    -- ^ Prover returned unknown, with the given reason-               | ProofError    SMTConfig [String]  -- ^ Prover errored out+data SMTResult = Unsatisfiable SMTConfig (Maybe [String]) -- ^ Unsatisfiable. If unsat-cores are enabled, they will be returned in the second parameter.+               | Satisfiable   SMTConfig SMTModel         -- ^ Satisfiable with model+               | SatExtField   SMTConfig SMTModel         -- ^ Prover returned a model, but in an extension field containing Infinite/epsilon+               | Unknown       SMTConfig String           -- ^ Prover returned unknown, with the given reason+               | ProofError    SMTConfig [String]         -- ^ Prover errored out  -- | A script, to be passed to the solver. data SMTScript = SMTScript {
− Data/SBV/Examples/BitPrecise/BitTricks.hs 
@@ -1,59 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.BitPrecise.BitTricks--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Checks the correctness of a few tricks from the large collection found in:---      <https://graphics.stanford.edu/~seander/bithacks.html>--------------------------------------------------------------------------------module Data.SBV.Examples.BitPrecise.BitTricks where--import Data.SBV---- | Formalizes <https://graphics.stanford.edu/~seander/bithacks.html#IntegerMinOrMax>-fastMinCorrect :: SInt32 -> SInt32 -> SBool-fastMinCorrect x y = m .== fm-  where m  = ite (x .< y) x y-        fm = y `xor` ((x `xor` y) .&. (-(oneIf (x .< y))));---- | Formalizes <https://graphics.stanford.edu/~seander/bithacks.html#IntegerMinOrMax>-fastMaxCorrect :: SInt32 -> SInt32 -> SBool-fastMaxCorrect x y = m .== fm-  where m  = ite (x .< y) y x-        fm = x `xor` ((x `xor` y) .&. (-(oneIf (x .< y))));---- | Formalizes <https://graphics.stanford.edu/~seander/bithacks.html#DetectOppositeSigns>-oppositeSignsCorrect :: SInt32 -> SInt32 -> SBool-oppositeSignsCorrect x y = r .== os-  where r  = (x .< 0 &&& y .>= 0) ||| (x .>= 0 &&& y .< 0)-        os = (x `xor` y) .< 0---- | Formalizes <https://graphics.stanford.edu/~seander/bithacks.html#ConditionalSetOrClearBitsWithoutBranching>-conditionalSetClearCorrect :: SBool -> SWord32 -> SWord32 -> SBool-conditionalSetClearCorrect f m w = r .== r'-  where r  = ite f (w .|. m) (w .&. complement m)-        r' = w `xor` ((-(oneIf f) `xor` w) .&. m);---- | Formalizes <https://graphics.stanford.edu/~seander/bithacks.html#DetermineIfPowerOf2>-powerOfTwoCorrect :: SWord32 -> SBool-powerOfTwoCorrect v = f .== s-  where f = (v ./= 0) &&& ((v .&. (v-1)) .== 0);-        powers :: [Word32]-        powers = map ((2::Word32)^) [(0::Word32) .. 31]-        s = bAny (v .==) $ map literal powers---- | Collection of queries-queries :: IO ()-queries =-  let check :: Provable a => String -> a -> IO ()-      check w t = do putStr $ "Proving " ++ show w ++ ": "-                     print =<< prove t-  in do check "Fast min             " fastMinCorrect-        check "Fast max             " fastMaxCorrect-        check "Opposite signs       " oppositeSignsCorrect-        check "Conditional set/clear" conditionalSetClearCorrect-        check "PowerOfTwo           " powerOfTwoCorrect
− Data/SBV/Examples/BitPrecise/Legato.hs 
@@ -1,323 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.BitPrecise.Legato--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ An encoding and correctness proof of Legato's multiplier in Haskell. Bill Legato came--- up with an interesting way to multiply two 8-bit numbers on Mostek, as described here:---   <http://www.cs.utexas.edu/~moore/acl2/workshop-2004/contrib/legato/Weakest-Preconditions-Report.pdf>------ Here's Legato's algorithm, as coded in Mostek assembly:------ @---    step1 :       LDX #8         ; load X immediate with the integer 8 ---    step2 :       LDA #0         ; load A immediate with the integer 0 ---    step3 : LOOP  ROR F1         ; rotate F1 right circular through C ---    step4 :       BCC ZCOEF      ; branch to ZCOEF if C = 0 ---    step5 :       CLC            ; set C to 0 ---    step6 :       ADC F2         ; set A to A+F2+C and C to the carry ---    step7 : ZCOEF ROR A          ; rotate A right circular through C ---    step8 :       ROR LOW        ; rotate LOW right circular through C ---    step9 :       DEX            ; set X to X-1 ---    step10:       BNE LOOP       ; branch to LOOP if Z = 0 --- @------ This program came to be known as the Legato's challenge in the community, where--- the challenge was to prove that it indeed does perform multiplication. This file--- formalizes the Mostek architecture in Haskell and proves that Legato's algorithm--- is indeed correct.--------------------------------------------------------------------------------{-# LANGUAGE DeriveGeneric  #-}-{-# LANGUAGE DeriveAnyClass #-}--module Data.SBV.Examples.BitPrecise.Legato where--import Data.Array (Array, Ix(..), (!), (//), array)--import Data.SBV-import Data.SBV.Tools.CodeGen-import Data.SBV.Internals (Timing(PrintTiming))--import GHC.Generics (Generic)----------------------------------------------------------------------- * Mostek architecture---------------------------------------------------------------------- | The memory is addressed by 32-bit words.-type Address  = SWord32---- | We model only two registers of Mostek that is used in the above algorithm, can add more.-data Register = RegX  | RegA  deriving (Eq, Ord, Ix, Bounded, Enum)---- | The carry flag ('FlagC') and the zero flag ('FlagZ')-data Flag = FlagC | FlagZ deriving (Eq, Ord, Ix, Bounded, Enum)---- | Mostek was an 8-bit machine.-type Value = SWord8---- | Convenient synonym for symbolic machine bits.-type Bit = SBool---- | Register bank-type Registers = Array Register Value---- | Flag bank-type Flags = Array Flag Bit---- | The memory maps 32-bit words to 8-bit words. (The 'Model' data-type is--- defined later, depending on the verification model used.)-type Memory = Model Word32 Word8        -- Model defined later---- | Abstraction of the machine: The CPU consists of memory, registers, and flags.--- Unlike traditional hardware, we assume the program is stored in some other memory area that--- we need not model. (No self modifying programs!)------ 'Mostek' is equipped with an automatically derived 'Mergeable' instance--- because each field is 'Mergeable'.-data Mostek = Mostek { memory    :: Memory-                     , registers :: Registers-                     , flags     :: Flags-                     } deriving (Generic, Mergeable)---- | Given a machine state, compute a value out of it-type Extract a = Mostek -> a---- | Programs are essentially state transformers (on the machine state)-type Program = Mostek -> Mostek----------------------------------------------------------------------- * Low-level operations----------------------------------------------------------------------- | Get the value of a given register-getReg :: Register -> Extract Value-getReg r m = registers m ! r---- | Set the value of a given register-setReg :: Register -> Value -> Program-setReg r v m = m {registers = registers m // [(r, v)]}---- | Get the value of a flag-getFlag :: Flag -> Extract Bit-getFlag f m = flags m ! f---- | Set the value of a flag-setFlag :: Flag -> Bit -> Program-setFlag f b m = m {flags = flags m // [(f, b)]}---- | Read memory-peek :: Address -> Extract Value-peek a m = readArray (memory m) a---- | Write to memory-poke :: Address -> Value -> Program-poke a v m = m {memory = writeArray (memory m) a v}---- | Checking overflow. In Legato's multipler the @ADC@ instruction--- needs to see if the expression x + y + c overflowed, as checked--- by this function. Note that we verify the correctness of this check--- separately below in `checkOverflowCorrect`.-checkOverflow :: SWord8 -> SWord8 -> SBool -> SBool-checkOverflow x y c = s .< x ||| s .< y ||| s' .< s-  where s  = x + y-        s' = s + ite c 1 0---- | Correctness theorem for our `checkOverflow` implementation.------   We have:------   >>> checkOverflowCorrect---   Q.E.D.-checkOverflowCorrect :: IO ThmResult-checkOverflowCorrect = checkOverflow === overflow-  where -- Reference spec for overflow. We do the addition-        -- using 16 bits and check that it's larger than 255-        overflow :: SWord8 -> SWord8 -> SBool -> SBool-        overflow x y c = (0 # x) + (0 # y) + ite c 1 0 .> 255---------------------------------------------------------------------- * Instruction set----------------------------------------------------------------------- | An instruction is modeled as a 'Program' transformer. We model--- mostek programs in direct continuation passing style.-type Instruction = Program -> Program---- | LDX: Set register @X@ to value @v@-ldx :: Value -> Instruction-ldx v k = k . setReg RegX v---- | LDA: Set register @A@ to value @v@-lda :: Value -> Instruction-lda v k = k . setReg RegA v---- | CLC: Clear the carry flag-clc :: Instruction-clc k = k . setFlag FlagC false---- | ROR, memory version: Rotate the value at memory location @a@--- to the right by 1 bit, using the carry flag as a transfer position.--- That is, the final bit of the memory location becomes the new carry--- and the carry moves over to the first bit. This very instruction--- is one of the reasons why Legato's multiplier is quite hard to understand--- and is typically presented as a verification challenge.-rorM :: Address -> Instruction-rorM a k m = k . setFlag FlagC c' . poke a v' $ m-  where v  = peek a m-        c  = getFlag FlagC m-        v' = setBitTo (v `rotateR` 1) 7 c-        c' = sTestBit v 0---- | ROR, register version: Same as 'rorM', except through register @r@.-rorR :: Register -> Instruction-rorR r k m = k . setFlag FlagC c' . setReg r v' $ m-  where v  = getReg r m-        c  = getFlag FlagC m-        v' = setBitTo (v `rotateR` 1) 7 c-        c' = sTestBit v 0---- | BCC: branch to label @l@ if the carry flag is false-bcc :: Program -> Instruction-bcc l k m = ite (c .== false) (l m) (k m)-  where c = getFlag FlagC m---- | ADC: Increment the value of register @A@ by the value of memory contents--- at address @a@, using the carry-bit as the carry-in for the addition.-adc :: Address -> Instruction-adc a k m = k . setFlag FlagZ (v' .== 0) . setFlag FlagC c' . setReg RegA v' $ m-  where v  = peek a m-        ra = getReg RegA m-        c  = getFlag FlagC m-        v' = v + ra + ite c 1 0-        c' = checkOverflow v ra c---- | DEX: Decrement the value of register @X@-dex :: Instruction-dex k m = k . setFlag FlagZ (x .== 0) . setReg RegX x $ m-  where x = getReg RegX m - 1---- | BNE: Branch if the zero-flag is false-bne :: Program -> Instruction-bne l k m = ite (z .== false) (l m) (k m)-  where z = getFlag FlagZ m---- | The 'end' combinator "stops" our program, providing the final continuation--- that does nothing.-end :: Program-end = id----------------------------------------------------------------------- * Legato's algorithm in Haskell/SBV----------------------------------------------------------------------- | Parameterized by the addresses of locations of the factors (@F1@ and @F2@),--- the following program multiplies them, storing the low-byte of the result--- in the memory location @lowAddr@, and the high-byte in register @A@. The--- implementation is a direct transliteration of Legato's algorithm given--- at the top, using our notation.-legato :: Address -> Address -> Address -> Program-legato f1Addr f2Addr lowAddr = start-  where start   =    ldx 8-                   $ lda 0-                   $ loop-        loop    =    rorM f1Addr-                   $ bcc zeroCoef-                   $ clc-                   $ adc f2Addr-                   $ zeroCoef-        zeroCoef =   rorR RegA-                   $ rorM lowAddr-                   $ dex-                   $ bne loop-                   $ end----------------------------------------------------------------------- * Verification interface---------------------------------------------------------------------- | Given address/value pairs for F1 and F2, and the location of where the low-byte--- of the result should go, @runLegato@ takes an arbitrary machine state @m@ and--- returns the high and low bytes of the multiplication.-runLegato :: (Address, Value) -> (Address, Value) -> Address -> Mostek -> (Value, Value)-runLegato (f1Addr, f1Val) (f2Addr, f2Val) loAddr m = (getReg RegA mFinal, peek loAddr mFinal)-  where m0     = poke f1Addr f1Val $ poke f2Addr f2Val m-        mFinal = legato f1Addr f2Addr loAddr m0---- | Helper synonym for capturing relevant bits of Mostek-type InitVals = ( Value      -- Content of Register X-                , Value      -- Content of Register A-                , Bit        -- Value of FlagC-                , Bit        -- Value of FlagZ-                )---- | Create an instance of the Mostek machine, initialized by the memory and the relevant--- values of the registers and the flags-initMachine :: Memory -> InitVals -> Mostek-initMachine mem (rx, ra, fc, fz) = Mostek { memory    = mem-                                          , registers = array (minBound, maxBound) [(RegX, rx),  (RegA, ra)]-                                          , flags     = array (minBound, maxBound) [(FlagC, fc), (FlagZ, fz)]-                                          }---- | The correctness theorem. For all possible memory configurations, the factors (@x@ and @y@ below), the location--- of the low-byte result and the initial-values of registers and the flags, this function will return True only if--- running Legato's algorithm does indeed compute the product of @x@ and @y@ correctly.-legatoIsCorrect :: Memory -> (Address, Value) -> (Address, Value) -> Address -> InitVals -> SBool-legatoIsCorrect mem (addrX, x) (addrY, y) addrLow initVals-        = distinct [addrX, addrY, addrLow]    -- note the conditional: addresses must be distinct!-                ==> result .== expected-    where (hi, lo) = runLegato (addrX, x) (addrY, y) addrLow (initMachine mem initVals)-          -- NB. perform the comparison over 16 bit values to avoid overflow!-          -- If Value changes to be something else, modify this accordingly.-          result, expected :: SWord16-          result   = 256 * (0 # hi) + (0 # lo)-          expected = (0 # x) * (0 # y)----------------------------------------------------------------------- * Verification----------------------------------------------------------------------- | Choose the appropriate array model to be used for modeling the memory. (See 'Memory'.)--- The 'SFunArray' is the function based model. 'SArray' is the SMT-Lib array's based model.-type Model = SFunArray--- type Model = SArray---- | The correctness theorem.--- On a 2011 MacBook, this proof takes about 1 minute 45 seconds with the 'SFunArray' memory model--- using boolector as the solver.-correctnessTheorem :: IO ThmResult-correctnessTheorem = proveWith boolector{timing = PrintTiming} $ do-        let mem = mkSFunArray (const 0)--        addrX <- sWord32 "addrX"-        x     <- sWord8  "x"--        addrY <- sWord32 "addrY"-        y     <- sWord8  "y"--        addrLow <- sWord32 "addrLow"--        regX  <- sWord8 "regX"-        regA  <- sWord8 "regA"--        flagC <- sBool "flagC"-        flagZ <- sBool "flagZ"--        return $ legatoIsCorrect mem (addrX, x) (addrY, y) addrLow (regX, regA, flagC, flagZ)----------------------------------------------------------------------- * C Code generation----------------------------------------------------------------------- | Generate a C program that implements Legato's algorithm automatically.-legatoInC :: IO ()-legatoInC = compileToC Nothing "runLegato" $ do-                x <- cgInput "x"-                y <- cgInput "y"-                let (hi, lo) = runLegato (0, x) (1, y) 2 (initMachine (mkSFunArray (const 0)) (0, 0, false, false))-                cgOutput "hi" hi-                cgOutput "lo" lo--{-# ANN legato ("HLint: ignore Redundant $" :: String)        #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
− Data/SBV/Examples/BitPrecise/MergeSort.hs 
@@ -1,95 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.BitPrecise.MergeSort--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Symbolic implementation of merge-sort and its correctness.--------------------------------------------------------------------------------module Data.SBV.Examples.BitPrecise.MergeSort where--import Data.SBV-import Data.SBV.Tools.CodeGen---------------------------------------------------------------------------------- * Implementing Merge-Sort--------------------------------------------------------------------------------- | Element type of lists we'd like to sort. For simplicity, we'll just--- use 'SWord8' here, but we can pick any symbolic type.-type E = SWord8---- | Merging two given sorted lists, preserving the order.-merge :: [E] -> [E] -> [E]-merge []     ys           = ys-merge xs     []           = xs-merge xs@(x:xr) ys@(y:yr) = ite (x .< y) (x : merge xr ys) (y : merge xs yr)---- | Simple merge-sort implementation. We simply divide the input list--- in two two halves so long as it has at least two elements, sort--- each half on its own, and then merge.-mergeSort :: [E] -> [E]-mergeSort []  = []-mergeSort [x] = [x]-mergeSort xs  = merge (mergeSort th) (mergeSort bh)-   where (th, bh) = splitAt (length xs `div` 2) xs---------------------------------------------------------------------------------- * Proving correctness--- ${props}-------------------------------------------------------------------------------{- $props-There are two main parts to proving that a sorting algorithm is correct:--       * Prove that the output is non-decreasing- -       * Prove that the output is a permutation of the input--}---- | Check whether a given sequence is non-decreasing.-nonDecreasing :: [E] -> SBool-nonDecreasing []       = true-nonDecreasing [_]      = true-nonDecreasing (a:b:xs) = a .<= b &&& nonDecreasing (b:xs)---- | Check whether two given sequences are permutations. We simply check that each sequence--- is a subset of the other, when considered as a set. The check is slightly complicated--- for the need to account for possibly duplicated elements.-isPermutationOf :: [E] -> [E] -> SBool-isPermutationOf as bs = go as (zip bs (repeat true)) &&& go bs (zip as (repeat true))-  where go []     _  = true-        go (x:xs) ys = let (found, ys') = mark x ys in found &&& go xs ys'-        -- Go and mark off an instance of 'x' in the list, if possible. We keep track-        -- of unmarked elements by associating a boolean bit. Note that we have to-        -- keep the lists equal size for the recursive result to merge properly.-        mark _ []         = (false, [])-        mark x ((y,v):ys) = ite (v &&& x .== y)-                                (true, (y, bnot v):ys)-                                (let (r, ys') = mark x ys in (r, (y,v):ys'))---- | Asserting correctness of merge-sort for a list of the given size. Note that we can--- only check correctness for fixed-size lists. Also, the proof will get more and more--- complicated for the backend SMT solver as 'n' increases. A value around 5 or 6 should--- be fairly easy to prove. For instance, we have:------ >>> correctness 5--- Q.E.D.-correctness :: Int -> IO ThmResult-correctness n = prove $ do xs <- mkFreeVars n-                           let ys = mergeSort xs-                           return $ nonDecreasing ys &&& isPermutationOf xs ys---------------------------------------------------------------------------------- * Generating C code---------------------------------------------------------------------------------- | Generate C code for merge-sorting an array of size 'n'. Again, we're restricted--- to fixed size inputs. While the output is not how one would code merge sort in C--- by hand, it's a faithful rendering of all the operations merge-sort would do as--- described by its Haskell counterpart.-codeGen :: Int -> IO ()-codeGen n = compileToC (Just ("mergeSort" ++ show n)) "mergeSort" $ do-                xs <- cgInputArr n "xs"-                cgOutputArr "ys" (mergeSort xs)
− Data/SBV/Examples/BitPrecise/MultMask.hs 
@@ -1,50 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.BitPrecise.MultMask--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ An SBV solution to the bit-precise puzzle of shuffling the bits in a--- 64-bit word in a custom order. The idea is to take a 64-bit value:------    @1.......2.......3.......4.......5.......6.......7.......8.......@------ And turn it into another 64-bit value, that looks like this:------    @12345678........................................................@------ We do not care what happens to the bits that are represented by dots. The--- problem is to do this with one mask and one multiplication.------ Apparently this operation has several applications, including in programs--- that play chess of all things. We use SBV to find the appropriate mask and--- the multiplier.------ Note that this is an instance of the program synthesis problem, where--- we "fill in the blanks" given a certain skeleton that satisfy a certain--- property, using quantified formulas.--------------------------------------------------------------------------------module Data.SBV.Examples.BitPrecise.MultMask where--import Data.SBV---- | Find the multiplier and the mask as described. We have:------ >>> maskAndMult--- Satisfiable. Model:---   mask = 0x8080808080808080 :: Word64---   mult = 0xc202040810204081 :: Word64------ That is, any 64 bit value masked by the first and multipled by the second--- value above will have its bits at positions @[7,15,23,31,39,47,55,63]@ moved--- to positions @[56,57,58,59,60,61,62,63]@ respectively.-maskAndMult :: IO ()-maskAndMult = print =<< satWith z3{printBase=16} find-  where find = do mask <- exists "mask"-                  mult <- exists "mult"-                  inp  <- forall "inp"-                  let res = (mask .&. inp) * (mult :: SWord64)-                  solve [inp `sExtractBits` [7, 15 .. 63] .== res `sExtractBits` [56 .. 63]]
− Data/SBV/Examples/BitPrecise/PrefixSum.hs 
@@ -1,97 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.BitPrecise.PrefixSum--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ The PrefixSum algorithm over power-lists and proof of--- the Ladner-Fischer implementation.--- See <http://dl.acm.org/citation.cfm?id=197356>--- and <http://www.cs.utexas.edu/~plaxton/c/337/05f/slides/ParallelRecursion-4.pdf>.--------------------------------------------------------------------------------{-# LANGUAGE Rank2Types          #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.SBV.Examples.BitPrecise.PrefixSum where--import Data.SBV--------------------------------------------------------------------------- * Formalizing power-lists--------------------------------------------------------------------------- | A poor man's representation of powerlists and--- basic operations on them: <http://dl.acm.org/citation.cfm?id=197356>--- We merely represent power-lists by ordinary lists.-type PowerList a = [a]---- | The tie operator, concatenation.-tiePL :: PowerList a -> PowerList a -> PowerList a-tiePL = (++)---- | The zip operator, zips the power-lists of the same size, returns--- a powerlist of double the size.-zipPL :: PowerList a -> PowerList a -> PowerList a-zipPL []     []     = []-zipPL (x:xs) (y:ys) = x : y : zipPL xs ys-zipPL _      _      = error "zipPL: nonsimilar powerlists received"---- | Inverse of zipping.-unzipPL :: PowerList a -> (PowerList a, PowerList a)-unzipPL = unzip . chunk2-  where chunk2 []       = []-        chunk2 (x:y:xs) = (x,y) : chunk2 xs-        chunk2 _        = error "unzipPL: malformed powerlist"--------------------------------------------------------------------------- * Reference prefix-sum implementation--------------------------------------------------------------------------- | Reference prefix sum (@ps@) is simply Haskell's @scanl1@ function.-ps :: (a, a -> a -> a) -> PowerList a -> PowerList a-ps (_, f) = scanl1 f--------------------------------------------------------------------------- * The Ladner-Fischer parallel version--------------------------------------------------------------------------- | The Ladner-Fischer (@lf@) implementation of prefix-sum. See <http://www.cs.utexas.edu/~plaxton/c/337/05f/slides/ParallelRecursion-4.pdf>--- or pg. 16 of <http://dl.acm.org/citation.cfm?id=197356>-lf :: (a, a -> a -> a) -> PowerList a -> PowerList a-lf _ []         = error "lf: malformed (empty) powerlist"-lf _ [x]        = [x]-lf (zero, f) pl = zipPL (zipWith f (rsh lfpq) p) lfpq-   where (p, q) = unzipPL pl-         pq     = zipWith f p q-         lfpq   = lf (zero, f) pq-         rsh xs = zero : init xs---------------------------------------------------------------------------- * Sample proofs for concrete operators--------------------------------------------------------------------------- | Correctness theorem, for a powerlist of given size, an associative operator, and its left-unit element.-flIsCorrect :: Int -> (forall a. (OrdSymbolic a, Num a, Bits a) => (a, a -> a -> a)) -> Symbolic SBool-flIsCorrect n zf = do-        args :: PowerList SWord32 <- mkForallVars n-        return $ ps zf args .== lf zf args---- | Proves Ladner-Fischer is equivalent to reference specification for addition.--- @0@ is the left-unit element, and we use a power-list of size @8@. We have:------ >>> thm1--- Q.E.D.-thm1 :: IO ThmResult-thm1 = prove $ flIsCorrect  8 (0, (+))---- | Proves Ladner-Fischer is equivalent to reference specification for the function @max@.--- @0@ is the left-unit element, and we use a power-list of size @16@. We have:------ >>> thm2--- Q.E.D.-thm2 :: IO ThmResult-thm2 = prove $ flIsCorrect 16 (0, smax)
− Data/SBV/Examples/CodeGeneration/AddSub.hs 
@@ -1,141 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.CodeGeneration.AddSub--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Simple code generation example.--------------------------------------------------------------------------------module Data.SBV.Examples.CodeGeneration.AddSub where--import Data.SBV-import Data.SBV.Tools.CodeGen---- | Simple function that returns add/sum of args-addSub :: SWord8 -> SWord8 -> (SWord8, SWord8)-addSub x y = (x+y, x-y)---- | Generate C code for addSub. Here's the output showing the generated C code:------ >>> genAddSub--- == BEGIN: "Makefile" ================--- # Makefile for addSub. Automatically generated by SBV. Do not edit!--- <BLANKLINE>--- # include any user-defined .mk file in the current directory.--- -include *.mk--- <BLANKLINE>--- CC?=gcc--- CCFLAGS?=-Wall -O3 -DNDEBUG -fomit-frame-pointer--- <BLANKLINE>--- all: addSub_driver--- <BLANKLINE>--- addSub.o: addSub.c addSub.h--- 	${CC} ${CCFLAGS} -c $< -o $@--- <BLANKLINE>--- addSub_driver.o: addSub_driver.c--- 	${CC} ${CCFLAGS} -c $< -o $@--- <BLANKLINE>--- addSub_driver: addSub.o addSub_driver.o--- 	${CC} ${CCFLAGS} $^ -o $@--- <BLANKLINE>--- clean:--- 	rm -f *.o--- <BLANKLINE>--- veryclean: clean--- 	rm -f addSub_driver--- == END: "Makefile" ==================--- == BEGIN: "addSub.h" ================--- /* Header file for addSub. Automatically generated by SBV. Do not edit! */--- <BLANKLINE>--- #ifndef __addSub__HEADER_INCLUDED__--- #define __addSub__HEADER_INCLUDED__--- <BLANKLINE>--- #include <stdio.h>--- #include <stdlib.h>--- #include <inttypes.h>--- #include <stdint.h>--- #include <stdbool.h>--- #include <string.h>--- #include <math.h>--- <BLANKLINE>--- /* The boolean type */--- typedef bool SBool;--- <BLANKLINE>--- /* The float type */--- typedef float SFloat;--- <BLANKLINE>--- /* The double type */--- typedef double SDouble;--- <BLANKLINE>--- /* Unsigned bit-vectors */--- typedef uint8_t  SWord8 ;--- typedef uint16_t SWord16;--- typedef uint32_t SWord32;--- typedef uint64_t SWord64;--- <BLANKLINE>--- /* Signed bit-vectors */--- typedef int8_t  SInt8 ;--- typedef int16_t SInt16;--- typedef int32_t SInt32;--- typedef int64_t SInt64;--- <BLANKLINE>--- /* Entry point prototype: */--- void addSub(const SWord8 x, const SWord8 y, SWord8 *sum,---             SWord8 *dif);--- <BLANKLINE>--- #endif /* __addSub__HEADER_INCLUDED__ */--- == END: "addSub.h" ==================--- == BEGIN: "addSub_driver.c" ================--- /* Example driver program for addSub. */--- /* Automatically generated by SBV. Edit as you see fit! */--- <BLANKLINE>--- #include <stdio.h>--- #include "addSub.h"--- <BLANKLINE>--- int main(void)--- {---   SWord8 sum;---   SWord8 dif;--- <BLANKLINE>---   addSub(132, 241, &sum, &dif);--- <BLANKLINE>---   printf("addSub(132, 241, &sum, &dif) ->\n");---   printf("  sum = %"PRIu8"\n", sum);---   printf("  dif = %"PRIu8"\n", dif);--- <BLANKLINE>---   return 0;--- }--- == END: "addSub_driver.c" ==================--- == BEGIN: "addSub.c" ================--- /* File: "addSub.c". Automatically generated by SBV. Do not edit! */--- <BLANKLINE>--- #include "addSub.h"--- <BLANKLINE>--- void addSub(const SWord8 x, const SWord8 y, SWord8 *sum,---             SWord8 *dif)--- {---   const SWord8 s0 = x;---   const SWord8 s1 = y;---   const SWord8 s2 = s0 + s1;---   const SWord8 s3 = s0 - s1;--- <BLANKLINE>---   *sum = s2;---   *dif = s3;--- }--- == END: "addSub.c" ==================----genAddSub :: IO ()-genAddSub = compileToC outDir "addSub" $ do-        x <- cgInput "x"-        y <- cgInput "y"-        -- leave the cgDriverVals call out for generating a driver with random values-        cgSetDriverValues [132, 241]-        let (s, d) = addSub x y-        cgOutput "sum" s-        cgOutput "dif" d- where -- use Just "dirName" for putting the output to the named directory-       -- otherwise, it'll go to standard output-       outDir = Nothing
− Data/SBV/Examples/CodeGeneration/CRC_USB5.hs 
@@ -1,87 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.CodeGeneration.CRC_USB5--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Computing the CRC symbolically, using the USB polynomial. We also--- generating C code for it as well. This example demonstrates the--- use of the 'crcBV' function, along with how CRC's can be computed--- mathematically using polynomial division. While the results are the--- same (i.e., proven equivalent, see 'crcGood' below), the internal--- CRC implementation generates much better code, compare 'cg1' vs 'cg2' below.--------------------------------------------------------------------------------module Data.SBV.Examples.CodeGeneration.CRC_USB5 where--import Data.SBV-import Data.SBV.Tools.CodeGen-import Data.SBV.Tools.Polynomial---------------------------------------------------------------------------------- * The USB polynomial---------------------------------------------------------------------------------- | The USB CRC polynomial: @x^5 + x^2 + 1@.--- Although this polynomial needs just 6 bits to represent (5 if higher--- order bit is implicitly assumed to be set), we'll simply use a 16 bit--- number for its representation to keep things simple for code generation--- purposes.-usb5 :: SWord16-usb5 = polynomial [5, 2, 0]---------------------------------------------------------------------------------- * Computing CRCs---------------------------------------------------------------------------------- | Given an 11 bit message, compute the CRC of it using the USB polynomial,--- which is 5 bits, and then append it to the msg to get a 16-bit word. Again,--- the incoming 11-bits is represented as a 16-bit word, with 5 highest bits--- essentially ignored for input purposes.-crcUSB :: SWord16 -> SWord16-crcUSB i = fromBitsBE (ib ++ cb)-  where ib = drop 5  (blastBE i)    -- only the last 11 bits needed-        pb = drop 11 (blastBE usb5) -- only the last  5 bits needed-        cb = crcBV 5 ib pb---- | Alternate method for computing the CRC, /mathematically/. We shift--- the number to the left by 5, and then compute the remainder from the--- polynomial division by the USB polynomial. The result is then appended--- to the end of the message.-crcUSB' :: SWord16 -> SWord16-crcUSB' i' = i .|. pMod i usb5-  where i = i' `shiftL` 5---------------------------------------------------------------------------------- * Correctness---------------------------------------------------------------------------------- | Prove that the custom 'crcBV' function is equivalent to the mathematical--- definition of CRC's for 11 bit messages. We have:------ >>> crcGood--- Q.E.D.-crcGood :: IO ThmResult-crcGood = prove $ \i -> crcUSB i .== crcUSB' i---------------------------------------------------------------------------------- * Code generation---------------------------------------------------------------------------------- | Generate a C function to compute the USB CRC, using the internal CRC--- function.-cg1 :: IO ()-cg1 = compileToC (Just "crcUSB1") "crcUSB1" $ do-        msg <- cgInput "msg"-        cgOutput "crc" (crcUSB msg)---- | Generate a C function to compute the USB CRC, using the mathematical--- definition of the CRCs. While this version generates functionally eqivalent--- C code, it's less efficient; it has about 30% more code. So, the above--- version is preferable for code generation purposes.-cg2 :: IO ()-cg2 = compileToC (Just "crcUSB2") "crcUSB2" $ do-        msg <- cgInput "msg"-        cgOutput "crc" (crcUSB' msg)
− Data/SBV/Examples/CodeGeneration/Fibonacci.hs 
@@ -1,176 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.CodeGeneration.Fibonacci--- Copyright   :  (c) Lee Pike, Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Computing Fibonacci numbers and generating C code. Inspired by Lee Pike's--- original implementation, modified for inclusion in the package. It illustrates--- symbolic termination issues one can have when working with recursive algorithms--- and how to deal with such, eventually generating good C code.--------------------------------------------------------------------------------module Data.SBV.Examples.CodeGeneration.Fibonacci where--import Data.SBV-import Data.SBV.Tools.CodeGen---------------------------------------------------------------------------------- * A naive implementation---------------------------------------------------------------------------------- | This is a naive implementation of fibonacci, and will work fine (albeit slow)--- for concrete inputs:------ >>> map fib0 [0..6]--- [0 :: SWord64,1 :: SWord64,1 :: SWord64,2 :: SWord64,3 :: SWord64,5 :: SWord64,8 :: SWord64]------ However, it is not suitable for doing proofs or generating code, as it is not--- symbolically terminating when it is called with a symbolic value @n@. When we--- recursively call @fib0@ on @n-1@ (or @n-2@), the test against @0@ will always--- explore both branches since the result will be symbolic, hence will not--- terminate. (An integrated theorem prover can establish termination--- after a certain number of unrollings, but this would be quite expensive to--- implement, and would be impractical.)-fib0 :: SWord64 -> SWord64-fib0 n = ite (n .== 0 ||| n .== 1)-             n-             (fib0 (n-1) + fib0 (n-2))---------------------------------------------------------------------------------- * Using a recursion depth, and accumulating parameters--------------------------------------------------------------------------------{- $genLookup-One way to deal with symbolic termination is to limit the number of recursive-calls. In this version, we impose a limit on the index to the function, working-correctly upto that limit. If we use a compile-time constant, then SBV's code generator-can produce code as the unrolling will eventually stop.--}---- | The recursion-depth limited version of fibonacci. Limiting the maximum number to be 20, we can say:------ >>> map (fib1 20) [0..6]--- [0 :: SWord64,1 :: SWord64,1 :: SWord64,2 :: SWord64,3 :: SWord64,5 :: SWord64,8 :: SWord64]------ The function will work correctly, so long as the index we query is at most @top@, and otherwise--- will return the value at @top@. Note that we also use accumulating parameters here for efficiency,--- although this is orthogonal to the termination concern.------ A note on modular arithmetic: The 64-bit word we use to represent the values will of course--- eventually overflow, beware! Fibonacci is a fast growing function..-fib1 :: SWord64 -> SWord64 -> SWord64-fib1 top n = fib' 0 1 0-  where fib' :: SWord64 -> SWord64 -> SWord64 -> SWord64-        fib' prev' prev m = ite (m .== top ||| m .== n)          -- did we reach recursion depth, or the index we're looking for-                                prev'                            -- stop and return the result-                                (fib' prev (prev' + prev) (m+1)) -- otherwise recurse---- | We can generate code for 'fib1' using the 'genFib1' action. Note that the--- generated code will grow larger as we pick larger values of @top@, but only linearly,--- thanks to the accumulating parameter trick used by 'fib1'. The following is an excerpt--- from the code generated for the call @genFib1 10@, where the code will work correctly--- for indexes up to 10:------ > SWord64 fib1(const SWord64 x)--- > {--- >   const SWord64 s0 = x;--- >   const SBool   s2 = s0 == 0x0000000000000000ULL;--- >   const SBool   s4 = s0 == 0x0000000000000001ULL;--- >   const SBool   s6 = s0 == 0x0000000000000002ULL;--- >   const SBool   s8 = s0 == 0x0000000000000003ULL;--- >   const SBool   s10 = s0 == 0x0000000000000004ULL;--- >   const SBool   s12 = s0 == 0x0000000000000005ULL;--- >   const SBool   s14 = s0 == 0x0000000000000006ULL;--- >   const SBool   s17 = s0 == 0x0000000000000007ULL;--- >   const SBool   s19 = s0 == 0x0000000000000008ULL;--- >   const SBool   s22 = s0 == 0x0000000000000009ULL;--- >   const SWord64 s25 = s22 ? 0x0000000000000022ULL : 0x0000000000000037ULL;--- >   const SWord64 s26 = s19 ? 0x0000000000000015ULL : s25;--- >   const SWord64 s27 = s17 ? 0x000000000000000dULL : s26;--- >   const SWord64 s28 = s14 ? 0x0000000000000008ULL : s27;--- >   const SWord64 s29 = s12 ? 0x0000000000000005ULL : s28;--- >   const SWord64 s30 = s10 ? 0x0000000000000003ULL : s29;--- >   const SWord64 s31 = s8 ? 0x0000000000000002ULL : s30;--- >   const SWord64 s32 = s6 ? 0x0000000000000001ULL : s31;--- >   const SWord64 s33 = s4 ? 0x0000000000000001ULL : s32;--- >   const SWord64 s34 = s2 ? 0x0000000000000000ULL : s33;--- >   --- >   return s34;--- > }-genFib1 :: SWord64 -> IO ()-genFib1 top = compileToC Nothing "fib1" $ do-        x <- cgInput "x"-        cgReturn $ fib1 top x---------------------------------------------------------------------------------- * Generating a look-up table--------------------------------------------------------------------------------{- $genLookup-While 'fib1' generates good C code, we can do much better by taking-advantage of the inherent partial-evaluation capabilities of SBV to generate-a look-up table, as follows.--}---- | Compute the fibonacci numbers statically at /code-generation/ time and--- put them in a table, accessed by the 'select' call. -fib2 :: SWord64 -> SWord64 -> SWord64-fib2 top = select table 0-  where table = map (fib1 top) [0 .. top]---- | Once we have 'fib2', we can generate the C code straightforwardly. Below--- is an excerpt from the code that SBV generates for the call @genFib2 64@. Note--- that this code is a constant-time look-up table implementation of fibonacci,--- with no run-time overhead. The index can be made arbitrarily large,--- naturally. (Note that this function returns @0@ if the index is larger--- than 64, as specified by the call to 'select' with default @0@.)------ > SWord64 fibLookup(const SWord64 x)--- > {--- >   const SWord64 s0 = x;--- >   static const SWord64 table0[] = {--- >       0x0000000000000000ULL, 0x0000000000000001ULL,--- >       0x0000000000000001ULL, 0x0000000000000002ULL,--- >       0x0000000000000003ULL, 0x0000000000000005ULL,--- >       0x0000000000000008ULL, 0x000000000000000dULL,--- >       0x0000000000000015ULL, 0x0000000000000022ULL,--- >       0x0000000000000037ULL, 0x0000000000000059ULL,--- >       0x0000000000000090ULL, 0x00000000000000e9ULL,--- >       0x0000000000000179ULL, 0x0000000000000262ULL,--- >       0x00000000000003dbULL, 0x000000000000063dULL,--- >       0x0000000000000a18ULL, 0x0000000000001055ULL,--- >       0x0000000000001a6dULL, 0x0000000000002ac2ULL,--- >       0x000000000000452fULL, 0x0000000000006ff1ULL,--- >       0x000000000000b520ULL, 0x0000000000012511ULL,--- >       0x000000000001da31ULL, 0x000000000002ff42ULL,--- >       0x000000000004d973ULL, 0x000000000007d8b5ULL,--- >       0x00000000000cb228ULL, 0x0000000000148addULL,--- >       0x0000000000213d05ULL, 0x000000000035c7e2ULL,--- >       0x00000000005704e7ULL, 0x00000000008cccc9ULL,--- >       0x0000000000e3d1b0ULL, 0x0000000001709e79ULL,--- >       0x0000000002547029ULL, 0x0000000003c50ea2ULL,--- >       0x0000000006197ecbULL, 0x0000000009de8d6dULL,--- >       0x000000000ff80c38ULL, 0x0000000019d699a5ULL,--- >       0x0000000029cea5ddULL, 0x0000000043a53f82ULL,--- >       0x000000006d73e55fULL, 0x00000000b11924e1ULL,--- >       0x000000011e8d0a40ULL, 0x00000001cfa62f21ULL,--- >       0x00000002ee333961ULL, 0x00000004bdd96882ULL,--- >       0x00000007ac0ca1e3ULL, 0x0000000c69e60a65ULL,--- >       0x0000001415f2ac48ULL, 0x000000207fd8b6adULL,--- >       0x0000003495cb62f5ULL, 0x0000005515a419a2ULL,--- >       0x00000089ab6f7c97ULL, 0x000000dec1139639ULL,--- >       0x000001686c8312d0ULL, 0x000002472d96a909ULL,--- >       0x000003af9a19bbd9ULL, 0x000005f6c7b064e2ULL, 0x000009a661ca20bbULL--- >   };--- >   const SWord64 s65 = s0 >= 65 ? 0x0000000000000000ULL : table0[s0];--- >   --- >   return s65;--- > }-genFib2 :: SWord64 -> IO ()-genFib2 top = compileToC Nothing "fibLookup" $ do-        cgPerformRTCs True       -- protect against potential overflow, our table is not big enough-        x <- cgInput "x"-        cgReturn $ fib2 top x
− Data/SBV/Examples/CodeGeneration/GCD.hs 
@@ -1,146 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.CodeGeneration.GCD--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Computing GCD symbolically, and generating C code for it. This example--- illustrates symbolic termination related issues when programming with--- SBV, when the termination of a recursive algorithm crucially depends--- on the value of a symbolic variable. The technique we use is to statically--- enforce termination by using a recursion depth counter.--------------------------------------------------------------------------------module Data.SBV.Examples.CodeGeneration.GCD where--import Data.SBV-import Data.SBV.Tools.CodeGen---------------------------------------------------------------------------------- * Computing GCD---------------------------------------------------------------------------------- | The symbolic GCD algorithm, over two 8-bit numbers. We define @sgcd a 0@ to--- be @a@ for all @a@, which implies @sgcd 0 0 = 0@. Note that this is essentially--- Euclid's algorithm, except with a recursion depth counter. We need the depth--- counter since the algorithm is not /symbolically terminating/, as we don't have--- a means of determining that the second argument (@b@) will eventually reach 0 in a symbolic--- context. Hence we stop after 12 iterations. Why 12? We've empirically determined that this--- algorithm will recurse at most 12 times for arbitrary 8-bit numbers. Of course, this is--- a claim that we shall prove below.-sgcd :: SWord8 -> SWord8 -> SWord8-sgcd a b = go a b 12-  where go :: SWord8 -> SWord8 -> SWord8 -> SWord8-        go x y c = ite (c .== 0 ||| y .== 0)   -- stop if y is 0, or if we reach the recursion depth-                       x-                       (go y y' (c-1))-          where (_, y') = x `sQuotRem` y---------------------------------------------------------------------------------- * Verification--------------------------------------------------------------------------------{- $VerificationIntro-We prove that 'sgcd' does indeed compute the common divisor of the given numbers.-Our predicate takes @x@, @y@, and @k@. We show that what 'sgcd' returns is indeed a common divisor,-and it is at least as large as any given @k@, provided @k@ is a common divisor as well.--}---- | We have:------ >>> prove sgcdIsCorrect--- Q.E.D.-sgcdIsCorrect :: SWord8 -> SWord8 -> SWord8 -> SBool-sgcdIsCorrect x y k = ite (y  .== 0)                        -- if y is 0-                          (k' .== x)                        -- then k' must be x, nothing else to prove by definition-                          (isCommonDivisor k'  &&&          -- otherwise, k' is a common divisor and-                          (isCommonDivisor k ==> k' .>= k)) -- if k is a common divisor as well, then k' is at least as large as k-  where k' = sgcd x y-        isCommonDivisor a = z1 .== 0 &&& z2 .== 0-           where (_, z1) = x `sQuotRem` a-                 (_, z2) = y `sQuotRem` a---------------------------------------------------------------------------------- * Code generation--------------------------------------------------------------------------------{- $VerificationIntro-Now that we have proof our 'sgcd' implementation is correct, we can go ahead-and generate C code for it.--}---- | This call will generate the required C files. The following is the function--- body generated for 'sgcd'. (We are not showing the generated header, @Makefile@,--- and the driver programs for brevity.) Note that the generated function is--- a constant time algorithm for GCD. It is not necessarily fastest, but it will take--- precisely the same amount of time for all values of @x@ and @y@.------ > /* File: "sgcd.c". Automatically generated by SBV. Do not edit! */--- > --- > #include <stdio.h>--- > #include <stdlib.h>--- > #include <inttypes.h>--- > #include <stdint.h>--- > #include <stdbool.h>--- > #include "sgcd.h"--- > --- > SWord8 sgcd(const SWord8 x, const SWord8 y)--- > {--- >   const SWord8 s0 = x;--- >   const SWord8 s1 = y;--- >   const SBool  s3 = s1 == 0;--- >   const SWord8 s4 = (s1 == 0) ? s0 : (s0 % s1);--- >   const SWord8 s5 = s3 ? s0 : s4;--- >   const SBool  s6 = 0 == s5;--- >   const SWord8 s7 = (s5 == 0) ? s1 : (s1 % s5);--- >   const SWord8 s8 = s6 ? s1 : s7;--- >   const SBool  s9 = 0 == s8;--- >   const SWord8 s10 = (s8 == 0) ? s5 : (s5 % s8);--- >   const SWord8 s11 = s9 ? s5 : s10;--- >   const SBool  s12 = 0 == s11;--- >   const SWord8 s13 = (s11 == 0) ? s8 : (s8 % s11);--- >   const SWord8 s14 = s12 ? s8 : s13;--- >   const SBool  s15 = 0 == s14;--- >   const SWord8 s16 = (s14 == 0) ? s11 : (s11 % s14);--- >   const SWord8 s17 = s15 ? s11 : s16;--- >   const SBool  s18 = 0 == s17;--- >   const SWord8 s19 = (s17 == 0) ? s14 : (s14 % s17);--- >   const SWord8 s20 = s18 ? s14 : s19;--- >   const SBool  s21 = 0 == s20;--- >   const SWord8 s22 = (s20 == 0) ? s17 : (s17 % s20);--- >   const SWord8 s23 = s21 ? s17 : s22;--- >   const SBool  s24 = 0 == s23;--- >   const SWord8 s25 = (s23 == 0) ? s20 : (s20 % s23);--- >   const SWord8 s26 = s24 ? s20 : s25;--- >   const SBool  s27 = 0 == s26;--- >   const SWord8 s28 = (s26 == 0) ? s23 : (s23 % s26);--- >   const SWord8 s29 = s27 ? s23 : s28;--- >   const SBool  s30 = 0 == s29;--- >   const SWord8 s31 = (s29 == 0) ? s26 : (s26 % s29);--- >   const SWord8 s32 = s30 ? s26 : s31;--- >   const SBool  s33 = 0 == s32;--- >   const SWord8 s34 = (s32 == 0) ? s29 : (s29 % s32);--- >   const SWord8 s35 = s33 ? s29 : s34;--- >   const SBool  s36 = 0 == s35;--- >   const SWord8 s37 = s36 ? s32 : s35;--- >   const SWord8 s38 = s33 ? s29 : s37;--- >   const SWord8 s39 = s30 ? s26 : s38;--- >   const SWord8 s40 = s27 ? s23 : s39;--- >   const SWord8 s41 = s24 ? s20 : s40;--- >   const SWord8 s42 = s21 ? s17 : s41;--- >   const SWord8 s43 = s18 ? s14 : s42;--- >   const SWord8 s44 = s15 ? s11 : s43;--- >   const SWord8 s45 = s12 ? s8 : s44;--- >   const SWord8 s46 = s9 ? s5 : s45;--- >   const SWord8 s47 = s6 ? s1 : s46;--- >   const SWord8 s48 = s3 ? s0 : s47;--- >   --- >   return s48;--- > }-genGCDInC :: IO ()-genGCDInC = compileToC Nothing "sgcd" $ do-                x <- cgInput "x"-                y <- cgInput "y"-                cgReturn $ sgcd x y
− Data/SBV/Examples/CodeGeneration/PopulationCount.hs 
@@ -1,230 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.CodeGeneration.PopulationCount--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Computing population-counts (number of set bits) and automatically--- generating C code.--------------------------------------------------------------------------------module Data.SBV.Examples.CodeGeneration.PopulationCount where--import Data.SBV-import Data.SBV.Tools.CodeGen---------------------------------------------------------------------------------- * Reference: Slow but /obviously/ correct---------------------------------------------------------------------------------- | Given a 64-bit quantity, the simplest (and obvious) way to count the--- number of bits that are set in it is to simply walk through all the bits--- and add 1 to a running count. This is slow, as it requires 64 iterations,--- but is simple and easy to convince yourself that it is correct. For instance:------ >>> popCountSlow 0x0123456789ABCDEF--- 32 :: SWord8-popCountSlow :: SWord64 -> SWord8-popCountSlow inp = go inp 0 0-  where go :: SWord64 -> Int -> SWord8 -> SWord8-        go _ 64 c = c-        go x i  c = go (x `shiftR` 1) (i+1) (ite (x .&. 1 .== 1) (c+1) c)---------------------------------------------------------------------------------- * Faster: Using a look-up table---------------------------------------------------------------------------------- | Faster version. This is essentially the same algorithm, except we--- go 8 bits at a time instead of one by one, by using a precomputed table--- of population-count values for each byte. This algorithm /loops/ only--- 8 times, and hence is at least 8 times more efficient.-popCountFast :: SWord64 -> SWord8-popCountFast inp = go inp 0 0-  where go :: SWord64 -> Int -> SWord8 -> SWord8-        go _ 8 c = c-        go x i c = go (x `shiftR` 8) (i+1) (c + select pop8 0 (x .&. 0xff))---- | Look-up table, containing population counts for all possible 8-bit--- value, from 0 to 255. Note that we do not \"hard-code\" the values, but--- merely use the slow version to compute them.-pop8 :: [SWord8]-pop8 = map popCountSlow [0 .. 255]---------------------------------------------------------------------------------- * Verification--------------------------------------------------------------------------------{- $VerificationIntro-We prove that `popCountFast` and `popCountSlow` are functionally equivalent.-This is essential as we will automatically generate C code from `popCountFast`,-and we would like to make sure that the fast version is correct with-respect to the slower reference version.--}---- | States the correctness of faster population-count algorithm, with respect--- to the reference slow version. Turns out Z3's default solver is rather slow--- for this one, but there's a magic incantation to make it go fast.--- See <https://github.com/Z3Prover/z3/issues/1150> for details.------ >>> let cmd = "(check-sat-using (then (using-params ackermannize_bv :div0_ackermann_limit 1000000) simplify bit-blast sat))"--- >>> proveWith z3{satCmd = cmd} fastPopCountIsCorrect--- Q.E.D.-fastPopCountIsCorrect :: SWord64 -> SBool-fastPopCountIsCorrect x = popCountFast x .== popCountSlow x---------------------------------------------------------------------------------- * Code generation---------------------------------------------------------------------------------- | Not only we can prove that faster version is correct, but we can also automatically--- generate C code to compute population-counts for us. This action will generate all the--- C files that you will need, including a driver program for test purposes.------ Below is the generated header file for `popCountFast`:------ >>> genPopCountInC--- == BEGIN: "Makefile" ================--- # Makefile for popCount. Automatically generated by SBV. Do not edit!--- <BLANKLINE>--- # include any user-defined .mk file in the current directory.--- -include *.mk--- <BLANKLINE>--- CC?=gcc--- CCFLAGS?=-Wall -O3 -DNDEBUG -fomit-frame-pointer--- <BLANKLINE>--- all: popCount_driver--- <BLANKLINE>--- popCount.o: popCount.c popCount.h--- 	${CC} ${CCFLAGS} -c $< -o $@--- <BLANKLINE>--- popCount_driver.o: popCount_driver.c--- 	${CC} ${CCFLAGS} -c $< -o $@--- <BLANKLINE>--- popCount_driver: popCount.o popCount_driver.o--- 	${CC} ${CCFLAGS} $^ -o $@--- <BLANKLINE>--- clean:--- 	rm -f *.o--- <BLANKLINE>--- veryclean: clean--- 	rm -f popCount_driver--- == END: "Makefile" ==================--- == BEGIN: "popCount.h" ================--- /* Header file for popCount. Automatically generated by SBV. Do not edit! */--- <BLANKLINE>--- #ifndef __popCount__HEADER_INCLUDED__--- #define __popCount__HEADER_INCLUDED__--- <BLANKLINE>--- #include <stdio.h>--- #include <stdlib.h>--- #include <inttypes.h>--- #include <stdint.h>--- #include <stdbool.h>--- #include <string.h>--- #include <math.h>--- <BLANKLINE>--- /* The boolean type */--- typedef bool SBool;--- <BLANKLINE>--- /* The float type */--- typedef float SFloat;--- <BLANKLINE>--- /* The double type */--- typedef double SDouble;--- <BLANKLINE>--- /* Unsigned bit-vectors */--- typedef uint8_t  SWord8 ;--- typedef uint16_t SWord16;--- typedef uint32_t SWord32;--- typedef uint64_t SWord64;--- <BLANKLINE>--- /* Signed bit-vectors */--- typedef int8_t  SInt8 ;--- typedef int16_t SInt16;--- typedef int32_t SInt32;--- typedef int64_t SInt64;--- <BLANKLINE>--- /* Entry point prototype: */--- SWord8 popCount(const SWord64 x);--- <BLANKLINE>--- #endif /* __popCount__HEADER_INCLUDED__ */--- == END: "popCount.h" ==================--- == BEGIN: "popCount_driver.c" ================--- /* Example driver program for popCount. */--- /* Automatically generated by SBV. Edit as you see fit! */--- <BLANKLINE>--- #include <stdio.h>--- #include "popCount.h"--- <BLANKLINE>--- int main(void)--- {---   const SWord8 __result = popCount(0x1b02e143e4f0e0e5ULL);--- <BLANKLINE>---   printf("popCount(0x1b02e143e4f0e0e5ULL) = %"PRIu8"\n", __result);--- <BLANKLINE>---   return 0;--- }--- == END: "popCount_driver.c" ==================--- == BEGIN: "popCount.c" ================--- /* File: "popCount.c". Automatically generated by SBV. Do not edit! */--- <BLANKLINE>--- #include "popCount.h"--- <BLANKLINE>--- SWord8 popCount(const SWord64 x)--- {---   const SWord64 s0 = x;---   static const SWord8 table0[] = {---       0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4, 1, 2, 2, 3, 2, 3,---       3, 4, 2, 3, 3, 4, 3, 4, 4, 5, 1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4,---       3, 4, 4, 5, 2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6, 1, 2,---       2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5, 2, 3, 3, 4, 3, 4, 4, 5,---       3, 4, 4, 5, 4, 5, 5, 6, 2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5,---       5, 6, 3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7, 1, 2, 2, 3,---       2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5, 2, 3, 3, 4, 3, 4, 4, 5, 3, 4,---       4, 5, 4, 5, 5, 6, 2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,---       3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7, 2, 3, 3, 4, 3, 4,---       4, 5, 3, 4, 4, 5, 4, 5, 5, 6, 3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6,---       5, 6, 6, 7, 3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7, 4, 5,---       5, 6, 5, 6, 6, 7, 5, 6, 6, 7, 6, 7, 7, 8---   };---   const SWord64 s11 = s0 & 0x00000000000000ffULL;---   const SWord8  s12 = table0[s11];---   const SWord64 s14 = s0 >> 8;---   const SWord64 s15 = 0x00000000000000ffULL & s14;---   const SWord8  s16 = table0[s15];---   const SWord8  s17 = s12 + s16;---   const SWord64 s18 = s14 >> 8;---   const SWord64 s19 = 0x00000000000000ffULL & s18;---   const SWord8  s20 = table0[s19];---   const SWord8  s21 = s17 + s20;---   const SWord64 s22 = s18 >> 8;---   const SWord64 s23 = 0x00000000000000ffULL & s22;---   const SWord8  s24 = table0[s23];---   const SWord8  s25 = s21 + s24;---   const SWord64 s26 = s22 >> 8;---   const SWord64 s27 = 0x00000000000000ffULL & s26;---   const SWord8  s28 = table0[s27];---   const SWord8  s29 = s25 + s28;---   const SWord64 s30 = s26 >> 8;---   const SWord64 s31 = 0x00000000000000ffULL & s30;---   const SWord8  s32 = table0[s31];---   const SWord8  s33 = s29 + s32;---   const SWord64 s34 = s30 >> 8;---   const SWord64 s35 = 0x00000000000000ffULL & s34;---   const SWord8  s36 = table0[s35];---   const SWord8  s37 = s33 + s36;---   const SWord64 s38 = s34 >> 8;---   const SWord64 s39 = 0x00000000000000ffULL & s38;---   const SWord8  s40 = table0[s39];---   const SWord8  s41 = s37 + s40;--- <BLANKLINE>---   return s41;--- }--- == END: "popCount.c" ==================-genPopCountInC :: IO ()-genPopCountInC = compileToC Nothing "popCount" $ do-        cgSetDriverValues [0x1b02e143e4f0e0e5]  -- remove this line to get a random test value-        x <- cgInput "x"-        cgReturn $ popCountFast x
− Data/SBV/Examples/CodeGeneration/Uninterpreted.hs 
@@ -1,61 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.CodeGeneration.Uninterpreted--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates the use of uninterpreted functions for the purposes of--- code generation. This facility is important when we want to take--- advantage of native libraries in the target platform, or when we'd--- like to hand-generate code for certain functions for various--- purposes, such as efficiency, or reliability.--------------------------------------------------------------------------------module Data.SBV.Examples.CodeGeneration.Uninterpreted where--import Data.Maybe (fromMaybe)--import Data.SBV-import Data.SBV.Tools.CodeGen---- | A definition of shiftLeft that can deal with variable length shifts.--- (Note that the ``shiftL`` method from the 'Bits' class requires an 'Int' shift--- amount.) Unfortunately, this'll generate rather clumsy C code due to the--- use of tables etc., so we uninterpret it for code generation purposes--- using the 'cgUninterpret' function.-shiftLeft :: SWord32 -> SWord32 -> SWord32-shiftLeft = cgUninterpret "SBV_SHIFTLEFT" cCode hCode-  where -- the C code we'd like SBV to spit out when generating code. Note that this is-        -- arbitrary C code. In this case we just used a macro, but it could be a function,-        -- text that includes files etc. It should essentially bring the name SBV_SHIFTLEFT-        -- used above into scope when compiled. If no code is needed, one can also just-        -- provide the empty list for the same effect. Also see 'cgAddDecl', 'cgAddLDFlags',-        -- and 'cgAddPrototype' functions for further variations.-        cCode = ["#define SBV_SHIFTLEFT(x, y) ((x) << (y))"]-        -- the Haskell code we'd like SBV to use when running inside Haskell or when-        -- translated to SMTLib for verification purposes. This is good old Haskell-        -- code, as one would typically write.-        hCode x = select [x * literal (bit b) | b <- [0.. bs x - 1]] (literal 0)-        bs x = fromMaybe (error "SBV.Example.CodeGeneration.Uninterpreted.shiftLeft: Unexpected non-finite usage!") (bitSizeMaybe x)---- | Test function that uses shiftLeft defined above. When used as a normal Haskell function--- or in verification the definition is fully used, i.e., no uninterpretation happens. To wit,--- we have:------  >>> tstShiftLeft 3 4 5---  224 :: SWord32------  >>> prove $ \x y -> tstShiftLeft x y 0 .== x + y---  Q.E.D.-tstShiftLeft ::  SWord32 -> SWord32 -> SWord32 -> SWord32-tstShiftLeft x y z = x `shiftLeft` z + y `shiftLeft` z---- | Generate C code for "tstShiftLeft". In this case, SBV will *use* the user given definition--- verbatim, instead of generating code for it. (Also see the functions 'cgAddDecl', 'cgAddLDFlags',--- and 'cgAddPrototype'.)-genCCode :: IO ()-genCCode = compileToC Nothing "tst" $ do-                [x, y, z] <- cgInputArr 3 "vs"-                cgReturn $ tstShiftLeft x y z
− Data/SBV/Examples/Crypto/AES.hs 
@@ -1,593 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Crypto.AES--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ An implementation of AES (Advanced Encryption Standard), using SBV.--- For details on AES, see <http://en.wikipedia.org/wiki/Advanced_Encryption_Standard>.------ We do a T-box implementation, which leads to good C code as we can take--- advantage of look-up tables. Note that we make virtually no attempt to--- optimize our Haskell code. The concern here is not with getting Haskell running--- fast at all. The idea is to program the T-Box implementation as naturally and clearly--- as possible in Haskell, and have SBV's code-generator generate fast C code automatically.--- Therefore, we merely use ordinary Haskell lists as our data-structures, and do not--- bother with any unboxing or strictness annotations. Thus, we achieve the separation--- of concerns: Correctness via clairty and simplicity and proofs on the Haskell side,--- performance by relying on SBV's code generator. If necessary, the generated code--- can be FFI'd back into Haskell to complete the loop.------ All 3 valid key sizes (128, 192, and 256) as required by the FIPS-197 standard--- are supported.--------------------------------------------------------------------------------{-# LANGUAGE ParallelListComp #-}--module Data.SBV.Examples.Crypto.AES where--import Data.SBV-import Data.SBV.Tools.CodeGen-import Data.SBV.Tools.Polynomial--import Data.List (transpose)-import Data.Maybe (fromJust)--import Numeric (showHex)---------------------------------------------------------------------------------- * Formalizing GF(2^8)---------------------------------------------------------------------------------- | An element of the Galois Field 2^8, which are essentially polynomials with--- maximum degree 7. They are conveniently represented as values between 0 and 255.-type GF28 = SWord8---- | Multiplication in GF(2^8). This is simple polynomial multipliation, followed--- by the irreducible polynomial @x^8+x^4+x^3+x^1+1@. We simply use the 'pMult'--- function exported by SBV to do the operation. -gf28Mult :: GF28 -> GF28 -> GF28-gf28Mult x y = pMult (x, y, [8, 4, 3, 1, 0])---- | Exponentiation by a constant in GF(2^8). The implementation uses the usual--- square-and-multiply trick to speed up the computation.-gf28Pow :: GF28 -> Int -> GF28-gf28Pow n = pow-  where sq x  = x `gf28Mult` x-        pow 0    = 1-        pow i-         | odd i = n `gf28Mult` sq (pow (i `shiftR` 1))-         | True  = sq (pow (i `shiftR` 1))---- | Computing inverses in GF(2^8). By the mathematical properties of GF(2^8)--- and the particular irreducible polynomial used @x^8+x^5+x^3+x^1+1@, it--- turns out that raising to the 254 power gives us the multiplicative inverse.--- Of course, we can prove this using SBV:------ >>> prove $ \x -> x ./= 0 ==> x `gf28Mult` gf28Inverse x .== 1--- Q.E.D.------ Note that we exclude @0@ in our theorem, as it does not have a--- multiplicative inverse.-gf28Inverse :: GF28 -> GF28-gf28Inverse x = x `gf28Pow` 254---------------------------------------------------------------------------------- * Implementing AES---------------------------------------------------------------------------------------------------------------------------------------------------------------- ** Types and basic operations--------------------------------------------------------------------------------- | AES state. The state consists of four 32-bit words, each of which is in turn treated--- as four GF28's, i.e., 4 bytes. The T-Box implementation keeps the four-bytes together--- for efficient representation.-type State = [SWord32]---- | The key, which can be 128, 192, or 256 bits. Represented as a sequence of 32-bit words.-type Key = [SWord32]---- | The key schedule. AES executes in rounds, and it treats first and last round keys slightly--- differently than the middle ones. We reflect that choice by being explicit about it in our type.--- The length of the middle list of keys depends on the key-size, which in turn determines--- the number of rounds.-type KS = (Key, [Key], Key)---- | Conversion from 32-bit words to 4 constituent bytes.-toBytes :: SWord32 -> [GF28]-toBytes x = [x1, x2, x3, x4]-        where (h,  l)  = split x-              (x1, x2) = split h-              (x3, x4) = split l---- | Conversion from 4 bytes, back to a 32-bit row, inverse of 'toBytes' above. We--- have the following simple theorems stating this relationship formally:------ >>> prove $ \a b c d -> toBytes (fromBytes [a, b, c, d]) .== [a, b, c, d]--- Q.E.D.------ >>> prove $ \r -> fromBytes (toBytes r) .== r--- Q.E.D.-fromBytes :: [GF28] -> SWord32-fromBytes [x1, x2, x3, x4] = (x1 # x2) # (x3 # x4)-fromBytes xs               = error $ "fromBytes: Unexpected input: " ++ show xs---- | Rotating a state row by a fixed amount to the right.-rotR :: [GF28] -> Int -> [GF28]-rotR [a, b, c, d] 1 = [d, a, b, c]-rotR [a, b, c, d] 2 = [c, d, a, b]-rotR [a, b, c, d] 3 = [b, c, d, a]-rotR xs           i = error $ "rotR: Unexpected input: " ++ show (xs, i)---------------------------------------------------------------------------------- ** The key schedule---------------------------------------------------------------------------------- | Definition of round-constants, as specified in Section 5.2 of the AES standard.-roundConstants :: [GF28]-roundConstants = 0 : [ gf28Pow 2 (k-1) | k <- [1 .. ] ]---- | The @InvMixColumns@ transformation, as described in Section 5.3.3 of the standard. Note--- that this transformation is only used explicitly during key-expansion in the T-Box implementation--- of AES.-invMixColumns :: State -> State-invMixColumns state = map fromBytes $ transpose $ mmult (map toBytes state)- where dot f   = foldr1 xor . zipWith ($) f-       mmult n = [map (dot r) n | r <- [ [mE, mB, mD, m9]-                                       , [m9, mE, mB, mD]-                                       , [mD, m9, mE, mB]-                                       , [mB, mD, m9, mE]-                                       ]]-       -- table-lookup versions of gf28Mult with the constants used in invMixColumns-       mE = select mETable 0-       mB = select mBTable 0-       mD = select mDTable 0-       m9 = select m9Table 0-       mETable = map (gf28Mult 0xE) [0..255]-       mBTable = map (gf28Mult 0xB) [0..255]-       mDTable = map (gf28Mult 0xD) [0..255]-       m9Table = map (gf28Mult 0x9) [0..255]---- | Key expansion. Starting with the given key, returns an infinite sequence of--- words, as described by the AES standard, Section 5.2, Figure 11.-keyExpansion :: Int -> Key -> [Key]-keyExpansion nk key = chop4 keys-   where keys :: [SWord32]-         keys = key ++ [nextWord i prev old | i <- [nk ..] | prev <- drop (nk-1) keys | old <- keys]-         chop4 :: [a] -> [[a]]-         chop4 xs = let (f, r) = splitAt 4 xs in f : chop4 r-         nextWord :: Int -> SWord32 -> SWord32 -> SWord32-         nextWord i prev old-           | i `mod` nk == 0           = old `xor` subWordRcon (prev `rotateL` 8) (roundConstants !! (i `div` nk))-           | i `mod` nk == 4 && nk > 6 = old `xor` subWordRcon prev 0-           | True                      = old `xor` prev-         subWordRcon :: SWord32 -> GF28 -> SWord32-         subWordRcon w rc = fromBytes [a `xor` rc, b, c, d]-            where [a, b, c, d] = map sbox $ toBytes w---------------------------------------------------------------------------------- ** The S-box transformation---------------------------------------------------------------------------------- | The values of the AES S-box table. Note that we describe the S-box programmatically--- using the mathematical construction given in Section 5.1.1 of the standard. However,--- the code-generation will turn this into a mere look-up table, as it is just a--- constant table, all computation being done at \"compile-time\".-sboxTable :: [GF28]-sboxTable = [xformByte (gf28Inverse b) | b <- [0 .. 255]]-  where xformByte :: GF28 -> GF28-        xformByte b = foldr xor 0x63 [b `rotateR` i | i <- [0, 4, 5, 6, 7]]---- | The sbox transformation. We simply select from the sbox table. Note that we--- are obliged to give a default value (here @0@) to be used if the index is out-of-bounds--- as required by SBV's 'select' function. However, that will never happen since--- the table has all 256 elements in it.-sbox :: GF28 -> GF28-sbox = select sboxTable 0---------------------------------------------------------------------------------- ** The inverse S-box transformation---------------------------------------------------------------------------------- | The values of the inverse S-box table. Again, the construction is programmatic.-unSBoxTable :: [GF28]-unSBoxTable = [gf28Inverse (xformByte b) | b <- [0 .. 255]]-  where xformByte :: GF28 -> GF28-        xformByte b = foldr xor 0x05 [b `rotateR` i | i <- [2, 5, 7]]---- | The inverse s-box transformation.-unSBox :: GF28 -> GF28-unSBox = select unSBoxTable 0---- | Prove that the 'sbox' and 'unSBox' are inverses. We have:------ >>> prove sboxInverseCorrect--- Q.E.D.----sboxInverseCorrect :: GF28 -> SBool-sboxInverseCorrect x = unSBox (sbox x) .== x &&& sbox (unSBox x) .== x---------------------------------------------------------------------------------- ** AddRoundKey transformation---------------------------------------------------------------------------------- | Adding the round-key to the current state. We simply exploit the fact--- that addition is just xor in implementing this transformation.-addRoundKey :: Key -> State -> State-addRoundKey = zipWith xor---------------------------------------------------------------------------------- ** Tables for T-Box encryption---------------------------------------------------------------------------------- | T-box table generation function for encryption-t0Func :: GF28 -> [GF28]-t0Func a = [s `gf28Mult` 2, s, s, s `gf28Mult` 3] where s = sbox a---- | First look-up table used in encryption-t0 :: GF28 -> SWord32-t0 = select t0Table 0 where t0Table = [fromBytes (t0Func a)          | a <- [0..255]]---- | Second look-up table used in encryption-t1 :: GF28 -> SWord32-t1 = select t1Table 0 where t1Table = [fromBytes (t0Func a `rotR` 1) | a <- [0..255]]---- | Third look-up table used in encryption-t2 :: GF28 -> SWord32-t2 = select t2Table 0 where t2Table = [fromBytes (t0Func a `rotR` 2) | a <- [0..255]]---- | Fourth look-up table used in encryption-t3 :: GF28 -> SWord32-t3 = select t3Table 0 where t3Table = [fromBytes (t0Func a `rotR` 3) | a <- [0..255]]---------------------------------------------------------------------------------- ** Tables for T-Box decryption---------------------------------------------------------------------------------- | T-box table generating function for decryption-u0Func :: GF28 -> [GF28]-u0Func a = [s `gf28Mult` 0xE, s `gf28Mult` 0x9, s `gf28Mult` 0xD, s `gf28Mult` 0xB] where s = unSBox a---- | First look-up table used in decryption-u0 :: GF28 -> SWord32-u0 = select t0Table 0 where t0Table = [fromBytes (u0Func a)          | a <- [0..255]]---- | Second look-up table used in decryption-u1 :: GF28 -> SWord32-u1 = select t1Table 0 where t1Table = [fromBytes (u0Func a `rotR` 1) | a <- [0..255]]---- | Third look-up table used in decryption-u2 :: GF28 -> SWord32-u2 = select t2Table 0 where t2Table = [fromBytes (u0Func a `rotR` 2) | a <- [0..255]]---- | Fourth look-up table used in decryption-u3 :: GF28 -> SWord32-u3 = select t3Table 0 where t3Table = [fromBytes (u0Func a `rotR` 3) | a <- [0..255]]---------------------------------------------------------------------------------- ** AES rounds---------------------------------------------------------------------------------- | Generic round function. Given the function to perform one round, a key-schedule,--- and a starting state, it performs the AES rounds.-doRounds :: (Bool -> State -> Key -> State) -> KS -> State -> State-doRounds rnd (ikey, rkeys, fkey) sIn = rnd True (last rs) fkey-  where s0 = ikey `addRoundKey` sIn-        rs = s0 : [rnd False s k | s <- rs | k <- rkeys ]---- | One encryption round. The first argument indicates whether this is the final round--- or not, in which case the construction is slightly different.-aesRound :: Bool -> State -> Key -> State-aesRound isFinal s key = d `addRoundKey` key-  where d = map (f isFinal) [0..3]-        a = map toBytes s-        f True j = fromBytes [ sbox (a !! ((j+0) `mod` 4) !! 0)-                             , sbox (a !! ((j+1) `mod` 4) !! 1)-                             , sbox (a !! ((j+2) `mod` 4) !! 2)-                             , sbox (a !! ((j+3) `mod` 4) !! 3)-                             ]-        f False j = e0 `xor` e1 `xor` e2 `xor` e3-              where e0 = t0 (a !! ((j+0) `mod` 4) !! 0)-                    e1 = t1 (a !! ((j+1) `mod` 4) !! 1)-                    e2 = t2 (a !! ((j+2) `mod` 4) !! 2)-                    e3 = t3 (a !! ((j+3) `mod` 4) !! 3)---- | One decryption round. Similar to the encryption round, the first argument--- indicates whether this is the final round or not.-aesInvRound :: Bool -> State -> Key -> State-aesInvRound isFinal s key = d `addRoundKey` key-  where d = map (f isFinal) [0..3]-        a = map toBytes s-        f True j = fromBytes [ unSBox (a !! ((j+0) `mod` 4) !! 0)-                             , unSBox (a !! ((j+3) `mod` 4) !! 1)-                             , unSBox (a !! ((j+2) `mod` 4) !! 2)-                             , unSBox (a !! ((j+1) `mod` 4) !! 3)-                             ]-        f False j = e0 `xor` e1 `xor` e2 `xor` e3-              where e0 = u0 (a !! ((j+0) `mod` 4) !! 0)-                    e1 = u1 (a !! ((j+3) `mod` 4) !! 1)-                    e2 = u2 (a !! ((j+2) `mod` 4) !! 2)-                    e3 = u3 (a !! ((j+1) `mod` 4) !! 3)---------------------------------------------------------------------------------- * AES API---------------------------------------------------------------------------------- | Key schedule. Given a 128, 192, or 256 bit key, expand it to get key-schedules--- for encryption and decryption. The key is given as a sequence of 32-bit words.--- (4 elements for 128-bits, 6 for 192, and 8 for 256.)-aesKeySchedule :: Key -> (KS, KS)-aesKeySchedule key-  | nk `elem` [4, 6, 8]-  = (encKS, decKS)-  | True-  = error "aesKeySchedule: Invalid key size"-  where nk = length key-        nr = nk + 6-        encKS@(f, m, l) = (head rKeys, take (nr-1) (tail rKeys), rKeys !! nr)-        decKS = (l, map invMixColumns (reverse m), f)-        rKeys = keyExpansion nk key---- | Block encryption. The first argument is the plain-text, which must have--- precisely 4 elements, for a total of 128-bits of input. The second--- argument is the key-schedule to be used, obtained by a call to 'aesKeySchedule'.--- The output will always have 4 32-bit words, which is the cipher-text.-aesEncrypt :: [SWord32] -> KS -> [SWord32]-aesEncrypt pt encKS-  | length pt == 4-  = doRounds aesRound encKS pt-  | True-  = error "aesEncrypt: Invalid plain-text size"---- | Block decryption. The arguments are the same as in 'aesEncrypt', except--- the first argument is the cipher-text and the output is the corresponding--- plain-text.-aesDecrypt :: [SWord32] -> KS -> [SWord32]-aesDecrypt ct decKS-  | length ct == 4-  = doRounds aesInvRound decKS ct-  | True-  = error "aesDecrypt: Invalid cipher-text size"---------------------------------------------------------------------------------- * Test vectors---------------------------------------------------------------------------------------------------------------------------------------------------------------- ** 128-bit enc/dec test---------------------------------------------------------------------------------- | 128-bit encryption test, from Appendix C.1 of the AES standard:------ >>> map hex8 t128Enc--- ["69c4e0d8","6a7b0430","d8cdb780","70b4c55a"]----t128Enc :: [SWord32]-t128Enc = aesEncrypt pt ks-  where pt  = [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]-        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f]-        (ks, _) = aesKeySchedule key---- | 128-bit decryption test, from Appendix C.1 of the AES standard:------ >>> map hex8 t128Dec--- ["00112233","44556677","8899aabb","ccddeeff"]----t128Dec :: [SWord32]-t128Dec = aesDecrypt ct ks-  where ct  = [0x69c4e0d8, 0x6a7b0430, 0xd8cdb780, 0x70b4c55a]-        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f]-        (_, ks) = aesKeySchedule key---------------------------------------------------------------------------------- ** 192-bit enc/dec test---------------------------------------------------------------------------------- | 192-bit encryption test, from Appendix C.2 of the AES standard:------ >>> map hex8 t192Enc--- ["dda97ca4","864cdfe0","6eaf70a0","ec0d7191"]----t192Enc :: [SWord32]-t192Enc = aesEncrypt pt ks-  where pt  = [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]-        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617]-        (ks, _) = aesKeySchedule key---- | 192-bit decryption test, from Appendix C.2 of the AES standard:------ >>> map hex8 t192Dec--- ["00112233","44556677","8899aabb","ccddeeff"]----t192Dec :: [SWord32]-t192Dec = aesDecrypt ct ks-  where ct  = [0xdda97ca4, 0x864cdfe0, 0x6eaf70a0, 0xec0d7191]-        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617]-        (_, ks) = aesKeySchedule key---------------------------------------------------------------------------------- ** 256-bit enc/dec test---------------------------------------------------------------------------------- | 256-bit encryption, from Appendix C.3 of the AES standard:------ >>> map hex8 t256Enc--- ["8ea2b7ca","516745bf","eafc4990","4b496089"]----t256Enc :: [SWord32]-t256Enc = aesEncrypt pt ks-  where pt  = [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]-        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617, 0x18191a1b, 0x1c1d1e1f]-        (ks, _) = aesKeySchedule key---- | 256-bit decryption, from Appendix C.3 of the AES standard:------ >>> map hex8 t256Dec--- ["00112233","44556677","8899aabb","ccddeeff"]----t256Dec :: [SWord32]-t256Dec = aesDecrypt ct ks-  where ct  = [0x8ea2b7ca, 0x516745bf, 0xeafc4990, 0x4b496089]-        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617, 0x18191a1b, 0x1c1d1e1f]-        (_, ks) = aesKeySchedule key----------------------------------------------------------------------------------- * Verification--- ${verifIntro}-------------------------------------------------------------------------------{- $verifIntro-  While SMT based technologies can prove correct many small properties fairly quickly, it would-  be naive for them to automatically verify that our AES implementation is correct. (By correct,-  we mean decryption follewed by encryption yielding the same result.) However, we can state-  this property precisely using SBV, and use quick-check to gain some confidence.--}---- | Correctness theorem for 128-bit AES. Ideally, we would run:------ @---   prove aes128IsCorrect--- @------ to get a proof automatically. Unfortunately, while SBV will successfully generate the proof--- obligation for this theorem and ship it to the SMT solver, it would be naive to expect the SMT-solver--- to finish that proof in any reasonable time with the currently available SMT solving technologies.--- Instead, we can issue:------ @---   quickCheck aes128IsCorrect--- @--- --- and get some degree of confidence in our code. Similar predicates can be easily constructed for 192, and--- 256 bit cases as well.-aes128IsCorrect :: (SWord32, SWord32, SWord32, SWord32)  -- ^ plain-text words-                -> (SWord32, SWord32, SWord32, SWord32)  -- ^ key-words-                -> SBool                                 -- ^ True if round-trip gives us plain-text back-aes128IsCorrect (i0, i1, i2, i3) (k0, k1, k2, k3) = pt .== pt'-   where pt  = [i0, i1, i2, i3]-         key = [k0, k1, k2, k3]-         (encKS, decKS) = aesKeySchedule key-         ct  = aesEncrypt pt encKS-         pt' = aesDecrypt ct decKS---------------------------------------------------------------------------------- * Code generation--- ${codeGenIntro}-------------------------------------------------------------------------------{- $codeGenIntro-   We have emphasized that our T-Box implementation in Haskell was guided by clarity and correctness, not-   performance. Indeed, our implementation is hardly the fastest AES implementation in Haskell. However,-   we can use it to automatically generate straight-line C-code that can run fairly fast.--   For the purposes of illustration, we only show here how to generate code for a 128-bit AES block-encrypt-   function, that takes 8 32-bit words as an argument. The first 4 are the 128-bit input, and the final-   four are the 128-bit key. The impact of this is that the generated function would expand the key for-   each block of encryption, a needless task unless we change the key in every block. In a more serios application,-   we would instead generate code for both the 'aesKeySchedule' and the 'aesEncrypt' functions, thus reusing the-   key-schedule over many applications of the encryption call. (Unfortunately doing this is rather cumbersome right-   now, since Haskell does not support fixed-size lists.)--}---- | Code generation for 128-bit AES encryption.------ The following sample from the generated code-lines show how T-Boxes are rendered as C arrays:------ @---   static const SWord32 table1[] = {---       0xc66363a5UL, 0xf87c7c84UL, 0xee777799UL, 0xf67b7b8dUL,---       0xfff2f20dUL, 0xd66b6bbdUL, 0xde6f6fb1UL, 0x91c5c554UL,---       0x60303050UL, 0x02010103UL, 0xce6767a9UL, 0x562b2b7dUL,---       0xe7fefe19UL, 0xb5d7d762UL, 0x4dababe6UL, 0xec76769aUL,---       ...---       }--- @------ The generated program has 5 tables (one sbox table, and 4-Tboxes), all converted to fast C arrays. Here--- is a sample of the generated straightline C-code:------ @---   const SWord8  s1915 = (SWord8) s1912;---   const SWord8  s1916 = table0[s1915];---   const SWord16 s1917 = (((SWord16) s1914) << 8) | ((SWord16) s1916);---   const SWord32 s1918 = (((SWord32) s1911) << 16) | ((SWord32) s1917);---   const SWord32 s1919 = s1844 ^ s1918;---   const SWord32 s1920 = s1903 ^ s1919;--- @------ The GNU C-compiler does a fine job of optimizing this straightline code to generate a fairly efficient C implementation.-cgAES128BlockEncrypt :: IO ()-cgAES128BlockEncrypt = compileToC Nothing "aes128BlockEncrypt" $ do-        pt  <- cgInputArr 4 "pt"        -- plain-text as an array of 4 Word32's-        key <- cgInputArr 4 "key"       -- key as an array of 4 Word32s-        -- Use the test values from Appendix C.1 of the AES standard as the driver values-        cgSetDriverValues $    [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]-                            ++ [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f]-        let (encKs, _) = aesKeySchedule key-        cgOutputArr "ct" $ aesEncrypt pt encKs---------------------------------------------------------------------------------- * C-library generation--- ${libraryIntro}-------------------------------------------------------------------------------{- $libraryIntro-   The 'cgAES128BlockEncrypt' example shows how to generate code for 128-bit AES encryption. As the generated-   function performs encryption on a given block, it performs key expansion as necessary. However, this is-   not quite practical: We would like to expand the key only once, and encrypt the stream of plain-text blocks using-   the same expanded key (potentially using some crypto-mode), until we decide to change the key. In this-   section, we show how to use SBV to instead generate a library of functions that can be used in such a scenario.-   The generated library is a typical @.a@ archive, that can be linked using the C-compiler as usual.--}---- | Components of the AES-128 implementation that the library is generated from-aes128LibComponents :: [(String, SBVCodeGen ())]-aes128LibComponents = [ ("aes128KeySchedule",  keySchedule)-                      , ("aes128BlockEncrypt", enc128)-                      , ("aes128BlockDecrypt", dec128)-                      ]-  where -- key-schedule-        keySchedule = do key <- cgInputArr 4 "key"     -- key-                         let (encKS, decKS) = aesKeySchedule key-                         cgOutputArr "encKS" (ksToXKey encKS)-                         cgOutputArr "decKS" (ksToXKey decKS)-        -- encryption-        enc128 = do pt   <- cgInputArr 4  "pt"    -- plain-text-                    xkey <- cgInputArr 44 "xkey"  -- expanded key, for 128-bit AES, the key-expansion has 44 Word32's-                    cgOutputArr "ct" $ aesEncrypt pt (xkeyToKS xkey)-        -- decryption-        dec128 = do pt   <- cgInputArr 4  "ct"    -- cipher-text-                    xkey <- cgInputArr 44 "xkey"  -- expanded key, for 128-bit AES, the key-expansion has 44 Word32's-                    cgOutputArr "pt" $ aesDecrypt pt (xkeyToKS xkey)-        -- Transforming back and forth from our KS type to a flat array used by the generated C code-        -- Turn a series of expanded keys to our internal KS type-        xkeyToKS :: [SWord32] -> KS-        xkeyToKS xs = (f, m, l)-           where f = take 4 xs                       -- first round key-                 m = chop4 (take 36 (drop 4 xs))     -- middle rounds-                 l = drop 40 xs                      -- last round key-        -- Turn a KS to a series of expanded key words-        ksToXKey :: KS -> [SWord32]-        ksToXKey (f, m, l) = f ++ concat m ++ l-        -- chunk in fours. (This function must be in some standard library, where?)-        chop4 :: [a] -> [[a]]-        chop4 [] = []-        chop4 xs = let (f, r) = splitAt 4 xs in f : chop4 r---- | Generate a C library, containing functions for performing 128-bit enc/dec/key-expansion.--- A note on performance: In a very rough speed test, the generated code was able to do--- 6.3 million block encryptions per second on a decent MacBook Pro. On the same machine, OpenSSL--- reports 8.2 million block encryptions per second. So, the generated code is about 25% slower--- as compared to the highly optimized OpenSSL implementation. (Note that the speed test was done--- somewhat simplistically, so these numbers should be considered very rough estimates.)-cgAES128Library :: IO ()-cgAES128Library = compileToCLib Nothing "aes128Lib" aes128LibComponents------------------------------------------------------------------------------------------------- | For doctest purposes only-hex8 :: (SymWord a, Show a, Integral a) => SBV a -> String-hex8 v = replicate (8 - length s) '0' ++ s-  where s = flip showHex "" . fromJust . unliteral $ v--{-# ANN aesRound    ("HLint: ignore Use head" :: String) #-}-{-# ANN aesInvRound ("HLint: ignore Use head" :: String) #-}
− Data/SBV/Examples/Crypto/RC4.hs 
@@ -1,153 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Crypto.RC4--- Copyright   :  (c) Austin Seipp--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ An implementation of RC4 (AKA Rivest Cipher 4 or Alleged RC4/ARC4),--- using SBV. For information on RC4, see: <http://en.wikipedia.org/wiki/RC4>.------ We make no effort to optimize the code, and instead focus on a clear--- implementation. In fact, the RC4 algorithm relies on in-place update of--- its state heavily for efficiency, and is therefore unsuitable for a purely--- functional implementation.--------------------------------------------------------------------------------{-# LANGUAGE ScopedTypeVariables #-}--module Data.SBV.Examples.Crypto.RC4 where--import Data.Char  (ord, chr)-import Data.List  (genericIndex)-import Data.Maybe (fromJust)-import Data.SBV--import Data.SBV.Tools.STree--import Numeric (showHex)---------------------------------------------------------------------------------- * Types---------------------------------------------------------------------------------- | RC4 State contains 256 8-bit values. We use the symbolically accessible--- full-binary type 'STree' to represent the state, since RC4 needs--- access to the array via a symbolic index and it's important to minimize access time.-type S = STree Word8 Word8---- | Construct the fully balanced initial tree, where the leaves are simply the numbers @0@ through @255@.-initS :: S-initS = mkSTree (map literal [0 .. 255])---- | The key is a stream of 'Word8' values.-type Key = [SWord8]---- | Represents the current state of the RC4 stream: it is the @S@ array--- along with the @i@ and @j@ index values used by the PRGA.-type RC4 = (S, SWord8, SWord8)---------------------------------------------------------------------------------- * The PRGA---------------------------------------------------------------------------------- | Swaps two elements in the RC4 array.-swap :: SWord8 -> SWord8 -> S -> S-swap i j st = writeSTree (writeSTree st i stj) j sti-  where sti = readSTree st i-        stj = readSTree st j---- | Implements the PRGA used in RC4. We return the new state and the next key value generated.-prga :: RC4 -> (SWord8, RC4)-prga (st', i', j') = (readSTree st kInd, (st, i, j))-  where i    = i' + 1-        j    = j' + readSTree st' i-        st   = swap i j st'-        kInd = readSTree st i + readSTree st j---------------------------------------------------------------------------------- * Key schedule---------------------------------------------------------------------------------- | Constructs the state to be used by the PRGA using the given key.-initRC4 :: Key -> S-initRC4 key- | keyLength < 1 || keyLength > 256- = error $ "RC4 requires a key of length between 1 and 256, received: " ++ show keyLength- | True- = snd $ foldl mix (0, initS) [0..255]- where keyLength = length key-       mix :: (SWord8, S) -> SWord8 -> (SWord8, S)-       mix (j', s) i = let j = j' + readSTree s i + genericIndex key (fromJust (unliteral i) `mod` fromIntegral keyLength)-                       in (j, swap i j s)---- | The key-schedule. Note that this function returns an infinite list.-keySchedule :: Key -> [SWord8]-keySchedule key = genKeys (initRC4 key, 0, 0)-  where genKeys :: RC4 -> [SWord8]-        genKeys st = let (k, st') = prga st in k : genKeys st'---- | Generate a key-schedule from a given key-string.-keyScheduleString :: String -> [SWord8]-keyScheduleString = keySchedule . map (literal . fromIntegral . ord)---------------------------------------------------------------------------------- * Encryption and Decryption---------------------------------------------------------------------------------- | RC4 encryption. We generate key-words and xor it with the input. The--- following test-vectors are from Wikipedia <http://en.wikipedia.org/wiki/RC4>:------ >>> concatMap hex2 $ encrypt "Key" "Plaintext"--- "bbf316e8d940af0ad3"------ >>> concatMap hex2 $ encrypt "Wiki" "pedia"--- "1021bf0420"------ >>> concatMap hex2 $ encrypt "Secret" "Attack at dawn"--- "45a01f645fc35b383552544b9bf5"-encrypt :: String -> String -> [SWord8]-encrypt key pt = zipWith xor (keyScheduleString key) (map cvt pt)-  where cvt = literal . fromIntegral . ord---- | RC4 decryption. Essentially the same as decryption. For the above test vectors we have:------ >>> decrypt "Key" [0xbb, 0xf3, 0x16, 0xe8, 0xd9, 0x40, 0xaf, 0x0a, 0xd3]--- "Plaintext"------ >>> decrypt "Wiki" [0x10, 0x21, 0xbf, 0x04, 0x20]--- "pedia"------ >>> decrypt "Secret" [0x45, 0xa0, 0x1f, 0x64, 0x5f, 0xc3, 0x5b, 0x38, 0x35, 0x52, 0x54, 0x4b, 0x9b, 0xf5]--- "Attack at dawn"-decrypt :: String -> [SWord8] -> String-decrypt key ct = map cvt $ zipWith xor (keyScheduleString key) ct-  where cvt = chr . fromIntegral . fromJust . unliteral---------------------------------------------------------------------------------- * Verification---------------------------------------------------------------------------------- | Prove that round-trip encryption/decryption leaves the plain-text unchanged.--- The theorem is stated parametrically over key and plain-text sizes. The expression--- performs the proof for a 40-bit key (5 bytes) and 40-bit plaintext (again 5 bytes).------ Note that this theorem is trivial to prove, since it is essentially establishing--- xor'in the same value twice leaves a word unchanged (i.e., @x `xor` y `xor` y = x@).--- However, the proof takes quite a while to complete, as it gives rise to a fairly--- large symbolic trace.-rc4IsCorrect :: IO ThmResult-rc4IsCorrect = prove $ do-        key <- mkForallVars 5-        pt  <- mkForallVars 5-        let ks  = keySchedule key-            ct  = zipWith xor ks pt-            pt' = zipWith xor ks ct-        return $ pt .== pt'------------------------------------------------------------------------------------------------- | For doctest purposes only-hex2 :: (SymWord a, Show a, Integral a) => SBV a -> String-hex2 v = replicate (2 - length s) '0' ++ s-  where s = flip showHex "" . fromJust . unliteral $ v
− Data/SBV/Examples/Existentials/CRCPolynomial.hs 
@@ -1,101 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Existentials.CRCPolynomial--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ This program demonstrates the use of the existentials and the QBVF (quantified--- bit-vector solver). We generate CRC polynomials of degree 16 that can be used--- for messages of size 48-bits. The query finds all such polynomials that have hamming--- distance is at least 4. That is, if the CRC can't tell two different 48-bit messages--- apart, then they must differ in at least 4 bits.--------------------------------------------------------------------------------module Data.SBV.Examples.Existentials.CRCPolynomial where--import Data.SBV-import Data.SBV.Tools.Polynomial---------------------------------------------------------------------------------- * Modeling 48 bit words--------------------------------------------------------------------------------- | SBV doesn't support 48 bit words natively. So, we represent them--- as a tuple, 32 high-bits and 16 low-bits.-type SWord48 = (SWord32, SWord16)---- | Compute the 16 bit CRC of a 48 bit message, using the given polynomial-crc_48_16 :: SWord48 -> SWord16 -> [SBool]-crc_48_16 msg poly = crcBV 16 msgBits polyBits-  where (hi, lo) = msg-        msgBits  = blastBE hi ++ blastBE lo-        polyBits = blastBE poly---- | Count the differing bits in the message and the corresponding CRC-diffCount :: (SWord48, [SBool]) -> (SWord48, [SBool]) -> SWord8-diffCount ((h1, l1), crc1) ((h2, l2), crc2) = count xorBits-  where bits1   = blastBE h1 ++ blastBE l1 ++ crc1-        bits2   = blastBE h2 ++ blastBE l2 ++ crc2-        -- xor will give us a false if bits match, true if they differ-        xorBits = zipWith (<+>) bits1 bits2-        count []     = 0-        count (b:bs) = let r = count bs in ite b (1+r) r---- | Given a hamming distance value @hd@, 'crcGood' returns @true@ if--- the 16 bit polynomial can distinguish all messages that has at most--- @hd@ different bits. Note that we express this conversely: If the--- @sent@ and @received@ messages are different, then it must be the--- case that that must differ from each other (including CRCs), in--- more than @hd@ bits.-crcGood :: SWord8 -> SWord16 -> SWord48 -> SWord48 -> SBool-crcGood hd poly sent received =-     sent ./= received ==> diffCount (sent, crcSent) (received, crcReceived) .>= hd-   where crcSent     = crc_48_16 sent     poly-         crcReceived = crc_48_16 received poly---- | Generate good CRC polynomials for 48-bit words, given the hamming distance @hd@.-genPoly :: SWord8 -> IO ()-genPoly hd = do res <- allSat $ do-                        -- the polynomial is existentially specified-                        p <- exists "polynomial"-                        -- sent word, universal-                        s <- do sh <- forall "sh"-                                sl <- forall "sl"-                                return (sh, sl)-                        -- received word, universal-                        r <- do rh <- forall "rh"-                                rl <- forall "rl"-                                return (rh, rl)-                        -- assert that the polynomial @p@ is good. Note-                        -- that we also supply the extra information that-                        -- the least significant bit must be set in the-                        -- polynomial, as all CRC polynomials have the "+1"-                        -- term in them set. This simplifies the query.-                        return $ sTestBit p 0 &&& crcGood hd p s r-                cnt <- displayModels disp res-                putStrLn $ "Found: " ++ show cnt ++ " polynomail(s)."-        where disp :: Int -> (Bool, Word16) -> IO ()-              disp n (_, s) = putStrLn $ "Polynomial #" ++ show n ++ ". x^16 + " ++ showPolynomial False s---- | Find and display all degree 16 polynomials with hamming distance at least 4, for 48 bit messages.------ When run, this function prints:------  @---    Polynomial #1. x^16 + x^2 + x + 1---    Polynomial #2. x^16 + x^15 + x^2 + 1---    Polynomial #3. x^16 + x^15 + x^2 + x + 1---    Polynomial #4. x^16 + x^14 + x^10 + 1---    Polynomial #5. x^16 + x^14 + x^9 + 1---    ...---  @------ Note that different runs can produce different results, depending on the random--- numbers used by the solver, solver version, etc. (Also, the solver will take some--- time to generate these results. On my machine, the first five polynomials were--- generated in about 5 minutes.)-findHD4Polynomials :: IO ()-findHD4Polynomials = genPoly 4--{-# ANN crc_48_16 ("HLint: ignore Use camelCase" :: String) #-}
− Data/SBV/Examples/Existentials/Diophantine.hs 
@@ -1,147 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Existentials.Diophantine--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Finding minimal natural number solutions to linear Diophantine equations,--- using explicit quantification.-------------------------------------------------------------------------------module Data.SBV.Examples.Existentials.Diophantine where--import Data.SBV-import Data.SBV.Control------------------------------------------------------------------------------------------------------- * Representing solutions------------------------------------------------------------------------------------------------------ | For a homogeneous problem, the solution is any linear combination of the resulting vectors.--- For a non-homogeneous problem, the solution is any linear combination of the vectors in the--- second component plus one of the vectors in the first component.-data Solution = Homogeneous    [[Integer]]-              | NonHomogeneous [[Integer]] [[Integer]]-              deriving Show------------------------------------------------------------------------------------------------------- * Solving diophantine equations------------------------------------------------------------------------------------------------------ | ldn: Solve a (L)inear (D)iophantine equation, returning minimal solutions over (N)aturals.--- The input is given as a rows of equations, with rhs values separated into a tuple. The first--- parameter limits the search to bound: In case there are too many solutions, you might want--- to limit your search space.-ldn :: Maybe Int -> [([Integer], Integer)] -> IO Solution-ldn mbLim problem = do solution <- basis mbLim (map (map literal) m)-                       if homogeneous-                           then return $ Homogeneous solution-                           else do let ones  = [xs | (1:xs) <- solution]-                                       zeros = [xs | (0:xs) <- solution]-                                   return $ NonHomogeneous ones zeros-  where rhs = map snd problem-        lhs = map fst problem-        homogeneous = all (== 0) rhs-        m | homogeneous = lhs-          | True        = zipWith (\x y -> -x : y) rhs lhs---- | Find the basis solution. By definition, the basis has all non-trivial (i.e., non-0) solutions--- that cannot be written as the sum of two other solutions. We use the mathematically equivalent--- statement that a solution is in the basis if it's least according to the lexicographic--- order using the ordinary less-than relation. (NB. We explicitly tell z3 to use the logic--- AUFLIA for this problem, as the BV solver that is chosen automatically has a performance--- issue. See: <https://z3.codeplex.com/workitem/88>.)-basis :: Maybe Int -> [[SInteger]] -> IO [[Integer]]-basis mbLim m = extractModels `fmap` allSatWith z3{allSatMaxModelCount = mbLim} cond- where cond = do as <- mkExistVars  n-                 bs <- mkForallVars n--                 -- Tell the solver to use this logic!-                 setLogic AUFLIA--                 return $ ok as &&& (ok bs ==> as .== bs ||| bnot (bs `less` as))--       n = if null m then 0 else length (head m)--       ok xs = bAny (.> 0) xs &&& bAll (.>= 0) xs &&& bAnd [sum (zipWith (*) r xs) .== 0 | r <- m]-       as `less` bs = bAnd (zipWith (.<=) as bs) &&& bOr (zipWith (.<) as bs)------------------------------------------------------------------------------------------------------- * Examples------------------------------------------------------------------------------------------------------- | Solve the equation:------    @2x + y - z = 2@------ We have:------ >>> test--- NonHomogeneous [[0,2,0],[1,0,0]] [[0,1,1],[1,0,2]]------ which means that the solutions are of the form:------    @(1, 0, 0) + k (0, 1, 1) + k' (1, 0, 2) = (1+k', k, k+2k')@------ OR------    @(0, 2, 0) + k (0, 1, 1) + k' (1, 0, 2) = (k', 2+k, k+2k')@------ for arbitrary @k@, @k'@. It's easy to see that these are really solutions--- to the equation given. It's harder to see that they cover all possibilities,--- but a moments thought reveals that is indeed the case.-test :: IO Solution-test = ldn Nothing [([2,1,-1], 2)]---- | A puzzle: Five sailors and a monkey escape from a naufrage and reach an island with--- coconuts. Before dawn, they gather a few of them and decide to sleep first and share--- the next day. At night, however, one of them awakes, counts the nuts, makes five parts,--- gives the remaining nut to the monkey, saves his share away, and sleeps. All other--- sailors do the same, one by one. When they all wake up in the morning, they again make 5 shares,--- and give the last remaining nut to the monkey. How many nuts were there at the beginning?------ We can model this as a series of diophantine equations:------ @---       x_0 = 5 x_1 + 1---     4 x_1 = 5 x_2 + 1---     4 x_2 = 5 x_3 + 1---     4 x_3 = 5 x_4 + 1---     4 x_4 = 5 x_5 + 1---     4 x_5 = 5 x_6 + 1--- @------ We need to solve for x_0, over the naturals. We have:------ >>> sailors--- [15621,3124,2499,1999,1599,1279,1023]------ That is:------ @---   * There was a total of 15621 coconuts---   * 1st sailor: 15621 = 3124*5+1, leaving 15621-3124-1 = 12496---   * 2nd sailor: 12496 = 2499*5+1, leaving 12496-2499-1 =  9996---   * 3rd sailor:  9996 = 1999*5+1, leaving  9996-1999-1 =  7996---   * 4th sailor:  7996 = 1599*5+1, leaving  7996-1599-1 =  6396---   * 5th sailor:  6396 = 1279*5+1, leaving  6396-1279-1 =  5116---   * In the morning, they had: 5116 = 1023*5+1.--- @------ Note that this is the minimum solution, that is, we are guaranteed that there's--- no solution with less number of coconuts. In fact, any member of @[15625*k-4 | k <- [1..]]@--- is a solution, i.e., so are @31246@, @46871@, @62496@, @78121@, etc.------ Note that we iteratively deepen our search by requesting increasing number of--- solutions to avoid the all-sat pitfall.-sailors :: IO [Integer]-sailors = search 1-  where search i = do soln <- ldn (Just i) [ ([1, -5,  0,  0,  0,  0,  0], 1)-                                           , ([0,  4, -5 , 0,  0,  0,  0], 1)-                                           , ([0,  0,  4, -5 , 0,  0,  0], 1)-                                           , ([0,  0,  0,  4, -5,  0,  0], 1)-                                           , ([0,  0,  0,  0,  4, -5,  0], 1)-                                           , ([0,  0,  0,  0,  0,  4, -5], 1)-                                           ]-                      case soln of-                        NonHomogeneous (xs:_) _ -> return xs-                        _                       -> search (i+1)
− Data/SBV/Examples/Misc/Auxiliary.hs 
@@ -1,63 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Misc.Auxiliary--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates model construction with auxiliary variables. Sometimes we--- need to introduce a variable in our problem as an existential variable,--- but it's "internal" to the problem and we do not consider it as part of--- the solution. Also, in an `allSat` scenario, we may not care for models--- that only differ in these auxiliaries. SBV allows designating such variables--- as `isNonModelVar` so we can still use them like any other variable, but without--- considering them explicitly in model construction.--------------------------------------------------------------------------------module Data.SBV.Examples.Misc.Auxiliary where--import Data.SBV---- | A simple predicate, based on two variables @x@ and @y@, true when--- @0 <= x <= 1@ and @x - abs y@ is @0@.-problem :: Predicate-problem = do x <- free "x"-             y <- free "y"-             constrain $ x .>= 0-             constrain $ x .<= 1-             return $ x - abs y .== (0 :: SInteger)---- | Generate all satisfying assignments for our problem. We have:------ >>> allModels--- Solution #1:---   x = 0 :: Integer---   y = 0 :: Integer--- Solution #2:---   x = 1 :: Integer---   y = 1 :: Integer--- Solution #3:---   x =  1 :: Integer---   y = -1 :: Integer--- Found 3 different solutions.------ Note that solutions @2@ and @3@ share the value @x = 1@, since there are--- multiple values of @y@ that make this particular choice of @x@ satisfy our constraint.-allModels :: IO AllSatResult-allModels = allSat problem---- | Generate all satisfying assignments, but we first tell SBV that @y@ should not be considered--- as a model problem, i.e., it's auxiliary. We have:------ >>> modelsWithYAux--- Solution #1:---   x = 0 :: Integer--- Solution #2:---   x = 1 :: Integer--- Found 2 different solutions.------ Note that we now have only two solutions, one for each unique value of @x@ that satisfy our--- constraint.-modelsWithYAux :: IO AllSatResult-modelsWithYAux = allSatWith z3{isNonModelVar = (`elem` ["y"])} problem
− Data/SBV/Examples/Misc/Enumerate.hs 
@@ -1,80 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Misc.Enumerate--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates how enumerations can be translated to their SMT-Lib--- counterparts, without losing any information content. Also see--- "Data.SBV.Examples.Puzzles.U2Bridge" for a more detailed--- example involving enumerations.--------------------------------------------------------------------------------{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveAnyClass      #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.SBV.Examples.Misc.Enumerate where--import Data.SBV---- | A simple enumerated type, that we'd like to translate to SMT-Lib intact;--- i.e., this type will not be uninterpreted but rather preserved and will--- be just like any other symbolic type SBV provides.------ Also note that we need to have the following @LANGUAGE@ options defined:--- @TemplateHaskell@, @StandaloneDeriving@, @DeriveDataTypeable@, @DeriveAnyClass@ for--- this to work.-data E = A | B | C---- | Make 'E' a symbolic value.-mkSymbolicEnumeration ''E---- | Give a name to the symbolic variants of 'E', for convenience-type SE = SBV E---- | Have the SMT solver enumerate the elements of the domain. We have:------ >>> elts--- Solution #1:---   s0 = B :: E--- Solution #2:---   s0 = A :: E--- Solution #3:---   s0 = C :: E--- Found 3 different solutions.-elts :: IO AllSatResult-elts = allSat $ \(x::SE) -> x .== x---- | Shows that if we require 4 distinct elements of the type 'E', we shall fail; as--- the domain only has three elements. We have:------ >>> four--- Unsatisfiable-four :: IO SatResult-four = sat $ \a b c (d::SE) -> distinct [a, b, c, d]---- | Enumerations are automatically ordered, so we can ask for the maximum--- element. Note the use of quantification. We have:------ >>> maxE--- Satisfiable. Model:---   maxE = C :: E-maxE :: IO SatResult-maxE = sat $ do mx <- exists "maxE"-                e  <- forall "e"-                return $ mx .>= (e::SE)---- | Similarly, we get the minumum element. We have:------ >>> minE--- Satisfiable. Model:---   minE = A :: E-minE :: IO SatResult-minE = sat $ do mx <- exists "minE"-                e  <- forall "e"-                return $ mx .<= (e::SE)
− Data/SBV/Examples/Misc/Floating.hs 
@@ -1,187 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Misc.Floating--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Several examples involving IEEE-754 floating point numbers, i.e., single--- precision 'Float' ('SFloat') and double precision 'Double' ('SDouble') types.------ Note that arithmetic with floating point is full of surprises; due to precision--- issues associativity of arithmetic operations typically do not hold. Also,--- the presence of @NaN@ is always something to look out for.--------------------------------------------------------------------------------{-# LANGUAGE ScopedTypeVariables #-}--module Data.SBV.Examples.Misc.Floating where--import Data.SBV---------------------------------------------------------------------------------- * FP addition is not associative---------------------------------------------------------------------------------- | Prove that floating point addition is not associative. For illustration purposes,--- we will require one of the inputs to be a @NaN@. We have:------ >>> prove $ assocPlus (0/0)--- Falsifiable. Counter-example:---   s0 = 0.0 :: Float---   s1 = 0.0 :: Float------ Indeed:------ >>> let i = 0/0 :: Float--- >>> i + (0.0 + 0.0)--- NaN--- >>> ((i + 0.0) + 0.0)--- NaN------ But keep in mind that @NaN@ does not equal itself in the floating point world! We have:------ >>> let nan = 0/0 :: Float in nan == nan--- False-assocPlus :: SFloat -> SFloat -> SFloat -> SBool-assocPlus x y z = x + (y + z) .== (x + y) + z---- | Prove that addition is not associative, even if we ignore @NaN@/@Infinity@ values.--- To do this, we use the predicate 'fpIsPoint', which is true of a floating point--- number ('SFloat' or 'SDouble') if it is neither @NaN@ nor @Infinity@. (That is, it's a--- representable point in the real-number line.)------ We have:------ >>> assocPlusRegular--- Falsifiable. Counter-example:---   x =  1.9259302e-34 :: Float---   y = -1.9259117e-34 :: Float---   z =  -1.814176e-39 :: Float------ Indeed, we have:------ >>> ((1.9259302e-34) + ((-1.9259117e-34) + (-1.814176e-39))) :: Float--- 3.4438e-41--- >>> (((1.9259302e-34) + ((-1.9259117e-34))) + (-1.814176e-39)) :: Float--- 3.4014e-41------ Note the difference between two additions!-assocPlusRegular :: IO ThmResult-assocPlusRegular = prove $ do [x, y, z] <- sFloats ["x", "y", "z"]-                              let lhs = x+(y+z)-                                  rhs = (x+y)+z-                              -- make sure we do not overflow at the intermediate points-                              constrain $ fpIsPoint lhs-                              constrain $ fpIsPoint rhs-                              return $ lhs .== rhs---------------------------------------------------------------------------------- * FP addition by non-zero can result in no change---------------------------------------------------------------------------------- | Demonstrate that @a+b = a@ does not necessarily mean @b@ is @0@ in the floating point world,--- even when we disallow the obvious solution when @a@ and @b@ are @Infinity.@--- We have:------ >>> nonZeroAddition--- Falsifiable. Counter-example:---   a = 2.424457e-38 :: Float---   b =     -1.0e-45 :: Float------ Indeed, we have:------ >>> (2.424457e-38 + (-1.0e-45)) == (2.424457e-38 :: Float)--- True------ But:------ >>> -1.0e-45 == (0 :: Float)--- False----nonZeroAddition :: IO ThmResult-nonZeroAddition = prove $ do [a, b] <- sFloats ["a", "b"]-                             constrain $ fpIsPoint a-                             constrain $ fpIsPoint b-                             constrain $ a + b .== a-                             return $ b .== 0---------------------------------------------------------------------------------- * FP multiplicative inverses may not exist---------------------------------------------------------------------------------- | This example illustrates that @a * (1/a)@ does not necessarily equal @1@. Again,--- we protect against division by @0@ and @NaN@/@Infinity@.------ We have:------ >>> multInverse--- Falsifiable. Counter-example:---   a = 1.119056263978578e-308 :: Double------ Indeed, we have:------ >>> let a = 1.119056263978578e-308 :: Double--- >>> a * (1/a)--- 0.9999999999999999-multInverse :: IO ThmResult-multInverse = prove $ do a <- sDouble "a"-                         constrain $ fpIsPoint a-                         constrain $ fpIsPoint (1/a)-                         return $ a * (1/a) .== 1---------------------------------------------------------------------------------- * Effect of rounding modes---------------------------------------------------------------------------------- | One interesting aspect of floating-point is that the chosen rounding-mode--- can effect the results of a computation if the exact result cannot be precisely--- represented. SBV exports the functions 'fpAdd', 'fpSub', 'fpMul', 'fpDiv', 'fpFMA'--- and 'fpSqrt' which allows users to specify the IEEE supported 'RoundingMode' for--- the operation. (Also see the class 'RoundingFloat'.) This example illustrates how SBV--- can be used to find rounding-modes where, for instance, addition can produce different--- results. We have:------ >>> roundingAdd--- Satisfiable. Model:---   rm = RoundTowardPositive :: RoundingMode---   x  =                 1.0 :: Float---   y  =       -6.1035094e-5 :: Float------ (Note that depending on your version of Z3, you might get a different result.)--- Unfortunately we can't directly validate this result at the Haskell level, as Haskell only supports--- 'RoundNearestTiesToEven'. We have:------ >>> (1 + (-6.1035094e-5)) :: Float--- 0.99993896------ While we cannot directly see the result when the mode is 'RoundTowardPositive' in Haskell, we can use--- SBV to provide us with that result thusly:------ >>> sat $ \z -> z .== fpAdd sRoundTowardPositive   1 (-6.1035094e-5 :: SFloat)--- Satisfiable. Model:---   s0 = 0.999939 :: Float------ We can see why these two resuls are indeed different: The 'RoundTowardsPositive'--- (which rounds towards positive-infinity) produces a larger result. Indeed, if we treat these numbers--- as 'Double' values, we get:------ >>> (1 + (-6.1035094e-5)) :: Double--- 0.999938964906------ we see that the "more precise" result is larger than what the 'Float' value is, justifying the--- larger value with 'RoundTowardPositive'. A more detailed study is beyond our current scope, so we'll---  merely -- note that floating point representation and semantics is indeed a thorny--- subject, and point to <https://ece.uwaterloo.ca/~dwharder/NumericalAnalysis/02Numerics/Double/paper.pdf> as--- an excellent guide.-roundingAdd :: IO SatResult-roundingAdd = sat $ do m :: SRoundingMode <- free "rm"-                       constrain $ m ./= literal RoundNearestTiesToEven-                       x <- sFloat "x"-                       y <- sFloat "y"-                       let lhs = fpAdd m x y-                       let rhs = x + y-                       constrain $ fpIsPoint lhs-                       constrain $ fpIsPoint rhs-                       return $ lhs ./= rhs
− Data/SBV/Examples/Misc/ModelExtract.hs 
@@ -1,46 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Misc.ModelExtract--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates use of programmatic model extraction. When programming with--- SBV, we typically use `sat`/`allSat` calls to compute models automatically.--- In more advanced uses, however, the user might want to use programmable--- extraction features to do fancier programming. We demonstrate some of--- these utilities here.--------------------------------------------------------------------------------module Data.SBV.Examples.Misc.ModelExtract where--import Data.SBV---- | A simple function to generate a new integer value, that is not in the--- given set of values. We also require the value to be non-negative-outside :: [Integer] -> IO SatResult-outside disallow = sat $ do x <- sInteger "x"-                            let notEq i = constrain $ x ./= literal i-                            mapM_ notEq disallow-                            return $ x .>= 0---- | We now use "outside" repeatedly to generate 10 integers, such that we not only disallow--- previously generated elements, but also any value that differs from previous solutions--- by less than 5.  Here, we use the `getModelValue` function. We could have also extracted the dictionary--- via `getModelDictionary` and did fancier programming as well, as necessary. We have:------ >>> genVals--- [45,40,35,30,25,20,15,10,5,0]-genVals :: IO [Integer]-genVals = go [] []-  where go _ model-         | length model >= 10 = return model-        go disallow model-          = do res <- outside disallow-               -- Look up the value of "x" in the generated model-               -- Note that we simply get an integer here; but any-               -- SBV known type would be OK as well.-               case "x" `getModelValue` res of-                 Just c -> go [c-4 .. c+4] (c : model)-                 _      -> return model
− Data/SBV/Examples/Misc/NoDiv0.hs 
@@ -1,44 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Misc.NoDiv0--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates SBV's assertion checking facilities--------------------------------------------------------------------------------{-# LANGUAGE ImplicitParams #-}--module Data.SBV.Examples.Misc.NoDiv0 where--import Data.SBV-import GHC.Stack---- | A simple variant of division, where we explicitly require the--- caller to make sure the divisor is not 0.-checkedDiv :: (?loc :: CallStack) => SInt32 -> SInt32 -> SInt32-checkedDiv x y = sAssert (Just ?loc)-                         "Divisor should not be 0"-                         (y ./= 0)-                         (x `sDiv` y)---- | Check whether an arbitrary call to 'checkedDiv' is safe. Clearly, we do not expect--- this to be safe:------ >>> test1--- [Data/SBV/Examples/Misc/NoDiv0.hs:36:14:checkedDiv: Divisor should not be 0: Violated. Model:---   s0 = 0 :: Int32---   s1 = 0 :: Int32]----test1 :: IO [SafeResult]-test1 = safe checkedDiv---- | Repeat the test, except this time we explicitly protect against the bad case. We have:------ >>> test2--- [Data/SBV/Examples/Misc/NoDiv0.hs:44:41:checkedDiv: Divisor should not be 0: No violations detected]----test2 :: IO [SafeResult]-test2 = safe $ \x y -> ite (y .== 0) 3 (checkedDiv x y)
− Data/SBV/Examples/Misc/Word4.hs 
@@ -1,145 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Misc.Enumerate--- Copyright   :  (c) Brian Huffman--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates how new sizes of word/int types can be defined and--- used with SBV.--------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Data.SBV.Examples.Misc.Word4 where--import GHC.Enum (boundedEnumFrom, boundedEnumFromThen, toEnumError, succError, predError)--import Data.Bits-import Data.Generics (Data, Typeable)-import System.Random (Random(..))--import Data.SBV-import Data.SBV.Internals---- | Word4 as a newtype. Invariant: @Word4 x@ should satisfy @x < 16@.-newtype Word4 = Word4 Word8-  deriving (Eq, Ord, Data, Typeable)---- | Smart constructor; simplifies conversion from Word8-word4 :: Word8 -> Word4-word4 x = Word4 (x .&. 0x0f)---- | Show instance-instance Show Word4 where-  show (Word4 x) = show x---- | Read instance. We read as an 8-bit word, and coerce-instance Read Word4 where-  readsPrec p s = [ (word4 x, s') | (x, s') <- readsPrec p s ]---- | Bounded instance; from 0 to 255-instance Bounded Word4 where-  minBound = Word4 0x00-  maxBound = Word4 0x0f---- | Enum instance, trivial definitions.-instance Enum Word4 where-  succ (Word4 x) = if x < 0x0f then Word4 (succ x) else succError "Word4"-  pred (Word4 x) = if x > 0x00 then Word4 (pred x) else predError "Word4"-  toEnum i | 0x00 <= i && i <= 0x0f = Word4 (toEnum i)-           | otherwise              = toEnumError "Word4" i (Word4 0x00, Word4 0x0f)-  fromEnum (Word4 x) = fromEnum x-  -- Comprehensions-  enumFrom                                     = boundedEnumFrom-  enumFromThen                                 = boundedEnumFromThen-  enumFromTo     (Word4 x) (Word4 y)           = map Word4 (enumFromTo x y)-  enumFromThenTo (Word4 x) (Word4 y) (Word4 z) = map Word4 (enumFromThenTo x y z)---- | Num instance, merely lifts underlying 8-bit operation and casts back-instance Num Word4 where-  Word4 x + Word4 y = word4 (x + y)-  Word4 x * Word4 y = word4 (x * y)-  Word4 x - Word4 y = word4 (x - y)-  negate (Word4 x)  = word4 (negate x)-  abs (Word4 x)     = Word4 x-  signum (Word4 x)  = Word4 (if x == 0 then 0 else 1)-  fromInteger n     = word4 (fromInteger n)---- | Real instance simply uses the Word8 instance-instance Real Word4 where-  toRational (Word4 x) = toRational x---- | Integral instance, again using Word8 instance and casting. NB. we do--- not need to use the smart constructor here as neither the quotient nor--- the remainder can overflow a Word4.-instance Integral Word4 where-  quotRem (Word4 x) (Word4 y) = (Word4 q, Word4 r)-    where (q, r) = quotRem x y-  toInteger (Word4 x) = toInteger x---- | Bits instance-instance Bits Word4 where-  Word4 x  .&.  Word4 y = Word4 (x  .&.  y)-  Word4 x  .|.  Word4 y = Word4 (x  .|.  y)-  Word4 x `xor` Word4 y = Word4 (x `xor` y)-  complement (Word4 x)  = Word4 (x `xor` 0x0f)-  Word4 x `shift`  i    = word4 (shift x i)-  Word4 x `shiftL` i    = word4 (shiftL x i)-  Word4 x `shiftR` i    = Word4 (shiftR x i)-  Word4 x `rotate` i    = word4 (x `shiftL` k .|. x `shiftR` (4-k))-                            where k = i .&. 3-  bitSize _             = 4-  bitSizeMaybe _        = Just 4-  isSigned _            = False-  testBit (Word4 x)     = testBit x-  bit i                 = word4 (bit i)-  popCount (Word4 x)    = popCount x---- | Random instance, used in quick-check-instance Random Word4 where-  randomR (Word4 lo, Word4 hi) gen = (Word4 x, gen')-    where (x, gen') = randomR (lo, hi) gen-  random gen = (Word4 x, gen')-    where (x, gen') = randomR (0x00, 0x0f) gen---- | SWord4 type synonym-type SWord4 = SBV Word4---- | SymWord instance, allowing this type to be used in proofs/sat etc.-instance SymWord Word4 where-  mkSymWord  = genMkSymVar (KBounded False 4)-  literal    = genLiteral  (KBounded False 4)-  fromCW     = genFromCW---- | HasKind instance; simply returning the underlying kind for the type-instance HasKind Word4 where-  kindOf _ = KBounded False 4---- | SatModel instance, merely uses the generic parsing method.-instance SatModel Word4 where-  parseCWs = genParse (KBounded False 4)---- | SDvisible instance, using 0-extension-instance SDivisible Word4 where-  sQuotRem x 0 = (0, x)-  sQuotRem x y = x `quotRem` y-  sDivMod  x 0 = (0, x)-  sDivMod  x y = x `divMod` y---- | SDvisible instance, using default methods-instance SDivisible SWord4 where-  sQuotRem = liftQRem-  sDivMod  = liftDMod---- | SIntegral instance, using default methods-instance SIntegral Word4---- | Joining/splitting to/from Word8-instance Splittable Word8 Word4 where-  split x           = (Word4 (x `shiftR` 4), word4 x)-  Word4 x # Word4 y = (x `shiftL` 4) .|. y-  extend (Word4 x)  = x
− Data/SBV/Examples/Optimization/ExtField.hs 
@@ -1,45 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Optimization.ExtField--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates the extension field (@oo@/@epsilon@) optimization results.--------------------------------------------------------------------------------module Data.SBV.Examples.Optimization.ExtField where--import Data.SBV---- | Optimization goals where min/max values might require assignments--- to values that are infinite (integer case), or infinite/epsion (real case).--- This simple example demostrates how SBV can be used to extract such values.------ We have:------ >>> optimize Independent problem--- Objective "one-x": Optimal in an extension field:---   one-x =                    oo :: Integer---   min_y = 7.0 + (2.0 * epsilon) :: Real---   min_z =         5.0 + epsilon :: Real--- Objective "min_y": Optimal in an extension field:---   one-x =                    oo :: Integer---   min_y = 7.0 + (2.0 * epsilon) :: Real---   min_z =         5.0 + epsilon :: Real--- Objective "min_z": Optimal in an extension field:---   one-x =                    oo :: Integer---   min_y = 7.0 + (2.0 * epsilon) :: Real---   min_z =         5.0 + epsilon :: Real-problem :: Goal-problem = do x <- sInteger "x"-             y <- sReal "y"-             z <- sReal "z"--             maximize "one-x" $ 1 - x--             constrain $ y .> 0 &&& z .> 5-             minimize "min_y" $ 2+y+z--             minimize "min_z" z
− Data/SBV/Examples/Optimization/LinearOpt.hs 
@@ -1,41 +0,0 @@--------------------------------------------------------------------------------- |--- 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 Lexicographic 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 
@@ -1,67 +0,0 @@--------------------------------------------------------------------------------- |--- 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 Lexicographic 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 
@@ -1,87 +0,0 @@--------------------------------------------------------------------------------- |--- 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---- | The allocation problem. Inspired by: <http://rise4fun.com/Z3/tutorialcontent/optimization#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 Lexicographic 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 $ pbStronglyMutexed x1-    constrain $ pbStronglyMutexed x2-    constrain $ pbStronglyMutexed 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 
@@ -1,78 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Polynomials.Polynomials--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Simple usage of polynomials over GF(2^n), using Rijndael's--- finite field: <http://en.wikipedia.org/wiki/Finite_field_arithmetic#Rijndael.27s_finite_field>------ The functions available are:------  [/pMult/] GF(2^n) Multiplication------  [/pDiv/] GF(2^n) Division------  [/pMod/] GF(2^n) Modulus------  [/pDivMod/] GF(2^n) Division/Modulus, packed together------ Note that addition in GF(2^n) is simply `xor`, so no custom function is provided.--------------------------------------------------------------------------------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.-type GF28 = SWord8---- | Multiplication in Rijndael's field; usual polynomial multiplication followed by reduction--- by the irreducible polynomial.  The irreducible used by Rijndael's field is the polynomial--- @x^8 + x^4 + x^3 + x + 1@, which we write by giving it's /exponents/ in SBV.--- See: <http://en.wikipedia.org/wiki/Finite_field_arithmetic#Rijndael.27s_finite_field>.--- Note that the irreducible itself is not in GF28! It has a degree of 8.------ NB. You can use the 'showPoly' function to print polynomials nicely, as a mathematician would write.-gfMult :: GF28 -> GF28 -> GF28-a `gfMult` b = pMult (a, b, [8, 4, 3, 1, 0])---- | States that the unit polynomial @1@, is the unit element-multUnit :: GF28 -> SBool-multUnit x = (x `gfMult` unit) .== x-  where unit = polynomial [0]   -- x@0---- | States that multiplication is commutative-multComm :: GF28 -> GF28 -> SBool-multComm x y = (x `gfMult` y) .== (y `gfMult` x)---- | States that multiplication is associative, note that associativity--- proofs are notoriously hard for SAT/SMT solvers-multAssoc :: GF28 -> GF28 -> GF28 -> SBool-multAssoc x y z = ((x `gfMult` y) `gfMult` z) .== (x `gfMult` (y `gfMult` z))---- | States that the usual multiplication rule holds over GF(2^n) polynomials--- Checks:------ @---    if (a, b) = x `pDivMod` y then x = y `pMult` a + b--- @------ being careful about @y = 0@. When divisor is 0, then quotient is--- defined to be 0 and the remainder is the numerator.--- (Note that addition is simply `xor` in GF(2^8).)-polyDivMod :: GF28 -> GF28 -> SBool-polyDivMod x y = ite (y .== 0) ((0, x) .== (a, b)) (x .== (y `gfMult` a) `xor` b)-  where (a, b) = x `pDivMod` y---- | Queries-testGF28 :: IO ()-testGF28 = do-  print =<< prove multUnit-  print =<< prove multComm-  -- print =<< prove multAssoc -- takes too long; see above note..-  print =<< prove polyDivMod
− Data/SBV/Examples/Puzzles/Birthday.hs 
@@ -1,145 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Puzzles.Birthday--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ This is a formalization of the Cheryl's birthday problem, which went viral in April 2015.--- (See <http://www.nytimes.com/2015/04/15/science/a-math-problem-from-singapore-goes-viral-when-is-cheryls-birthday.html>.)------ Here's the puzzle:------ @--- Albert and Bernard just met Cheryl. “When’s your birthday?” Albert asked Cheryl.------ Cheryl thought a second and said, “I’m not going to tell you, but I’ll give you some clues.” She wrote down a list of 10 dates:------   May 15, May 16, May 19---   June 17, June 18---   July 14, July 16---   August 14, August 15, August 17------ “My birthday is one of these,” she said.------ Then Cheryl whispered in Albert’s ear the month — and only the month — of her birthday. To Bernard, she whispered the day, and only the day. --- “Can you figure it out now?” she asked Albert.------ Albert: I don’t know when your birthday is, but I know Bernard doesn’t know, either.--- Bernard: I didn’t know originally, but now I do.--- Albert: Well, now I know, too!------ When is Cheryl’s birthday?--- @------ NB. Thanks to Amit Goel for suggesting the formalization strategy used in here.--------------------------------------------------------------------------------module Data.SBV.Examples.Puzzles.Birthday where--import Data.SBV---------------------------------------------------------------------------------------------------- * Types and values---------------------------------------------------------------------------------------------------- | Represent month by 8-bit words; We can also use an uninterpreted type, but numbers work well here.-type Month = SWord8---- | Represent day by 8-bit words; Again, an uninterpreted type would work as well.-type Day = SWord8---- | Months referenced in the problem.-may, june, july, august :: SWord8-[may, june, july, august] = [5, 6, 7, 8]---------------------------------------------------------------------------------------------------- * Helper predicates---------------------------------------------------------------------------------------------------- | Check that a given month/day combo is a possible birth-date.-valid :: Month -> Day -> SBool-valid month day = (month, day) `sElem` candidates-  where candidates :: [(Month, Day)]-        candidates = [ (   may, 15), (   may, 16), (   may, 19)-                     , (  june, 17), (  june, 18)-                     , (  july, 14), (  july, 16)-                     , (august, 14), (august, 15), (august, 17)-                     ]---- | Assert that the given function holds for one of the possible days.-existsDay :: (Day -> SBool) -> SBool-existsDay f = bAny (f . literal) [14 .. 19]---- | Assert that the given function holds for all of the possible days.-forallDay :: (Day -> SBool) -> SBool-forallDay f = bAll (f . literal) [14 .. 19]---- | Assert that the given function holds for one of the possible months.-existsMonth :: (Month -> SBool) -> SBool-existsMonth f = bAny f [may .. august]---- | Assert that the given function holds for all of the possible months.-forallMonth :: (Month -> SBool) -> SBool-forallMonth f = bAll f [may .. august]---------------------------------------------------------------------------------------------------- * The puzzle---------------------------------------------------------------------------------------------------- | Encode the conversation as given in the puzzle.------ NB. Lee Pike pointed out that not all the constraints are actually necessary! (Private--- communication.) The puzzle still has a unique solution if the statements 'a1' and 'b1'--- (i.e., Albert and Bernard saying they themselves do not know the answer) are removed.--- To experiment you can simply comment out those statements and observe that there still--- is a unique solution. Thanks to Lee for pointing this out! In fact, it is instructive to--- assert the conversation line-by-line, and see how the search-space gets reduced in each--- step.-puzzle :: Predicate-puzzle = do birthDay   <- exists "birthDay"-            birthMonth <- exists "birthMonth"--            -- Albert: I do not know-            let a1 m = existsDay $ \d1 -> existsDay $ \d2 ->-                           d1 ./= d2 &&& valid m d1 &&& valid m d2--            -- Albert: I know that Bernard doesn't know-            let a2 m = forallDay $ \d -> valid m d ==>-                          existsMonth (\m1 -> existsMonth $ \m2 ->-                                m1 ./= m2 &&& valid m1 d &&& valid m2 d)--            -- Bernard: I did not know-            let b1 d = existsMonth $ \m1 -> existsMonth $ \m2 ->-                           m1 ./= m2 &&& valid m1 d &&& valid m2 d--            -- Bernard: But now I know-            let b2p m d = valid m d &&& a1 m &&& a2 m-                b2  d   = forallMonth $ \m1 -> forallMonth $ \m2 ->-                                (b2p m1 d &&& b2p m2 d) ==> m1 .== m2--            -- Albert: Now I know too-            let a3p m d = valid m d &&& a1 m &&& a2 m &&& b1 d &&& b2 d-                a3 m    = forallDay $ \d1 -> forallDay $ \d2 ->-                                (a3p m d1 &&& a3p m d2) ==> d1 .== d2--            -- Assert all the statements made:-            constrain $ a1 birthMonth-            constrain $ a2 birthMonth-            constrain $ b1 birthDay-            constrain $ b2 birthDay-            constrain $ a3 birthMonth--            -- Find a valid birth-day that satisfies the above constraints:-            return $ valid birthMonth birthDay---- | Find all solutions to the birthday problem. We have:------ >>> cheryl--- Solution #1:---   birthDay   = 16 :: Word8---   birthMonth =  7 :: Word8--- This is the only solution.-cheryl :: IO ()-cheryl = print =<< allSat puzzle
− Data/SBV/Examples/Puzzles/Coins.hs 
@@ -1,103 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Puzzles.Coins--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Solves the following puzzle:------ @--- You and a friend pass by a standard coin operated vending machine and you decide to get a candy bar.--- The price is US $0.95, but after checking your pockets you only have a dollar (US $1) and the machine--- only takes coins. You turn to your friend and have this conversation:---   you: Hey, do you have change for a dollar?---   friend: Let's see. I have 6 US coins but, although they add up to a US $1.15, I can't break a dollar.---   you: Huh? Can you make change for half a dollar?---   friend: No.---   you: How about a quarter?---   friend: Nope, and before you ask I cant make change for a dime or nickel either.---   you: Really? and these six coins are all US government coins currently in production? ---   friend: Yes.---   you: Well can you just put your coins into the vending machine and buy me a candy bar, and I'll pay you back?---   friend: Sorry, I would like to but I cant with the coins I have.--- What coins are your friend holding?--- @------ To be fair, the problem has no solution /mathematically/. But there is a solution when one takes into account that--- vending machines typically do not take the 50 cent coins!-----------------------------------------------------------------------------------module Data.SBV.Examples.Puzzles.Coins where--import Data.SBV---- | We will represent coins with 16-bit words (more than enough precision for coins).-type Coin = SWord16---- | Create a coin. The argument Int argument just used for naming the coin. Note that--- we constrain the value to be one of the valid U.S. coin values as we create it.-mkCoin :: Int -> Symbolic Coin-mkCoin i = do c <- exists $ 'c' : show i-              constrain $ bAny (.== c) [1, 5, 10, 25, 50, 100]-              return c---- | Return all combinations of a sequence of values.-combinations :: [a] -> [[a]]-combinations coins = concat [combs i coins | i <- [1 .. length coins]]-  where combs 0 _      = [[]]-        combs _ []     = []-        combs k (x:xs) = map (x:) (combs (k-1) xs) ++ combs k xs---- | Constraint 1: Cannot make change for a dollar.-c1 :: [Coin] -> SBool-c1 xs = sum xs ./= 100---- | Constraint 2: Cannot make change for half a dollar.-c2 :: [Coin] -> SBool-c2 xs = sum xs ./= 50---- | Constraint 3: Cannot make change for a quarter.-c3 :: [Coin] -> SBool-c3 xs = sum xs ./= 25---- | Constraint 4: Cannot make change for a dime.-c4 :: [Coin] -> SBool-c4 xs = sum xs ./= 10---- | Constraint 5: Cannot make change for a nickel-c5 :: [Coin] -> SBool-c5 xs = sum xs ./= 5---- | Constraint 6: Cannot buy the candy either. Here's where we need to have the extra knowledge--- that the vending machines do not take 50 cent coins.-c6 :: [Coin] -> SBool-c6 xs = sum (map val xs) ./= 95-   where val x = ite (x .== 50) 0 x---- | Solve the puzzle. We have:------ >>> puzzle--- Satisfiable. Model:---   c1 = 50 :: Word16---   c2 = 25 :: Word16---   c3 = 10 :: Word16---   c4 = 10 :: Word16---   c5 = 10 :: Word16---   c6 = 10 :: Word16------ i.e., your friend has 4 dimes, a quarter, and a half dollar.-puzzle :: IO SatResult-puzzle = sat $ do-        cs <- mapM mkCoin [1..6]-        -- Assert each of the constraints for all combinations that has-        -- at least two coins (to make change)-        mapM_ constrain [c s | s <- combinations cs, length s >= 2, c <- [c1, c2, c3, c4, c5, c6]]-        -- the following constraint is not necessary for solving the puzzle-        -- however, it makes sure that the solution comes in decreasing value of coins,-        -- thus allowing the above test to succeed regardless of the solver used.-        constrain $ bAnd $ zipWith (.>=) cs (tail cs)-        -- assert that the sum must be 115 cents.-        return $ sum cs .== 115
− Data/SBV/Examples/Puzzles/Counts.hs 
@@ -1,83 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Puzzles.Counts--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Consider the sentence:------ @---    In this sentence, the number of occurrences of 0 is _, of 1 is _, of 2 is _,---    of 3 is _, of 4 is _, of 5 is _, of 6 is _, of 7 is _, of 8 is _, and of 9 is _.--- @------ The puzzle is to fill the blanks with numbers, such that the sentence--- will be correct. There are precisely two solutions to this puzzle, both of--- which are found by SBV successfully.------  References:------    * Douglas Hofstadter, Metamagical Themes, pg. 27.------    * <http://mathcentral.uregina.ca/mp/archives/previous2002/dec02sol.html>-----------------------------------------------------------------------------------module Data.SBV.Examples.Puzzles.Counts where--import Data.SBV---- | We will assume each number can be represented by an 8-bit word, i.e., can be at most 128.-type Count  = SWord8---- | Given a number, increment the count array depending on the digits of the number-count :: Count -> [Count] -> [Count]-count n cnts = ite (n .< 10)-                   (upd n cnts)                           -- only one digit-                   (ite (n .< 100)-                        (upd d1 (upd d2 cnts))            -- two digits-                        (upd d1 (upd d2 (upd d3 cnts))))  -- three digits-  where (r1, d1)   = n  `sQuotRem` 10-        (d3, d2)   = r1 `sQuotRem` 10-        upd d = zipWith inc [0..]-          where inc i c = ite (i .== d) (c+1) c---- | Encoding of the puzzle. The solution is a sequence of 10 numbers--- for the occurrences of the digits such that if we count each digit,--- we find these numbers.-puzzle :: [Count] -> SBool-puzzle cnt = cnt .== last css-  where ones = replicate 10 1  -- all digits occur once to start with-        css  = ones : zipWith count cnt css---- | Finds all two known solutions to this puzzle. We have:------ >>> counts--- Solution #1--- In this sentence, the number of occurrences of 0 is 1, of 1 is 7, of 2 is 3, of 3 is 2, of 4 is 1, of 5 is 1, of 6 is 1, of 7 is 2, of 8 is 1, of 9 is 1.--- Solution #2--- In this sentence, the number of occurrences of 0 is 1, of 1 is 11, of 2 is 2, of 3 is 1, of 4 is 1, of 5 is 1, of 6 is 1, of 7 is 1, of 8 is 1, of 9 is 1.--- Found: 2 solution(s).-counts :: IO ()-counts = do res <- allSat $ puzzle `fmap` mkExistVars 10-            cnt <- displayModels disp res-            putStrLn $ "Found: " ++ show cnt ++ " solution(s)."-  where disp n (_, s) = do putStrLn $ "Solution #" ++ show n-                           dispSolution s-        dispSolution :: [Word8] -> IO ()-        dispSolution ns = putStrLn soln-          where soln =  "In this sentence, the number of occurrences"-                     ++  " of 0 is " ++ show (ns !! 0)-                     ++ ", of 1 is " ++ show (ns !! 1)-                     ++ ", of 2 is " ++ show (ns !! 2)-                     ++ ", of 3 is " ++ show (ns !! 3)-                     ++ ", of 4 is " ++ show (ns !! 4)-                     ++ ", of 5 is " ++ show (ns !! 5)-                     ++ ", of 6 is " ++ show (ns !! 6)-                     ++ ", of 7 is " ++ show (ns !! 7)-                     ++ ", of 8 is " ++ show (ns !! 8)-                     ++ ", of 9 is " ++ show (ns !! 9)-                     ++ "."-{-# ANN counts ("HLint: ignore Use head" :: String) #-}
− Data/SBV/Examples/Puzzles/DogCatMouse.hs 
@@ -1,37 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Puzzles.DogCatMouse--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Puzzle:---   Spend exactly 100 dollars and buy exactly 100 animals.---   Dogs cost 15 dollars, cats cost 1 dollar, and mice cost 25 cents each.---   You have to buy at least one of each.---   How many of each should you buy?--------------------------------------------------------------------------------module Data.SBV.Examples.Puzzles.DogCatMouse where--import Data.SBV---- | Prints the only solution:------ >>> puzzle--- Solution #1:---   dog   =  3 :: Integer---   cat   = 41 :: Integer---   mouse = 56 :: Integer--- This is the only solution.-puzzle :: IO AllSatResult-puzzle = allSat $ do-           [dog, cat, mouse] <- sIntegers ["dog", "cat", "mouse"]-           solve [ dog   .>= 1                                           -- at least one dog-                 , cat   .>= 1                                           -- at least one cat-                 , mouse .>= 1                                           -- at least one mouse-                 , dog + cat + mouse .== 100                             -- buy precisely 100 animals-                 , 15 `per` dog + 1 `per` cat + 0.25 `per` mouse .== 100 -- spend exactly 100 dollars-                 ]-  where p `per` q = p * (sFromIntegral q :: SReal)
− Data/SBV/Examples/Puzzles/Euler185.hs 
@@ -1,49 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Puzzles.Euler185--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ A solution to Project Euler problem #185: <http://projecteuler.net/index.php?section=problems&id=185>--------------------------------------------------------------------------------module Data.SBV.Examples.Puzzles.Euler185 where--import Data.Char(ord)-import Data.SBV---- | The given guesses and the correct digit counts, encoded as a simple list.-guesses :: [(String, SWord8)]-guesses = [ ("5616185650518293", 2), ("3847439647293047", 1), ("5855462940810587", 3)-          , ("9742855507068353", 3), ("4296849643607543", 3), ("3174248439465858", 1)-          , ("4513559094146117", 2), ("7890971548908067", 3), ("8157356344118483", 1)-          , ("2615250744386899", 2), ("8690095851526254", 3), ("6375711915077050", 1)-          , ("6913859173121360", 1), ("6442889055042768", 2), ("2321386104303845", 0)-          , ("2326509471271448", 2), ("5251583379644322", 2), ("1748270476758276", 3)-          , ("4895722652190306", 1), ("3041631117224635", 3), ("1841236454324589", 3)-          , ("2659862637316867", 2)-          ]---- | Encode the problem, note that we check digits are within 0-9 as--- we use 8-bit words to represent them. Otherwise, the constraints are simply--- generated by zipping the alleged solution with each guess, and making sure the--- number of matching digits match what's given in the problem statement.-euler185 :: Symbolic SBool-euler185 = do soln <- mkExistVars 16-              return $ bAll digit soln &&& bAnd (map (genConstr soln) guesses)-  where genConstr a (b, c) = sum (zipWith eq a b) .== (c :: SWord8)-        digit x = (x :: SWord8) .>= 0 &&& x .<= 9-        eq x y =  ite (x .== fromIntegral (ord y - ord '0')) 1 0---- | Print out the solution nicely. We have:------ >>> solveEuler185--- 4640261571849533--- Number of solutions: 1-solveEuler185 :: IO ()-solveEuler185 = do res <- allSat euler185-                   cnt <- displayModels disp res-                   putStrLn $ "Number of solutions: " ++ show cnt-   where disp _ (_, ss) = putStrLn $ concatMap show (ss :: [Word8])
− Data/SBV/Examples/Puzzles/Fish.hs 
@@ -1,122 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Puzzles.Fish--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Solves the following logic puzzle:------   - The Briton lives in the red house.---   - The Swede keeps dogs as pets.---   - The Dane drinks tea.---   - The green house is left to the white house.---   - The owner of the green house drinks coffee.---   - The person who plays football rears birds.---   - The owner of the yellow house plays baseball.---   - The man living in the center house drinks milk.---   - The Norwegian lives in the first house.---   - The man who plays volleyball lives next to the one who keeps cats.---   - The man who keeps the horse lives next to the one who plays baseball.---   - The owner who plays tennis drinks beer.---   - The German plays hockey.---   - The Norwegian lives next to the blue house.---   - The man who plays volleyball has a neighbor who drinks water.------ Who owns the fish?---------------------------------------------------------------------------------{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveAnyClass      #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.SBV.Examples.Puzzles.Fish where--import Data.SBV---- | Colors of houses-data Color = Red | Green | White | Yellow | Blue---- | Make 'Color' a symbolic value.-mkSymbolicEnumeration ''Color---- | Nationalities of the occupants-data Nationality = Briton | Dane | Swede | Norwegian | German---- | Make 'Nationality' a symbolic value.-mkSymbolicEnumeration ''Nationality---- | Beverage choices-data Beverage = Tea | Coffee | Milk | Beer | Water---- | Make 'Beverage' a symbolic value.-mkSymbolicEnumeration ''Beverage---- | Pets they keep-data Pet = Dog | Horse | Cat | Bird | Fish---- | Make 'Pet' a symbolic value.-mkSymbolicEnumeration ''Pet---- | Sports they engage in-data Sport = Football | Baseball | Volleyball | Hockey | Tennis---- | Make 'Sport' a symbolic value.-mkSymbolicEnumeration ''Sport---- | We have:------ >>> fishOwner--- German------ It's not hard to modify this program to grab the values of all the assignments, i.e., the full--- solution to the puzzle. We leave that as an exercise to the interested reader!-fishOwner :: IO ()-fishOwner = do vs <- getModelValues "fishOwner" `fmap` allSat puzzle-               case vs of-                 [Just (v::Nationality)] -> print v-                 []                      -> error "no solution"-                 _                       -> error "no unique solution"- where puzzle = do--          let c = uninterpret "color"-              n = uninterpret "nationality"-              b = uninterpret "beverage"-              p = uninterpret "pet"-              s = uninterpret "sport"--          let i `neighbor` j = i .== j+1 ||| j .== i+1-              a `is`       v = a .== literal v--          let fact0   = constrain-              fact1 f = do i <- free_-                           constrain $ 1 .<= i &&& i .<= (5 :: SInteger)-                           constrain $ f i-              fact2 f = do i <- free_-                           j <- free_-                           constrain $ 1 .<= i &&& i .<= (5 :: SInteger)-                           constrain $ 1 .<= j &&& j .<= 5-                           constrain $ i ./= j-                           constrain $ f i j--          fact1 $ \i   -> n i `is` Briton     &&& c i `is` Red-          fact1 $ \i   -> n i `is` Swede      &&& p i `is` Dog-          fact1 $ \i   -> n i `is` Dane       &&& b i `is` Tea-          fact2 $ \i j -> c i `is` Green      &&& c j `is` White    &&& i .== j-1-          fact1 $ \i   -> c i `is` Green      &&& b i `is` Coffee-          fact1 $ \i   -> s i `is` Football   &&& p i `is` Bird-          fact1 $ \i   -> c i `is` Yellow     &&& s i `is` Baseball-          fact0 $         b 3 `is` Milk-          fact0 $         n 1 `is` Norwegian-          fact2 $ \i j -> s i `is` Volleyball &&& p j `is` Cat      &&& i `neighbor` j-          fact2 $ \i j -> p i `is` Horse      &&& s j `is` Baseball &&& i `neighbor` j-          fact1 $ \i   -> s i `is` Tennis     &&& b i `is` Beer-          fact1 $ \i   -> n i `is` German     &&& s i `is` Hockey-          fact2 $ \i j -> n i `is` Norwegian  &&& c j `is` Blue     &&& i `neighbor` j-          fact2 $ \i j -> s i `is` Volleyball &&& b j `is` Water    &&& i `neighbor` j--          ownsFish <- free "fishOwner"-          fact1 $ \i -> n i .== ownsFish &&& p i `is` Fish
− Data/SBV/Examples/Puzzles/MagicSquare.hs 
@@ -1,75 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Puzzles.MagicSquare--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Solves the magic-square puzzle. An NxN magic square is one where all entries--- are filled with numbers from 1 to NxN such that sums of all rows, columns--- and diagonals is the same.--------------------------------------------------------------------------------module Data.SBV.Examples.Puzzles.MagicSquare where--import Data.List (genericLength, transpose)--import Data.SBV---- | Use 32-bit words for elements.-type Elem  = SWord32---- | A row is a list of elements-type Row   = [Elem]---- | The puzzle board is a list of rows-type Board = [Row]---- | Checks that all elements in a list are within bounds-check :: Elem -> Elem -> [Elem] -> SBool-check low high = bAll $ \x -> x .>= low &&& x .<= high---- | Get the diagonal of a square matrix-diag :: [[a]] -> [a]-diag ((a:_):rs) = a : diag (map tail rs)-diag _          = []---- | Test if a given board is a magic square-isMagic :: Board -> SBool-isMagic rows = bAnd $ fromBool isSquare : allEqual (map sum items) : distinct (concat rows) : map chk items-  where items = d1 : d2 : rows ++ columns-        n = genericLength rows-        isSquare = all (\r -> genericLength r == n) rows-        columns = transpose rows-        d1 = diag rows-        d2 = diag (map reverse rows)-        chk = check (literal 1) (literal (n*n))---- | Group a list of elements in the sublists of length @i@-chunk :: Int -> [a] -> [[a]]-chunk _ [] = []-chunk i xs = let (f, r) = splitAt i xs in f : chunk i r---- | Given @n@, magic @n@ prints all solutions to the @nxn@ magic square problem-magic :: Int -> IO ()-magic n- | n < 0 = putStrLn $ "n must be non-negative, received: " ++ show n- | True  = do putStrLn $ "Finding all " ++ show n ++ "-magic squares.."-              res <- allSat $ (isMagic . chunk n) `fmap` mkExistVars n2-              cnt <- displayModels disp res-              putStrLn $ "Found: " ++ show cnt ++ " solution(s)."-   where n2 = n * n-         disp i (_, model)-          | lmod /= n2-          = error $ "Impossible! Backend solver returned " ++ show n ++ " values, was expecting: " ++ show lmod-          | True-          = do putStrLn $ "Solution #" ++ show i-               mapM_ printRow board-               putStrLn $ "Valid Check: " ++ show (isMagic sboard)-               putStrLn "Done."-          where lmod  = length model-                board = chunk n model-                sboard = map (map literal) board-                sh2 z = let s = show z in if length s < 2 then ' ':s else s-                printRow r = putStr "   " >> mapM_ (\x -> putStr (sh2 x ++ " ")) r >> putStrLn ""
− Data/SBV/Examples/Puzzles/NQueens.hs 
@@ -1,46 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Puzzles.NQueens--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Solves the NQueens puzzle: <http://en.wikipedia.org/wiki/Eight_queens_puzzle>--------------------------------------------------------------------------------module Data.SBV.Examples.Puzzles.NQueens where--import Data.SBV---- | A solution is a sequence of row-numbers where queens should be placed-type Solution = [SWord8]---- | Checks that a given solution of @n@-queens is valid, i.e., no queen--- captures any other.-isValid :: Int -> Solution -> SBool-isValid n s = bAll rangeFine s &&& distinct s &&& bAll checkDiag ijs-  where rangeFine x = x .>= 1 &&& x .<= fromIntegral n-        ijs = [(i, j) | i <- [1..n], j <- [i+1..n]]-        checkDiag (i, j) = diffR ./= diffC-           where qi = s !! (i-1)-                 qj = s !! (j-1)-                 diffR = ite (qi .>= qj) (qi-qj) (qj-qi)-                 diffC = fromIntegral (j-i)---- | Given @n@, it solves the @n-queens@ puzzle, printing all possible solutions.-nQueens :: Int -> IO ()-nQueens n- | n < 0 = putStrLn $ "n must be non-negative, received: " ++ show n- | True  = do putStrLn $ "Finding all " ++ show n ++ "-queens solutions.."-              res <- allSat $ isValid n `fmap` mkExistVars n-              cnt <- displayModels disp res-              putStrLn $ "Found: " ++ show cnt ++ " solution(s)."-   where disp i (_, s) = do putStr $ "Solution #" ++ show i ++ ": "-                            dispSolution s-         dispSolution :: [Word8] -> IO ()-         dispSolution model-           | lmod /= n = error $ "Impossible! Backend solver returned " ++ show lmod ++ " values, was expecting: " ++ show n-           | True      = do putStr $ show model-                            putStrLn $ " (Valid: " ++ show (isValid n (map literal model)) ++ ")"-           where lmod  = length model
− Data/SBV/Examples/Puzzles/SendMoreMoney.hs 
@@ -1,45 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Puzzles.SendMoreMoney--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Solves the classic @send + more = money@ puzzle.--------------------------------------------------------------------------------module Data.SBV.Examples.Puzzles.SendMoreMoney where--import Data.SBV---- | Solve the puzzle. We have:------ >>> sendMoreMoney--- Solution #1:---   s = 9 :: Integer---   e = 5 :: Integer---   n = 6 :: Integer---   d = 7 :: Integer---   m = 1 :: Integer---   o = 0 :: Integer---   r = 8 :: Integer---   y = 2 :: Integer--- This is the only solution.------ That is:------ >>> 9567 + 1085 == 10652--- True-sendMoreMoney :: IO AllSatResult-sendMoreMoney = allSat $ do-        ds@[s,e,n,d,m,o,r,y] <- mapM sInteger ["s", "e", "n", "d", "m", "o", "r", "y"]-        let isDigit x = x .>= 0 &&& x .<= 9-            val xs    = sum $ zipWith (*) (reverse xs) (iterate (*10) 1)-            send      = val [s,e,n,d]-            more      = val [m,o,r,e]-            money     = val [m,o,n,e,y]-        constrain $ bAll isDigit ds-        constrain $ distinct ds-        constrain $ s ./= 0 &&& m ./= 0-        solve [send + more .== money]
− Data/SBV/Examples/Puzzles/Sudoku.hs 
@@ -1,252 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Puzzles.Sudoku--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ The Sudoku solver, quintessential SMT solver example!--------------------------------------------------------------------------------module Data.SBV.Examples.Puzzles.Sudoku where--import Data.List  (transpose)-import Data.Maybe (fromJust)--import Data.SBV------------------------------------------------------------------------ * Modeling Sudoku----------------------------------------------------------------------- | A row is a sequence of 8-bit words, too large indeed for representing 1-9, but does not harm-type Row   = [SWord8]---- | A Sudoku board is a sequence of 9 rows-type Board = [Row]---- | Given a series of elements, make sure they are all different--- and they all are numbers between 1 and 9-check :: [SWord8] -> SBool-check grp = bAnd $ distinct grp : map rangeFine grp-  where rangeFine x = x .> 0 &&& x .<= 9---- | Given a full Sudoku board, check that it is valid-valid :: Board -> SBool-valid rows = bAnd $ literal sizesOK : map check (rows ++ columns ++ squares)-  where sizesOK = length rows == 9 && all (\r -> length r == 9) rows-        columns = transpose rows-        regions = transpose [chunk 3 row | row <- rows]-        squares = [concat sq | sq <- chunk 3 (concat regions)]-        chunk :: Int -> [a] -> [[a]]-        chunk _ [] = []-        chunk i xs = let (f, r) = splitAt i xs in f : chunk i r---- | A puzzle is a pair: First is the number of missing elements, second--- is a function that given that many elements returns the final board.-type Puzzle = (Int, [SWord8] -> Board)------------------------------------------------------------------------ * Solving Sudoku puzzles------------------------------------------------------------------------ | Solve a given puzzle and print the results-sudoku :: Puzzle -> IO ()-sudoku p@(i, f) = do putStrLn "Solving the puzzle.."-                     model <- getModelAssignment `fmap` sat ((valid . f) `fmap` mkExistVars i)-                     case model of-                       Right sln -> dispSolution p sln-                       Left m    -> putStrLn $ "Unsolvable puzzle: " ++ m---- | Helper function to display results nicely, not really needed, but helps presentation-dispSolution :: Puzzle -> (Bool, [Word8]) -> IO ()-dispSolution (i, f) (_, fs)-  | lmod /= i = error $ "Impossible! Backend solver returned " ++ show lmod ++ " values, was expecting: " ++ show i-  | True      = do putStrLn "Final board:"-                   mapM_ printRow final-                   putStrLn $ "Valid Check: " ++ show (valid final)-                   putStrLn "Done."-  where lmod = length fs-        final = f (map literal fs)-        printRow r = putStr "   " >> mapM_ (\x -> putStr (show (fromJust (unliteral x)) ++ " ")) r >> putStrLn ""---- | Find all solutions to a puzzle-solveAll :: Puzzle -> IO ()-solveAll p@(i, f) = do putStrLn "Finding all solutions.."-                       res <- allSat $ (valid . f) `fmap` mkExistVars i-                       cnt <- displayModels disp res-                       putStrLn $ "Found: " ++ show cnt ++ " solution(s)."-   where disp n s = do putStrLn $ "Solution #" ++ show n-                       dispSolution p s------------------------------------------------------------------------ * Example boards------------------------------------------------------------------------ | Find an arbitrary good board-puzzle0 :: Puzzle-puzzle0 = (81, f)-  where f   [ a1, a2, a3, a4, a5, a6, a7, a8, a9,-              b1, b2, b3, b4, b5, b6, b7, b8, b9,-              c1, c2, c3, c4, c5, c6, c7, c8, c9,-              d1, d2, d3, d4, d5, d6, d7, d8, d9,-              e1, e2, e3, e4, e5, e6, e7, e8, e9,-              f1, f2, f3, f4, f5, f6, f7, f8, f9,-              g1, g2, g3, g4, g5, g6, g7, g8, g9,-              h1, h2, h3, h4, h5, h6, h7, h8, h9,-              i1, i2, i3, i4, i5, i6, i7, i8, i9 ]-         = [ [a1, a2, a3, a4, a5, a6, a7, a8, a9],-             [b1, b2, b3, b4, b5, b6, b7, b8, b9],-             [c1, c2, c3, c4, c5, c6, c7, c8, c9],-             [d1, d2, d3, d4, d5, d6, d7, d8, d9],-             [e1, e2, e3, e4, e5, e6, e7, e8, e9],-             [f1, f2, f3, f4, f5, f6, f7, f8, f9],-             [g1, g2, g3, g4, g5, g6, g7, g8, g9],-             [h1, h2, h3, h4, h5, h6, h7, h8, h9],-             [i1, i2, i3, i4, i5, i6, i7, i8, i9] ]-        f _ = error "puzzle0 needs exactly 81 elements!"---- | A random puzzle, found on the internet..-puzzle1 :: Puzzle-puzzle1 = (49, f)-  where f   [ a1,     a3, a4, a5, a6, a7,     a9,-              b1, b2, b3,             b7, b8, b9,-                  c2,     c4, c5, c6,     c8,-                      d3,     d5,     d7,-              e1, e2,     e4, e5, e6,     e8, e9,-                      f3,     f5,     f7,-                  g2,     g4, g5, g6,     g8,-              h1, h2, h3,             h7, h8, h9,-              i1,     i3, i4, i5, i6, i7,     i9 ]-         = [ [a1,  6, a3, a4, a5, a6, a7,  1, a9],-             [b1, b2, b3,  6,  5,  1, b7, b8, b9],-             [ 1, c2,  7, c4, c5, c6,  6, c8,  2],-             [ 6,  2, d3,  3, d5,  5, d7,  9,  4],-             [e1, e2,  3, e4, e5, e6,  2, e8, e9],-             [ 4,  8, f3,  9, f5,  7, f7,  3,  6],-             [ 9, g2,  6, g4, g5, g6,  4, g8,  8],-             [h1, h2, h3,  7,  9,  4, h7, h8, h9],-             [i1,  5, i3, i4, i5, i6, i7,  7, i9] ]-        f _ = error "puzzle1 needs exactly 49 elements!"---- | Another random puzzle, found on the internet..-puzzle2 :: Puzzle-puzzle2 = (55, f)-  where f   [     a2,     a4, a5, a6, a7,     a9,-              b1, b2,     b4,         b7, b8, b9,-              c1,     c3, c4, c5, c6, c7, c8, c9,-                  d2, d3, d4,             d8, d9,-              e1,     e3,     e5,     e7,     e9,-              f1, f2,             f6, f7, f8,-              g1, g2, g3, g4, g5, g6, g7,     g9,-              h1, h2, h3,         h6,     h8, h9,-              i1,     i3, i4, i5, i6,     i8     ]-         = [ [ 1, a2,  3, a4, a5, a6, a7,  8, a9],-             [b1, b2,  6, b4,  4,  8, b7, b8, b9],-             [c1,  4, c3, c4, c5, c6, c7, c8, c9],-             [ 2, d2, d3, d4,  9,  6,  1, d8, d9],-             [e1,  9, e3,  8, e5,  1, e7,  4, e9],-             [f1, f2,  4,  3,  2, f6, f7, f8,  8],-             [g1, g2, g3, g4, g5, g6, g7,  7, g9],-             [h1, h2, h3,  1,  5, h6,  4, h8, h9],-             [i1,  6, i3, i4, i5, i6,  2, i8,  3] ]-        f _ = error "puzzle2 needs exactly 55 elements!"---- | Another random puzzle, found on the internet..-puzzle3 :: Puzzle-puzzle3 = (56, f)-  where f   [     a2, a3, a4,     a6,     a8, a9,-                  b2,     b4, b5, b6, b7, b8, b9,-              c1, c2, c3, c4,     c6, c7,     c9,-              d1,     d3,     d5,     d7,     d9,-                  e2, e3, e4,     e6, e7, e8,-              f1,     f3,     f5,     f7,     f9,-              g1,     g3, g4,     g6, g7, g8, g9,-              h1, h2, h3, h4, h5, h6,     h8,-              i1, i2,     i4,     i6, i7, i8     ]-         = [ [ 6, a2, a3, a4,  1, a6,  5, a8, a9],-             [ 8, b2,  3, b4, b5, b6, b7, b8, b9],-             [c1, c2, c3, c4,  6, c6, c7,  2, c9],-             [d1,  3, d3,  1, d5,  8, d7,  9, d9],-             [ 1, e2, e3, e4,  9, e6, e7, e8,  4],-             [f1,  5, f3,  2, f5,  3, f7,  1, f9],-             [g1,  7, g3, g4,  3, g6, g7, g8, g9],-             [h1, h2, h3, h4, h5, h6,  3, h8,  6],-             [i1, i2,  4, i4,  5, i6, i7, i8,  9] ]-        f _ = error "puzzle3 needs exactly 56 elements!"---- | According to the web, this is the toughest --- sudoku puzzle ever.. It even has a name: Al Escargot:--- <http://zonkedyak.blogspot.com/2006/11/worlds-hardest-sudoku-puzzle-al.html>-puzzle4 :: Puzzle-puzzle4 = (58, f)-  where f   [     a2, a3, a4, a5,     a7,     a9,-              b1,     b3, b4,     b6, b7, b8,-              c1, c2,         c5, c6,     c8, c9,-              d1, d2,         d5, d6,     d8, d9,-              e1,     e3, e4,     e6, e7, e8,-                  f2, f3, f4, f5,     f7, f8, f9,-                  g2, g3, g4, g5, g6, g7,     g9,-              h1,     h3, h4, h5, h6, h7, h8,-              i1, i2,     i4, i5, i6,     i8, i9 ]-         = [ [ 1, a2, a3, a4, a5,  7, a7,  9, a9],-             [b1,  3, b3, b4,  2, b6, b7, b8,  8],-             [c1, c2,  9,  6, c5, c6,  5, c8, c9],-             [d1, d2,  5,  3, d5, d6,  9, d8, d9],-             [e1,  1, e3, e4,  8, e6, e7, e8,  2],-             [ 6, f2, f3, f4, f5,  4, f7, f8, f9],-             [ 3, g2, g3, g4, g5, g6, g7,  1, g9],-             [h1,  4, h3, h4, h5, h6, h7, h8,  7],-             [i1, i2,  7, i4, i5, i6,  3, i8, i9] ]-        f _ = error "puzzle4 needs exactly 58 elements!"---- | This one has been called diabolical, apparently-puzzle5 :: Puzzle-puzzle5 = (53, f)-  where f   [ a1,     a3,     a5, a6,         a9,-              b1,         b4, b5,     b7,     b9,-                  c2,     c4, c5, c6, c7, c8, c9,-              d1, d2,     d4,     d6, d7, d8,-              e1, e2, e3,     e5,     e7, e8, e9,-                  f2, f3, f4,     f6,     f8, f9,-              g1, g2, g3, g4, g5, g6,     g8,-              h1,     h3,     h5, h6,         h9,-              i1,         i4, i5,     i7,     i9 ]-         = [ [a1,  9, a3,  7, a5, a6,  8,  6, a9],-             [b1,  3,  1, b4, b5,  5, b7,  2, b9],-             [ 8, c2,  6, c4, c5, c6, c7, c8, c9],-             [d1, d2,  7, d4,  5, d6, d7, d8,  6],-             [e1, e2, e3,  3, e5,  7, e7, e8, e9],-             [ 5, f2, f3, f4,  1, f6,  7, f8, f9],-             [g1, g2, g3, g4, g5, g6,  1, g8,  9],-             [h1,  2, h3,  6, h5, h6,  3,  5, h9],-             [i1,  5,  4, i4, i5,  8, i7,  7, i9] ]-        f _ = error "puzzle5 needs exactly 53 elements!"---- | The following is nefarious according to--- <http://haskell.org/haskellwiki/Sudoku>-puzzle6 :: Puzzle-puzzle6 = (64, f)-  where f   [ a1, a2, a3, a4,     a6, a7,     a9,-              b1,     b3, b4, b5, b6, b7, b8, b9,-              c1, c2,     c4, c5, c6, c7, c8, c9,-              d1,     d3, d4, d5, d6,     d8,-                  e2, e3, e4,     e6, e7, e8, e9,-              f1, f2, f3, f4, f5, f6,     f8, f9,-              g1, g2,         g5,     g7, g8, g9,-                  h2, h3,     h5, h6,     h8, h9,-              i1, i2, i3, i4, i5, i6, i7,     i9  ]-         = [ [a1, a2, a3, a4,  6, a6, a7,  8, a9],-             [b1,  2, b3, b4, b5, b6, b7, b8, b9],-             [c1, c2,  1, c4, c5, c6, c7, c8, c9],-             [d1,  7, d3, d4, d5, d6,  1, d8,  2],-             [ 5, e2, e3, e4,  3, e6, e7, e8, e9],-             [f1, f2, f3, f4, f5, f6,  4, f8, f9],-             [g1, g2,  4,  2, g5,  1, g7, g8, g9],-             [ 3, h2, h3,  7, h5, h6,  6, h8, h9],-             [i1, i2, i3, i4, i5, i6, i7,  5, i9] ]-        f _ = error "puzzle6 needs exactly 64 elements!"---- | Solve them all, this takes a fraction of a second to run for each case-allPuzzles :: IO ()-allPuzzles = mapM_ sudoku [puzzle0, puzzle1, puzzle2, puzzle3, puzzle4, puzzle5, puzzle6]
− Data/SBV/Examples/Puzzles/U2Bridge.hs 
@@ -1,278 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Puzzles.U2Bridge--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ The famous U2 bridge crossing puzzle: <http://www.braingle.com/brainteasers/515/u2.html>--------------------------------------------------------------------------------{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE StandaloneDeriving   #-}-{-# LANGUAGE DeriveAnyClass       #-}-{-# LANGUAGE DeriveDataTypeable   #-}-{-# LANGUAGE DeriveGeneric        #-}--module Data.SBV.Examples.Puzzles.U2Bridge where--import Control.Monad       (unless)-import Control.Monad.State (State, runState, put, get, modify, evalState)--import GHC.Generics (Generic)--import Data.SBV------------------------------------------------------------------ * Modeling the puzzle------------------------------------------------------------------ | U2 band members. We want to translate this to SMT-Lib as a data-type, and hence the--- call to mkSymbolicEnumeration.-data U2Member = Bono | Edge | Adam | Larry---- | Make 'U2Member' a symbolic value.-mkSymbolicEnumeration ''U2Member---- | Symbolic shorthand for a 'U2Member'-type SU2Member = SBV U2Member---- | Shorthands for symbolic versions of the members-bono, edge, adam, larry :: SU2Member-[bono, edge, adam, larry] = map literal [Bono, Edge, Adam, Larry]---- | Model time using 32 bits-type Time  = Word32---- | Symbolic variant for time-type STime = SBV Time---- | Crossing times for each member of the band-crossTime :: U2Member -> Time-crossTime Bono  = 1-crossTime Edge  = 2-crossTime Adam  = 5-crossTime Larry = 10---- | The symbolic variant.. The duplication is unfortunate.-sCrossTime :: SU2Member -> STime-sCrossTime m =   ite (m .== bono) (literal (crossTime Bono))-               $ ite (m .== edge) (literal (crossTime Edge))-               $ ite (m .== adam) (literal (crossTime Adam))-                                  (literal (crossTime Larry)) -- Must be Larry---- | Location of the flash-data Location = Here | There---- | Make 'Location' a symbolic value.-mkSymbolicEnumeration ''Location---- | Symbolic variant of 'Location'-type SLocation = SBV Location---- | Shorthands for symbolic versions of locations-here, there :: SLocation-[here, there]  = map literal [Here, There]---- | The status of the puzzle after each move------ This type is equipped with an automatically derived 'Mergeable' instance--- because each field is 'Mergeable'. A 'Generic' instance must also be derived--- for this to work, and the 'DeriveAnyClass' language extension must be--- enabled. The derived 'Mergeable' instance simply walks down the structure--- field by field and merges each one. An equivalent hand-written 'Mergeable'--- instance is provided in a comment below.-data Status = Status { time   :: STime       -- ^ elapsed time-                     , flash  :: SLocation   -- ^ location of the flash-                     , lBono  :: SLocation   -- ^ location of Bono-                     , lEdge  :: SLocation   -- ^ location of Edge-                     , lAdam  :: SLocation   -- ^ location of Adam-                     , lLarry :: SLocation   -- ^ location of Larry-                     } deriving (Generic, Mergeable)---- The derived Mergeable instance is equivalent to the following:------ instance Mergeable Status where---   symbolicMerge f t s1 s2 = Status { time   = symbolicMerge f t (time   s1) (time   s2)---                                    , flash  = symbolicMerge f t (flash  s1) (flash  s2)---                                    , lBono  = symbolicMerge f t (lBono  s1) (lBono  s2)---                                    , lEdge  = symbolicMerge f t (lEdge  s1) (lEdge  s2)---                                    , lAdam  = symbolicMerge f t (lAdam  s1) (lAdam  s2)---                                    , lLarry = symbolicMerge f t (lLarry s1) (lLarry s2)---                                    }---- | Start configuration, time elapsed is 0 and everybody is 'here'-start :: Status-start = Status { time   = 0-               , flash  = here-               , lBono  = here-               , lEdge  = here-               , lAdam  = here-               , lLarry = here-               }---- | A puzzle move is modeled as a state-transformer-type Move a = State Status a---- | Mergeable instance for 'Move' simply pushes the merging the data after run of each branch--- starting from the same state.-instance Mergeable a => Mergeable (Move a) where-  symbolicMerge f t a b-    = do s <- get-         let (ar, s1) = runState a s-             (br, s2) = runState b s-         put $ symbolicMerge f t s1 s2-         return $ symbolicMerge f t ar br---- | Read the state via an accessor function-peek :: (Status -> a) -> Move a-peek f = f <$> get---- | Given an arbitrary member, return his location-whereIs :: SU2Member -> Move SLocation-whereIs p =  ite (p .== bono) (peek lBono)-           $ ite (p .== edge) (peek lEdge)-           $ ite (p .== adam) (peek lAdam)-                              (peek lLarry)---- | Transferring the flash to the other side-xferFlash :: Move ()-xferFlash = modify $ \s -> s{flash = ite (flash s .== here) there here}---- | Transferring a person to the other side-xferPerson :: SU2Member -> Move ()-xferPerson p =  do [lb, le, la, ll] <- mapM peek [lBono, lEdge, lAdam, lLarry]-                   let move l = ite (l .== here) there here-                       lb' = ite (p .== bono)  (move lb) lb-                       le' = ite (p .== edge)  (move le) le-                       la' = ite (p .== adam)  (move la) la-                       ll' = ite (p .== larry) (move ll) ll-                   modify $ \s -> s{lBono = lb', lEdge = le', lAdam = la', lLarry = ll'}---- | Increment the time, when only one person crosses-bumpTime1 :: SU2Member -> Move ()-bumpTime1 p = modify $ \s -> s{time = time s + sCrossTime p}---- | Increment the time, when two people cross together-bumpTime2 :: SU2Member -> SU2Member -> Move ()-bumpTime2 p1 p2 = modify $ \s -> s{time = time s + sCrossTime p1 `smax` sCrossTime p2}---- | Symbolic version of 'when'-whenS :: SBool -> Move () -> Move ()-whenS t a = ite t a (return ())---- | Move one member, remembering to take the flash-move1 :: SU2Member -> Move ()-move1 p = do f <- peek flash-             l <- whereIs p-             -- only do the move if the person and the flash are at the same side-             whenS (f .== l) $ do bumpTime1 p-                                  xferFlash-                                  xferPerson p---- | Move two members, again with the flash-move2 :: SU2Member -> SU2Member -> Move ()-move2 p1 p2 = do f  <- peek flash-                 l1 <- whereIs p1-                 l2 <- whereIs p2-                 -- only do the move if both people and the flash are at the same side-                 whenS (f .== l1 &&& f .== l2) $ do bumpTime2 p1 p2-                                                    xferFlash-                                                    xferPerson p1-                                                    xferPerson p2------------------------------------------------------------------ * Actions------------------------------------------------------------------ | A move action is a sequence of triples. The first component is symbolically--- True if only one member crosses. (In this case the third element of the triple--- is irrelevant.) If the first component is (symbolically) False, then both members--- move together-type Actions = [(SBool, SU2Member, SU2Member)]---- | Run a sequence of given actions.-run :: Actions -> Move [Status]-run = mapM step- where step (b, p1, p2) = ite b (move1 p1) (move2 p1 p2) >> get------------------------------------------------------------------ * Recognizing valid solutions------------------------------------------------------------------ | Check if a given sequence of actions is valid, i.e., they must all--- cross the bridge according to the rules and in less than 17 seconds-isValid :: Actions -> SBool-isValid as = time end .<= 17 &&& bAll check as &&& zigZag (cycle [there, here]) (map flash states) &&& bAll (.== there) [lBono end, lEdge end, lAdam end, lLarry end]-  where check (s, p1, p2) =   (bnot s ==> p1 .> p2)      -- for two person moves, ensure first person is "larger"-                          &&& (s      ==> p2 .== bono)   -- for one person moves, ensure second person is always "bono"-        states = evalState (run as) start-        end = last states-        zigZag reqs locs = bAnd $ zipWith (.==) locs reqs------------------------------------------------------------------ * Solving the puzzle------------------------------------------------------------------ | See if there is a solution that has precisely @n@ steps-solveN :: Int -> IO Bool-solveN n = do putStrLn $ "Checking for solutions with " ++ show n ++ " move" ++ plu n ++ "."-              let genAct = do b  <- exists_-                              p1 <- exists_-                              p2 <- exists_-                              return (b, p1, p2)-              res <- allSat $ isValid `fmap` mapM (const genAct) [1..n]-              cnt <- displayModels disp res-              if cnt == 0 then return False-                          else do putStrLn $ "Found: " ++ show cnt ++ " solution" ++ plu cnt ++ " with " ++ show n ++ " move" ++ plu n ++ "."-                                  return True-  where plu v = if v == 1 then "" else "s"-        disp :: Int -> (Bool, [(Bool, U2Member, U2Member)]) -> IO ()-        disp i (_, ss)-         | lss /= n = error $ "Expected " ++ show n ++ " results; got: " ++ show lss-         | True     = do putStrLn $ "Solution #" ++ show i ++ ": "-                         go False 0 ss-                         return ()-         where lss  = length ss-               go _ t []                   = putStrLn $ "Total time: " ++ show t-               go l t ((True,  a, _):rest) = do putStrLn $ sh2 t ++ shL l ++ show a-                                                go (not l) (t + crossTime a) rest-               go l t ((False, a, b):rest) = do putStrLn $ sh2 t ++ shL l ++ show a ++ ", " ++ show b-                                                go (not l) (t + crossTime a `max` crossTime b) rest-               sh2 t = let s = show t in if length s < 2 then ' ' : s else s-               shL False = " --> "-               shL True  = " <-- "---- | Solve the U2-bridge crossing puzzle, starting by testing solutions with--- increasing number of steps, until we find one. We have:------ >>> solveU2--- Checking for solutions with 1 move.--- Checking for solutions with 2 moves.--- Checking for solutions with 3 moves.--- Checking for solutions with 4 moves.--- Checking for solutions with 5 moves.--- Solution #1:---  0 --> Edge, Bono---  2 <-- Bono---  3 --> Larry, Adam--- 13 <-- Edge--- 15 --> Edge, Bono--- Total time: 17--- Solution #2:---  0 --> Edge, Bono---  2 <-- Edge---  4 --> Larry, Adam--- 14 <-- Bono--- 15 --> Edge, Bono--- Total time: 17--- Found: 2 solutions with 5 moves.------ Finding all possible solutions to the puzzle.-solveU2 :: IO ()-solveU2 = go 1- where go i = do p <- solveN i-                 unless p $ go (i+1)
− Data/SBV/Examples/Queries/AllSat.hs 
@@ -1,86 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Queries.AllSat--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ When we would like to find all solutions to a problem, we can query the--- solver repeatedly, telling it to give us a new model each time. SBV already--- provides 'allSat' that precisely does this. However, this example demonstrates--- how the query mode can be used to achieve the same, and can also incorporate--- extra conditions with easy as we walk through solutions.--------------------------------------------------------------------------------module Data.SBV.Examples.Queries.AllSat where--import Data.SBV-import Data.SBV.Control--import Data.List---- | Find all solutions to @x + y .== 10@ for positive @x@ and @y@, but at each--- iteration we would like to ensure that the value of @x@ we get is at least twice as large as--- the previous one. This is rather silly, but demonstrates how we can dynamically--- query the result and put in new constraints based on those.-goodSum :: Symbolic [(Integer, Integer)]-goodSum = do x <- sInteger "x"-             y <- sInteger "y"--             -- constrain positive and sum:-             constrain $ x .>= 0-             constrain $ y .>= 0-             constrain $ x + y .== 10--             -- Capture the "next" solution function:-             let next i sofar = do-                    io $ putStrLn $ "Iteration: " ++ show (i :: Int)--                    cs <- checkSat-                    case cs of-                      Unk   -> error "Too bad, solver said unknown.." -- Won't happen-                      Unsat -> do io $ putStrLn "No other solution!"-                                  return sofar--                      Sat   -> do xv <- getValue x-                                  yv <- getValue y--                                  io $ putStrLn $ "Current solution is: " ++ show (xv, yv)--                                  -- For next iteration: Put in constraints outlawing the current one:-                                  -- Note that we do *not* put these separately, as we do want-                                  -- to allow repetition on one value if the other is different!-                                  constrain $   x ./= literal xv-                                            ||| y ./= literal yv--                                  -- Also request @x@ to be twice as large, for demo purposes:-                                  constrain $ x .>= 2 * literal xv--                                  -- loop around!-                                  next (i+1) ((xv, yv) : sofar)--             -- Go into query mode and execute the loop:-             query $ do io $ putStrLn "Starting the all-sat engine!"-                        next 1 []---- | Run the query. We have:------ >>> demo--- Starting the all-sat engine!--- Iteration: 1--- Current solution is: (0,10)--- Iteration: 2--- Current solution is: (1,9)--- Iteration: 3--- Current solution is: (2,8)--- Iteration: 4--- Current solution is: (4,6)--- Iteration: 5--- Current solution is: (8,2)--- Iteration: 6--- No other solution!--- [(0,10),(1,9),(2,8),(4,6),(8,2)]-demo :: IO ()-demo = do ss <- runSMT goodSum-          print $ sort ss
− Data/SBV/Examples/Queries/CaseSplit.hs 
@@ -1,81 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Queries.CaseSplit--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ A couple of demonstrations for the 'caseSplit' function.--------------------------------------------------------------------------------module Data.SBV.Examples.Queries.CaseSplit where--import Data.SBV-import Data.SBV.Control---- | A simple floating-point problem, but we do the sat-analysis via a case-split.--- Due to the nature of floating-point numbers, a case-split on the characteristics--- of the number (such as NaN, negative-zero, etc. is most suitable.)------ We have:--- >>> csDemo1--- Case fpIsNegativeZero: Starting--- Case fpIsNegativeZero: Unsatisfiable--- Case fpIsPositiveZero: Starting--- Case fpIsPositiveZero: Unsatisfiable--- Case fpIsNormal: Starting--- Case fpIsNormal: Unsatisfiable--- Case fpIsSubnormal: Starting--- Case fpIsSubnormal: Unsatisfiable--- Case fpIsPoint: Starting--- Case fpIsPoint: Unsatisfiable--- Case fpIsNaN: Starting--- Case fpIsNaN: Satisfiable--- ("fpIsNaN",NaN)-csDemo1 :: IO (String, Float)-csDemo1 = runSMT $ do--       x <- sFloat "x"--       constrain $ x ./= x -- yes, in the FP land, this does hold--       query $ do mbR <- caseSplit True [ ("fpIsNegativeZero", fpIsNegativeZero x)-                                        , ("fpIsPositiveZero", fpIsPositiveZero x)-                                        , ("fpIsNormal",       fpIsNormal       x)-                                        , ("fpIsSubnormal",    fpIsSubnormal    x)-                                        , ("fpIsPoint",        fpIsPoint        x)-                                        , ("fpIsNaN",          fpIsNaN          x)-                                        ]--                  case mbR of-                    Nothing     -> error "Cannot find a FP number x such that x == x + 1"  -- Won't happen!-                    Just (s, _) -> do xv <- getValue x-                                      return (s, xv)---- | Demonstrates the "coverage" case.------ We have:--- >>> csDemo2--- Case negative: Starting--- Case negative: Unsatisfiable--- Case less than 8: Starting--- Case less than 8: Unsatisfiable--- Case Coverage: Starting--- Case Coverage: Satisfiable--- ("Coverage",10)-csDemo2 :: IO (String, Integer)-csDemo2 = runSMT $ do--       x <- sInteger "x"--       constrain $ x .== 10--       query $ do mbR <- caseSplit True [ ("negative"   , x .< 0)-                                        , ("less than 8", x .< 8)-                                        ]--                  case mbR of-                    Nothing     -> error "Cannot find a solution!" -- Won't happen!-                    Just (s, _) -> do xv <- getValue x-                                      return (s, xv)
− Data/SBV/Examples/Queries/Enums.hs 
@@ -1,67 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Queries.Enums--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates the use of enumeration values during queries.--------------------------------------------------------------------------------{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveAnyClass      #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.SBV.Examples.Queries.Enums where--import Data.SBV-import Data.SBV.Control---- | Days of the week. We make it symbolic using the 'mkSymbolicEnumeration' splice.-data Day = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday---- | Make 'Day' a symbolic value.-mkSymbolicEnumeration ''Day---- | The type synonym 'SDay' is the symbolic variant of 'Day'. (Similar to 'SInteger'/'Integer'--- and others.)-type SDay = SBV Day---- | A trivial query to find three consecutive days that's all before 'Thursday'. The point--- here is that we can perform queries on such enumerated values and use 'getValue' on them--- and return their values from queries just like any other value. We have:------ >>> findDays--- [Monday,Tuesday,Wednesday]-findDays :: IO [Day]-findDays = runSMT $ do (d1 :: SDay) <- free "d1"-                       (d2 :: SDay) <- free "d2"-                       (d3 :: SDay) <- free "d3"--                       -- Assert that they are ordered-                       constrain $ d1 .<= d2-                       constrain $ d2 .<= d3--                       -- Assert that last day is before 'Thursday'-                       constrain $ d3 .< literal Thursday--                       -- Constraints can be given before or after-                       -- the query mode starts. We will assert that-                       -- they are different after we start interacting-                       -- with the solver. Note that we can query the-                       -- values based on other values obtained too,-                       -- if we want to guide the search.--                       query $ do constrain $ distinct [d1, d2, d3]--                                  cs <- checkSat-                                  case cs of-                                    Sat -> do a <- getValue d1-                                              b <- getValue d2-                                              c <- getValue d3-                                              return [a, b, c]--                                    _   -> error "Impossible, can't find days!"
− Data/SBV/Examples/Queries/FourFours.hs 
@@ -1,218 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Queries.FourFours--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ A query based solution to the four-fours puzzle.--- Inspired by <http://www.gigamonkeys.com/trees/>------ @--- Try to make every number between 0 and 20 using only four 4s and any--- mathematical operation, with all four 4s being used each time.--- @------ We pretty much follow the structure of <http://www.gigamonkeys.com/trees/>,--- with the exception that we generate the trees filled with symbolic operators--- and ask the SMT solver to find the appropriate fillings.--------------------------------------------------------------------------------{-# LANGUAGE FlexibleInstances  #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveAnyClass      #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.SBV.Examples.Queries.FourFours where--import Data.SBV-import Data.SBV.Control--import Data.List (inits, tails)-import Data.Maybe---- | Supported binary operators. To keep the search-space small, we will only allow division by @2@ or @4@,--- and exponentiation will only be to the power @0@. This does restrict the search space, but is sufficient to--- solve all the instances.-data BinOp = Plus | Minus | Times | Divide | Expt---- | Make 'BinOp' a symbolic value.-mkSymbolicEnumeration ''BinOp---- | Supported unary operators. Similar to 'BinOp' case, we will restrict square-root and factorial to--- be only applied to the value @4.-data UnOp  = Negate | Sqrt | Factorial---- | Make 'UnOp' a symbolic value.-mkSymbolicEnumeration ''UnOp---- | Symbolic variant of 'BinOp'.-type SBinOp = SBV BinOp---- | Symbolic variant of 'UnOp'.-type SUnOp  = SBV UnOp---- | The shape of a tree, either a binary node, or a unary node, or the number @4@, represented hear by--- the constructor @F@. We parameterize by the operator type: When doing symbolic computations, we'll fill--- those with 'SBinOp' and 'SUnOp'. When finding the shapes, we will simply put unit values, i.e., holes.-data T b u = B b (T b u) (T b u)-           | U u (T b u)-           | F---- | A rudimentary 'Show' instance for trees, nothing fancy.-instance Show (T BinOp UnOp) where-   show F       = "4"-   show (U u t) = case u of-                    Negate    -> "-" ++ show t-                    Sqrt      -> "sqrt(" ++ show t ++ ")"-                    Factorial -> show t ++ "!"-   show (B o l r) = "(" ++ show l ++ " " ++ so ++ " " ++ show r ++ ")"-     where so = fromMaybe (error $ "Unexpected operator: " ++ show o)-                        $ o `lookup` [(Plus, "+"), (Minus, "-"), (Times, "*"), (Divide, "/"), (Expt, "^")]---- | Construct all possible tree shapes. The argument here follows the logic in <http://www.gigamonkeys.com/trees/>:--- We simply construct all possible shapes and extend with the operators. The number of such trees is:------ >>> length allPossibleTrees--- 640------ Note that this is a /lot/ smaller than what is generated by <http://www.gigamonkeys.com/trees/>. (There, the--- number of trees is 10240000: 16000 times more than what we have to consider!)-allPossibleTrees :: [T () ()]-allPossibleTrees = trees $ replicate 4 F-  where trees :: [T () ()] -> [T () ()]-        trees [x] = [x, U () x]-        trees xs  = do (left, right) <- splits-                       t1            <- trees left-                       t2            <- trees right-                       trees [B () t1 t2]-          where splits = init $ tail $ zip (inits xs) (tails xs)---- | Given a tree with hols, fill it with symbolic operators. This is the /trick/ that allows--- us to consider only 640 trees as opposed to over 10 million.-fill :: T () () -> Symbolic (T SBinOp SUnOp)-fill (B _ l r) = B <$> free_ <*> fill l <*> fill r-fill (U _ t)   = U <$> free_ <*> fill t-fill F         = return F---- | Minor helper for writing "symbolic" case statements. Simply walks down a list--- of values to match against a symbolic version of the key.-sCase :: (SymWord a, Mergeable v) => SBV a -> [(a, v)] -> v-sCase k = walk-  where walk []              = error "sCase: Expected a non-empty list of cases!"-        walk [(_, v)]        = v-        walk ((k1, v1):rest) = ite (k .== literal k1) v1 (walk rest)---- | Evaluate a symbolic tree, obtaining a symbolic value. Note how we structure--- this evaluation so we impose extra constraints on what values square-root, divide--- etc. can take. This is the power of the symbolic approach: We can put arbitrary--- symbolic constraints as we evaluate the tree.-eval :: T SBinOp SUnOp -> Symbolic SInteger-eval tree = case tree of-              B b l r -> eval l >>= \l' -> eval r >>= \r' -> binOp b l' r'-              U u t   -> eval t >>= uOp u-              F       -> return 4--  where binOp :: SBinOp -> SInteger -> SInteger -> Symbolic SInteger-        binOp o l r = do constrain $ o .== literal Divide ==> r .== 4 ||| r .== 2-                         constrain $ o .== literal Expt   ==> r .== 0-                         return $ sCase o-                                    [ (Plus,    l+r)-                                    , (Minus,   l-r)-                                    , (Times,   l*r)-                                    , (Divide,  l `sDiv` r)-                                    , (Expt,    1)   -- exponent is restricted to 0, so the value is 1-                                    ]--        uOp :: SUnOp -> SInteger -> Symbolic SInteger-        uOp o v = do constrain $ o .== literal Sqrt      ==> v .== 4-                     constrain $ o .== literal Factorial ==> v .== 4-                     return $ sCase o-                                [ (Negate,    -v)-                                , (Sqrt,       2)  -- argument is restricted to 4, so the value is 2-                                , (Factorial, 24)  -- argument is restricted to 4, so the value is 24-                                ]---- | In the query mode, find a filling of a given tree shape /t/, such that it evalutes to the--- requested number /i/. Note that we return back a concrete tree.-generate :: Integer -> T () () -> IO (Maybe (T BinOp UnOp))-generate i t = runSMT $ do symT <- fill t-                           val  <- eval symT-                           constrain $ val .== literal i-                           query $ do cs <- checkSat-                                      case cs of-                                        Sat -> Just <$> construct symT-                                        _   -> return Nothing-    where -- Walk through the tree, ask the solver for-          -- the assignment to symbolic operators and fill back.-          construct F           = return F-          construct (U o s')    = do uo <- getValue o-                                     U uo <$> construct s'-          construct (B b l' r') = do bo <- getValue b-                                     B bo <$> construct l' <*> construct r'---- | Given an integer, walk through all possible tree shapes (at most 640 of them), and find a--- filling that solves the puzzle.-find :: Integer -> IO ()-find target = go allPossibleTrees-  where go []     = putStrLn $ show target ++ ": No solution found."-        go (t:ts) = do chk <- generate target t-                       case chk of-                         Nothing -> go ts-                         Just r  -> do let ok  = concEval r == target-                                           tag = if ok then " [OK]: " else " [BAD]: "-                                           sh i | i < 10 = ' ' : show i-                                                | True   =       show i--                                       putStrLn $ sh target ++ tag ++ show r--        -- Make sure the result is correct!-        concEval :: T BinOp UnOp -> Integer-        concEval F         = 4-        concEval (U u t)   = uEval u (concEval t)-        concEval (B b l r) = bEval b (concEval l) (concEval r)--        uEval :: UnOp -> Integer -> Integer-        uEval Negate    i = -i-        uEval Sqrt      i = if i == 4 then  2 else error $ "uEval: Found sqrt applied to value: " ++ show i-        uEval Factorial i = if i == 4 then 24 else error $ "uEval: Found factorial applied to value: " ++ show i--        bEval :: BinOp -> Integer -> Integer -> Integer-        bEval Plus   i j = i + j-        bEval Minus  i j = i - j-        bEval Times  i j = i * j-        bEval Divide i j = i `div` j-        bEval Expt   i j = i ^ j---- | Solution to the puzzle. When you run this puzzle, the solver can produce different results--- than what's shown here, but the expressions should still be all valid!------ @--- ghci> puzzle---  0 [OK]: (4 - (4 + (4 - 4)))---  1 [OK]: (4 / (4 + (4 - 4)))---  2 [OK]: sqrt((4 + (4 * (4 - 4))))---  3 [OK]: (4 - (4 ^ (4 - 4)))---  4 [OK]: (4 + (4 * (4 - 4)))---  5 [OK]: (4 + (4 ^ (4 - 4)))---  6 [OK]: (4 + sqrt((4 * (4 / 4))))---  7 [OK]: (4 + (4 - (4 / 4)))---  8 [OK]: (4 - (4 - (4 + 4)))---  9 [OK]: (4 + (4 + (4 / 4)))--- 10 [OK]: (4 + (4 + (4 - sqrt(4))))--- 11 [OK]: (4 + ((4 + 4!) / 4))--- 12 [OK]: (4 * (4 - (4 / 4)))--- 13 [OK]: (4! + ((sqrt(4) - 4!) / sqrt(4)))--- 14 [OK]: (4 + (4 + (4 + sqrt(4))))--- 15 [OK]: (4 + ((4! - sqrt(4)) / sqrt(4)))--- 16 [OK]: (4 * (4 * (4 / 4)))--- 17 [OK]: (4 + ((sqrt(4) + 4!) / sqrt(4)))--- 18 [OK]: -(4 + (4 - (sqrt(4) + 4!)))--- 19 [OK]: -(4 - (4! - (4 / 4)))--- 20 [OK]: (4 * (4 + (4 / 4)))--- @-puzzle :: IO ()-puzzle = mapM_ find [0 .. 20]
− Data/SBV/Examples/Queries/GuessNumber.hs 
@@ -1,78 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Queries.GuessNumber--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ A simple number-guessing game implementation via queries. Clearly an--- SMT solver is hardly needed for this problem, but it is a nice demo--- for the interactive-query programming.--------------------------------------------------------------------------------module Data.SBV.Examples.Queries.GuessNumber where--import Data.SBV-import Data.SBV.Control---- | Use the backend solver to guess the number given as argument.--- The number is assumed to be between @0@ and @1000@, and we use a simple--- binary search. Returns the sequence of guesses we performed during--- the search process.-guess :: Integer -> Symbolic [Integer]-guess input = do g <- sInteger "guess"--                 -- A simple loop to find the value in a query. lb and up-                 -- correspond to the current lower/upper bound we operate in.-                 let loop lb ub sofar = do--                          io $ putStrLn $ "Current bounds: " ++ show (lb, ub)--                          -- Assert the current bound:-                          constrain $ g .>= literal lb-                          constrain $ g .<= literal ub--                          -- Issue a check-sat-                          cs <- checkSat-                          case cs of-                            Unk   -> error "Too bad, solver said Unknown.." -- Won't really happen-                            Unsat ->-                                  -- This cannot happen! If it does, the input was-                                  -- not properly constrainted. Note that we found this-                                  -- by getting an Unsat, not by checking the value!-                                  error $ unlines [ "There's no solution!"-                                                  , "Guess sequence: " ++ show (reverse sofar)-                                                  ]-                            Sat   -> do gv <- getValue g-                                        case gv `compare` input of-                                          EQ -> -- Got it, return:-                                                return (reverse (gv : sofar))-                                          LT -> -- Solver guess is too small, increase the lower bound:-                                                loop ((lb+1) `max` (lb + (input - lb) `div` 2)) ub (gv : sofar)-                                          GT -> -- Solver guess is too big, decrease the upper bound:-                                                loop lb ((ub-1) `min` (ub - (ub - input) `div` 2)) (gv : sofar)--                 -- Start the search-                 query $ loop 0 1000 []---- | Play a round of the game, making the solver guess the secret number 42.--- Note that you can generate a random-number and make the solver guess it too!--- We have:------ >>> play--- Current bounds: (0,1000)--- Current bounds: (0,521)--- Current bounds: (21,521)--- Current bounds: (31,521)--- Current bounds: (36,521)--- Current bounds: (39,521)--- Current bounds: (40,521)--- Current bounds: (41,521)--- Current bounds: (42,521)--- Solved in: 9 guesses:---   1000 0 21 31 36 39 40 41 42-play :: IO ()-play = do gs <- runSMT (guess 42)-          putStrLn $ "Solved in: " ++ show (length gs) ++ " guesses:"-          putStrLn $ "  " ++ unwords (map show gs)
− Data/SBV/Examples/Queries/Interpolants.hs 
@@ -1,65 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Queries.Interpolants--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates extraction of interpolants via queries.--------------------------------------------------------------------------------module Data.SBV.Examples.Queries.Interpolants where--import Data.SBV-import Data.SBV.Control---- | Compute the interpolant for formulas @y = 2x@ and @y = 2z+1@.--- These formulas are not satisfiable together since it would mean--- @y@ is both even and odd at the same time. An interpolant for--- this pair of formulas is a formula that's expressed only in terms--- of @y@, which is the only common symbol among them. We have:------ >>> runSMT evenOdd--- ["(<= 0 (+ (div s1 2) (div (* (- 1) s1) 2)))"]------ This is a bit hard to read unfortunately, due to translation artifacts and use of strings. To analyze,--- we need to know that @s1@ is @y@ through SBV's translation. Let's express it in--- regular infix notation with @y@ for @s1@:------ @ 0 <= (y `div` 2) + ((-y) `div` 2)@------ Notice that the only symbol is @y@, as required. To establish that this is--- indeed an interpolant, we should establish that when @y@ is even, this formula--- is @True@; and if @y@ is odd, then then it should be @False@. You can argue--- mathematically that this indeed the case, but let's just use SBV to prove these:------ >>> prove $ \y -> (y `sMod` 2 .== 0) ==> (0 .<= (y `sDiv` 2) + ((-y) `sDiv` 2::SInteger))--- Q.E.D.------ And:------ >>> prove $ \y -> (y `sMod` 2 .== 1) ==> bnot (0 .<= (y `sDiv` 2) + ((-y) `sDiv` 2::SInteger))--- Q.E.D.------ This establishes that we indeed have an interpolant!-evenOdd :: Symbolic [String]-evenOdd = do-       x <- sInteger "x"-       y <- sInteger "y"-       z <- sInteger "z"--       -- tell the solver we want interpolants-       setOption $ ProduceInterpolants True--       -- create named constraints, which will allow-       -- computation of the interpolants for our formulas-       namedConstraint "y is even" $ y .== 2*x-       namedConstraint "y is odd"  $ y .== 2*z + 1--       -- To obtain the interpolant, we run a query-       query $ do cs <- checkSat-                  case cs of-                    Unsat -> getInterpolant ["y is even", "y is odd"]-                    Sat   -> error "Unexpected sat result!"-                    Unk   -> error "Unexpected unknown result!"
− Data/SBV/Examples/Queries/UnsatCore.hs 
@@ -1,50 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Queries.UnsatCore--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates extraction of unsat-cores via queries.--------------------------------------------------------------------------------module Data.SBV.Examples.Queries.UnsatCore where--import Data.SBV-import Data.SBV.Control---- | A simple goal with three constraints, two of which are--- conflicting with each other. The third is irrelevant, in the sense--- that it does not contribute to the fact that the goal is unsatisfiable.-p :: Symbolic (Maybe [String])-p = do a <- sInteger "a"-       b <- sInteger "b"--       -- tell the solver we want unsat-cores-       setOption $ ProduceUnsatCores True--       -- create named constraints, which will allow-       -- unsat-core extraction with the given names-       namedConstraint "less than 5"  $ a .< 5-       namedConstraint "more than 10" $ a .> 10-       namedConstraint "irrelevant"   $ a .> b--       -- To obtain the unsat-core, we run a query-       query $ do cs <- checkSat-                  case cs of-                    Unsat -> Just <$> getUnsatCore-                    _     -> return Nothing----- | Extract the unsat-core of 'p'. We have:------ >>> ucCore--- Unsat core is: ["less than 5","more than 10"]------ Demonstrating that the constraint @a .> b@ is /not/ needed for unsatisfiablity in this case.-ucCore :: IO ()-ucCore = do mbCore <- runSMT p-            case mbCore of-              Nothing   -> putStrLn "Problem is satisfiable."-              Just core -> putStrLn $ "Unsat core is: " ++ show core
− Data/SBV/Examples/Uninterpreted/AUF.hs 
@@ -1,91 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Uninterpreted.AUF--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Formalizes and proves the following theorem, about arithmetic,--- uninterpreted functions, and arrays. (For reference, see <http://research.microsoft.com/en-us/um/redmond/projects/z3/fmcad06-slides.pdf>--- slide number 24):------ @---    x + 2 = y  implies  f (read (write (a, x, 3), y - 2)) = f (y - x + 1)--- @------ We interpret the types as follows (other interpretations certainly possible):------    [/x/] 'SWord32' (32-bit unsigned address)------    [/y/] 'SWord32' (32-bit unsigned address)------    [/a/] An array, indexed by 32-bit addresses, returning 32-bit unsigned integers------    [/f/] An uninterpreted function of type @'SWord32' -> 'SWord64'@------ The function @read@ and @write@ are usual array operations.--------------------------------------------------------------------------------module Data.SBV.Examples.Uninterpreted.AUF where--import Data.SBV------------------------------------------------------------------- * Model using functional arrays------------------------------------------------------------------- | The array type, takes symbolic 32-bit unsigned indexes--- and stores 32-bit unsigned symbolic values. These are--- functional arrays where reading before writing a cell--- throws an exception.-type A = SFunArray Word32 Word32---- | Uninterpreted function in the theorem-f :: SWord32 -> SWord64-f = uninterpret "f"---- | Correctness theorem. We state it for all values of @x@, @y@, and--- the given array @a@. -thm1 :: SWord32 -> SWord32 -> A -> SBool-thm1 x y a = lhs ==> rhs-  where lhs = x + 2 .== y-        rhs =     f (readArray (writeArray a x 3) (y - 2))-              .== f (y - x + 1)---- | Prints Q.E.D. when run, as expected------ >>> proveThm1--- Q.E.D.-proveThm1 :: IO ThmResult-proveThm1 = prove $ do-                x <- free "x"-                y <- free "y"-                -- Take an "initialized" array, one that returns 0's for all initial reads-                let a = mkSFunArray (const 0)-                return $ thm1 x y a------------------------------------------------------------------- * Model using SMT arrays------------------------------------------------------------------- | This version directly uses SMT-arrays and hence does not need an initializer.--- Reading an element before writing to it returns an arbitrary value.-type B = SArray Word32 Word32---- | Same as 'thm1', except we don't need an initializer with the 'SArray' model.-thm2 :: SWord32 -> SWord32 -> B -> SBool-thm2 x y a = lhs ==> rhs-  where lhs = x + 2 .== y-        rhs =     f (readArray (writeArray a x 3) (y - 2))-              .== f (y - x + 1)---- | Prints Q.E.D. when run, as expected:------ >>> proveThm2--- Q.E.D.-proveThm2 :: IO ThmResult-proveThm2 = prove $ do-                x <- free "x"-                y <- free "y"-                thm2 x y <$> newArray "b"
− Data/SBV/Examples/Uninterpreted/Deduce.hs 
@@ -1,95 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Uninterpreted.Deduce--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates uninterpreted sorts and how they can be used for deduction.--- This example is inspired by the discussion at <http://stackoverflow.com/questions/10635783/using-axioms-for-deductions-in-z3>,--- essentially showing how to show the required deduction using SBV.--------------------------------------------------------------------------------{-# LANGUAGE DeriveAnyClass     #-}-{-# LANGUAGE DeriveDataTypeable #-}--module Data.SBV.Examples.Uninterpreted.Deduce where--import Data.Generics-import Data.SBV---- we will have our own "uninterpreted" functions corresponding--- to not/or/and, so hide their Prelude counterparts.-import Prelude hiding (not, or, and)---------------------------------------------------------------------------------- * Representing uninterpreted booleans---------------------------------------------------------------------------------- | The uninterpreted sort 'B', corresponding to the carrier.--- To prevent SBV from translating it to an enumerated type, we simply attach an unused field-newtype B = B () deriving (Eq, Ord, Show, Read, Data, SymWord, HasKind)---- | Handy shortcut for the type of symbolic values over 'B'-type SB = SBV B---------------------------------------------------------------------------------- * Uninterpreted connectives over 'B'---------------------------------------------------------------------------------- | Uninterpreted logical connective 'and'-and :: SB -> SB -> SB-and = uninterpret "AND"---- | Uninterpreted logical connective 'or'-or :: SB -> SB -> SB-or  = uninterpret "OR"---- | Uninterpreted logical connective 'not'-not :: SB -> SB-not = uninterpret "NOT"---------------------------------------------------------------------------------- * Axioms of the logical system---------------------------------------------------------------------------------- | Distributivity of OR over AND, as an axiom in terms of--- the uninterpreted functions we have introduced. Note how--- variables range over the uninterpreted sort 'B'.-ax1 :: [String]-ax1 = [ "(assert (forall ((p B) (q B) (r B))"-      , "   (= (AND (OR p q) (OR p r))"-      , "      (OR p (AND q r)))))"-      ]---- | One of De Morgan's laws, again as an axiom in terms--- of our uninterpeted logical connectives.-ax2 :: [String]-ax2 = [ "(assert (forall ((p B) (q B))"-      , "   (= (NOT (OR p q))"-      , "      (AND (NOT p) (NOT q)))))"-      ]---- | Double negation axiom, similar to the above.-ax3 :: [String]-ax3 = ["(assert (forall ((p B)) (= (NOT (NOT p)) p)))"]---------------------------------------------------------------------------------- * Demonstrated deduction---------------------------------------------------------------------------------- | Proves the equivalence @NOT (p OR (q AND r)) == (NOT p AND NOT q) OR (NOT p AND NOT r)@,--- following from the axioms we have specified above. We have:------ >>> test--- Q.E.D.-test :: IO ThmResult-test = prove $ do addAxiom "OR distributes over AND" ax1-                  addAxiom "de Morgan"               ax2-                  addAxiom "double negation"         ax3-                  p <- free "p"-                  q <- free "q"-                  r <- free "r"-                  return $   not (p `or` (q `and` r))-                         .== (not p `and` not q) `or` (not p `and` not r)
− Data/SBV/Examples/Uninterpreted/Function.hs 
@@ -1,25 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Uninterpreted.Function--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates function counter-examples--------------------------------------------------------------------------------module Data.SBV.Examples.Uninterpreted.Function where--import Data.SBV---- | An uninterpreted function-f :: SWord8 -> SWord8 -> SWord16-f = uninterpret "f"---- | Asserts that @f x z == f (y+2) z@ whenever @x == y+2@. Naturally correct:------ >>> prove thmGood--- Q.E.D.-thmGood :: SWord8 -> SWord8 -> SWord8 -> SBool-thmGood x y z = x .== y+2 ==> f x z .== f (y + 2) z
− Data/SBV/Examples/Uninterpreted/Shannon.hs 
@@ -1,129 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Uninterpreted.Shannon--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Proves (instances of) Shannon's expansion theorem and other relevant--- facts.  See: <http://en.wikipedia.org/wiki/Shannon's_expansion>--------------------------------------------------------------------------------module Data.SBV.Examples.Uninterpreted.Shannon where--import Data.SBV---------------------------------------------------------------------------------- * Boolean functions---------------------------------------------------------------------------------- | A ternary boolean function-type Ternary = SBool -> SBool -> SBool -> SBool---- | A binary boolean function-type Binary = SBool -> SBool-> SBool---------------------------------------------------------------------------------- * Shannon cofactors---------------------------------------------------------------------------------- | Positive Shannon cofactor of a boolean function, with--- respect to its first argument-pos :: (SBool -> a) -> a-pos f = f true---- | Negative Shannon cofactor of a boolean function, with--- respect to its first argument-neg :: (SBool -> a) -> a-neg f = f false---------------------------------------------------------------------------------- * Shannon expansion theorem---------------------------------------------------------------------------------- | Shannon's expansion over the first argument of a function. We have:------ >>> shannon--- Q.E.D.-shannon :: IO ThmResult-shannon = prove $ \x y z -> f x y z .== (x &&& pos f y z ||| bnot x &&& neg f y z)- where f :: Ternary-       f = uninterpret "f"---- | Alternative form of Shannon's expansion over the first argument of a function. We have:------ >>> shannon2--- Q.E.D.-shannon2 :: IO ThmResult-shannon2 = prove $ \x y z -> f x y z .== ((x ||| neg f y z) &&& (bnot x ||| pos f y z))- where f :: Ternary-       f = uninterpret "f"---------------------------------------------------------------------------------- * Derivatives---------------------------------------------------------------------------------- | Computing the derivative of a boolean function (boolean difference).--- Defined as exclusive-or of Shannon cofactors with respect to that--- variable.-derivative :: Ternary -> Binary-derivative f y z = pos f y z <+> neg f y z---- | The no-wiggle theorem: If the derivative of a function with respect to--- a variable is constant False, then that variable does not "wiggle" the--- function; i.e., any changes to it won't affect the result of the function.--- In fact, we have an equivalence: The variable only changes the--- result of the function iff the derivative with respect to it is not False:------ >>> noWiggle--- Q.E.D.-noWiggle :: IO ThmResult-noWiggle = prove $ \y z -> bnot (f' y z) <=> pos f y z .== neg f y z-  where f :: Ternary-        f  = uninterpret "f"-        f' = derivative f---------------------------------------------------------------------------------- * Universal quantification---------------------------------------------------------------------------------- | Universal quantification of a boolean function with respect to a variable.--- Simply defined as the conjunction of the Shannon cofactors.-universal :: Ternary -> Binary-universal f y z = pos f y z &&& neg f y z---- | Show that universal quantification is really meaningful: That is, if the universal--- quantification with respect to a variable is True, then both cofactors are true for--- those arguments. Of course, this is a trivial theorem if you think about it for a--- moment, or you can just let SBV prove it for you:------ >>> univOK--- Q.E.D.-univOK :: IO ThmResult-univOK = prove $ \y z -> f' y z ==> pos f y z &&& neg f y z-  where f :: Ternary-        f  = uninterpret "f"-        f' = universal f---------------------------------------------------------------------------------- * Existential quantification---------------------------------------------------------------------------------- | Existential quantification of a boolean function with respect to a variable.--- Simply defined as the conjunction of the Shannon cofactors.-existential :: Ternary -> Binary-existential f y z = pos f y z ||| neg f y z---- | Show that existential quantification is really meaningful: That is, if the existential--- quantification with respect to a variable is True, then one of the cofactors must be true for--- those arguments. Again, this is a trivial theorem if you think about it for a moment, but--- we will just let SBV prove it:------ >>> existsOK--- Q.E.D.-existsOK :: IO ThmResult-existsOK = prove $ \y z -> f' y z ==> pos f y z ||| neg f y z-  where f :: Ternary-        f  = uninterpret "f"-        f' = existential f
− Data/SBV/Examples/Uninterpreted/Sort.hs 
@@ -1,50 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Uninterpreted.Sort--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates uninterpreted sorts, together with axioms.--------------------------------------------------------------------------------{-# LANGUAGE DeriveAnyClass     #-}-{-# LANGUAGE DeriveDataTypeable #-}--module Data.SBV.Examples.Uninterpreted.Sort where--import Data.Generics-import Data.SBV---- | A new data-type that we expect to use in an uninterpreted fashion--- in the backend SMT solver. Note the custom @deriving@ clause, which--- takes care of most of the boilerplate. The () field is needed so--- SBV will not translate it to an enumerated data-type-newtype Q = Q () deriving (Eq, Ord, Data, Read, Show, SymWord, HasKind)---- | Declare an uninterpreted function that works over Q's-f :: SBV Q -> SBV Q-f = uninterpret "f"---- | A satisfiable example, stating that there is an element of the domain--- 'Q' such that 'f' returns a different element. Note that this is valid only--- when the domain 'Q' has at least two elements. We have:------ >>> t1--- Satisfiable. Model:---   x = Q!val!0 :: Q-t1 :: IO SatResult-t1 = sat $ do x <- free "x"-              return $ f x ./= x---- | This is a variant on the first example, except we also add an axiom--- for the sort, stating that the domain 'Q' has only one element. In this case--- the problem naturally becomes unsat. We have:------ >>> t2--- Unsatisfiable-t2 :: IO SatResult-t2 = sat $ do x <- free "x"-              addAxiom "Q" ["(assert (forall ((x Q) (y Q)) (= x y)))"]-              return $ f x ./= x
− Data/SBV/Examples/Uninterpreted/UISortAllSat.hs 
@@ -1,75 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.SBV.Examples.Uninterpreted.UISortAllSat--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Demonstrates uninterpreted sorts and how all-sat behaves for them.--- Thanks to Eric Seidel for the idea.--------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}--module Data.SBV.Examples.Uninterpreted.UISortAllSat where--import Data.Generics-import Data.SBV---- | A "list-like" data type, but one we plan to uninterpret at the SMT level.--- The actual shape is really immaterial for us, but could be used as a proxy--- to generate test cases or explore data-space in some other part of a program.--- Note that we neither rely on the shape of this data, nor need the actual--- constructors.-data L = Nil-       | Cons Int L-       deriving (Eq, Ord, Show, Read, Data)---- | Declare instances to make 'L' a usable uninterpreted sort. First we need the--- 'SymWord' instance, with the default definition sufficing.-instance SymWord L---- | Similarly, 'HasKind's default implementation is sufficient.-instance HasKind L---- | An uninterpreted "classify" function. Really, we only care about--- the fact that such a function exists, not what it does.-classify :: SBV L -> SInteger-classify = uninterpret "classify"---- | Formulate a query that essentially asserts a cardinality constraint on--- the uninterpreted sort 'L'. The goal is to say there are precisely 3--- such things, as it might be the case. We manage this by declaring four--- elements, and asserting that for a free variable of this sort, the--- shape of the data matches one of these three instances. That is, we--- assert that all the instances of the data 'L' can be classified into--- 3 equivalence classes. Then, allSat returns all the possible instances,--- which of course are all uninterpreted.------ As expected, we have:------ >>> genLs--- Solution #1:---   l  = L!val!0 :: L---   l0 = L!val!0 :: L---   l1 = L!val!1 :: L---   l2 = L!val!2 :: L--- Solution #2:---   l  = L!val!1 :: L---   l0 = L!val!0 :: L---   l1 = L!val!1 :: L---   l2 = L!val!2 :: L--- Solution #3:---   l  = L!val!2 :: L---   l0 = L!val!0 :: L---   l1 = L!val!1 :: L---   l2 = L!val!2 :: L--- Found 3 different solutions.-genLs :: IO AllSatResult-genLs = allSatWith z3-               $ do [l, l0, l1, l2] <- symbolics ["l", "l0", "l1", "l2"]-                    constrain $ classify l0 .== 0-                    constrain $ classify l1 .== 1-                    constrain $ classify l2 .== 2-                    return $ l .== l0 ||| l .== l1 ||| l .== l2
+ Data/SBV/RegExp.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE Rank2Types           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE OverloadedStrings    #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.RegExp+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- A collection of regular-expression related utilities. The recommended+-- workflow is to import this module qualified as the names of the functions+-- are specificly chosen to be common identifiers. Also, it is recommended+-- you use the @OverloadedStrings@ extension to allow literal strings to be+-- used as symbolic-strings and regular-expressions when working with+-- this module.+-----------------------------------------------------------------------------++module Data.SBV.RegExp (+        -- * Regular expressions+        RegExp(..)+        -- * Matching+        -- $matching+        , RegExpMatchable(..)+        -- * Constructing regular expressions+        -- ** Literals+        , exactly+        -- ** A class of characters+        , oneOf+        -- ** Spaces+        , newline, whiteSpaceNoNewLine, whiteSpace+        -- ** Separators+        , tab, punctuation+        -- ** Letters+        , asciiLetter, asciiLower, asciiUpper+        -- ** Digits+        , digit, octDigit, hexDigit+        -- ** Numbers+        , decimal, octal, hexadecimal, floating+        -- ** Identifiers+        , identifier+        ) where++import Prelude hiding (length, take, elem, notElem, head)++import Data.SBV.Core.Data+import Data.SBV.Core.Model () -- instances only++import Data.SBV.String+import qualified Data.Char as C++-- For testing only+import Data.SBV.Char++-- For doctest use only+--+-- $setup+-- >>> import Prelude hiding (length, take, elem, notElem, head)+-- >>> import Data.SBV.Provers.Prover (prove, sat)+-- >>> import Data.SBV.Utils.Boolean  ((<=>), (==>), bAny, (&&&), (|||), bnot)+-- >>> import Data.SBV.Core.Model+-- >>> :set -XOverloadedStrings+-- >>> :set -XScopedTypeVariables++-- | Matchable class. Things we can match against a 'RegExp'.+-- (TODO: Currently SBV does *not* optimize this call if the input is a concrete string or+-- a character, but rather directly calls down to the solver. We might want to perform the+-- operation on the Haskell side for performance reasons, should this become important.)+--+-- For instance, you can generate valid-looking phone numbers like this:+--+-- >>> :set -XOverloadedStrings+-- >>> let dig09 = Range '0' '9'+-- >>> let dig19 = Range '1' '9'+-- >>> let pre   = dig19 * Loop 2 2 dig09+-- >>> let post  = dig19 * Loop 3 3 dig09+-- >>> let phone = pre * "-" * post+-- >>> sat $ \s -> (s :: SString) `match` phone+-- Satisfiable. Model:+--   s0 = "222-2248" :: String+class RegExpMatchable a where+   -- | @`match` s r@ checks whether @s@ is in the language generated by @r@.+   match :: a -> RegExp -> SBool++-- | Matching a character simply means the singleton string matches the regex.+instance RegExpMatchable SChar where+   match = match . charToStr++-- | Matching symbolic strings.+instance RegExpMatchable SString where+   match s r = lift1 (StrInRe r) opt s+     where -- TODO: Replace this with a function that concretely evaluates the string against the+           -- reg-exp, possible future work. But probably there isn't enough ROI.+           opt :: Maybe (String -> Bool)+           opt = Nothing++-- | A literal regular-expression, matching the given string exactly. Note that+-- with 'OverloadedStrings' extension, you can simply use a Haskell+-- string to mean the same thing, so this function is rarely needed.+--+-- >>> prove $ \(s :: SString) -> s `match` exactly "LITERAL" <=> s .== "LITERAL"+-- Q.E.D.+exactly :: String -> RegExp+exactly = Literal++-- | Helper to define a character class.+--+-- >>> prove $ \(c :: SChar) -> c `match` oneOf "ABCD" <=> bAny (c .==) (map literal "ABCD")+-- Q.E.D.+oneOf :: String -> RegExp+oneOf xs = Union [exactly [x] | x <- xs]++-- | Recognize a newline. Also includes carriage-return and form-feed.+--+-- >>> newline+-- (re.union (str.to.re "\n") (str.to.re "\r") (str.to.re "\f"))+-- >>> prove $ \c -> c `match` newline ==> isSpace c+-- Q.E.D.+newline :: RegExp+newline = oneOf "\n\r\f"++-- | Recognize a tab.+--+-- >>> tab+-- (str.to.re "\x09")+-- >>> prove $ \c -> c `match` tab ==> c .== literal '\t'+-- Q.E.D.+tab :: RegExp+tab = oneOf "\t"++-- | Recognize white-space, but without a new line.+--+-- >>> whiteSpaceNoNewLine+-- (re.union (str.to.re "\x09") (re.union (str.to.re "\v") (str.to.re "\xa0") (str.to.re " ")))+-- >>> prove $ \c -> c `match` whiteSpaceNoNewLine ==> c `match` whiteSpace &&& c ./= literal '\n'+-- Q.E.D.+whiteSpaceNoNewLine :: RegExp+whiteSpaceNoNewLine = tab + oneOf "\v\160 "++-- | Recognize white space.+--+-- >>> prove $ \c -> c `match` whiteSpace ==> isSpace c+-- Q.E.D.+whiteSpace :: RegExp+whiteSpace = newline + whiteSpaceNoNewLine++-- | Recognize a punctuation character. Anything that satisfies the predicate 'isPunctuation' will+-- be accepted.  (TODO: Will need modification when we move to unicode.)+--+-- >>> prove $ \c -> c `match` punctuation ==> isPunctuation c+-- Q.E.D.+punctuation :: RegExp+punctuation = oneOf $ filter C.isPunctuation $ map C.chr [0..255]++-- | Recognize an alphabet letter, i.e., @A@..@Z@, @a@..@z@.+--+-- >>> asciiLetter+-- (re.union (re.range "a" "z") (re.range "A" "Z"))+-- >>> prove $ \c -> c `match` asciiLetter <=> toUpper c `match` asciiLetter+-- Q.E.D.+-- >>> prove $ \c -> c `match` asciiLetter <=> toLower c `match` asciiLetter+-- Q.E.D.+asciiLetter :: RegExp+asciiLetter = asciiLower + asciiUpper++-- | Recognize an ASCII lower case letter+--+-- >>> asciiLower+-- (re.range "a" "z")+-- >>> prove $ \c -> (c :: SChar) `match` asciiLower  ==> c `match` asciiLetter+-- Q.E.D.+-- >>> prove $ \c -> c `match` asciiLower  ==> toUpper c `match` asciiUpper+-- Q.E.D.+-- >>> prove $ \c -> c `match` asciiLetter ==> toLower c `match` asciiLower+-- Q.E.D.+asciiLower :: RegExp+asciiLower = Range 'a' 'z'++-- | Recognize an upper case letter+--+-- >>> asciiUpper+-- (re.range "A" "Z")+-- >>> prove $ \c -> (c :: SChar) `match` asciiUpper  ==> c `match` asciiLetter+-- Q.E.D.+-- >>> prove $ \c -> c `match` asciiUpper  ==> toLower c `match` asciiLower+-- Q.E.D.+-- >>> prove $ \c -> c `match` asciiLetter ==> toUpper c `match` asciiUpper+-- Q.E.D.+asciiUpper :: RegExp+asciiUpper = Range 'A' 'Z'++-- | Recognize a digit. One of @0@..@9@.+--+-- >>> digit+-- (re.range "0" "9")+-- >>> prove $ \c -> c `match` digit <=> let v = digitToInt c in 0 .<= v &&& v .< 10+-- Q.E.D.+digit :: RegExp+digit = Range '0' '9'++-- | Recognize an octal digit. One of @0@..@7@.+--+-- >>> octDigit+-- (re.range "0" "7")+-- >>> prove $ \c -> c `match` octDigit <=> let v = digitToInt c in 0 .<= v &&& v .< 8+-- Q.E.D.+-- >>> prove $ \(c :: SChar) -> c `match` octDigit ==> c `match` digit+-- Q.E.D.+octDigit :: RegExp+octDigit = Range '0' '7'++-- | Recognize a hexadecimal digit. One of @0@..@9@, @a@..@f@, @A@..@F@.+--+-- >>> hexDigit+-- (re.union (re.range "0" "9") (re.range "a" "f") (re.range "A" "F"))+-- >>> prove $ \c -> c `match` hexDigit <=> let v = digitToInt c in 0 .<= v &&& v .< 16+-- Q.E.D.+-- >>> prove $ \(c :: SChar) -> c `match` digit ==> c `match` hexDigit+-- Q.E.D.+hexDigit :: RegExp+hexDigit = digit + Range 'a' 'f' + Range 'A' 'F'++-- | Recognize a decimal number.+--+-- >>> decimal+-- (re.+ (re.range "0" "9"))+-- >>> prove $ \s -> (s::SString) `match` decimal ==> bnot (s `match` KStar asciiLetter)+-- Q.E.D.+decimal :: RegExp+decimal = KPlus digit++-- | Recognize an octal number. Must have a prefix of the form @0o@\/@0O@.+--+-- >>> octal+-- (re.++ (re.union (str.to.re "0o") (str.to.re "0O")) (re.+ (re.range "0" "7")))+-- >>> prove $ \s -> s `match` octal ==> bAny (.== take 2 s) ["0o", "0O"]+-- Q.E.D.+octal :: RegExp+octal = ("0o" + "0O") * KPlus octDigit++-- | Recognize a hexadecimal number. Must have a prefix of the form @0x@\/@0X@.+--+-- >>> hexadecimal+-- (re.++ (re.union (str.to.re "0x") (str.to.re "0X")) (re.+ (re.union (re.range "0" "9") (re.range "a" "f") (re.range "A" "F"))))+-- >>> prove $ \s -> s `match` hexadecimal ==> bAny (.== take 2 s) ["0x", "0X"]+-- Q.E.D.+hexadecimal :: RegExp+hexadecimal = ("0x" + "0X") * KPlus hexDigit++-- | Recognize a floating point number. The exponent part is optional if a fraction+-- is present. The exponent may or may not have a sign.+--+-- >>> prove $ \s -> s `match` floating ==> length s .>= 3+-- Q.E.D.+floating :: RegExp+floating = withFraction + withoutFraction+  where withFraction    = decimal * "." * decimal * Opt expt+        withoutFraction = decimal * expt+        expt            = ("e" + "E") * Opt (oneOf "+-") * decimal++-- | For the purposes of this regular expression, an identifier consists of a letter+-- followed by zero or more letters, digits, underscores, and single quotes. The first+-- letter must be lowercase.+--+-- >>> prove $ \s -> s `match` identifier ==> isAsciiLower (head s)+-- Q.E.D.+-- >>> prove $ \s -> s `match` identifier ==> length s .>= 1+-- Q.E.D.+identifier :: RegExp+identifier = asciiLower * KStar (asciiLetter + digit + "_" + "'")++-- | Lift a unary operator over strings.+lift1 :: forall a b. (SymWord a, SymWord b) => StrOp -> Maybe (a -> b) -> SBV a -> SBV b+lift1 w mbOp a+  | Just cv <- concEval1 mbOp a+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where k = kindOf (undefined :: b)+        r st = do swa <- sbvToSW st a+                  newExpr st k (SBVApp (StrOp w) [swa])++-- | Concrete evaluation for unary ops+concEval1 :: (SymWord a, SymWord b) => Maybe (a -> b) -> SBV a -> Maybe (SBV b)+concEval1 mbOp a = literal <$> (mbOp <*> unliteral a)++-- | Quiet GHC about testing only imports+__unused :: a+__unused = undefined isSpace length take elem notElem head++{- $matching+A symbolic string or a character ('SString' or 'SChar') can be matched against a regular-expression. Note+that the regular-expression itself is not a symbolic object: It's a fully concrete representation, as+captured by the 'RegExp' class. The 'RegExp' class is an instance of 'IsString', which makes writing+literal matches easier. The 'RegExp' type also has a (somewhat degenerate) 'Num' instance: Concatenation+corresponds to multiplication, union corresponds to addition, and @0@ corresponds to the empty language.++Note that since `match` is a method of 'RegExpMatchable' class, both 'SChar' and 'SString' can be used as+an argument for matching. In practice, this means you might have to disambiguate with a type-ascription+if it is not deducible from context.++>>> prove $ \s -> (s :: SString) `match` "hello" <=> s .== "hello"+Q.E.D.+>>> prove $ \s -> s `match` Loop 2 5 "xyz" ==> length s .>= 6+Q.E.D.+>>> prove $ \s -> s `match` Loop 2 5 "xyz" ==> length s .<= 15+Q.E.D.+>>> prove $ \s -> match s (Loop 2 5 "xyz") ==> length s .>= 7+Falsifiable. Counter-example:+  s0 = "xyzxyz" :: String+>>> prove $ \s -> (s :: SString) `match` "hello" ==> s `match` ("hello" + "world")+Q.E.D.+>>> prove $ \s -> bnot $ (s::SString) `match` ("so close" * 0)+Q.E.D.+>>> prove $ \c -> (c :: SChar) `match` oneOf "abcd" ==> ord c .>= ord (literal 'a') &&& ord c .<= ord (literal 'd')+Q.E.D.+-}
Data/SBV/SMT/SMT.hs view
@@ -73,7 +73,7 @@  -- | Extract the final configuration from a result resultConfig :: SMTResult -> SMTConfig-resultConfig (Unsatisfiable c)   = c+resultConfig (Unsatisfiable c _) = c resultConfig (Satisfiable   c _) = c resultConfig (SatExtField   c _) = c resultConfig (Unknown       c _) = c@@ -382,11 +382,11 @@  -- | 'SMTResult' as a generic model provider instance Modelable SMTResult where-  getModelAssignment (Unsatisfiable _) = Left "SBV.getModelAssignment: Unsatisfiable result"-  getModelAssignment (Satisfiable _ m) = Right (False, parseModelOut m)-  getModelAssignment (SatExtField _ _) = Left "SBV.getModelAssignment: The model is in an extension field"-  getModelAssignment (Unknown _ m)     = Left $ "SBV.getModelAssignment: Solver state is unknown: " ++ m-  getModelAssignment (ProofError _ s)  = error $ unlines $ "Backend solver complains: " : s+  getModelAssignment (Unsatisfiable _ _) = Left "SBV.getModelAssignment: Unsatisfiable result"+  getModelAssignment (Satisfiable _ m)   = Right (False, parseModelOut m)+  getModelAssignment (SatExtField _ _)   = Left "SBV.getModelAssignment: The model is in an extension field"+  getModelAssignment (Unknown _ m)       = Left $ "SBV.getModelAssignment: Solver state is unknown: " ++ m+  getModelAssignment (ProofError _ s)    = error $ unlines $ "Backend solver complains: " : s    modelExists Satisfiable{}   = True   modelExists Unknown{}       = False -- don't risk it@@ -424,7 +424,7 @@ -- | Show an SMTResult; generic version showSMTResult :: String -> String -> String -> String -> String -> SMTResult -> String showSMTResult unsatMsg unkMsg satMsg satMsgModel satExtMsg result = case result of-  Unsatisfiable _               -> unsatMsg+  Unsatisfiable _ uc            -> unsatMsg ++ showUnsatCore uc   Satisfiable _ (SMTModel _ []) -> satMsg   Satisfiable _ m               -> satMsgModel ++ showModel cfg m   SatExtField _ (SMTModel b _)  -> satExtMsg   ++ showModelDictionary cfg b@@ -432,6 +432,8 @@   ProofError  _ []              -> "*** An error occurred. No additional information available. Try running in verbose mode"   ProofError  _ ls              -> "*** An error occurred.\n" ++ intercalate "\n" (map ("***  " ++) ls)  where cfg = resultConfig result+       showUnsatCore Nothing   = ""+       showUnsatCore (Just xs) = ". Unsat core:\n" ++ intercalate "\n" ["    " ++ x | x <- xs]  -- | 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
Data/SBV/SMT/SMTLib2.hs view
@@ -35,8 +35,10 @@   where hasInteger     = KUnbounded `Set.member` kindInfo         hasReal        = KReal      `Set.member` kindInfo         hasFloat       = KFloat     `Set.member` kindInfo+        hasString      = KString    `Set.member` kindInfo+        hasChar        = KChar      `Set.member` kindInfo         hasDouble      = KDouble    `Set.member` kindInfo-        hasBVs         = not $ null [() | KBounded{} <- Set.toList kindInfo]+        hasBVs         = hasChar || not (null [() | KBounded{} <- Set.toList kindInfo])   -- Remember, characters map to Word8         usorts         = [(s, dt) | KUserSort s dt <- Set.toList kindInfo]         hasNonBVArrays = (not . null) [() | (_, (_, (k1, k2), _)) <- arrs, not (isBounded k1 && isBounded k2)]         rm             = roundingMode cfg@@ -58,6 +60,11 @@             -- Otherwise, we try to determine the most suitable logic.            -- NB. This isn't really fool proof!++           -- we never set QF_S (ALL seems to work better in all cases)+           | hasString+           = ["(set-logic ALL)"]+            | hasDouble || hasFloat            = if hasInteger || not (null foralls)              then ["(set-logic ALL)"]@@ -361,6 +368,8 @@ smtType KReal           = "Real" smtType KFloat          = "(_ FloatingPoint  8 24)" smtType KDouble         = "(_ FloatingPoint 11 53)"+smtType KString         = "String"+smtType KChar           = "(_ BitVec 8)" smtType (KUserSort s _) = s  cvtType :: SBVType -> String@@ -398,6 +407,8 @@         doubleOp = any isDouble  arguments         floatOp  = any isFloat   arguments         boolOp   = all isBoolean arguments+        charOp   = all isChar    arguments+        stringOp = all isString  arguments          bad | intOp = error $ "SBV.SMTLib2: Unsupported operation on unbounded integers: " ++ show expr             | True  = error $ "SBV.SMTLib2: Unsupported operation on real values: " ++ show expr@@ -470,6 +481,14 @@           = let idx v = "(" ++ s ++ "_constrIndex " ++ v ++ ")" in "(" ++ o ++ " " ++ idx a ++ " " ++ idx b ++ ")"         unintComp o sbvs = error $ "SBV.SMT.SMTLib2.sh.unintComp: Unexpected arguments: "   ++ show (o, sbvs) +        -- NB. String comparisons are currently not supported by Z3; but will be with the new logic.+        stringCmp swap o [a, b]+          | KString <- kindOf (head arguments)+          = let [a1, a2] | swap = [b, a]+                         | True = [a, b]+            in "(" ++ o ++ " " ++ a1 ++ " " ++ a2 ++ ")"+        stringCmp _ o sbvs = error $ "SBV.SMT.SMTLib2.sh.stringCmp: Unexpected arguments: " ++ show (o, sbvs)+         lift1  o _ [x]    = "(" ++ o ++ " " ++ x ++ ")"         lift1  o _ sbvs   = error $ "SBV.SMT.SMTLib2.sh.lift1: Unexpected arguments: "   ++ show (o, sbvs) @@ -485,6 +504,8 @@                               KReal         -> error "SBV.SMT.SMTLib2.cvtExp: unexpected real valued index"                               KFloat        -> error "SBV.SMT.SMTLib2.cvtExp: unexpected float valued index"                               KDouble       -> error "SBV.SMT.SMTLib2.cvtExp: unexpected double valued index"+                              KChar         -> error "SBV.SMT.SMTLib2.cvtExp: unexpected char valued index"+                              KString       -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"                               KUserSort s _ -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected uninterpreted valued index: " ++ s                 lkUp = "(" ++ getTable tableMap t ++ " " ++ ssw i ++ ")"                 cond@@ -497,6 +518,8 @@                                 KReal         -> ("<", "<=")                                 KFloat        -> ("fp.lt", "fp.leq")                                 KDouble       -> ("fp.lt", "fp.geq")+                                KChar         -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"+                                KString       -> error "SBV.SMT.SMTLib2.cvtExp: unexpected string valued index"                                 KUserSort s _ -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected uninterpreted valued index: " ++ s                 mkCnst = cvtCW rm . mkConstCW (kindOf i)                 le0  = "(" ++ less ++ " " ++ ssw i ++ " " ++ mkCnst 0 ++ ")"@@ -551,6 +574,10 @@           | True       = reducePB pb args'           where args' = map ssw args +        -- Note the unfortunate reversal in StrInRe..+        sh (SBVApp (StrOp (StrInRe r)) args) = "(str.in.re " ++ unwords (map ssw args) ++ " " ++ show r ++ ")"+        sh (SBVApp (StrOp op)          args) = "(" ++ show op ++ " " ++ unwords (map ssw args) ++ ")"+         sh inp@(SBVApp op args)           | intOp, Just f <- lookup op smtOpIntTable           = f True (map ssw args)@@ -562,6 +589,10 @@           = f (any hasSign args) (map ssw args)           | floatOp || doubleOp, Just f <- lookup op smtOpFloatDoubleTable           = f (any hasSign args) (map ssw args)+          | charOp, Just f <- lookup op smtCharTable+          = f False (map ssw args)+          | stringOp, Just f <- lookup op smtStringTable+          = f (map ssw args)           | Just f <- lookup op uninterpretedTable           = f (map ssw args)           | True@@ -613,7 +644,7 @@                                     , (LessEq,        lift2Cmp  "<=" "fp.leq")                                     , (GreaterEq,     lift2Cmp  ">=" "fp.geq")                                     ]-                -- equality and comparisons are the only thing that works on uninterpreted sorts+                -- equality and comparisons are the only thing that works on uninterpreted sorts and pretty much everything else                 uninterpretedTable = [ (Equal,       lift2S "="        "="        True)                                      , (NotEqual,    liftNS "distinct" "distinct" True)                                      , (LessThan,    unintComp "<")@@ -621,6 +652,24 @@                                      , (LessEq,      unintComp "<=")                                      , (GreaterEq,   unintComp ">=")                                      ]+                -- For chars, the underlying type is currently SWord8, so we go with the regular bit-vector operations+                -- TODO: This will change when we move to unicode!+                smtCharTable = [ (Equal,         eqBV)+                               , (NotEqual,      neqBV)+                               , (LessThan,      lift2S  "bvult" (error "smtChar.<: did-not expect signed char here!"))+                               , (GreaterThan,   lift2S  "bvugt" (error "smtChar.>: did-not expect signed char here!"))+                               , (LessEq,        lift2S  "bvule" (error "smtChar.<=: did-not expect signed char here!"))+                               , (GreaterEq,     lift2S  "bvuge" (error "smtChar.>=: did-not expect signed char here!"))+                               ]+                -- For strings, equality and comparisons are the only operators+                -- TODO: The string comparison operators will most likely change with the new theory!+                smtStringTable = [ (Equal,       lift2S "="        "="        True)+                                 , (NotEqual,    liftNS "distinct" "distinct" True)+                                 , (LessThan,    stringCmp False "str.<")+                                 , (GreaterThan, stringCmp True  "str.<")+                                 , (LessEq,      stringCmp False "str.<=")+                                 , (GreaterEq,   stringCmp True  "str.<=")+                                 ]  ----------------------------------------------------------------------------------------------- -- Casts supported by SMTLib. (From: <http://smtlib.cs.uiowa.edu/theories-FloatingPoint.shtml>)@@ -640,7 +689,7 @@ --   ((_ fp.to_ubv m) RoundingMode (_ FloatingPoint eb sb) (_ BitVec m)) -- --   ; to signed machine integer, represented as a 2's complement bit vector---   ((_ fp.to_sbv m) RoundingMode (_ FloatingPoint eb sb) (_ BitVec m)) +--   ((_ fp.to_sbv m) RoundingMode (_ FloatingPoint eb sb) (_ BitVec m)) -- --   ; to real --   (fp.to_real (_ FloatingPoint eb sb) Real)
Data/SBV/SMT/Utils.hs view
@@ -117,11 +117,10 @@        grab _ []     = ([], [])        grab i (l:ls) = let (a, b) = grab (i+parenDiff l) ls in (l:a, b) -       skipString ('\\':'"':cs) = skipString cs-       skipString ('"':'"':cs)  = skipString cs-       skipString ('"':cs)      = cs-       skipString (_:cs)        = skipString cs-       skipString []            = []             -- Oh dear, line finished, but the string didn't. We're in trouble. Ignore!+       skipString ('"':'"':cs)   = skipString cs+       skipString ('"':cs)       = cs+       skipString (_:cs)         = skipString cs+       skipString []             = []             -- Oh dear, line finished, but the string didn't. We're in trouble. Ignore!         skipBar ('|':cs) = cs        skipBar (_:cs)   = skipBar cs
+ Data/SBV/String.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.SBV.String+-- Copyright   :  (c) Joel Burget, Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- A collection of string/character utilities, useful when working+-- with symbolic strings. To the extent possible, the functions+-- in this module follow those of "Data.List" so importing qualified+-- is the recommended workflow. Also, it is recommended you use the+-- @OverloadedStrings@ extension to allow literal strings to be+-- used as symbolic-strings.+-----------------------------------------------------------------------------++module Data.SBV.String (+        -- * Length, emptiness+          length, null+        -- * Deconstructing/Reconstructing+        , head, tail, charToStr, strToStrAt, strToCharAt, (.!!), implode, concat, (.++)+        -- * Containment+        , isInfixOf, isSuffixOf, isPrefixOf+        -- * Substrings+        , take, drop, subStr, replace, indexOf, offsetIndexOf+        -- * Conversion to\/from naturals+        , strToNat, natToStr+        ) where++import Prelude hiding (head, tail, length, take, drop, concat, null)+import qualified Prelude as P++import Data.SBV.Core.Data+import Data.SBV.Core.Model++import qualified Data.Char as C+import Data.List (genericLength, genericIndex, genericDrop, genericTake)+import qualified Data.List as L (tails, isSuffixOf, isPrefixOf, isInfixOf)++-- For doctest use only+--+-- $setup+-- >>> import Data.SBV.Provers.Prover (prove, sat)+-- >>> import Data.SBV.Utils.Boolean  ((==>), (&&&), bnot, (<=>))+-- >>> :set -XOverloadedStrings++-- | Length of a string.+--+-- >>> sat $ \s -> length s .== 2+-- Satisfiable. Model:+--   s0 = "\NUL\NUL" :: String+-- >>> sat $ \s -> length s .< 0+-- Unsatisfiable+-- >>> prove $ \s1 s2 -> length s1 + length s2 .== length (s1 .++ s2)+-- Q.E.D.+length :: SString -> SInteger+length = lift1 StrLen (Just (fromIntegral . P.length))++-- | @`null` s@ is True iff the string is empty+--+-- >>> prove $ \s -> null s <=> length s .== 0+-- Q.E.D.+-- >>> prove $ \s -> null s <=> s .== ""+-- Q.E.D.+null :: SString -> SBool+null s+  | Just cs <- unliteral s+  = literal (P.null cs)+  | True+  = s .== literal ""++-- | @`head`@ returns the head of a string. Unspecified if the string is empty.+--+-- >>> prove $ \c -> head (charToStr c) .== c+-- Q.E.D.+head :: SString -> SChar+head = (`strToCharAt` 0)++-- | @`tail`@ returns the tail of a string. Unspecified if the string is empty.+--+-- >>> prove $ \h s -> tail (charToStr h .++ s) .== s+-- Q.E.D.+-- >>> prove $ \s -> length s .> 0 ==> length (tail s) .== length s - 1+-- Q.E.D.+-- >>> prove $ \s -> bnot (null s) ==> charToStr (head s) .++ tail s .== s+-- Q.E.D.+tail :: SString -> SString+tail s+ | Just (_:cs) <- unliteral s+ = literal cs+ | True+ = subStr s 1 (length s - 1)++-- | @`charToStr` c@ is the string of length 1 that contains the only character+-- whose value is the 8-bit value @c@.+--+-- >>> prove $ \c -> c .== literal 'A' ==> charToStr c .== "A"+-- Q.E.D.+-- >>> prove $ \c -> length (charToStr c) .== 1+-- Q.E.D.+charToStr :: SChar -> SString+charToStr = lift1 StrUnit (Just wrap)+  where wrap c = [c]++-- | @`strToStrAt` s offset@. Substring of length 1 at @offset@ in @s@. Unspecified if+-- index is out of bounds.+--+-- >>> prove $ \s1 s2 -> strToStrAt (s1 .++ s2) (length s1) .== strToStrAt s2 0+-- Q.E.D.+-- >>> sat $ \s -> length s .>= 2 &&& strToStrAt s 0 ./= strToStrAt s (length s - 1)+-- Satisfiable. Model:+--   s0 = "\NUL\NUL " :: String+strToStrAt :: SString -> SInteger -> SString+strToStrAt s offset = subStr s offset 1++-- | @`strToCharAt` s i@ is the 8-bit value stored at location @i@. Unspecified if+-- index is out of bounds.+--+-- >>> prove $ \i -> i .>= 0 &&& i .<= 4 ==> "AAAAA" `strToCharAt` i .== literal 'A'+-- Q.E.D.+-- >>> prove $ \s i c -> s `strToCharAt` i .== c ==> indexOf s (charToStr c) .<= i+-- Q.E.D.+strToCharAt :: SString -> SInteger -> SChar+strToCharAt s i+  | Just cs <- unliteral s, Just ci <- unliteral i, ci >= 0, ci < genericLength cs, let c = C.ord (cs `genericIndex` ci)+  = literal (C.chr c)+  | True+  = SBV (SVal w8 (Right (cache (y (s `strToStrAt` i)))))+  where w8      = KBounded False 8+        -- This is trickier than it needs to be, but necessary since there's+        -- no SMTLib function to extract the character from a string. Instead,+        -- we form a singleton string, and assert that it is equivalent to+        -- the extracted value. See <http://github.com/Z3Prover/z3/issues/1302>+        y si st = do c <- internalVariable st w8+                     cs <- newExpr st KString (SBVApp (StrOp StrUnit) [c])+                     let csSBV = SBV (SVal KString (Right (cache (\_ -> return cs))))+                     internalConstraint st Nothing $ unSBV $ csSBV .== si+                     return c++-- | Short cut for 'strToCharAt'+(.!!) :: SString -> SInteger -> SChar+(.!!) = strToCharAt++-- | @`implode` cs@ is the string of length @|cs|@ containing precisely those+-- characters. Note that there is no corresponding function @explode@, since+-- we wouldn't know the length of a symbolic string.+--+-- >>> prove $ \c1 c2 c3 -> length (implode [c1, c2, c3]) .== 3+-- Q.E.D.+-- >>> prove $ \c1 c2 c3 -> map (strToCharAt (implode [c1, c2, c3])) (map literal [0 .. 2]) .== [c1, c2, c3]+-- Q.E.D.+implode :: [SChar] -> SString+implode = foldr ((.++) . charToStr) ""++-- | Concatenate two strings. See also `.++`.+concat :: SString -> SString -> SString+concat x y | isConcretelyEmpty x = y+           | isConcretelyEmpty y = x+           | True                = lift2 StrConcat (Just (++)) x y++-- | Short cut for `concat`.+--+-- >>> sat $ \x y z -> length x .== 5 &&& length y .== 1 &&& x .++ y .++ z .== "Hello world!"+-- Satisfiable. Model:+--   s0 =  "Hello" :: String+--   s1 =      " " :: String+--   s2 = "world!" :: String+infixr 5 .+++(.++) :: SString -> SString -> SString+(.++) = concat++-- | @`isInfixOf` sub s@. Does @s@ contain the substring @sub@?+--+-- >>> prove $ \s1 s2 s3 -> s2 `isInfixOf` (s1 .++ s2 .++ s3)+-- Q.E.D.+-- >>> prove $ \s1 s2 -> s1 `isInfixOf` s2 &&& s2 `isInfixOf` s1 <=> s1 .== s2+-- Q.E.D.+isInfixOf :: SString -> SString -> SBool+sub `isInfixOf` s+  | isConcretelyEmpty sub+  = literal True+  | True+  = lift2 StrContains (Just (flip L.isInfixOf)) s sub -- NB. flip, since `StrContains` takes args in rev order!++-- | @`isPrefixOf` pre s@. Is @pre@ a prefix of @s@?+--+-- >>> prove $ \s1 s2 -> s1 `isPrefixOf` (s1 .++ s2)+-- Q.E.D.+-- >>> prove $ \s1 s2 -> s1 `isPrefixOf` s2 ==> subStr s2 0 (length s1) .== s1+-- Q.E.D.+isPrefixOf :: SString -> SString -> SBool+pre `isPrefixOf` s+  | isConcretelyEmpty pre+  = literal True+  | True+  = lift2 StrPrefixOf (Just L.isPrefixOf) pre s++-- | @`isSuffixOf` suf s@. Is @suf@ a suffix of @s@?+--+-- >>> prove $ \s1 s2 -> s2 `isSuffixOf` (s1 .++ s2)+-- Q.E.D.+-- >>> prove $ \s1 s2 -> s1 `isSuffixOf` s2 ==> subStr s2 (length s2 - length s1) (length s1) .== s1+-- Q.E.D.+isSuffixOf :: SString -> SString -> SBool+suf `isSuffixOf` s+  | isConcretelyEmpty suf+  = literal True+  | True+  = lift2 StrSuffixOf (Just L.isSuffixOf) suf s++-- | @`take` len s@. Corresponds to Haskell's `take` on symbolic-strings.+--+-- >>> prove $ \s i -> i .>= 0 ==> length (take i s) .<= i+-- Q.E.D.+take :: SInteger -> SString -> SString+take i s = ite (i .<= 0)        (literal "")+         $ ite (i .>= length s) s+         $ subStr s 0 i++-- | @`drop` len s@. Corresponds to Haskell's `drop` on symbolic-strings.+--+-- >>> prove $ \s i -> length (drop i s) .<= length s+-- Q.E.D.+-- >>> prove $ \s i -> take i s .++ drop i s .== s+-- Q.E.D.+drop :: SInteger -> SString -> SString+drop i s = ite (i .>= ls) (literal "")+         $ ite (i .<= 0)  s+         $ subStr s i (ls - i)+  where ls = length s++-- | @`subStr` s offset len@ is the substring of @s@ at offset `offset` with length `len`.+-- This function is under-specified when the offset is outside the range of positions in @s@ or @len@+-- is negative or @offset+len@ exceeds the length of @s@. For a friendlier version of this function+-- that acts like Haskell's `take`\/`drop`, see `strTake`\/`strDrop`.+--+-- >>> prove $ \s i -> i .>= 0 &&& i .< length s ==> subStr s 0 i .++ subStr s i (length s - i) .== s+-- Q.E.D.+-- >>> sat  $ \i j -> subStr "hello" i j .== "ell"+-- Satisfiable. Model:+--   s0 = 1 :: Integer+--   s1 = 3 :: Integer+-- >>> sat  $ \i j -> subStr "hell" i j .== "no"+-- Unsatisfiable+subStr :: SString -> SInteger -> SInteger -> SString+subStr s offset len+  | Just c <- unliteral s                    -- a constant string+  , Just o <- unliteral offset               -- a constant offset+  , Just l <- unliteral len                  -- a constant length+  , let lc = genericLength c                 -- length of the string+  , let valid x = x >= 0 && x <= lc          -- predicate that checks valid point+  , valid o                                  -- offset is valid+  , l >= 0                                   -- length is not-negative+  , valid $ o + l                            -- we don't overrun+  = literal $ genericTake l $ genericDrop o c+  | True                                     -- either symbolic, or something is out-of-bounds+  = lift3 StrSubstr Nothing s offset len++-- | @`replace` s src dst@. Replace the first occurrence of @src@ by @dst@ in @s@+--+-- >>> prove $ \s -> replace "hello" s "world" .== "world" ==> s .== "hello"+-- Q.E.D.+-- >>> prove $ \s1 s2 s3 -> length s2 .> length s1 ==> replace s1 s2 s3 .== s1+-- Q.E.D.+replace :: SString -> SString -> SString -> SString+replace s src dst+  | Just b <- unliteral src, P.null b   -- If src is null, simply prepend+  = dst .++ s+  | Just a <- unliteral s+  , Just b <- unliteral src+  , Just c <- unliteral dst+  = literal $ walk a b c+  | True+  = lift3 StrReplace Nothing s src dst+  where walk haystack needle newNeedle = go haystack   -- note that needle is guaranteed non-empty here.+           where go []       = []+                 go i@(c:cs)+                  | needle `L.isPrefixOf` i = newNeedle ++ genericDrop (genericLength needle :: Integer) i+                  | True                    = c : go cs++-- | @`indexOf` s sub@. Retrieves first position of @sub@ in @s@, @-1@ if there are no occurrences.+-- Equivalent to @`offsetIndexOf` s sub 0@.+--+-- >>> prove $ \s i -> i .> 0 &&& i .< length s ==> indexOf s (subStr s i 1) .<= i+-- Q.E.D.+-- >>> prove $ \s i -> i .> 0 &&& i .< length s ==> indexOf s (subStr s i 1) .== i+-- Falsifiable. Counter-example:+--   s0 = "\NUL\NUL\NUL" :: String+--   s1 =              2 :: Integer+-- >>> prove $ \s1 s2 -> length s2 .> length s1 ==> indexOf s1 s2 .== -1+-- Q.E.D.+indexOf :: SString -> SString -> SInteger+indexOf s sub = offsetIndexOf s sub 0++-- | @`offsetIndexOf` s sub offset@. Retrieves first position of @sub@ at or+-- after @offset@ in @s@, @-1@ if there are no occurrences.+--+-- >>> prove $ \s sub -> offsetIndexOf s sub 0 .== indexOf s sub+-- Q.E.D.+-- >>> prove $ \s sub i -> i .>= length s &&& length sub .> 0 ==> offsetIndexOf s sub i .== -1+-- Q.E.D.+-- >>> prove $ \s sub i -> i .> length s ==> offsetIndexOf s sub i .== -1+-- Q.E.D.+offsetIndexOf :: SString -> SString -> SInteger -> SInteger+offsetIndexOf s sub offset+  | Just c <- unliteral s               -- a constant string+  , Just n <- unliteral sub             -- a constant search pattern+  , Just o <- unliteral offset          -- at a constant offset+  , o >= 0, o <= genericLength c        -- offset is good+  = case [i | (i, t) <- zip [o ..] (L.tails (genericDrop o c)), n `L.isPrefixOf` t] of+      (i:_) -> literal i+      _     -> -1+  | True+  = lift3 StrIndexOf Nothing s sub offset++-- | @`strToNat` s@. Retrieve integer encoded by string @s@ (ground rewriting only).+-- Note that by definition this function only works when 's' only contains digits,+-- that is, if it encodes a natural number. Otherwise, it returns '-1'.+-- See <http://cvc4.cs.stanford.edu/wiki/Strings> for details.+--+-- >>> prove $ \s -> let n = strToNat s in n .>= 0 &&& n .< 10 ==> length s .== 1+-- Q.E.D.+strToNat :: SString -> SInteger+strToNat s+ | Just a <- unliteral s+ = if all C.isDigit a && not (P.null a)+   then literal (read a)+   else -1+ | True+ = lift1 StrStrToNat Nothing s++-- | @`natToStr` i@. Retrieve string encoded by integer @i@ (ground rewriting only).+-- Again, only naturals are supported, any input that is not a natural number+-- produces empty string, even though we take an integer as an argument.+-- See <http://cvc4.cs.stanford.edu/wiki/Strings> for details.+--+-- >>> prove $ \i -> length (natToStr i) .== 3 ==> i .<= 999+-- Q.E.D.+natToStr :: SInteger -> SString+natToStr i+ | Just v <- unliteral i+ = literal $ if v >= 0 then show v else ""+ | True+ = lift1 StrNatToStr Nothing i++-- | Lift a unary operator over strings.+lift1 :: forall a b. (SymWord a, SymWord b) => StrOp -> Maybe (a -> b) -> SBV a -> SBV b+lift1 w mbOp a+  | Just cv <- concEval1 mbOp a+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where k = kindOf (undefined :: b)+        r st = do swa <- sbvToSW st a+                  newExpr st k (SBVApp (StrOp w) [swa])++-- | Lift a binary operator over strings.+lift2 :: forall a b c. (SymWord a, SymWord b, SymWord c) => StrOp -> Maybe (a -> b -> c) -> SBV a -> SBV b -> SBV c+lift2 w mbOp a b+  | Just cv <- concEval2 mbOp a b+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where k = kindOf (undefined :: c)+        r st = do swa <- sbvToSW st a+                  swb <- sbvToSW st b+                  newExpr st k (SBVApp (StrOp w) [swa, swb])++-- | Lift a ternary operator over strings.+lift3 :: forall a b c d. (SymWord a, SymWord b, SymWord c, SymWord d) => StrOp -> Maybe (a -> b -> c -> d) -> SBV a -> SBV b -> SBV c -> SBV d+lift3 w mbOp a b c+  | Just cv <- concEval3 mbOp a b c+  = cv+  | True+  = SBV $ SVal k $ Right $ cache r+  where k = kindOf (undefined :: d)+        r st = do swa <- sbvToSW st a+                  swb <- sbvToSW st b+                  swc <- sbvToSW st c+                  newExpr st k (SBVApp (StrOp w) [swa, swb, swc])++-- | Concrete evaluation for unary ops+concEval1 :: (SymWord a, SymWord b) => Maybe (a -> b) -> SBV a -> Maybe (SBV b)+concEval1 mbOp a = literal <$> (mbOp <*> unliteral a)++-- | Concrete evaluation for binary ops+concEval2 :: (SymWord a, SymWord b, SymWord c) => Maybe (a -> b -> c) -> SBV a -> SBV b -> Maybe (SBV c)+concEval2 mbOp a b = literal <$> (mbOp <*> unliteral a <*> unliteral b)++-- | Concrete evaluation for ternary ops+concEval3 :: (SymWord a, SymWord b, SymWord c, SymWord d) => Maybe (a -> b -> c -> d) -> SBV a -> SBV b -> SBV c -> Maybe (SBV d)+concEval3 mbOp a b c = literal <$> (mbOp <*> unliteral a <*> unliteral b <*> unliteral c)++-- | Is the string concretely known empty?+isConcretelyEmpty :: SString -> Bool+isConcretelyEmpty ss | Just s <- unliteral ss = P.null s+                     | True                   = False
Data/SBV/Tools/GenTest.hs view
@@ -125,6 +125,8 @@                  KUnbounded        -> "Integer"                  KFloat            -> "Float"                  KDouble           -> "Double"+                 KChar             -> error "SBV.renderTest: Unsupported char"+                 KString           -> error "SBV.renderTest: Unsupported string"                  KReal             -> error $ "SBV.renderTest: Unsupported real valued test value: " ++ show cw                  KUserSort us _    -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us                  _                 -> error $ "SBV.renderTest: Unexpected CW: " ++ show cw@@ -134,6 +136,8 @@                   KUnbounded        -> let CWInteger w = cwVal cw in shexI False True           w                   KFloat            -> let CWFloat w   = cwVal cw in showHFloat w                   KDouble           -> let CWDouble w  = cwVal cw in showHDouble w+                  KChar             -> error "SBV.renderTest: Unsupported char"+                  KString           -> error "SBV.renderTest: Unsupported string"                   KReal             -> let CWAlgReal w = cwVal cw in algRealToHaskell w                   KUserSort us _    -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us @@ -158,13 +162,13 @@               , "typedef double SDouble;"               , ""               , "/* Unsigned bit-vectors */"-              , "typedef uint8_t  SWord8 ;"+              , "typedef uint8_t  SWord8;"               , "typedef uint16_t SWord16;"               , "typedef uint32_t SWord32;"               , "typedef uint64_t SWord64;"               , ""               , "/* Signed bit-vectors */"-              , "typedef int8_t  SInt8 ;"+              , "typedef int8_t  SInt8;"               , "typedef int16_t SInt16;"               , "typedef int32_t SInt32;"               , "typedef int64_t SInt64;"@@ -212,6 +216,8 @@                         KBounded True  64 -> "SInt64"                         KFloat            -> "SFloat"                         KDouble           -> "SDouble"+                        KChar             -> error "SBV.renderTest: Unsupported char"+                        KString           -> error "SBV.renderTest: Unsupported string"                         KUnbounded        -> error "SBV.renderTest: Unbounded integers are not supported when generating C test-cases."                         KReal             -> error "SBV.renderTest: Real values are not supported when generating C test-cases."                         KUserSort us _    -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us@@ -223,6 +229,8 @@                   KUnbounded      -> let CWInteger w = cwVal cw in shexI False True           w                   KFloat          -> let CWFloat w   = cwVal cw in showCFloat w                   KDouble         -> let CWDouble w  = cwVal cw in showCDouble w+                  KChar           -> error "SBV.renderTest: Unsupported char"+                  KString         -> error "SBV.renderTest: Unsupported string"                   KUserSort us _  -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us                   KReal           -> error "SBV.renderTest: Real values are not supported when generating C test-cases."         outLine@@ -249,6 +257,8 @@                     KBounded True  64 -> "%\"PRId64\"LL"                     KFloat            -> "%f"                     KDouble           -> "%f"+                    KChar             -> error "SBV.renderTest: Unsupported char"+                    KString           -> error "SBV.renderTest: Unsupported string"                     KUnbounded        -> error "SBV.renderTest: Unsupported unbounded integers for C generation."                     KReal             -> error "SBV.renderTest: Unsupported real valued values for C generation."                     _                 -> error $ "SBV.renderTest: Unexpected CW: " ++ show cw@@ -281,13 +291,17 @@                      KBounded True 64  -> xlt 64 (cwVal cw)                      KFloat            -> error "SBV.renderTest: Float values are not supported when generating Forte test-cases."                      KDouble           -> error "SBV.renderTest: Double values are not supported when generating Forte test-cases."+                     KChar             -> error "SBV.renderTest: Char values are not supported when generating Forte test-cases."+                     KString           -> error "SBV.renderTest: String values are not supported when generating Forte test-cases."                      KReal             -> error "SBV.renderTest: Real values are not supported when generating Forte test-cases."                      KUnbounded        -> error "SBV.renderTest: Unbounded integers are not supported when generating Forte test-cases."                      _                 -> error $ "SBV.renderTest: Unexpected CW: " ++ show cw-        xlt s (CWInteger v)   = [toF (testBit v i) | i <- [s-1, s-2 .. 0]]-        xlt _ (CWFloat r)     = error $ "SBV.renderTest.Forte: Unexpected float value: " ++ show r-        xlt _ (CWDouble r)    = error $ "SBV.renderTest.Forte: Unexpected double value: " ++ show r-        xlt _ (CWAlgReal r)   = error $ "SBV.renderTest.Forte: Unexpected real value: " ++ show r+        xlt s (CWInteger  v)  = [toF (testBit v i) | i <- [s-1, s-2 .. 0]]+        xlt _ (CWFloat    r)  = error $ "SBV.renderTest.Forte: Unexpected float value: "         ++ show r+        xlt _ (CWDouble   r)  = error $ "SBV.renderTest.Forte: Unexpected double value: "        ++ show r+        xlt _ (CWChar     r)  = error $ "SBV.renderTest.Forte: Unexpected char value: "          ++ show r+        xlt _ (CWString   r)  = error $ "SBV.renderTest.Forte: Unexpected string value: "        ++ show r+        xlt _ (CWAlgReal  r)  = error $ "SBV.renderTest.Forte: Unexpected real value: "          ++ show r         xlt _ (CWUserSort r)  = error $ "SBV.renderTest.Forte: Unexpected uninterpreted value: " ++ show r         mkLine  (i, o) = "("  ++ mkTuple (form (fst ss) (concatMap blast i)) ++ ", " ++ mkTuple (form (snd ss) (concatMap blast o)) ++ ")"         mkTuple []  = "()"
Data/SBV/Tools/Polynomial.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Module      :  Data.SBV.Core.Polynomials+-- Module      :  Data.SBV.Tools.Polynomials -- Copyright   :  (c) Levent Erkok -- License     :  BSD3 -- Maintainer  :  erkokl@gmail.com
Data/SBV/Utils/Lib.hs view
@@ -9,11 +9,17 @@ -- Misc helpers ----------------------------------------------------------------------------- -module Data.SBV.Utils.Lib (mlift2, mlift3, mlift4, mlift5, mlift6, mlift7, mlift8, joinArgs, splitArgs) where+module Data.SBV.Utils.Lib ( mlift2, mlift3, mlift4, mlift5, mlift6, mlift7, mlift8+                          , joinArgs, splitArgs+                          , stringToQFS, qfsToString)+                          where -import Data.Char (isSpace)+import Data.Char (isSpace, chr, ord) import Data.Maybe (fromJust, isNothing) +import Numeric (readHex, readOct, showHex)++ -- | Monadic lift over 2-tuples mlift2 :: Monad m => (a' -> b' -> r) -> (a -> m a') -> (b -> m b') -> (a, b) -> m r mlift2 k f g (a, b) = f a >>= \a' -> g b >>= \b' -> return $ k a' b'@@ -88,3 +94,43 @@           f Norm (x:xs) | isSpace x = Nothing : f Init xs           f m (x:xs)                = Just x : f m xs           f _ []                    = []++-- | Given a QF_S string (i.e., one that works in the string theory), convert it to a Haskell equivalent+qfsToString :: String -> String+qfsToString = go+  where go ""                                                          = ""+        go ('\\':'n'       : rest)                                     = chr 10 : go rest+        go ('\\':'\\'       : rest)                                    = '\\'   : go rest+        go ('\\':'v'       : rest)                                     = chr 11 : go rest+        go ('\\':'f'       : rest)                                     = chr 12 : go rest+        go ('\\':'r'       : rest)                                     = chr 13 : go rest+        go ('\\':'x':c1:c2 : rest) | [(v, "")] <- readHex [c1, c2]     = chr  v : go rest+        go ('\\':c1:c2:c3  : rest) | [(v, "")] <- readOct [c1, c2, c3] = chr  v : go rest+        go (c              : rest)                                     = c      : go rest++-- | Given a Haskell, convert it to one that's understood by the QF_S logic+-- TODO: This function will require mods with the new String logic; as escapes+-- will completely be different!+stringToQFS :: String -> String+stringToQFS = concatMap cvt+  where -- strings are almost just show, but escapes are different. Sigh+        cvt c+         | 0 <= o && o < 32+         = escapeTable !! o+         | c == '\\'+         = "\\\\"+         | c == '"'+         = "\"\""+         | o >= 128 && o < 256+         = "\\x" ++ showHex (ord c) ""+         | o > 256+         = error $ "Data.SBV: stringToQFS: Haskell character: " ++ show c ++ " is not representable in QF_S"+         | True+         = [c]+         where o = ord c++        -- | First 32 values are coded in a custom way by Z3:+        escapeTable :: [String]+        escapeTable = [ "\\x00", "\\x01", "\\x02", "\\x03", "\\x04", "\\x05", "\\x06", "\\x07", "\\x08", "\\x09", "\\n",   "\\v",   "\\f",   "\\r",   "\\x0E", "\\x0F"+                      , "\\x10", "\\x11", "\\x12", "\\x13", "\\x14", "\\x15", "\\x16", "\\x17", "\\x18", "\\x19", "\\x1A", "\\x1B", "\\x1C", "\\x1D", "\\x1E", "\\x1F"+                      ]
Data/SBV/Utils/PrettyNum.hs view
@@ -9,6 +9,7 @@ -- Number representations in hex/bin ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -18,7 +19,7 @@       , showSMTFloat, showSMTDouble, smtRoundingMode, cwToSMTLib, mkSkolemZero       ) where -import Data.Char  (ord, intToDigit)+import Data.Char  (intToDigit, ord) import Data.Int   (Int8, Int16, Int32, Int64) import Data.List  (isPrefixOf) import Data.Maybe (fromJust, fromMaybe, listToMaybe)@@ -31,6 +32,8 @@ import Data.SBV.Core.Data import Data.SBV.Core.AlgReals (algRealToSMTLib2) +import Data.SBV.Utils.Lib (stringToQFS)+ -- | PrettyNum class captures printing of numbers in hex and binary formats; also supporting negative numbers. -- -- Minimal complete definition: 'hexS' and 'binS'@@ -47,6 +50,8 @@ -- 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 String 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@@ -69,25 +74,28 @@ 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)+          | 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"+          | isString cw        = let CWString  s = cwVal cw in show s ++ " :: String"           | 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)+          | 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"+          | isString cw        = let CWString  s = cwVal cw in show s ++ " :: String"           | 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+         | 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+         | isString cw        = let CWString  s = cwVal cw in show s          | 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 @@ -96,6 +104,7 @@          | 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+         | isString cw        = let CWString  s = cwVal cw in show s          | 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 @@ -270,6 +279,8 @@   | 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)+  | isChar x         , CWChar c          <- cwVal x = smtLibHex 8 (fromIntegral (ord c))+  | isString x       , CWString s        <- cwVal x = '\"' : stringToQFS s ++ "\""   | 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@@ -284,6 +295,7 @@         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
Data/SBV/Utils/SExpr.hs view
@@ -53,14 +53,14 @@                             (pre, '|':rest) -> go rest (pre : sofar)                             (pre, rest)     -> go rest (pre : sofar) -       go ('"':r) sofar = go rest (show str : sofar)-           where grabString []            acc = (reverse acc, [])        -- Strictly speaking, this is the unterminated string case; but let's ignore-                 grabString ('\\':'"':cs) acc = grabString cs ('"':acc)  -- I don't think this is a valid escape actually, but it used to be. Be safe.-                 grabString ('"' :'"':cs) acc = grabString cs ('"':acc)  -- In SMTLib "" becomes ". Weird escape indeed.-                 grabString ('"':cs)      acc = (reverse acc, cs)-                 grabString (c:cs)        acc = grabString cs (c:acc)+       go ('"':r) sofar = go rest (finalStr : sofar)+           where grabString []             acc = (reverse acc, [])         -- Strictly speaking, this is the unterminated string case; but let's ignore+                 grabString ('"' :'"':cs)  acc = grabString cs ('"' :acc)+                 grabString ('"':cs)       acc = (reverse acc, cs)+                 grabString (c:cs)         acc = grabString cs (c:acc)                   (str, rest) = grabString r []+                 finalStr    = '"' : str ++ "\""         go cs sofar = case span (`notElem` stopper) cs of                        (pre, post) -> go post (pre : sofar)@@ -74,7 +74,7 @@ parenDeficit :: String -> Int parenDeficit = go 0 . tokenize   where go :: Int -> [String] -> Int-        go !balance []          = balance+        go !balance []           = balance         go !balance ("(" : rest) = go (balance+1) rest         go !balance (")" : rest) = go (balance-1) rest         go !balance (_   : rest) = go balance     rest@@ -116,6 +116,7 @@         pTok ('b':'v':r) | not (null r) && all isDigit r = mkNum Nothing               $ readDec (takeWhile (/= '[') r)         pTok ('#':'b':r)                                 = mkNum (Just (length r))     $ readInt 2 (`elem` "01") (\c -> ord c - ord '0') r         pTok ('#':'x':r)                                 = mkNum (Just (4 * length r)) $ readHex r+         pTok n           | not (null n) && isDigit (head n)           = if '.' `elem` n then getReal n
+ Documentation/SBV/Examples/BitPrecise/BitTricks.hs view
@@ -0,0 +1,59 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.BitPrecise.BitTricks+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Checks the correctness of a few tricks from the large collection found in:+--      <https://graphics.stanford.edu/~seander/bithacks.html>+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.BitPrecise.BitTricks where++import Data.SBV++-- | Formalizes <https://graphics.stanford.edu/~seander/bithacks.html#IntegerMinOrMax>+fastMinCorrect :: SInt32 -> SInt32 -> SBool+fastMinCorrect x y = m .== fm+  where m  = ite (x .< y) x y+        fm = y `xor` ((x `xor` y) .&. (-(oneIf (x .< y))));++-- | Formalizes <https://graphics.stanford.edu/~seander/bithacks.html#IntegerMinOrMax>+fastMaxCorrect :: SInt32 -> SInt32 -> SBool+fastMaxCorrect x y = m .== fm+  where m  = ite (x .< y) y x+        fm = x `xor` ((x `xor` y) .&. (-(oneIf (x .< y))));++-- | Formalizes <https://graphics.stanford.edu/~seander/bithacks.html#DetectOppositeSigns>+oppositeSignsCorrect :: SInt32 -> SInt32 -> SBool+oppositeSignsCorrect x y = r .== os+  where r  = (x .< 0 &&& y .>= 0) ||| (x .>= 0 &&& y .< 0)+        os = (x `xor` y) .< 0++-- | Formalizes <https://graphics.stanford.edu/~seander/bithacks.html#ConditionalSetOrClearBitsWithoutBranching>+conditionalSetClearCorrect :: SBool -> SWord32 -> SWord32 -> SBool+conditionalSetClearCorrect f m w = r .== r'+  where r  = ite f (w .|. m) (w .&. complement m)+        r' = w `xor` ((-(oneIf f) `xor` w) .&. m);++-- | Formalizes <https://graphics.stanford.edu/~seander/bithacks.html#DetermineIfPowerOf2>+powerOfTwoCorrect :: SWord32 -> SBool+powerOfTwoCorrect v = f .== s+  where f = (v ./= 0) &&& ((v .&. (v-1)) .== 0);+        powers :: [Word32]+        powers = map ((2::Word32)^) [(0::Word32) .. 31]+        s = bAny (v .==) $ map literal powers++-- | Collection of queries+queries :: IO ()+queries =+  let check :: Provable a => String -> a -> IO ()+      check w t = do putStr $ "Proving " ++ show w ++ ": "+                     print =<< prove t+  in do check "Fast min             " fastMinCorrect+        check "Fast max             " fastMaxCorrect+        check "Opposite signs       " oppositeSignsCorrect+        check "Conditional set/clear" conditionalSetClearCorrect+        check "PowerOfTwo           " powerOfTwoCorrect
+ Documentation/SBV/Examples/BitPrecise/Legato.hs view
@@ -0,0 +1,323 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.BitPrecise.Legato+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- An encoding and correctness proof of Legato's multiplier in Haskell. Bill Legato came+-- up with an interesting way to multiply two 8-bit numbers on Mostek, as described here:+--   <http://www.cs.utexas.edu/~moore/acl2/workshop-2004/contrib/legato/Weakest-Preconditions-Report.pdf>+--+-- Here's Legato's algorithm, as coded in Mostek assembly:+--+-- @+--    step1 :       LDX #8         ; load X immediate with the integer 8 +--    step2 :       LDA #0         ; load A immediate with the integer 0 +--    step3 : LOOP  ROR F1         ; rotate F1 right circular through C +--    step4 :       BCC ZCOEF      ; branch to ZCOEF if C = 0 +--    step5 :       CLC            ; set C to 0 +--    step6 :       ADC F2         ; set A to A+F2+C and C to the carry +--    step7 : ZCOEF ROR A          ; rotate A right circular through C +--    step8 :       ROR LOW        ; rotate LOW right circular through C +--    step9 :       DEX            ; set X to X-1 +--    step10:       BNE LOOP       ; branch to LOOP if Z = 0 +-- @+--+-- This program came to be known as the Legato's challenge in the community, where+-- the challenge was to prove that it indeed does perform multiplication. This file+-- formalizes the Mostek architecture in Haskell and proves that Legato's algorithm+-- is indeed correct.+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveGeneric  #-}+{-# LANGUAGE DeriveAnyClass #-}++module Documentation.SBV.Examples.BitPrecise.Legato where++import Data.Array (Array, Ix(..), (!), (//), array)++import Data.SBV+import Data.SBV.Tools.CodeGen+import Data.SBV.Internals (Timing(PrintTiming))++import GHC.Generics (Generic)++------------------------------------------------------------------+-- * Mostek architecture+------------------------------------------------------------------+-- | The memory is addressed by 32-bit words.+type Address  = SWord32++-- | We model only two registers of Mostek that is used in the above algorithm, can add more.+data Register = RegX  | RegA  deriving (Eq, Ord, Ix, Bounded, Enum)++-- | The carry flag ('FlagC') and the zero flag ('FlagZ')+data Flag = FlagC | FlagZ deriving (Eq, Ord, Ix, Bounded, Enum)++-- | Mostek was an 8-bit machine.+type Value = SWord8++-- | Convenient synonym for symbolic machine bits.+type Bit = SBool++-- | Register bank+type Registers = Array Register Value++-- | Flag bank+type Flags = Array Flag Bit++-- | The memory maps 32-bit words to 8-bit words. (The 'Model' data-type is+-- defined later, depending on the verification model used.)+type Memory = Model Word32 Word8        -- Model defined later++-- | Abstraction of the machine: The CPU consists of memory, registers, and flags.+-- Unlike traditional hardware, we assume the program is stored in some other memory area that+-- we need not model. (No self modifying programs!)+--+-- 'Mostek' is equipped with an automatically derived 'Mergeable' instance+-- because each field is 'Mergeable'.+data Mostek = Mostek { memory    :: Memory+                     , registers :: Registers+                     , flags     :: Flags+                     } deriving (Generic, Mergeable)++-- | Given a machine state, compute a value out of it+type Extract a = Mostek -> a++-- | Programs are essentially state transformers (on the machine state)+type Program = Mostek -> Mostek++------------------------------------------------------------------+-- * Low-level operations+------------------------------------------------------------------++-- | Get the value of a given register+getReg :: Register -> Extract Value+getReg r m = registers m ! r++-- | Set the value of a given register+setReg :: Register -> Value -> Program+setReg r v m = m {registers = registers m // [(r, v)]}++-- | Get the value of a flag+getFlag :: Flag -> Extract Bit+getFlag f m = flags m ! f++-- | Set the value of a flag+setFlag :: Flag -> Bit -> Program+setFlag f b m = m {flags = flags m // [(f, b)]}++-- | Read memory+peek :: Address -> Extract Value+peek a m = readArray (memory m) a++-- | Write to memory+poke :: Address -> Value -> Program+poke a v m = m {memory = writeArray (memory m) a v}++-- | Checking overflow. In Legato's multipler the @ADC@ instruction+-- needs to see if the expression x + y + c overflowed, as checked+-- by this function. Note that we verify the correctness of this check+-- separately below in `checkOverflowCorrect`.+checkOverflow :: SWord8 -> SWord8 -> SBool -> SBool+checkOverflow x y c = s .< x ||| s .< y ||| s' .< s+  where s  = x + y+        s' = s + ite c 1 0++-- | Correctness theorem for our `checkOverflow` implementation.+--+--   We have:+--+--   >>> checkOverflowCorrect+--   Q.E.D.+checkOverflowCorrect :: IO ThmResult+checkOverflowCorrect = checkOverflow === overflow+  where -- Reference spec for overflow. We do the addition+        -- using 16 bits and check that it's larger than 255+        overflow :: SWord8 -> SWord8 -> SBool -> SBool+        overflow x y c = (0 # x) + (0 # y) + ite c 1 0 .> 255+------------------------------------------------------------------+-- * Instruction set+------------------------------------------------------------------++-- | An instruction is modeled as a 'Program' transformer. We model+-- mostek programs in direct continuation passing style.+type Instruction = Program -> Program++-- | LDX: Set register @X@ to value @v@+ldx :: Value -> Instruction+ldx v k = k . setReg RegX v++-- | LDA: Set register @A@ to value @v@+lda :: Value -> Instruction+lda v k = k . setReg RegA v++-- | CLC: Clear the carry flag+clc :: Instruction+clc k = k . setFlag FlagC false++-- | ROR, memory version: Rotate the value at memory location @a@+-- to the right by 1 bit, using the carry flag as a transfer position.+-- That is, the final bit of the memory location becomes the new carry+-- and the carry moves over to the first bit. This very instruction+-- is one of the reasons why Legato's multiplier is quite hard to understand+-- and is typically presented as a verification challenge.+rorM :: Address -> Instruction+rorM a k m = k . setFlag FlagC c' . poke a v' $ m+  where v  = peek a m+        c  = getFlag FlagC m+        v' = setBitTo (v `rotateR` 1) 7 c+        c' = sTestBit v 0++-- | ROR, register version: Same as 'rorM', except through register @r@.+rorR :: Register -> Instruction+rorR r k m = k . setFlag FlagC c' . setReg r v' $ m+  where v  = getReg r m+        c  = getFlag FlagC m+        v' = setBitTo (v `rotateR` 1) 7 c+        c' = sTestBit v 0++-- | BCC: branch to label @l@ if the carry flag is false+bcc :: Program -> Instruction+bcc l k m = ite (c .== false) (l m) (k m)+  where c = getFlag FlagC m++-- | ADC: Increment the value of register @A@ by the value of memory contents+-- at address @a@, using the carry-bit as the carry-in for the addition.+adc :: Address -> Instruction+adc a k m = k . setFlag FlagZ (v' .== 0) . setFlag FlagC c' . setReg RegA v' $ m+  where v  = peek a m+        ra = getReg RegA m+        c  = getFlag FlagC m+        v' = v + ra + ite c 1 0+        c' = checkOverflow v ra c++-- | DEX: Decrement the value of register @X@+dex :: Instruction+dex k m = k . setFlag FlagZ (x .== 0) . setReg RegX x $ m+  where x = getReg RegX m - 1++-- | BNE: Branch if the zero-flag is false+bne :: Program -> Instruction+bne l k m = ite (z .== false) (l m) (k m)+  where z = getFlag FlagZ m++-- | The 'end' combinator "stops" our program, providing the final continuation+-- that does nothing.+end :: Program+end = id++------------------------------------------------------------------+-- * Legato's algorithm in Haskell/SBV+------------------------------------------------------------------++-- | Parameterized by the addresses of locations of the factors (@F1@ and @F2@),+-- the following program multiplies them, storing the low-byte of the result+-- in the memory location @lowAddr@, and the high-byte in register @A@. The+-- implementation is a direct transliteration of Legato's algorithm given+-- at the top, using our notation.+legato :: Address -> Address -> Address -> Program+legato f1Addr f2Addr lowAddr = start+  where start   =    ldx 8+                   $ lda 0+                   $ loop+        loop    =    rorM f1Addr+                   $ bcc zeroCoef+                   $ clc+                   $ adc f2Addr+                   $ zeroCoef+        zeroCoef =   rorR RegA+                   $ rorM lowAddr+                   $ dex+                   $ bne loop+                   $ end++------------------------------------------------------------------+-- * Verification interface+------------------------------------------------------------------+-- | Given address/value pairs for F1 and F2, and the location of where the low-byte+-- of the result should go, @runLegato@ takes an arbitrary machine state @m@ and+-- returns the high and low bytes of the multiplication.+runLegato :: (Address, Value) -> (Address, Value) -> Address -> Mostek -> (Value, Value)+runLegato (f1Addr, f1Val) (f2Addr, f2Val) loAddr m = (getReg RegA mFinal, peek loAddr mFinal)+  where m0     = poke f1Addr f1Val $ poke f2Addr f2Val m+        mFinal = legato f1Addr f2Addr loAddr m0++-- | Helper synonym for capturing relevant bits of Mostek+type InitVals = ( Value      -- Content of Register X+                , Value      -- Content of Register A+                , Bit        -- Value of FlagC+                , Bit        -- Value of FlagZ+                )++-- | Create an instance of the Mostek machine, initialized by the memory and the relevant+-- values of the registers and the flags+initMachine :: Memory -> InitVals -> Mostek+initMachine mem (rx, ra, fc, fz) = Mostek { memory    = mem+                                          , registers = array (minBound, maxBound) [(RegX, rx),  (RegA, ra)]+                                          , flags     = array (minBound, maxBound) [(FlagC, fc), (FlagZ, fz)]+                                          }++-- | The correctness theorem. For all possible memory configurations, the factors (@x@ and @y@ below), the location+-- of the low-byte result and the initial-values of registers and the flags, this function will return True only if+-- running Legato's algorithm does indeed compute the product of @x@ and @y@ correctly.+legatoIsCorrect :: Memory -> (Address, Value) -> (Address, Value) -> Address -> InitVals -> SBool+legatoIsCorrect mem (addrX, x) (addrY, y) addrLow initVals+        = distinct [addrX, addrY, addrLow]    -- note the conditional: addresses must be distinct!+                ==> result .== expected+    where (hi, lo) = runLegato (addrX, x) (addrY, y) addrLow (initMachine mem initVals)+          -- NB. perform the comparison over 16 bit values to avoid overflow!+          -- If Value changes to be something else, modify this accordingly.+          result, expected :: SWord16+          result   = 256 * (0 # hi) + (0 # lo)+          expected = (0 # x) * (0 # y)++------------------------------------------------------------------+-- * Verification+------------------------------------------------------------------++-- | Choose the appropriate array model to be used for modeling the memory. (See 'Memory'.)+-- The 'SFunArray' is the function based model. 'SArray' is the SMT-Lib array's based model.+type Model = SFunArray+-- type Model = SArray++-- | The correctness theorem.+-- On a 2011 MacBook, this proof takes about 1 minute 45 seconds with the 'SFunArray' memory model+-- using boolector as the solver.+correctnessTheorem :: IO ThmResult+correctnessTheorem = proveWith boolector{timing = PrintTiming} $ do+        let mem = mkSFunArray (const 0)++        addrX <- sWord32 "addrX"+        x     <- sWord8  "x"++        addrY <- sWord32 "addrY"+        y     <- sWord8  "y"++        addrLow <- sWord32 "addrLow"++        regX  <- sWord8 "regX"+        regA  <- sWord8 "regA"++        flagC <- sBool "flagC"+        flagZ <- sBool "flagZ"++        return $ legatoIsCorrect mem (addrX, x) (addrY, y) addrLow (regX, regA, flagC, flagZ)++------------------------------------------------------------------+-- * C Code generation+------------------------------------------------------------------++-- | Generate a C program that implements Legato's algorithm automatically.+legatoInC :: IO ()+legatoInC = compileToC Nothing "runLegato" $ do+                x <- cgInput "x"+                y <- cgInput "y"+                let (hi, lo) = runLegato (0, x) (1, y) 2 (initMachine (mkSFunArray (const 0)) (0, 0, false, false))+                cgOutput "hi" hi+                cgOutput "lo" lo++{-# ANN legato ("HLint: ignore Redundant $" :: String)        #-}+{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
+ Documentation/SBV/Examples/BitPrecise/MergeSort.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.BitPrecise.MergeSort+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Symbolic implementation of merge-sort and its correctness.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.BitPrecise.MergeSort where++import Data.SBV+import Data.SBV.Tools.CodeGen++-----------------------------------------------------------------------------+-- * Implementing Merge-Sort+-----------------------------------------------------------------------------+-- | Element type of lists we'd like to sort. For simplicity, we'll just+-- use 'SWord8' here, but we can pick any symbolic type.+type E = SWord8++-- | Merging two given sorted lists, preserving the order.+merge :: [E] -> [E] -> [E]+merge []     ys           = ys+merge xs     []           = xs+merge xs@(x:xr) ys@(y:yr) = ite (x .< y) (x : merge xr ys) (y : merge xs yr)++-- | Simple merge-sort implementation. We simply divide the input list+-- in two two halves so long as it has at least two elements, sort+-- each half on its own, and then merge.+mergeSort :: [E] -> [E]+mergeSort []  = []+mergeSort [x] = [x]+mergeSort xs  = merge (mergeSort th) (mergeSort bh)+   where (th, bh) = splitAt (length xs `div` 2) xs++-----------------------------------------------------------------------------+-- * Proving correctness+-- ${props}+-----------------------------------------------------------------------------+{- $props+There are two main parts to proving that a sorting algorithm is correct:++       * Prove that the output is non-decreasing+ +       * Prove that the output is a permutation of the input+-}++-- | Check whether a given sequence is non-decreasing.+nonDecreasing :: [E] -> SBool+nonDecreasing []       = true+nonDecreasing [_]      = true+nonDecreasing (a:b:xs) = a .<= b &&& nonDecreasing (b:xs)++-- | Check whether two given sequences are permutations. We simply check that each sequence+-- is a subset of the other, when considered as a set. The check is slightly complicated+-- for the need to account for possibly duplicated elements.+isPermutationOf :: [E] -> [E] -> SBool+isPermutationOf as bs = go as (zip bs (repeat true)) &&& go bs (zip as (repeat true))+  where go []     _  = true+        go (x:xs) ys = let (found, ys') = mark x ys in found &&& go xs ys'+        -- Go and mark off an instance of 'x' in the list, if possible. We keep track+        -- of unmarked elements by associating a boolean bit. Note that we have to+        -- keep the lists equal size for the recursive result to merge properly.+        mark _ []         = (false, [])+        mark x ((y,v):ys) = ite (v &&& x .== y)+                                (true, (y, bnot v):ys)+                                (let (r, ys') = mark x ys in (r, (y,v):ys'))++-- | Asserting correctness of merge-sort for a list of the given size. Note that we can+-- only check correctness for fixed-size lists. Also, the proof will get more and more+-- complicated for the backend SMT solver as 'n' increases. A value around 5 or 6 should+-- be fairly easy to prove. For instance, we have:+--+-- >>> correctness 5+-- Q.E.D.+correctness :: Int -> IO ThmResult+correctness n = prove $ do xs <- mkFreeVars n+                           let ys = mergeSort xs+                           return $ nonDecreasing ys &&& isPermutationOf xs ys++-----------------------------------------------------------------------------+-- * Generating C code+-----------------------------------------------------------------------------++-- | Generate C code for merge-sorting an array of size 'n'. Again, we're restricted+-- to fixed size inputs. While the output is not how one would code merge sort in C+-- by hand, it's a faithful rendering of all the operations merge-sort would do as+-- described by its Haskell counterpart.+codeGen :: Int -> IO ()+codeGen n = compileToC (Just ("mergeSort" ++ show n)) "mergeSort" $ do+                xs <- cgInputArr n "xs"+                cgOutputArr "ys" (mergeSort xs)
+ Documentation/SBV/Examples/BitPrecise/MultMask.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.BitPrecise.MultMask+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- An SBV solution to the bit-precise puzzle of shuffling the bits in a+-- 64-bit word in a custom order. The idea is to take a 64-bit value:+--+--    @1.......2.......3.......4.......5.......6.......7.......8.......@+--+-- And turn it into another 64-bit value, that looks like this:+--+--    @12345678........................................................@+--+-- We do not care what happens to the bits that are represented by dots. The+-- problem is to do this with one mask and one multiplication.+--+-- Apparently this operation has several applications, including in programs+-- that play chess of all things. We use SBV to find the appropriate mask and+-- the multiplier.+--+-- Note that this is an instance of the program synthesis problem, where+-- we "fill in the blanks" given a certain skeleton that satisfy a certain+-- property, using quantified formulas.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.BitPrecise.MultMask where++import Data.SBV++-- | Find the multiplier and the mask as described. We have:+--+-- >>> maskAndMult+-- Satisfiable. Model:+--   mask = 0x8080808080808080 :: Word64+--   mult = 0xc202040810204081 :: Word64+--+-- That is, any 64 bit value masked by the first and multipled by the second+-- value above will have its bits at positions @[7,15,23,31,39,47,55,63]@ moved+-- to positions @[56,57,58,59,60,61,62,63]@ respectively.+maskAndMult :: IO ()+maskAndMult = print =<< satWith z3{printBase=16} find+  where find = do mask <- exists "mask"+                  mult <- exists "mult"+                  inp  <- forall "inp"+                  let res = (mask .&. inp) * (mult :: SWord64)+                  solve [inp `sExtractBits` [7, 15 .. 63] .== res `sExtractBits` [56 .. 63]]
+ Documentation/SBV/Examples/BitPrecise/PrefixSum.hs view
@@ -0,0 +1,97 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.BitPrecise.PrefixSum+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- The PrefixSum algorithm over power-lists and proof of+-- the Ladner-Fischer implementation.+-- See <http://dl.acm.org/citation.cfm?id=197356>+-- and <http://www.cs.utexas.edu/~plaxton/c/337/05f/slides/ParallelRecursion-4.pdf>.+-----------------------------------------------------------------------------++{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Documentation.SBV.Examples.BitPrecise.PrefixSum where++import Data.SBV++----------------------------------------------------------------------+-- * Formalizing power-lists+----------------------------------------------------------------------++-- | A poor man's representation of powerlists and+-- basic operations on them: <http://dl.acm.org/citation.cfm?id=197356>+-- We merely represent power-lists by ordinary lists.+type PowerList a = [a]++-- | The tie operator, concatenation.+tiePL :: PowerList a -> PowerList a -> PowerList a+tiePL = (++)++-- | The zip operator, zips the power-lists of the same size, returns+-- a powerlist of double the size.+zipPL :: PowerList a -> PowerList a -> PowerList a+zipPL []     []     = []+zipPL (x:xs) (y:ys) = x : y : zipPL xs ys+zipPL _      _      = error "zipPL: nonsimilar powerlists received"++-- | Inverse of zipping.+unzipPL :: PowerList a -> (PowerList a, PowerList a)+unzipPL = unzip . chunk2+  where chunk2 []       = []+        chunk2 (x:y:xs) = (x,y) : chunk2 xs+        chunk2 _        = error "unzipPL: malformed powerlist"++----------------------------------------------------------------------+-- * Reference prefix-sum implementation+----------------------------------------------------------------------++-- | Reference prefix sum (@ps@) is simply Haskell's @scanl1@ function.+ps :: (a, a -> a -> a) -> PowerList a -> PowerList a+ps (_, f) = scanl1 f++----------------------------------------------------------------------+-- * The Ladner-Fischer parallel version+----------------------------------------------------------------------++-- | The Ladner-Fischer (@lf@) implementation of prefix-sum. See <http://www.cs.utexas.edu/~plaxton/c/337/05f/slides/ParallelRecursion-4.pdf>+-- or pg. 16 of <http://dl.acm.org/citation.cfm?id=197356>+lf :: (a, a -> a -> a) -> PowerList a -> PowerList a+lf _ []         = error "lf: malformed (empty) powerlist"+lf _ [x]        = [x]+lf (zero, f) pl = zipPL (zipWith f (rsh lfpq) p) lfpq+   where (p, q) = unzipPL pl+         pq     = zipWith f p q+         lfpq   = lf (zero, f) pq+         rsh xs = zero : init xs+++----------------------------------------------------------------------+-- * Sample proofs for concrete operators+----------------------------------------------------------------------++-- | Correctness theorem, for a powerlist of given size, an associative operator, and its left-unit element.+flIsCorrect :: Int -> (forall a. (OrdSymbolic a, Num a, Bits a) => (a, a -> a -> a)) -> Symbolic SBool+flIsCorrect n zf = do+        args :: PowerList SWord32 <- mkForallVars n+        return $ ps zf args .== lf zf args++-- | Proves Ladner-Fischer is equivalent to reference specification for addition.+-- @0@ is the left-unit element, and we use a power-list of size @8@. We have:+--+-- >>> thm1+-- Q.E.D.+thm1 :: IO ThmResult+thm1 = prove $ flIsCorrect  8 (0, (+))++-- | Proves Ladner-Fischer is equivalent to reference specification for the function @max@.+-- @0@ is the left-unit element, and we use a power-list of size @16@. We have:+--+-- >>> thm2+-- Q.E.D.+thm2 :: IO ThmResult+thm2 = prove $ flIsCorrect 16 (0, smax)
+ Documentation/SBV/Examples/CodeGeneration/AddSub.hs view
@@ -0,0 +1,141 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.CodeGeneration.AddSub+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Simple code generation example.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.CodeGeneration.AddSub where++import Data.SBV+import Data.SBV.Tools.CodeGen++-- | Simple function that returns add/sum of args+addSub :: SWord8 -> SWord8 -> (SWord8, SWord8)+addSub x y = (x+y, x-y)++-- | Generate C code for addSub. Here's the output showing the generated C code:+--+-- >>> genAddSub+-- == BEGIN: "Makefile" ================+-- # Makefile for addSub. Automatically generated by SBV. Do not edit!+-- <BLANKLINE>+-- # include any user-defined .mk file in the current directory.+-- -include *.mk+-- <BLANKLINE>+-- CC?=gcc+-- CCFLAGS?=-Wall -O3 -DNDEBUG -fomit-frame-pointer+-- <BLANKLINE>+-- all: addSub_driver+-- <BLANKLINE>+-- addSub.o: addSub.c addSub.h+-- 	${CC} ${CCFLAGS} -c $< -o $@+-- <BLANKLINE>+-- addSub_driver.o: addSub_driver.c+-- 	${CC} ${CCFLAGS} -c $< -o $@+-- <BLANKLINE>+-- addSub_driver: addSub.o addSub_driver.o+-- 	${CC} ${CCFLAGS} $^ -o $@+-- <BLANKLINE>+-- clean:+-- 	rm -f *.o+-- <BLANKLINE>+-- veryclean: clean+-- 	rm -f addSub_driver+-- == END: "Makefile" ==================+-- == BEGIN: "addSub.h" ================+-- /* Header file for addSub. Automatically generated by SBV. Do not edit! */+-- <BLANKLINE>+-- #ifndef __addSub__HEADER_INCLUDED__+-- #define __addSub__HEADER_INCLUDED__+-- <BLANKLINE>+-- #include <stdio.h>+-- #include <stdlib.h>+-- #include <inttypes.h>+-- #include <stdint.h>+-- #include <stdbool.h>+-- #include <string.h>+-- #include <math.h>+-- <BLANKLINE>+-- /* The boolean type */+-- typedef bool SBool;+-- <BLANKLINE>+-- /* The float type */+-- typedef float SFloat;+-- <BLANKLINE>+-- /* The double type */+-- typedef double SDouble;+-- <BLANKLINE>+-- /* Unsigned bit-vectors */+-- typedef uint8_t  SWord8;+-- typedef uint16_t SWord16;+-- typedef uint32_t SWord32;+-- typedef uint64_t SWord64;+-- <BLANKLINE>+-- /* Signed bit-vectors */+-- typedef int8_t  SInt8;+-- typedef int16_t SInt16;+-- typedef int32_t SInt32;+-- typedef int64_t SInt64;+-- <BLANKLINE>+-- /* Entry point prototype: */+-- void addSub(const SWord8 x, const SWord8 y, SWord8 *sum,+--             SWord8 *dif);+-- <BLANKLINE>+-- #endif /* __addSub__HEADER_INCLUDED__ */+-- == END: "addSub.h" ==================+-- == BEGIN: "addSub_driver.c" ================+-- /* Example driver program for addSub. */+-- /* Automatically generated by SBV. Edit as you see fit! */+-- <BLANKLINE>+-- #include <stdio.h>+-- #include "addSub.h"+-- <BLANKLINE>+-- int main(void)+-- {+--   SWord8 sum;+--   SWord8 dif;+-- <BLANKLINE>+--   addSub(132, 241, &sum, &dif);+-- <BLANKLINE>+--   printf("addSub(132, 241, &sum, &dif) ->\n");+--   printf("  sum = %"PRIu8"\n", sum);+--   printf("  dif = %"PRIu8"\n", dif);+-- <BLANKLINE>+--   return 0;+-- }+-- == END: "addSub_driver.c" ==================+-- == BEGIN: "addSub.c" ================+-- /* File: "addSub.c". Automatically generated by SBV. Do not edit! */+-- <BLANKLINE>+-- #include "addSub.h"+-- <BLANKLINE>+-- void addSub(const SWord8 x, const SWord8 y, SWord8 *sum,+--             SWord8 *dif)+-- {+--   const SWord8 s0 = x;+--   const SWord8 s1 = y;+--   const SWord8 s2 = s0 + s1;+--   const SWord8 s3 = s0 - s1;+-- <BLANKLINE>+--   *sum = s2;+--   *dif = s3;+-- }+-- == END: "addSub.c" ==================+--+genAddSub :: IO ()+genAddSub = compileToC outDir "addSub" $ do+        x <- cgInput "x"+        y <- cgInput "y"+        -- leave the cgDriverVals call out for generating a driver with random values+        cgSetDriverValues [132, 241]+        let (s, d) = addSub x y+        cgOutput "sum" s+        cgOutput "dif" d+ where -- use Just "dirName" for putting the output to the named directory+       -- otherwise, it'll go to standard output+       outDir = Nothing
+ Documentation/SBV/Examples/CodeGeneration/CRC_USB5.hs view
@@ -0,0 +1,87 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.CodeGeneration.CRC_USB5+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Computing the CRC symbolically, using the USB polynomial. We also+-- generating C code for it as well. This example demonstrates the+-- use of the 'crcBV' function, along with how CRC's can be computed+-- mathematically using polynomial division. While the results are the+-- same (i.e., proven equivalent, see 'crcGood' below), the internal+-- CRC implementation generates much better code, compare 'cg1' vs 'cg2' below.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.CodeGeneration.CRC_USB5 where++import Data.SBV+import Data.SBV.Tools.CodeGen+import Data.SBV.Tools.Polynomial++-----------------------------------------------------------------------------+-- * The USB polynomial+-----------------------------------------------------------------------------++-- | The USB CRC polynomial: @x^5 + x^2 + 1@.+-- Although this polynomial needs just 6 bits to represent (5 if higher+-- order bit is implicitly assumed to be set), we'll simply use a 16 bit+-- number for its representation to keep things simple for code generation+-- purposes.+usb5 :: SWord16+usb5 = polynomial [5, 2, 0]++-----------------------------------------------------------------------------+-- * Computing CRCs+-----------------------------------------------------------------------------++-- | Given an 11 bit message, compute the CRC of it using the USB polynomial,+-- which is 5 bits, and then append it to the msg to get a 16-bit word. Again,+-- the incoming 11-bits is represented as a 16-bit word, with 5 highest bits+-- essentially ignored for input purposes.+crcUSB :: SWord16 -> SWord16+crcUSB i = fromBitsBE (ib ++ cb)+  where ib = drop 5  (blastBE i)    -- only the last 11 bits needed+        pb = drop 11 (blastBE usb5) -- only the last  5 bits needed+        cb = crcBV 5 ib pb++-- | Alternate method for computing the CRC, /mathematically/. We shift+-- the number to the left by 5, and then compute the remainder from the+-- polynomial division by the USB polynomial. The result is then appended+-- to the end of the message.+crcUSB' :: SWord16 -> SWord16+crcUSB' i' = i .|. pMod i usb5+  where i = i' `shiftL` 5++-----------------------------------------------------------------------------+-- * Correctness+-----------------------------------------------------------------------------++-- | Prove that the custom 'crcBV' function is equivalent to the mathematical+-- definition of CRC's for 11 bit messages. We have:+--+-- >>> crcGood+-- Q.E.D.+crcGood :: IO ThmResult+crcGood = prove $ \i -> crcUSB i .== crcUSB' i++-----------------------------------------------------------------------------+-- * Code generation+-----------------------------------------------------------------------------++-- | Generate a C function to compute the USB CRC, using the internal CRC+-- function.+cg1 :: IO ()+cg1 = compileToC (Just "crcUSB1") "crcUSB1" $ do+        msg <- cgInput "msg"+        cgOutput "crc" (crcUSB msg)++-- | Generate a C function to compute the USB CRC, using the mathematical+-- definition of the CRCs. While this version generates functionally eqivalent+-- C code, it's less efficient; it has about 30% more code. So, the above+-- version is preferable for code generation purposes.+cg2 :: IO ()+cg2 = compileToC (Just "crcUSB2") "crcUSB2" $ do+        msg <- cgInput "msg"+        cgOutput "crc" (crcUSB' msg)
+ Documentation/SBV/Examples/CodeGeneration/Fibonacci.hs view
@@ -0,0 +1,176 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.CodeGeneration.Fibonacci+-- Copyright   :  (c) Lee Pike, Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Computing Fibonacci numbers and generating C code. Inspired by Lee Pike's+-- original implementation, modified for inclusion in the package. It illustrates+-- symbolic termination issues one can have when working with recursive algorithms+-- and how to deal with such, eventually generating good C code.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.CodeGeneration.Fibonacci where++import Data.SBV+import Data.SBV.Tools.CodeGen++-----------------------------------------------------------------------------+-- * A naive implementation+-----------------------------------------------------------------------------++-- | This is a naive implementation of fibonacci, and will work fine (albeit slow)+-- for concrete inputs:+--+-- >>> map fib0 [0..6]+-- [0 :: SWord64,1 :: SWord64,1 :: SWord64,2 :: SWord64,3 :: SWord64,5 :: SWord64,8 :: SWord64]+--+-- However, it is not suitable for doing proofs or generating code, as it is not+-- symbolically terminating when it is called with a symbolic value @n@. When we+-- recursively call @fib0@ on @n-1@ (or @n-2@), the test against @0@ will always+-- explore both branches since the result will be symbolic, hence will not+-- terminate. (An integrated theorem prover can establish termination+-- after a certain number of unrollings, but this would be quite expensive to+-- implement, and would be impractical.)+fib0 :: SWord64 -> SWord64+fib0 n = ite (n .== 0 ||| n .== 1)+             n+             (fib0 (n-1) + fib0 (n-2))++-----------------------------------------------------------------------------+-- * Using a recursion depth, and accumulating parameters+-----------------------------------------------------------------------------++{- $genLookup+One way to deal with symbolic termination is to limit the number of recursive+calls. In this version, we impose a limit on the index to the function, working+correctly upto that limit. If we use a compile-time constant, then SBV's code generator+can produce code as the unrolling will eventually stop.+-}++-- | The recursion-depth limited version of fibonacci. Limiting the maximum number to be 20, we can say:+--+-- >>> map (fib1 20) [0..6]+-- [0 :: SWord64,1 :: SWord64,1 :: SWord64,2 :: SWord64,3 :: SWord64,5 :: SWord64,8 :: SWord64]+--+-- The function will work correctly, so long as the index we query is at most @top@, and otherwise+-- will return the value at @top@. Note that we also use accumulating parameters here for efficiency,+-- although this is orthogonal to the termination concern.+--+-- A note on modular arithmetic: The 64-bit word we use to represent the values will of course+-- eventually overflow, beware! Fibonacci is a fast growing function..+fib1 :: SWord64 -> SWord64 -> SWord64+fib1 top n = fib' 0 1 0+  where fib' :: SWord64 -> SWord64 -> SWord64 -> SWord64+        fib' prev' prev m = ite (m .== top ||| m .== n)          -- did we reach recursion depth, or the index we're looking for+                                prev'                            -- stop and return the result+                                (fib' prev (prev' + prev) (m+1)) -- otherwise recurse++-- | We can generate code for 'fib1' using the 'genFib1' action. Note that the+-- generated code will grow larger as we pick larger values of @top@, but only linearly,+-- thanks to the accumulating parameter trick used by 'fib1'. The following is an excerpt+-- from the code generated for the call @genFib1 10@, where the code will work correctly+-- for indexes up to 10:+--+-- > SWord64 fib1(const SWord64 x)+-- > {+-- >   const SWord64 s0 = x;+-- >   const SBool   s2 = s0 == 0x0000000000000000ULL;+-- >   const SBool   s4 = s0 == 0x0000000000000001ULL;+-- >   const SBool   s6 = s0 == 0x0000000000000002ULL;+-- >   const SBool   s8 = s0 == 0x0000000000000003ULL;+-- >   const SBool   s10 = s0 == 0x0000000000000004ULL;+-- >   const SBool   s12 = s0 == 0x0000000000000005ULL;+-- >   const SBool   s14 = s0 == 0x0000000000000006ULL;+-- >   const SBool   s17 = s0 == 0x0000000000000007ULL;+-- >   const SBool   s19 = s0 == 0x0000000000000008ULL;+-- >   const SBool   s22 = s0 == 0x0000000000000009ULL;+-- >   const SWord64 s25 = s22 ? 0x0000000000000022ULL : 0x0000000000000037ULL;+-- >   const SWord64 s26 = s19 ? 0x0000000000000015ULL : s25;+-- >   const SWord64 s27 = s17 ? 0x000000000000000dULL : s26;+-- >   const SWord64 s28 = s14 ? 0x0000000000000008ULL : s27;+-- >   const SWord64 s29 = s12 ? 0x0000000000000005ULL : s28;+-- >   const SWord64 s30 = s10 ? 0x0000000000000003ULL : s29;+-- >   const SWord64 s31 = s8 ? 0x0000000000000002ULL : s30;+-- >   const SWord64 s32 = s6 ? 0x0000000000000001ULL : s31;+-- >   const SWord64 s33 = s4 ? 0x0000000000000001ULL : s32;+-- >   const SWord64 s34 = s2 ? 0x0000000000000000ULL : s33;+-- >   +-- >   return s34;+-- > }+genFib1 :: SWord64 -> IO ()+genFib1 top = compileToC Nothing "fib1" $ do+        x <- cgInput "x"+        cgReturn $ fib1 top x++-----------------------------------------------------------------------------+-- * Generating a look-up table+-----------------------------------------------------------------------------++{- $genLookup+While 'fib1' generates good C code, we can do much better by taking+advantage of the inherent partial-evaluation capabilities of SBV to generate+a look-up table, as follows.+-}++-- | Compute the fibonacci numbers statically at /code-generation/ time and+-- put them in a table, accessed by the 'select' call. +fib2 :: SWord64 -> SWord64 -> SWord64+fib2 top = select table 0+  where table = map (fib1 top) [0 .. top]++-- | Once we have 'fib2', we can generate the C code straightforwardly. Below+-- is an excerpt from the code that SBV generates for the call @genFib2 64@. Note+-- that this code is a constant-time look-up table implementation of fibonacci,+-- with no run-time overhead. The index can be made arbitrarily large,+-- naturally. (Note that this function returns @0@ if the index is larger+-- than 64, as specified by the call to 'select' with default @0@.)+--+-- > SWord64 fibLookup(const SWord64 x)+-- > {+-- >   const SWord64 s0 = x;+-- >   static const SWord64 table0[] = {+-- >       0x0000000000000000ULL, 0x0000000000000001ULL,+-- >       0x0000000000000001ULL, 0x0000000000000002ULL,+-- >       0x0000000000000003ULL, 0x0000000000000005ULL,+-- >       0x0000000000000008ULL, 0x000000000000000dULL,+-- >       0x0000000000000015ULL, 0x0000000000000022ULL,+-- >       0x0000000000000037ULL, 0x0000000000000059ULL,+-- >       0x0000000000000090ULL, 0x00000000000000e9ULL,+-- >       0x0000000000000179ULL, 0x0000000000000262ULL,+-- >       0x00000000000003dbULL, 0x000000000000063dULL,+-- >       0x0000000000000a18ULL, 0x0000000000001055ULL,+-- >       0x0000000000001a6dULL, 0x0000000000002ac2ULL,+-- >       0x000000000000452fULL, 0x0000000000006ff1ULL,+-- >       0x000000000000b520ULL, 0x0000000000012511ULL,+-- >       0x000000000001da31ULL, 0x000000000002ff42ULL,+-- >       0x000000000004d973ULL, 0x000000000007d8b5ULL,+-- >       0x00000000000cb228ULL, 0x0000000000148addULL,+-- >       0x0000000000213d05ULL, 0x000000000035c7e2ULL,+-- >       0x00000000005704e7ULL, 0x00000000008cccc9ULL,+-- >       0x0000000000e3d1b0ULL, 0x0000000001709e79ULL,+-- >       0x0000000002547029ULL, 0x0000000003c50ea2ULL,+-- >       0x0000000006197ecbULL, 0x0000000009de8d6dULL,+-- >       0x000000000ff80c38ULL, 0x0000000019d699a5ULL,+-- >       0x0000000029cea5ddULL, 0x0000000043a53f82ULL,+-- >       0x000000006d73e55fULL, 0x00000000b11924e1ULL,+-- >       0x000000011e8d0a40ULL, 0x00000001cfa62f21ULL,+-- >       0x00000002ee333961ULL, 0x00000004bdd96882ULL,+-- >       0x00000007ac0ca1e3ULL, 0x0000000c69e60a65ULL,+-- >       0x0000001415f2ac48ULL, 0x000000207fd8b6adULL,+-- >       0x0000003495cb62f5ULL, 0x0000005515a419a2ULL,+-- >       0x00000089ab6f7c97ULL, 0x000000dec1139639ULL,+-- >       0x000001686c8312d0ULL, 0x000002472d96a909ULL,+-- >       0x000003af9a19bbd9ULL, 0x000005f6c7b064e2ULL, 0x000009a661ca20bbULL+-- >   };+-- >   const SWord64 s65 = s0 >= 65 ? 0x0000000000000000ULL : table0[s0];+-- >   +-- >   return s65;+-- > }+genFib2 :: SWord64 -> IO ()+genFib2 top = compileToC Nothing "fibLookup" $ do+        cgPerformRTCs True       -- protect against potential overflow, our table is not big enough+        x <- cgInput "x"+        cgReturn $ fib2 top x
+ Documentation/SBV/Examples/CodeGeneration/GCD.hs view
@@ -0,0 +1,146 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.CodeGeneration.GCD+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Computing GCD symbolically, and generating C code for it. This example+-- illustrates symbolic termination related issues when programming with+-- SBV, when the termination of a recursive algorithm crucially depends+-- on the value of a symbolic variable. The technique we use is to statically+-- enforce termination by using a recursion depth counter.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.CodeGeneration.GCD where++import Data.SBV+import Data.SBV.Tools.CodeGen++-----------------------------------------------------------------------------+-- * Computing GCD+-----------------------------------------------------------------------------++-- | The symbolic GCD algorithm, over two 8-bit numbers. We define @sgcd a 0@ to+-- be @a@ for all @a@, which implies @sgcd 0 0 = 0@. Note that this is essentially+-- Euclid's algorithm, except with a recursion depth counter. We need the depth+-- counter since the algorithm is not /symbolically terminating/, as we don't have+-- a means of determining that the second argument (@b@) will eventually reach 0 in a symbolic+-- context. Hence we stop after 12 iterations. Why 12? We've empirically determined that this+-- algorithm will recurse at most 12 times for arbitrary 8-bit numbers. Of course, this is+-- a claim that we shall prove below.+sgcd :: SWord8 -> SWord8 -> SWord8+sgcd a b = go a b 12+  where go :: SWord8 -> SWord8 -> SWord8 -> SWord8+        go x y c = ite (c .== 0 ||| y .== 0)   -- stop if y is 0, or if we reach the recursion depth+                       x+                       (go y y' (c-1))+          where (_, y') = x `sQuotRem` y++-----------------------------------------------------------------------------+-- * Verification+-----------------------------------------------------------------------------++{- $VerificationIntro+We prove that 'sgcd' does indeed compute the common divisor of the given numbers.+Our predicate takes @x@, @y@, and @k@. We show that what 'sgcd' returns is indeed a common divisor,+and it is at least as large as any given @k@, provided @k@ is a common divisor as well.+-}++-- | We have:+--+-- >>> prove sgcdIsCorrect+-- Q.E.D.+sgcdIsCorrect :: SWord8 -> SWord8 -> SWord8 -> SBool+sgcdIsCorrect x y k = ite (y  .== 0)                        -- if y is 0+                          (k' .== x)                        -- then k' must be x, nothing else to prove by definition+                          (isCommonDivisor k'  &&&          -- otherwise, k' is a common divisor and+                          (isCommonDivisor k ==> k' .>= k)) -- if k is a common divisor as well, then k' is at least as large as k+  where k' = sgcd x y+        isCommonDivisor a = z1 .== 0 &&& z2 .== 0+           where (_, z1) = x `sQuotRem` a+                 (_, z2) = y `sQuotRem` a++-----------------------------------------------------------------------------+-- * Code generation+-----------------------------------------------------------------------------++{- $VerificationIntro+Now that we have proof our 'sgcd' implementation is correct, we can go ahead+and generate C code for it.+-}++-- | This call will generate the required C files. The following is the function+-- body generated for 'sgcd'. (We are not showing the generated header, @Makefile@,+-- and the driver programs for brevity.) Note that the generated function is+-- a constant time algorithm for GCD. It is not necessarily fastest, but it will take+-- precisely the same amount of time for all values of @x@ and @y@.+--+-- > /* File: "sgcd.c". Automatically generated by SBV. Do not edit! */+-- > +-- > #include <stdio.h>+-- > #include <stdlib.h>+-- > #include <inttypes.h>+-- > #include <stdint.h>+-- > #include <stdbool.h>+-- > #include "sgcd.h"+-- > +-- > SWord8 sgcd(const SWord8 x, const SWord8 y)+-- > {+-- >   const SWord8 s0 = x;+-- >   const SWord8 s1 = y;+-- >   const SBool  s3 = s1 == 0;+-- >   const SWord8 s4 = (s1 == 0) ? s0 : (s0 % s1);+-- >   const SWord8 s5 = s3 ? s0 : s4;+-- >   const SBool  s6 = 0 == s5;+-- >   const SWord8 s7 = (s5 == 0) ? s1 : (s1 % s5);+-- >   const SWord8 s8 = s6 ? s1 : s7;+-- >   const SBool  s9 = 0 == s8;+-- >   const SWord8 s10 = (s8 == 0) ? s5 : (s5 % s8);+-- >   const SWord8 s11 = s9 ? s5 : s10;+-- >   const SBool  s12 = 0 == s11;+-- >   const SWord8 s13 = (s11 == 0) ? s8 : (s8 % s11);+-- >   const SWord8 s14 = s12 ? s8 : s13;+-- >   const SBool  s15 = 0 == s14;+-- >   const SWord8 s16 = (s14 == 0) ? s11 : (s11 % s14);+-- >   const SWord8 s17 = s15 ? s11 : s16;+-- >   const SBool  s18 = 0 == s17;+-- >   const SWord8 s19 = (s17 == 0) ? s14 : (s14 % s17);+-- >   const SWord8 s20 = s18 ? s14 : s19;+-- >   const SBool  s21 = 0 == s20;+-- >   const SWord8 s22 = (s20 == 0) ? s17 : (s17 % s20);+-- >   const SWord8 s23 = s21 ? s17 : s22;+-- >   const SBool  s24 = 0 == s23;+-- >   const SWord8 s25 = (s23 == 0) ? s20 : (s20 % s23);+-- >   const SWord8 s26 = s24 ? s20 : s25;+-- >   const SBool  s27 = 0 == s26;+-- >   const SWord8 s28 = (s26 == 0) ? s23 : (s23 % s26);+-- >   const SWord8 s29 = s27 ? s23 : s28;+-- >   const SBool  s30 = 0 == s29;+-- >   const SWord8 s31 = (s29 == 0) ? s26 : (s26 % s29);+-- >   const SWord8 s32 = s30 ? s26 : s31;+-- >   const SBool  s33 = 0 == s32;+-- >   const SWord8 s34 = (s32 == 0) ? s29 : (s29 % s32);+-- >   const SWord8 s35 = s33 ? s29 : s34;+-- >   const SBool  s36 = 0 == s35;+-- >   const SWord8 s37 = s36 ? s32 : s35;+-- >   const SWord8 s38 = s33 ? s29 : s37;+-- >   const SWord8 s39 = s30 ? s26 : s38;+-- >   const SWord8 s40 = s27 ? s23 : s39;+-- >   const SWord8 s41 = s24 ? s20 : s40;+-- >   const SWord8 s42 = s21 ? s17 : s41;+-- >   const SWord8 s43 = s18 ? s14 : s42;+-- >   const SWord8 s44 = s15 ? s11 : s43;+-- >   const SWord8 s45 = s12 ? s8 : s44;+-- >   const SWord8 s46 = s9 ? s5 : s45;+-- >   const SWord8 s47 = s6 ? s1 : s46;+-- >   const SWord8 s48 = s3 ? s0 : s47;+-- >   +-- >   return s48;+-- > }+genGCDInC :: IO ()+genGCDInC = compileToC Nothing "sgcd" $ do+                x <- cgInput "x"+                y <- cgInput "y"+                cgReturn $ sgcd x y
+ Documentation/SBV/Examples/CodeGeneration/PopulationCount.hs view
@@ -0,0 +1,230 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.CodeGeneration.PopulationCount+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Computing population-counts (number of set bits) and automatically+-- generating C code.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.CodeGeneration.PopulationCount where++import Data.SBV+import Data.SBV.Tools.CodeGen++-----------------------------------------------------------------------------+-- * Reference: Slow but /obviously/ correct+-----------------------------------------------------------------------------++-- | Given a 64-bit quantity, the simplest (and obvious) way to count the+-- number of bits that are set in it is to simply walk through all the bits+-- and add 1 to a running count. This is slow, as it requires 64 iterations,+-- but is simple and easy to convince yourself that it is correct. For instance:+--+-- >>> popCountSlow 0x0123456789ABCDEF+-- 32 :: SWord8+popCountSlow :: SWord64 -> SWord8+popCountSlow inp = go inp 0 0+  where go :: SWord64 -> Int -> SWord8 -> SWord8+        go _ 64 c = c+        go x i  c = go (x `shiftR` 1) (i+1) (ite (x .&. 1 .== 1) (c+1) c)++-----------------------------------------------------------------------------+-- * Faster: Using a look-up table+-----------------------------------------------------------------------------++-- | Faster version. This is essentially the same algorithm, except we+-- go 8 bits at a time instead of one by one, by using a precomputed table+-- of population-count values for each byte. This algorithm /loops/ only+-- 8 times, and hence is at least 8 times more efficient.+popCountFast :: SWord64 -> SWord8+popCountFast inp = go inp 0 0+  where go :: SWord64 -> Int -> SWord8 -> SWord8+        go _ 8 c = c+        go x i c = go (x `shiftR` 8) (i+1) (c + select pop8 0 (x .&. 0xff))++-- | Look-up table, containing population counts for all possible 8-bit+-- value, from 0 to 255. Note that we do not \"hard-code\" the values, but+-- merely use the slow version to compute them.+pop8 :: [SWord8]+pop8 = map popCountSlow [0 .. 255]++-----------------------------------------------------------------------------+-- * Verification+-----------------------------------------------------------------------------++{- $VerificationIntro+We prove that `popCountFast` and `popCountSlow` are functionally equivalent.+This is essential as we will automatically generate C code from `popCountFast`,+and we would like to make sure that the fast version is correct with+respect to the slower reference version.+-}++-- | States the correctness of faster population-count algorithm, with respect+-- to the reference slow version. Turns out Z3's default solver is rather slow+-- for this one, but there's a magic incantation to make it go fast.+-- See <https://github.com/Z3Prover/z3/issues/1150> for details.+--+-- >>> let cmd = "(check-sat-using (then (using-params ackermannize_bv :div0_ackermann_limit 1000000) simplify bit-blast sat))"+-- >>> proveWith z3{satCmd = cmd} fastPopCountIsCorrect+-- Q.E.D.+fastPopCountIsCorrect :: SWord64 -> SBool+fastPopCountIsCorrect x = popCountFast x .== popCountSlow x++-----------------------------------------------------------------------------+-- * Code generation+-----------------------------------------------------------------------------++-- | Not only we can prove that faster version is correct, but we can also automatically+-- generate C code to compute population-counts for us. This action will generate all the+-- C files that you will need, including a driver program for test purposes.+--+-- Below is the generated header file for `popCountFast`:+--+-- >>> genPopCountInC+-- == BEGIN: "Makefile" ================+-- # Makefile for popCount. Automatically generated by SBV. Do not edit!+-- <BLANKLINE>+-- # include any user-defined .mk file in the current directory.+-- -include *.mk+-- <BLANKLINE>+-- CC?=gcc+-- CCFLAGS?=-Wall -O3 -DNDEBUG -fomit-frame-pointer+-- <BLANKLINE>+-- all: popCount_driver+-- <BLANKLINE>+-- popCount.o: popCount.c popCount.h+-- 	${CC} ${CCFLAGS} -c $< -o $@+-- <BLANKLINE>+-- popCount_driver.o: popCount_driver.c+-- 	${CC} ${CCFLAGS} -c $< -o $@+-- <BLANKLINE>+-- popCount_driver: popCount.o popCount_driver.o+-- 	${CC} ${CCFLAGS} $^ -o $@+-- <BLANKLINE>+-- clean:+-- 	rm -f *.o+-- <BLANKLINE>+-- veryclean: clean+-- 	rm -f popCount_driver+-- == END: "Makefile" ==================+-- == BEGIN: "popCount.h" ================+-- /* Header file for popCount. Automatically generated by SBV. Do not edit! */+-- <BLANKLINE>+-- #ifndef __popCount__HEADER_INCLUDED__+-- #define __popCount__HEADER_INCLUDED__+-- <BLANKLINE>+-- #include <stdio.h>+-- #include <stdlib.h>+-- #include <inttypes.h>+-- #include <stdint.h>+-- #include <stdbool.h>+-- #include <string.h>+-- #include <math.h>+-- <BLANKLINE>+-- /* The boolean type */+-- typedef bool SBool;+-- <BLANKLINE>+-- /* The float type */+-- typedef float SFloat;+-- <BLANKLINE>+-- /* The double type */+-- typedef double SDouble;+-- <BLANKLINE>+-- /* Unsigned bit-vectors */+-- typedef uint8_t  SWord8;+-- typedef uint16_t SWord16;+-- typedef uint32_t SWord32;+-- typedef uint64_t SWord64;+-- <BLANKLINE>+-- /* Signed bit-vectors */+-- typedef int8_t  SInt8;+-- typedef int16_t SInt16;+-- typedef int32_t SInt32;+-- typedef int64_t SInt64;+-- <BLANKLINE>+-- /* Entry point prototype: */+-- SWord8 popCount(const SWord64 x);+-- <BLANKLINE>+-- #endif /* __popCount__HEADER_INCLUDED__ */+-- == END: "popCount.h" ==================+-- == BEGIN: "popCount_driver.c" ================+-- /* Example driver program for popCount. */+-- /* Automatically generated by SBV. Edit as you see fit! */+-- <BLANKLINE>+-- #include <stdio.h>+-- #include "popCount.h"+-- <BLANKLINE>+-- int main(void)+-- {+--   const SWord8 __result = popCount(0x1b02e143e4f0e0e5ULL);+-- <BLANKLINE>+--   printf("popCount(0x1b02e143e4f0e0e5ULL) = %"PRIu8"\n", __result);+-- <BLANKLINE>+--   return 0;+-- }+-- == END: "popCount_driver.c" ==================+-- == BEGIN: "popCount.c" ================+-- /* File: "popCount.c". Automatically generated by SBV. Do not edit! */+-- <BLANKLINE>+-- #include "popCount.h"+-- <BLANKLINE>+-- SWord8 popCount(const SWord64 x)+-- {+--   const SWord64 s0 = x;+--   static const SWord8 table0[] = {+--       0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4, 1, 2, 2, 3, 2, 3,+--       3, 4, 2, 3, 3, 4, 3, 4, 4, 5, 1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4,+--       3, 4, 4, 5, 2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6, 1, 2,+--       2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5, 2, 3, 3, 4, 3, 4, 4, 5,+--       3, 4, 4, 5, 4, 5, 5, 6, 2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5,+--       5, 6, 3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7, 1, 2, 2, 3,+--       2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5, 2, 3, 3, 4, 3, 4, 4, 5, 3, 4,+--       4, 5, 4, 5, 5, 6, 2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,+--       3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7, 2, 3, 3, 4, 3, 4,+--       4, 5, 3, 4, 4, 5, 4, 5, 5, 6, 3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6,+--       5, 6, 6, 7, 3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7, 4, 5,+--       5, 6, 5, 6, 6, 7, 5, 6, 6, 7, 6, 7, 7, 8+--   };+--   const SWord64 s11 = s0 & 0x00000000000000ffULL;+--   const SWord8  s12 = table0[s11];+--   const SWord64 s14 = s0 >> 8;+--   const SWord64 s15 = 0x00000000000000ffULL & s14;+--   const SWord8  s16 = table0[s15];+--   const SWord8  s17 = s12 + s16;+--   const SWord64 s18 = s14 >> 8;+--   const SWord64 s19 = 0x00000000000000ffULL & s18;+--   const SWord8  s20 = table0[s19];+--   const SWord8  s21 = s17 + s20;+--   const SWord64 s22 = s18 >> 8;+--   const SWord64 s23 = 0x00000000000000ffULL & s22;+--   const SWord8  s24 = table0[s23];+--   const SWord8  s25 = s21 + s24;+--   const SWord64 s26 = s22 >> 8;+--   const SWord64 s27 = 0x00000000000000ffULL & s26;+--   const SWord8  s28 = table0[s27];+--   const SWord8  s29 = s25 + s28;+--   const SWord64 s30 = s26 >> 8;+--   const SWord64 s31 = 0x00000000000000ffULL & s30;+--   const SWord8  s32 = table0[s31];+--   const SWord8  s33 = s29 + s32;+--   const SWord64 s34 = s30 >> 8;+--   const SWord64 s35 = 0x00000000000000ffULL & s34;+--   const SWord8  s36 = table0[s35];+--   const SWord8  s37 = s33 + s36;+--   const SWord64 s38 = s34 >> 8;+--   const SWord64 s39 = 0x00000000000000ffULL & s38;+--   const SWord8  s40 = table0[s39];+--   const SWord8  s41 = s37 + s40;+-- <BLANKLINE>+--   return s41;+-- }+-- == END: "popCount.c" ==================+genPopCountInC :: IO ()+genPopCountInC = compileToC Nothing "popCount" $ do+        cgSetDriverValues [0x1b02e143e4f0e0e5]  -- remove this line to get a random test value+        x <- cgInput "x"+        cgReturn $ popCountFast x
+ Documentation/SBV/Examples/CodeGeneration/Uninterpreted.hs view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.CodeGeneration.Uninterpreted+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates the use of uninterpreted functions for the purposes of+-- code generation. This facility is important when we want to take+-- advantage of native libraries in the target platform, or when we'd+-- like to hand-generate code for certain functions for various+-- purposes, such as efficiency, or reliability.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.CodeGeneration.Uninterpreted where++import Data.Maybe (fromMaybe)++import Data.SBV+import Data.SBV.Tools.CodeGen++-- | A definition of shiftLeft that can deal with variable length shifts.+-- (Note that the ``shiftL`` method from the 'Bits' class requires an 'Int' shift+-- amount.) Unfortunately, this'll generate rather clumsy C code due to the+-- use of tables etc., so we uninterpret it for code generation purposes+-- using the 'cgUninterpret' function.+shiftLeft :: SWord32 -> SWord32 -> SWord32+shiftLeft = cgUninterpret "SBV_SHIFTLEFT" cCode hCode+  where -- the C code we'd like SBV to spit out when generating code. Note that this is+        -- arbitrary C code. In this case we just used a macro, but it could be a function,+        -- text that includes files etc. It should essentially bring the name SBV_SHIFTLEFT+        -- used above into scope when compiled. If no code is needed, one can also just+        -- provide the empty list for the same effect. Also see 'cgAddDecl', 'cgAddLDFlags',+        -- and 'cgAddPrototype' functions for further variations.+        cCode = ["#define SBV_SHIFTLEFT(x, y) ((x) << (y))"]+        -- the Haskell code we'd like SBV to use when running inside Haskell or when+        -- translated to SMTLib for verification purposes. This is good old Haskell+        -- code, as one would typically write.+        hCode x = select [x * literal (bit b) | b <- [0.. bs x - 1]] (literal 0)+        bs x = fromMaybe (error "SBV.Example.CodeGeneration.Uninterpreted.shiftLeft: Unexpected non-finite usage!") (bitSizeMaybe x)++-- | Test function that uses shiftLeft defined above. When used as a normal Haskell function+-- or in verification the definition is fully used, i.e., no uninterpretation happens. To wit,+-- we have:+--+--  >>> tstShiftLeft 3 4 5+--  224 :: SWord32+--+--  >>> prove $ \x y -> tstShiftLeft x y 0 .== x + y+--  Q.E.D.+tstShiftLeft ::  SWord32 -> SWord32 -> SWord32 -> SWord32+tstShiftLeft x y z = x `shiftLeft` z + y `shiftLeft` z++-- | Generate C code for "tstShiftLeft". In this case, SBV will *use* the user given definition+-- verbatim, instead of generating code for it. (Also see the functions 'cgAddDecl', 'cgAddLDFlags',+-- and 'cgAddPrototype'.)+genCCode :: IO ()+genCCode = compileToC Nothing "tst" $ do+                [x, y, z] <- cgInputArr 3 "vs"+                cgReturn $ tstShiftLeft x y z
+ Documentation/SBV/Examples/Crypto/AES.hs view
@@ -0,0 +1,593 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Crypto.AES+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- An implementation of AES (Advanced Encryption Standard), using SBV.+-- For details on AES, see <http://en.wikipedia.org/wiki/Advanced_Encryption_Standard>.+--+-- We do a T-box implementation, which leads to good C code as we can take+-- advantage of look-up tables. Note that we make virtually no attempt to+-- optimize our Haskell code. The concern here is not with getting Haskell running+-- fast at all. The idea is to program the T-Box implementation as naturally and clearly+-- as possible in Haskell, and have SBV's code-generator generate fast C code automatically.+-- Therefore, we merely use ordinary Haskell lists as our data-structures, and do not+-- bother with any unboxing or strictness annotations. Thus, we achieve the separation+-- of concerns: Correctness via clairty and simplicity and proofs on the Haskell side,+-- performance by relying on SBV's code generator. If necessary, the generated code+-- can be FFI'd back into Haskell to complete the loop.+--+-- All 3 valid key sizes (128, 192, and 256) as required by the FIPS-197 standard+-- are supported.+-----------------------------------------------------------------------------++{-# LANGUAGE ParallelListComp #-}++module Documentation.SBV.Examples.Crypto.AES where++import Data.SBV+import Data.SBV.Tools.CodeGen+import Data.SBV.Tools.Polynomial++import Data.List (transpose)+import Data.Maybe (fromJust)++import Numeric (showHex)++-----------------------------------------------------------------------------+-- * Formalizing GF(2^8)+-----------------------------------------------------------------------------++-- | An element of the Galois Field 2^8, which are essentially polynomials with+-- maximum degree 7. They are conveniently represented as values between 0 and 255.+type GF28 = SWord8++-- | Multiplication in GF(2^8). This is simple polynomial multipliation, followed+-- by the irreducible polynomial @x^8+x^4+x^3+x^1+1@. We simply use the 'pMult'+-- function exported by SBV to do the operation. +gf28Mult :: GF28 -> GF28 -> GF28+gf28Mult x y = pMult (x, y, [8, 4, 3, 1, 0])++-- | Exponentiation by a constant in GF(2^8). The implementation uses the usual+-- square-and-multiply trick to speed up the computation.+gf28Pow :: GF28 -> Int -> GF28+gf28Pow n = pow+  where sq x  = x `gf28Mult` x+        pow 0    = 1+        pow i+         | odd i = n `gf28Mult` sq (pow (i `shiftR` 1))+         | True  = sq (pow (i `shiftR` 1))++-- | Computing inverses in GF(2^8). By the mathematical properties of GF(2^8)+-- and the particular irreducible polynomial used @x^8+x^5+x^3+x^1+1@, it+-- turns out that raising to the 254 power gives us the multiplicative inverse.+-- Of course, we can prove this using SBV:+--+-- >>> prove $ \x -> x ./= 0 ==> x `gf28Mult` gf28Inverse x .== 1+-- Q.E.D.+--+-- Note that we exclude @0@ in our theorem, as it does not have a+-- multiplicative inverse.+gf28Inverse :: GF28 -> GF28+gf28Inverse x = x `gf28Pow` 254++-----------------------------------------------------------------------------+-- * Implementing AES+-----------------------------------------------------------------------------++-----------------------------------------------------------------------------+-- ** Types and basic operations+-----------------------------------------------------------------------------+-- | AES state. The state consists of four 32-bit words, each of which is in turn treated+-- as four GF28's, i.e., 4 bytes. The T-Box implementation keeps the four-bytes together+-- for efficient representation.+type State = [SWord32]++-- | The key, which can be 128, 192, or 256 bits. Represented as a sequence of 32-bit words.+type Key = [SWord32]++-- | The key schedule. AES executes in rounds, and it treats first and last round keys slightly+-- differently than the middle ones. We reflect that choice by being explicit about it in our type.+-- The length of the middle list of keys depends on the key-size, which in turn determines+-- the number of rounds.+type KS = (Key, [Key], Key)++-- | Conversion from 32-bit words to 4 constituent bytes.+toBytes :: SWord32 -> [GF28]+toBytes x = [x1, x2, x3, x4]+        where (h,  l)  = split x+              (x1, x2) = split h+              (x3, x4) = split l++-- | Conversion from 4 bytes, back to a 32-bit row, inverse of 'toBytes' above. We+-- have the following simple theorems stating this relationship formally:+--+-- >>> prove $ \a b c d -> toBytes (fromBytes [a, b, c, d]) .== [a, b, c, d]+-- Q.E.D.+--+-- >>> prove $ \r -> fromBytes (toBytes r) .== r+-- Q.E.D.+fromBytes :: [GF28] -> SWord32+fromBytes [x1, x2, x3, x4] = (x1 # x2) # (x3 # x4)+fromBytes xs               = error $ "fromBytes: Unexpected input: " ++ show xs++-- | Rotating a state row by a fixed amount to the right.+rotR :: [GF28] -> Int -> [GF28]+rotR [a, b, c, d] 1 = [d, a, b, c]+rotR [a, b, c, d] 2 = [c, d, a, b]+rotR [a, b, c, d] 3 = [b, c, d, a]+rotR xs           i = error $ "rotR: Unexpected input: " ++ show (xs, i)++-----------------------------------------------------------------------------+-- ** The key schedule+-----------------------------------------------------------------------------++-- | Definition of round-constants, as specified in Section 5.2 of the AES standard.+roundConstants :: [GF28]+roundConstants = 0 : [ gf28Pow 2 (k-1) | k <- [1 .. ] ]++-- | The @InvMixColumns@ transformation, as described in Section 5.3.3 of the standard. Note+-- that this transformation is only used explicitly during key-expansion in the T-Box implementation+-- of AES.+invMixColumns :: State -> State+invMixColumns state = map fromBytes $ transpose $ mmult (map toBytes state)+ where dot f   = foldr1 xor . zipWith ($) f+       mmult n = [map (dot r) n | r <- [ [mE, mB, mD, m9]+                                       , [m9, mE, mB, mD]+                                       , [mD, m9, mE, mB]+                                       , [mB, mD, m9, mE]+                                       ]]+       -- table-lookup versions of gf28Mult with the constants used in invMixColumns+       mE = select mETable 0+       mB = select mBTable 0+       mD = select mDTable 0+       m9 = select m9Table 0+       mETable = map (gf28Mult 0xE) [0..255]+       mBTable = map (gf28Mult 0xB) [0..255]+       mDTable = map (gf28Mult 0xD) [0..255]+       m9Table = map (gf28Mult 0x9) [0..255]++-- | Key expansion. Starting with the given key, returns an infinite sequence of+-- words, as described by the AES standard, Section 5.2, Figure 11.+keyExpansion :: Int -> Key -> [Key]+keyExpansion nk key = chop4 keys+   where keys :: [SWord32]+         keys = key ++ [nextWord i prev old | i <- [nk ..] | prev <- drop (nk-1) keys | old <- keys]+         chop4 :: [a] -> [[a]]+         chop4 xs = let (f, r) = splitAt 4 xs in f : chop4 r+         nextWord :: Int -> SWord32 -> SWord32 -> SWord32+         nextWord i prev old+           | i `mod` nk == 0           = old `xor` subWordRcon (prev `rotateL` 8) (roundConstants !! (i `div` nk))+           | i `mod` nk == 4 && nk > 6 = old `xor` subWordRcon prev 0+           | True                      = old `xor` prev+         subWordRcon :: SWord32 -> GF28 -> SWord32+         subWordRcon w rc = fromBytes [a `xor` rc, b, c, d]+            where [a, b, c, d] = map sbox $ toBytes w++-----------------------------------------------------------------------------+-- ** The S-box transformation+-----------------------------------------------------------------------------++-- | The values of the AES S-box table. Note that we describe the S-box programmatically+-- using the mathematical construction given in Section 5.1.1 of the standard. However,+-- the code-generation will turn this into a mere look-up table, as it is just a+-- constant table, all computation being done at \"compile-time\".+sboxTable :: [GF28]+sboxTable = [xformByte (gf28Inverse b) | b <- [0 .. 255]]+  where xformByte :: GF28 -> GF28+        xformByte b = foldr xor 0x63 [b `rotateR` i | i <- [0, 4, 5, 6, 7]]++-- | The sbox transformation. We simply select from the sbox table. Note that we+-- are obliged to give a default value (here @0@) to be used if the index is out-of-bounds+-- as required by SBV's 'select' function. However, that will never happen since+-- the table has all 256 elements in it.+sbox :: GF28 -> GF28+sbox = select sboxTable 0++-----------------------------------------------------------------------------+-- ** The inverse S-box transformation+-----------------------------------------------------------------------------++-- | The values of the inverse S-box table. Again, the construction is programmatic.+unSBoxTable :: [GF28]+unSBoxTable = [gf28Inverse (xformByte b) | b <- [0 .. 255]]+  where xformByte :: GF28 -> GF28+        xformByte b = foldr xor 0x05 [b `rotateR` i | i <- [2, 5, 7]]++-- | The inverse s-box transformation.+unSBox :: GF28 -> GF28+unSBox = select unSBoxTable 0++-- | Prove that the 'sbox' and 'unSBox' are inverses. We have:+--+-- >>> prove sboxInverseCorrect+-- Q.E.D.+--+sboxInverseCorrect :: GF28 -> SBool+sboxInverseCorrect x = unSBox (sbox x) .== x &&& sbox (unSBox x) .== x++-----------------------------------------------------------------------------+-- ** AddRoundKey transformation+-----------------------------------------------------------------------------++-- | Adding the round-key to the current state. We simply exploit the fact+-- that addition is just xor in implementing this transformation.+addRoundKey :: Key -> State -> State+addRoundKey = zipWith xor++-----------------------------------------------------------------------------+-- ** Tables for T-Box encryption+-----------------------------------------------------------------------------++-- | T-box table generation function for encryption+t0Func :: GF28 -> [GF28]+t0Func a = [s `gf28Mult` 2, s, s, s `gf28Mult` 3] where s = sbox a++-- | First look-up table used in encryption+t0 :: GF28 -> SWord32+t0 = select t0Table 0 where t0Table = [fromBytes (t0Func a)          | a <- [0..255]]++-- | Second look-up table used in encryption+t1 :: GF28 -> SWord32+t1 = select t1Table 0 where t1Table = [fromBytes (t0Func a `rotR` 1) | a <- [0..255]]++-- | Third look-up table used in encryption+t2 :: GF28 -> SWord32+t2 = select t2Table 0 where t2Table = [fromBytes (t0Func a `rotR` 2) | a <- [0..255]]++-- | Fourth look-up table used in encryption+t3 :: GF28 -> SWord32+t3 = select t3Table 0 where t3Table = [fromBytes (t0Func a `rotR` 3) | a <- [0..255]]++-----------------------------------------------------------------------------+-- ** Tables for T-Box decryption+-----------------------------------------------------------------------------++-- | T-box table generating function for decryption+u0Func :: GF28 -> [GF28]+u0Func a = [s `gf28Mult` 0xE, s `gf28Mult` 0x9, s `gf28Mult` 0xD, s `gf28Mult` 0xB] where s = unSBox a++-- | First look-up table used in decryption+u0 :: GF28 -> SWord32+u0 = select t0Table 0 where t0Table = [fromBytes (u0Func a)          | a <- [0..255]]++-- | Second look-up table used in decryption+u1 :: GF28 -> SWord32+u1 = select t1Table 0 where t1Table = [fromBytes (u0Func a `rotR` 1) | a <- [0..255]]++-- | Third look-up table used in decryption+u2 :: GF28 -> SWord32+u2 = select t2Table 0 where t2Table = [fromBytes (u0Func a `rotR` 2) | a <- [0..255]]++-- | Fourth look-up table used in decryption+u3 :: GF28 -> SWord32+u3 = select t3Table 0 where t3Table = [fromBytes (u0Func a `rotR` 3) | a <- [0..255]]++-----------------------------------------------------------------------------+-- ** AES rounds+-----------------------------------------------------------------------------++-- | Generic round function. Given the function to perform one round, a key-schedule,+-- and a starting state, it performs the AES rounds.+doRounds :: (Bool -> State -> Key -> State) -> KS -> State -> State+doRounds rnd (ikey, rkeys, fkey) sIn = rnd True (last rs) fkey+  where s0 = ikey `addRoundKey` sIn+        rs = s0 : [rnd False s k | s <- rs | k <- rkeys ]++-- | One encryption round. The first argument indicates whether this is the final round+-- or not, in which case the construction is slightly different.+aesRound :: Bool -> State -> Key -> State+aesRound isFinal s key = d `addRoundKey` key+  where d = map (f isFinal) [0..3]+        a = map toBytes s+        f True j = fromBytes [ sbox (a !! ((j+0) `mod` 4) !! 0)+                             , sbox (a !! ((j+1) `mod` 4) !! 1)+                             , sbox (a !! ((j+2) `mod` 4) !! 2)+                             , sbox (a !! ((j+3) `mod` 4) !! 3)+                             ]+        f False j = e0 `xor` e1 `xor` e2 `xor` e3+              where e0 = t0 (a !! ((j+0) `mod` 4) !! 0)+                    e1 = t1 (a !! ((j+1) `mod` 4) !! 1)+                    e2 = t2 (a !! ((j+2) `mod` 4) !! 2)+                    e3 = t3 (a !! ((j+3) `mod` 4) !! 3)++-- | One decryption round. Similar to the encryption round, the first argument+-- indicates whether this is the final round or not.+aesInvRound :: Bool -> State -> Key -> State+aesInvRound isFinal s key = d `addRoundKey` key+  where d = map (f isFinal) [0..3]+        a = map toBytes s+        f True j = fromBytes [ unSBox (a !! ((j+0) `mod` 4) !! 0)+                             , unSBox (a !! ((j+3) `mod` 4) !! 1)+                             , unSBox (a !! ((j+2) `mod` 4) !! 2)+                             , unSBox (a !! ((j+1) `mod` 4) !! 3)+                             ]+        f False j = e0 `xor` e1 `xor` e2 `xor` e3+              where e0 = u0 (a !! ((j+0) `mod` 4) !! 0)+                    e1 = u1 (a !! ((j+3) `mod` 4) !! 1)+                    e2 = u2 (a !! ((j+2) `mod` 4) !! 2)+                    e3 = u3 (a !! ((j+1) `mod` 4) !! 3)++-----------------------------------------------------------------------------+-- * AES API+-----------------------------------------------------------------------------++-- | Key schedule. Given a 128, 192, or 256 bit key, expand it to get key-schedules+-- for encryption and decryption. The key is given as a sequence of 32-bit words.+-- (4 elements for 128-bits, 6 for 192, and 8 for 256.)+aesKeySchedule :: Key -> (KS, KS)+aesKeySchedule key+  | nk `elem` [4, 6, 8]+  = (encKS, decKS)+  | True+  = error "aesKeySchedule: Invalid key size"+  where nk = length key+        nr = nk + 6+        encKS@(f, m, l) = (head rKeys, take (nr-1) (tail rKeys), rKeys !! nr)+        decKS = (l, map invMixColumns (reverse m), f)+        rKeys = keyExpansion nk key++-- | Block encryption. The first argument is the plain-text, which must have+-- precisely 4 elements, for a total of 128-bits of input. The second+-- argument is the key-schedule to be used, obtained by a call to 'aesKeySchedule'.+-- The output will always have 4 32-bit words, which is the cipher-text.+aesEncrypt :: [SWord32] -> KS -> [SWord32]+aesEncrypt pt encKS+  | length pt == 4+  = doRounds aesRound encKS pt+  | True+  = error "aesEncrypt: Invalid plain-text size"++-- | Block decryption. The arguments are the same as in 'aesEncrypt', except+-- the first argument is the cipher-text and the output is the corresponding+-- plain-text.+aesDecrypt :: [SWord32] -> KS -> [SWord32]+aesDecrypt ct decKS+  | length ct == 4+  = doRounds aesInvRound decKS ct+  | True+  = error "aesDecrypt: Invalid cipher-text size"++-----------------------------------------------------------------------------+-- * Test vectors+-----------------------------------------------------------------------------++-----------------------------------------------------------------------------+-- ** 128-bit enc/dec test+-----------------------------------------------------------------------------++-- | 128-bit encryption test, from Appendix C.1 of the AES standard:+--+-- >>> map hex8 t128Enc+-- ["69c4e0d8","6a7b0430","d8cdb780","70b4c55a"]+--+t128Enc :: [SWord32]+t128Enc = aesEncrypt pt ks+  where pt  = [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]+        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f]+        (ks, _) = aesKeySchedule key++-- | 128-bit decryption test, from Appendix C.1 of the AES standard:+--+-- >>> map hex8 t128Dec+-- ["00112233","44556677","8899aabb","ccddeeff"]+--+t128Dec :: [SWord32]+t128Dec = aesDecrypt ct ks+  where ct  = [0x69c4e0d8, 0x6a7b0430, 0xd8cdb780, 0x70b4c55a]+        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f]+        (_, ks) = aesKeySchedule key++-----------------------------------------------------------------------------+-- ** 192-bit enc/dec test+-----------------------------------------------------------------------------++-- | 192-bit encryption test, from Appendix C.2 of the AES standard:+--+-- >>> map hex8 t192Enc+-- ["dda97ca4","864cdfe0","6eaf70a0","ec0d7191"]+--+t192Enc :: [SWord32]+t192Enc = aesEncrypt pt ks+  where pt  = [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]+        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617]+        (ks, _) = aesKeySchedule key++-- | 192-bit decryption test, from Appendix C.2 of the AES standard:+--+-- >>> map hex8 t192Dec+-- ["00112233","44556677","8899aabb","ccddeeff"]+--+t192Dec :: [SWord32]+t192Dec = aesDecrypt ct ks+  where ct  = [0xdda97ca4, 0x864cdfe0, 0x6eaf70a0, 0xec0d7191]+        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617]+        (_, ks) = aesKeySchedule key++-----------------------------------------------------------------------------+-- ** 256-bit enc/dec test+-----------------------------------------------------------------------------++-- | 256-bit encryption, from Appendix C.3 of the AES standard:+--+-- >>> map hex8 t256Enc+-- ["8ea2b7ca","516745bf","eafc4990","4b496089"]+--+t256Enc :: [SWord32]+t256Enc = aesEncrypt pt ks+  where pt  = [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]+        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617, 0x18191a1b, 0x1c1d1e1f]+        (ks, _) = aesKeySchedule key++-- | 256-bit decryption, from Appendix C.3 of the AES standard:+--+-- >>> map hex8 t256Dec+-- ["00112233","44556677","8899aabb","ccddeeff"]+--+t256Dec :: [SWord32]+t256Dec = aesDecrypt ct ks+  where ct  = [0x8ea2b7ca, 0x516745bf, 0xeafc4990, 0x4b496089]+        key = [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f, 0x10111213, 0x14151617, 0x18191a1b, 0x1c1d1e1f]+        (_, ks) = aesKeySchedule key+++-----------------------------------------------------------------------------+-- * Verification+-- ${verifIntro}+-----------------------------------------------------------------------------+{- $verifIntro+  While SMT based technologies can prove correct many small properties fairly quickly, it would+  be naive for them to automatically verify that our AES implementation is correct. (By correct,+  we mean decryption follewed by encryption yielding the same result.) However, we can state+  this property precisely using SBV, and use quick-check to gain some confidence.+-}++-- | Correctness theorem for 128-bit AES. Ideally, we would run:+--+-- @+--   prove aes128IsCorrect+-- @+--+-- to get a proof automatically. Unfortunately, while SBV will successfully generate the proof+-- obligation for this theorem and ship it to the SMT solver, it would be naive to expect the SMT-solver+-- to finish that proof in any reasonable time with the currently available SMT solving technologies.+-- Instead, we can issue:+--+-- @+--   quickCheck aes128IsCorrect+-- @+-- +-- and get some degree of confidence in our code. Similar predicates can be easily constructed for 192, and+-- 256 bit cases as well.+aes128IsCorrect :: (SWord32, SWord32, SWord32, SWord32)  -- ^ plain-text words+                -> (SWord32, SWord32, SWord32, SWord32)  -- ^ key-words+                -> SBool                                 -- ^ True if round-trip gives us plain-text back+aes128IsCorrect (i0, i1, i2, i3) (k0, k1, k2, k3) = pt .== pt'+   where pt  = [i0, i1, i2, i3]+         key = [k0, k1, k2, k3]+         (encKS, decKS) = aesKeySchedule key+         ct  = aesEncrypt pt encKS+         pt' = aesDecrypt ct decKS++-----------------------------------------------------------------------------+-- * Code generation+-- ${codeGenIntro}+-----------------------------------------------------------------------------+{- $codeGenIntro+   We have emphasized that our T-Box implementation in Haskell was guided by clarity and correctness, not+   performance. Indeed, our implementation is hardly the fastest AES implementation in Haskell. However,+   we can use it to automatically generate straight-line C-code that can run fairly fast.++   For the purposes of illustration, we only show here how to generate code for a 128-bit AES block-encrypt+   function, that takes 8 32-bit words as an argument. The first 4 are the 128-bit input, and the final+   four are the 128-bit key. The impact of this is that the generated function would expand the key for+   each block of encryption, a needless task unless we change the key in every block. In a more serios application,+   we would instead generate code for both the 'aesKeySchedule' and the 'aesEncrypt' functions, thus reusing the+   key-schedule over many applications of the encryption call. (Unfortunately doing this is rather cumbersome right+   now, since Haskell does not support fixed-size lists.)+-}++-- | Code generation for 128-bit AES encryption.+--+-- The following sample from the generated code-lines show how T-Boxes are rendered as C arrays:+--+-- @+--   static const SWord32 table1[] = {+--       0xc66363a5UL, 0xf87c7c84UL, 0xee777799UL, 0xf67b7b8dUL,+--       0xfff2f20dUL, 0xd66b6bbdUL, 0xde6f6fb1UL, 0x91c5c554UL,+--       0x60303050UL, 0x02010103UL, 0xce6767a9UL, 0x562b2b7dUL,+--       0xe7fefe19UL, 0xb5d7d762UL, 0x4dababe6UL, 0xec76769aUL,+--       ...+--       }+-- @+--+-- The generated program has 5 tables (one sbox table, and 4-Tboxes), all converted to fast C arrays. Here+-- is a sample of the generated straightline C-code:+--+-- @+--   const SWord8  s1915 = (SWord8) s1912;+--   const SWord8  s1916 = table0[s1915];+--   const SWord16 s1917 = (((SWord16) s1914) << 8) | ((SWord16) s1916);+--   const SWord32 s1918 = (((SWord32) s1911) << 16) | ((SWord32) s1917);+--   const SWord32 s1919 = s1844 ^ s1918;+--   const SWord32 s1920 = s1903 ^ s1919;+-- @+--+-- The GNU C-compiler does a fine job of optimizing this straightline code to generate a fairly efficient C implementation.+cgAES128BlockEncrypt :: IO ()+cgAES128BlockEncrypt = compileToC Nothing "aes128BlockEncrypt" $ do+        pt  <- cgInputArr 4 "pt"        -- plain-text as an array of 4 Word32's+        key <- cgInputArr 4 "key"       -- key as an array of 4 Word32s+        -- Use the test values from Appendix C.1 of the AES standard as the driver values+        cgSetDriverValues $    [0x00112233, 0x44556677, 0x8899aabb, 0xccddeeff]+                            ++ [0x00010203, 0x04050607, 0x08090a0b, 0x0c0d0e0f]+        let (encKs, _) = aesKeySchedule key+        cgOutputArr "ct" $ aesEncrypt pt encKs++-----------------------------------------------------------------------------+-- * C-library generation+-- ${libraryIntro}+-----------------------------------------------------------------------------+{- $libraryIntro+   The 'cgAES128BlockEncrypt' example shows how to generate code for 128-bit AES encryption. As the generated+   function performs encryption on a given block, it performs key expansion as necessary. However, this is+   not quite practical: We would like to expand the key only once, and encrypt the stream of plain-text blocks using+   the same expanded key (potentially using some crypto-mode), until we decide to change the key. In this+   section, we show how to use SBV to instead generate a library of functions that can be used in such a scenario.+   The generated library is a typical @.a@ archive, that can be linked using the C-compiler as usual.+-}++-- | Components of the AES-128 implementation that the library is generated from+aes128LibComponents :: [(String, SBVCodeGen ())]+aes128LibComponents = [ ("aes128KeySchedule",  keySchedule)+                      , ("aes128BlockEncrypt", enc128)+                      , ("aes128BlockDecrypt", dec128)+                      ]+  where -- key-schedule+        keySchedule = do key <- cgInputArr 4 "key"     -- key+                         let (encKS, decKS) = aesKeySchedule key+                         cgOutputArr "encKS" (ksToXKey encKS)+                         cgOutputArr "decKS" (ksToXKey decKS)+        -- encryption+        enc128 = do pt   <- cgInputArr 4  "pt"    -- plain-text+                    xkey <- cgInputArr 44 "xkey"  -- expanded key, for 128-bit AES, the key-expansion has 44 Word32's+                    cgOutputArr "ct" $ aesEncrypt pt (xkeyToKS xkey)+        -- decryption+        dec128 = do pt   <- cgInputArr 4  "ct"    -- cipher-text+                    xkey <- cgInputArr 44 "xkey"  -- expanded key, for 128-bit AES, the key-expansion has 44 Word32's+                    cgOutputArr "pt" $ aesDecrypt pt (xkeyToKS xkey)+        -- Transforming back and forth from our KS type to a flat array used by the generated C code+        -- Turn a series of expanded keys to our internal KS type+        xkeyToKS :: [SWord32] -> KS+        xkeyToKS xs = (f, m, l)+           where f = take 4 xs                       -- first round key+                 m = chop4 (take 36 (drop 4 xs))     -- middle rounds+                 l = drop 40 xs                      -- last round key+        -- Turn a KS to a series of expanded key words+        ksToXKey :: KS -> [SWord32]+        ksToXKey (f, m, l) = f ++ concat m ++ l+        -- chunk in fours. (This function must be in some standard library, where?)+        chop4 :: [a] -> [[a]]+        chop4 [] = []+        chop4 xs = let (f, r) = splitAt 4 xs in f : chop4 r++-- | Generate a C library, containing functions for performing 128-bit enc/dec/key-expansion.+-- A note on performance: In a very rough speed test, the generated code was able to do+-- 6.3 million block encryptions per second on a decent MacBook Pro. On the same machine, OpenSSL+-- reports 8.2 million block encryptions per second. So, the generated code is about 25% slower+-- as compared to the highly optimized OpenSSL implementation. (Note that the speed test was done+-- somewhat simplistically, so these numbers should be considered very rough estimates.)+cgAES128Library :: IO ()+cgAES128Library = compileToCLib Nothing "aes128Lib" aes128LibComponents++--------------------------------------------------------------------------------------------+-- | For doctest purposes only+hex8 :: (SymWord a, Show a, Integral a) => SBV a -> String+hex8 v = replicate (8 - length s) '0' ++ s+  where s = flip showHex "" . fromJust . unliteral $ v++{-# ANN aesRound    ("HLint: ignore Use head" :: String) #-}+{-# ANN aesInvRound ("HLint: ignore Use head" :: String) #-}
+ Documentation/SBV/Examples/Crypto/RC4.hs view
@@ -0,0 +1,153 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Crypto.RC4+-- Copyright   :  (c) Austin Seipp+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- An implementation of RC4 (AKA Rivest Cipher 4 or Alleged RC4/ARC4),+-- using SBV. For information on RC4, see: <http://en.wikipedia.org/wiki/RC4>.+--+-- We make no effort to optimize the code, and instead focus on a clear+-- implementation. In fact, the RC4 algorithm relies on in-place update of+-- its state heavily for efficiency, and is therefore unsuitable for a purely+-- functional implementation.+-----------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables #-}++module Documentation.SBV.Examples.Crypto.RC4 where++import Data.Char  (ord, chr)+import Data.List  (genericIndex)+import Data.Maybe (fromJust)+import Data.SBV++import Data.SBV.Tools.STree++import Numeric (showHex)++-----------------------------------------------------------------------------+-- * Types+-----------------------------------------------------------------------------++-- | RC4 State contains 256 8-bit values. We use the symbolically accessible+-- full-binary type 'STree' to represent the state, since RC4 needs+-- access to the array via a symbolic index and it's important to minimize access time.+type S = STree Word8 Word8++-- | Construct the fully balanced initial tree, where the leaves are simply the numbers @0@ through @255@.+initS :: S+initS = mkSTree (map literal [0 .. 255])++-- | The key is a stream of 'Word8' values.+type Key = [SWord8]++-- | Represents the current state of the RC4 stream: it is the @S@ array+-- along with the @i@ and @j@ index values used by the PRGA.+type RC4 = (S, SWord8, SWord8)++-----------------------------------------------------------------------------+-- * The PRGA+-----------------------------------------------------------------------------++-- | Swaps two elements in the RC4 array.+swap :: SWord8 -> SWord8 -> S -> S+swap i j st = writeSTree (writeSTree st i stj) j sti+  where sti = readSTree st i+        stj = readSTree st j++-- | Implements the PRGA used in RC4. We return the new state and the next key value generated.+prga :: RC4 -> (SWord8, RC4)+prga (st', i', j') = (readSTree st kInd, (st, i, j))+  where i    = i' + 1+        j    = j' + readSTree st' i+        st   = swap i j st'+        kInd = readSTree st i + readSTree st j++-----------------------------------------------------------------------------+-- * Key schedule+-----------------------------------------------------------------------------++-- | Constructs the state to be used by the PRGA using the given key.+initRC4 :: Key -> S+initRC4 key+ | keyLength < 1 || keyLength > 256+ = error $ "RC4 requires a key of length between 1 and 256, received: " ++ show keyLength+ | True+ = snd $ foldl mix (0, initS) [0..255]+ where keyLength = length key+       mix :: (SWord8, S) -> SWord8 -> (SWord8, S)+       mix (j', s) i = let j = j' + readSTree s i + genericIndex key (fromJust (unliteral i) `mod` fromIntegral keyLength)+                       in (j, swap i j s)++-- | The key-schedule. Note that this function returns an infinite list.+keySchedule :: Key -> [SWord8]+keySchedule key = genKeys (initRC4 key, 0, 0)+  where genKeys :: RC4 -> [SWord8]+        genKeys st = let (k, st') = prga st in k : genKeys st'++-- | Generate a key-schedule from a given key-string.+keyScheduleString :: String -> [SWord8]+keyScheduleString = keySchedule . map (literal . fromIntegral . ord)++-----------------------------------------------------------------------------+-- * Encryption and Decryption+-----------------------------------------------------------------------------++-- | RC4 encryption. We generate key-words and xor it with the input. The+-- following test-vectors are from Wikipedia <http://en.wikipedia.org/wiki/RC4>:+--+-- >>> concatMap hex2 $ encrypt "Key" "Plaintext"+-- "bbf316e8d940af0ad3"+--+-- >>> concatMap hex2 $ encrypt "Wiki" "pedia"+-- "1021bf0420"+--+-- >>> concatMap hex2 $ encrypt "Secret" "Attack at dawn"+-- "45a01f645fc35b383552544b9bf5"+encrypt :: String -> String -> [SWord8]+encrypt key pt = zipWith xor (keyScheduleString key) (map cvt pt)+  where cvt = literal . fromIntegral . ord++-- | RC4 decryption. Essentially the same as decryption. For the above test vectors we have:+--+-- >>> decrypt "Key" [0xbb, 0xf3, 0x16, 0xe8, 0xd9, 0x40, 0xaf, 0x0a, 0xd3]+-- "Plaintext"+--+-- >>> decrypt "Wiki" [0x10, 0x21, 0xbf, 0x04, 0x20]+-- "pedia"+--+-- >>> decrypt "Secret" [0x45, 0xa0, 0x1f, 0x64, 0x5f, 0xc3, 0x5b, 0x38, 0x35, 0x52, 0x54, 0x4b, 0x9b, 0xf5]+-- "Attack at dawn"+decrypt :: String -> [SWord8] -> String+decrypt key ct = map cvt $ zipWith xor (keyScheduleString key) ct+  where cvt = chr . fromIntegral . fromJust . unliteral++-----------------------------------------------------------------------------+-- * Verification+-----------------------------------------------------------------------------++-- | Prove that round-trip encryption/decryption leaves the plain-text unchanged.+-- The theorem is stated parametrically over key and plain-text sizes. The expression+-- performs the proof for a 40-bit key (5 bytes) and 40-bit plaintext (again 5 bytes).+--+-- Note that this theorem is trivial to prove, since it is essentially establishing+-- xor'in the same value twice leaves a word unchanged (i.e., @x `xor` y `xor` y = x@).+-- However, the proof takes quite a while to complete, as it gives rise to a fairly+-- large symbolic trace.+rc4IsCorrect :: IO ThmResult+rc4IsCorrect = prove $ do+        key <- mkForallVars 5+        pt  <- mkForallVars 5+        let ks  = keySchedule key+            ct  = zipWith xor ks pt+            pt' = zipWith xor ks ct+        return $ pt .== pt'++--------------------------------------------------------------------------------------------+-- | For doctest purposes only+hex2 :: (SymWord a, Show a, Integral a) => SBV a -> String+hex2 v = replicate (2 - length s) '0' ++ s+  where s = flip showHex "" . fromJust . unliteral $ v
+ Documentation/SBV/Examples/Existentials/CRCPolynomial.hs view
@@ -0,0 +1,101 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Existentials.CRCPolynomial+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- This program demonstrates the use of the existentials and the QBVF (quantified+-- bit-vector solver). We generate CRC polynomials of degree 16 that can be used+-- for messages of size 48-bits. The query finds all such polynomials that have hamming+-- distance is at least 4. That is, if the CRC can't tell two different 48-bit messages+-- apart, then they must differ in at least 4 bits.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Existentials.CRCPolynomial where++import Data.SBV+import Data.SBV.Tools.Polynomial++-----------------------------------------------------------------------------+-- * Modeling 48 bit words+-----------------------------------------------------------------------------+-- | SBV doesn't support 48 bit words natively. So, we represent them+-- as a tuple, 32 high-bits and 16 low-bits.+type SWord48 = (SWord32, SWord16)++-- | Compute the 16 bit CRC of a 48 bit message, using the given polynomial+crc_48_16 :: SWord48 -> SWord16 -> [SBool]+crc_48_16 msg poly = crcBV 16 msgBits polyBits+  where (hi, lo) = msg+        msgBits  = blastBE hi ++ blastBE lo+        polyBits = blastBE poly++-- | Count the differing bits in the message and the corresponding CRC+diffCount :: (SWord48, [SBool]) -> (SWord48, [SBool]) -> SWord8+diffCount ((h1, l1), crc1) ((h2, l2), crc2) = count xorBits+  where bits1   = blastBE h1 ++ blastBE l1 ++ crc1+        bits2   = blastBE h2 ++ blastBE l2 ++ crc2+        -- xor will give us a false if bits match, true if they differ+        xorBits = zipWith (<+>) bits1 bits2+        count []     = 0+        count (b:bs) = let r = count bs in ite b (1+r) r++-- | Given a hamming distance value @hd@, 'crcGood' returns @true@ if+-- the 16 bit polynomial can distinguish all messages that has at most+-- @hd@ different bits. Note that we express this conversely: If the+-- @sent@ and @received@ messages are different, then it must be the+-- case that that must differ from each other (including CRCs), in+-- more than @hd@ bits.+crcGood :: SWord8 -> SWord16 -> SWord48 -> SWord48 -> SBool+crcGood hd poly sent received =+     sent ./= received ==> diffCount (sent, crcSent) (received, crcReceived) .>= hd+   where crcSent     = crc_48_16 sent     poly+         crcReceived = crc_48_16 received poly++-- | Generate good CRC polynomials for 48-bit words, given the hamming distance @hd@.+genPoly :: SWord8 -> IO ()+genPoly hd = do res <- allSat $ do+                        -- the polynomial is existentially specified+                        p <- exists "polynomial"+                        -- sent word, universal+                        s <- do sh <- forall "sh"+                                sl <- forall "sl"+                                return (sh, sl)+                        -- received word, universal+                        r <- do rh <- forall "rh"+                                rl <- forall "rl"+                                return (rh, rl)+                        -- assert that the polynomial @p@ is good. Note+                        -- that we also supply the extra information that+                        -- the least significant bit must be set in the+                        -- polynomial, as all CRC polynomials have the "+1"+                        -- term in them set. This simplifies the query.+                        return $ sTestBit p 0 &&& crcGood hd p s r+                cnt <- displayModels disp res+                putStrLn $ "Found: " ++ show cnt ++ " polynomail(s)."+        where disp :: Int -> (Bool, Word16) -> IO ()+              disp n (_, s) = putStrLn $ "Polynomial #" ++ show n ++ ". x^16 + " ++ showPolynomial False s++-- | Find and display all degree 16 polynomials with hamming distance at least 4, for 48 bit messages.+--+-- When run, this function prints:+--+--  @+--    Polynomial #1. x^16 + x^2 + x + 1+--    Polynomial #2. x^16 + x^15 + x^2 + 1+--    Polynomial #3. x^16 + x^15 + x^2 + x + 1+--    Polynomial #4. x^16 + x^14 + x^10 + 1+--    Polynomial #5. x^16 + x^14 + x^9 + 1+--    ...+--  @+--+-- Note that different runs can produce different results, depending on the random+-- numbers used by the solver, solver version, etc. (Also, the solver will take some+-- time to generate these results. On my machine, the first five polynomials were+-- generated in about 5 minutes.)+findHD4Polynomials :: IO ()+findHD4Polynomials = genPoly 4++{-# ANN crc_48_16 ("HLint: ignore Use camelCase" :: String) #-}
+ Documentation/SBV/Examples/Existentials/Diophantine.hs view
@@ -0,0 +1,147 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Existentials.Diophantine+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Finding minimal natural number solutions to linear Diophantine equations,+-- using explicit quantification.+-----------------------------------------------------------------------------+module Documentation.SBV.Examples.Existentials.Diophantine where++import Data.SBV+import Data.SBV.Control++--------------------------------------------------------------------------------------------------+-- * Representing solutions+--------------------------------------------------------------------------------------------------+-- | For a homogeneous problem, the solution is any linear combination of the resulting vectors.+-- For a non-homogeneous problem, the solution is any linear combination of the vectors in the+-- second component plus one of the vectors in the first component.+data Solution = Homogeneous    [[Integer]]+              | NonHomogeneous [[Integer]] [[Integer]]+              deriving Show++--------------------------------------------------------------------------------------------------+-- * Solving diophantine equations+--------------------------------------------------------------------------------------------------+-- | ldn: Solve a (L)inear (D)iophantine equation, returning minimal solutions over (N)aturals.+-- The input is given as a rows of equations, with rhs values separated into a tuple. The first+-- parameter limits the search to bound: In case there are too many solutions, you might want+-- to limit your search space.+ldn :: Maybe Int -> [([Integer], Integer)] -> IO Solution+ldn mbLim problem = do solution <- basis mbLim (map (map literal) m)+                       if homogeneous+                           then return $ Homogeneous solution+                           else do let ones  = [xs | (1:xs) <- solution]+                                       zeros = [xs | (0:xs) <- solution]+                                   return $ NonHomogeneous ones zeros+  where rhs = map snd problem+        lhs = map fst problem+        homogeneous = all (== 0) rhs+        m | homogeneous = lhs+          | True        = zipWith (\x y -> -x : y) rhs lhs++-- | Find the basis solution. By definition, the basis has all non-trivial (i.e., non-0) solutions+-- that cannot be written as the sum of two other solutions. We use the mathematically equivalent+-- statement that a solution is in the basis if it's least according to the lexicographic+-- order using the ordinary less-than relation. (NB. We explicitly tell z3 to use the logic+-- AUFLIA for this problem, as the BV solver that is chosen automatically has a performance+-- issue. See: <https://z3.codeplex.com/workitem/88>.)+basis :: Maybe Int -> [[SInteger]] -> IO [[Integer]]+basis mbLim m = extractModels `fmap` allSatWith z3{allSatMaxModelCount = mbLim} cond+ where cond = do as <- mkExistVars  n+                 bs <- mkForallVars n++                 -- Tell the solver to use this logic!+                 setLogic AUFLIA++                 return $ ok as &&& (ok bs ==> as .== bs ||| bnot (bs `less` as))++       n = if null m then 0 else length (head m)++       ok xs = bAny (.> 0) xs &&& bAll (.>= 0) xs &&& bAnd [sum (zipWith (*) r xs) .== 0 | r <- m]+       as `less` bs = bAnd (zipWith (.<=) as bs) &&& bOr (zipWith (.<) as bs)++--------------------------------------------------------------------------------------------------+-- * Examples+--------------------------------------------------------------------------------------------------++-- | Solve the equation:+--+--    @2x + y - z = 2@+--+-- We have:+--+-- >>> test+-- NonHomogeneous [[0,2,0],[1,0,0]] [[0,1,1],[1,0,2]]+--+-- which means that the solutions are of the form:+--+--    @(1, 0, 0) + k (0, 1, 1) + k' (1, 0, 2) = (1+k', k, k+2k')@+--+-- OR+--+--    @(0, 2, 0) + k (0, 1, 1) + k' (1, 0, 2) = (k', 2+k, k+2k')@+--+-- for arbitrary @k@, @k'@. It's easy to see that these are really solutions+-- to the equation given. It's harder to see that they cover all possibilities,+-- but a moments thought reveals that is indeed the case.+test :: IO Solution+test = ldn Nothing [([2,1,-1], 2)]++-- | A puzzle: Five sailors and a monkey escape from a naufrage and reach an island with+-- coconuts. Before dawn, they gather a few of them and decide to sleep first and share+-- the next day. At night, however, one of them awakes, counts the nuts, makes five parts,+-- gives the remaining nut to the monkey, saves his share away, and sleeps. All other+-- sailors do the same, one by one. When they all wake up in the morning, they again make 5 shares,+-- and give the last remaining nut to the monkey. How many nuts were there at the beginning?+--+-- We can model this as a series of diophantine equations:+--+-- @+--       x_0 = 5 x_1 + 1+--     4 x_1 = 5 x_2 + 1+--     4 x_2 = 5 x_3 + 1+--     4 x_3 = 5 x_4 + 1+--     4 x_4 = 5 x_5 + 1+--     4 x_5 = 5 x_6 + 1+-- @+--+-- We need to solve for x_0, over the naturals. We have:+--+-- >>> sailors+-- [15621,3124,2499,1999,1599,1279,1023]+--+-- That is:+--+-- @+--   * There was a total of 15621 coconuts+--   * 1st sailor: 15621 = 3124*5+1, leaving 15621-3124-1 = 12496+--   * 2nd sailor: 12496 = 2499*5+1, leaving 12496-2499-1 =  9996+--   * 3rd sailor:  9996 = 1999*5+1, leaving  9996-1999-1 =  7996+--   * 4th sailor:  7996 = 1599*5+1, leaving  7996-1599-1 =  6396+--   * 5th sailor:  6396 = 1279*5+1, leaving  6396-1279-1 =  5116+--   * In the morning, they had: 5116 = 1023*5+1.+-- @+--+-- Note that this is the minimum solution, that is, we are guaranteed that there's+-- no solution with less number of coconuts. In fact, any member of @[15625*k-4 | k <- [1..]]@+-- is a solution, i.e., so are @31246@, @46871@, @62496@, @78121@, etc.+--+-- Note that we iteratively deepen our search by requesting increasing number of+-- solutions to avoid the all-sat pitfall.+sailors :: IO [Integer]+sailors = search 1+  where search i = do soln <- ldn (Just i) [ ([1, -5,  0,  0,  0,  0,  0], 1)+                                           , ([0,  4, -5 , 0,  0,  0,  0], 1)+                                           , ([0,  0,  4, -5 , 0,  0,  0], 1)+                                           , ([0,  0,  0,  4, -5,  0,  0], 1)+                                           , ([0,  0,  0,  0,  4, -5,  0], 1)+                                           , ([0,  0,  0,  0,  0,  4, -5], 1)+                                           ]+                      case soln of+                        NonHomogeneous (xs:_) _ -> return xs+                        _                       -> search (i+1)
+ Documentation/SBV/Examples/Misc/Auxiliary.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Misc.Auxiliary+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates model construction with auxiliary variables. Sometimes we+-- need to introduce a variable in our problem as an existential variable,+-- but it's "internal" to the problem and we do not consider it as part of+-- the solution. Also, in an `allSat` scenario, we may not care for models+-- that only differ in these auxiliaries. SBV allows designating such variables+-- as `isNonModelVar` so we can still use them like any other variable, but without+-- considering them explicitly in model construction.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Misc.Auxiliary where++import Data.SBV++-- | A simple predicate, based on two variables @x@ and @y@, true when+-- @0 <= x <= 1@ and @x - abs y@ is @0@.+problem :: Predicate+problem = do x <- free "x"+             y <- free "y"+             constrain $ x .>= 0+             constrain $ x .<= 1+             return $ x - abs y .== (0 :: SInteger)++-- | Generate all satisfying assignments for our problem. We have:+--+-- >>> allModels+-- Solution #1:+--   x = 0 :: Integer+--   y = 0 :: Integer+-- Solution #2:+--   x = 1 :: Integer+--   y = 1 :: Integer+-- Solution #3:+--   x =  1 :: Integer+--   y = -1 :: Integer+-- Found 3 different solutions.+--+-- Note that solutions @2@ and @3@ share the value @x = 1@, since there are+-- multiple values of @y@ that make this particular choice of @x@ satisfy our constraint.+allModels :: IO AllSatResult+allModels = allSat problem++-- | Generate all satisfying assignments, but we first tell SBV that @y@ should not be considered+-- as a model problem, i.e., it's auxiliary. We have:+--+-- >>> modelsWithYAux+-- Solution #1:+--   x = 0 :: Integer+-- Solution #2:+--   x = 1 :: Integer+-- Found 2 different solutions.+--+-- Note that we now have only two solutions, one for each unique value of @x@ that satisfy our+-- constraint.+modelsWithYAux :: IO AllSatResult+modelsWithYAux = allSatWith z3{isNonModelVar = (`elem` ["y"])} problem
+ Documentation/SBV/Examples/Misc/Enumerate.hs view
@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Misc.Enumerate+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates how enumerations can be translated to their SMT-Lib+-- counterparts, without losing any information content. Also see+-- "Documentation.SBV.Examples.Puzzles.U2Bridge" for a more detailed+-- example involving enumerations.+-----------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Documentation.SBV.Examples.Misc.Enumerate where++import Data.SBV++-- | A simple enumerated type, that we'd like to translate to SMT-Lib intact;+-- i.e., this type will not be uninterpreted but rather preserved and will+-- be just like any other symbolic type SBV provides.+--+-- Also note that we need to have the following @LANGUAGE@ options defined:+-- @TemplateHaskell@, @StandaloneDeriving@, @DeriveDataTypeable@, @DeriveAnyClass@ for+-- this to work.+data E = A | B | C++-- | Make 'E' a symbolic value.+mkSymbolicEnumeration ''E++-- | Give a name to the symbolic variants of 'E', for convenience+type SE = SBV E++-- | Have the SMT solver enumerate the elements of the domain. We have:+--+-- >>> elts+-- Solution #1:+--   s0 = B :: E+-- Solution #2:+--   s0 = A :: E+-- Solution #3:+--   s0 = C :: E+-- Found 3 different solutions.+elts :: IO AllSatResult+elts = allSat $ \(x::SE) -> x .== x++-- | Shows that if we require 4 distinct elements of the type 'E', we shall fail; as+-- the domain only has three elements. We have:+--+-- >>> four+-- Unsatisfiable+four :: IO SatResult+four = sat $ \a b c (d::SE) -> distinct [a, b, c, d]++-- | Enumerations are automatically ordered, so we can ask for the maximum+-- element. Note the use of quantification. We have:+--+-- >>> maxE+-- Satisfiable. Model:+--   maxE = C :: E+maxE :: IO SatResult+maxE = sat $ do mx <- exists "maxE"+                e  <- forall "e"+                return $ mx .>= (e::SE)++-- | Similarly, we get the minumum element. We have:+--+-- >>> minE+-- Satisfiable. Model:+--   minE = A :: E+minE :: IO SatResult+minE = sat $ do mx <- exists "minE"+                e  <- forall "e"+                return $ mx .<= (e::SE)
+ Documentation/SBV/Examples/Misc/Floating.hs view
@@ -0,0 +1,187 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Misc.Floating+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Several examples involving IEEE-754 floating point numbers, i.e., single+-- precision 'Float' ('SFloat') and double precision 'Double' ('SDouble') types.+--+-- Note that arithmetic with floating point is full of surprises; due to precision+-- issues associativity of arithmetic operations typically do not hold. Also,+-- the presence of @NaN@ is always something to look out for.+-----------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables #-}++module Documentation.SBV.Examples.Misc.Floating where++import Data.SBV++-----------------------------------------------------------------------------+-- * FP addition is not associative+-----------------------------------------------------------------------------++-- | Prove that floating point addition is not associative. For illustration purposes,+-- we will require one of the inputs to be a @NaN@. We have:+--+-- >>> prove $ assocPlus (0/0)+-- Falsifiable. Counter-example:+--   s0 = 0.0 :: Float+--   s1 = 0.0 :: Float+--+-- Indeed:+--+-- >>> let i = 0/0 :: Float+-- >>> i + (0.0 + 0.0)+-- NaN+-- >>> ((i + 0.0) + 0.0)+-- NaN+--+-- But keep in mind that @NaN@ does not equal itself in the floating point world! We have:+--+-- >>> let nan = 0/0 :: Float in nan == nan+-- False+assocPlus :: SFloat -> SFloat -> SFloat -> SBool+assocPlus x y z = x + (y + z) .== (x + y) + z++-- | Prove that addition is not associative, even if we ignore @NaN@/@Infinity@ values.+-- To do this, we use the predicate 'fpIsPoint', which is true of a floating point+-- number ('SFloat' or 'SDouble') if it is neither @NaN@ nor @Infinity@. (That is, it's a+-- representable point in the real-number line.)+--+-- We have:+--+-- >>> assocPlusRegular+-- Falsifiable. Counter-example:+--   x =  1.9259302e-34 :: Float+--   y = -1.9259117e-34 :: Float+--   z =  -1.814176e-39 :: Float+--+-- Indeed, we have:+--+-- >>> ((1.9259302e-34) + ((-1.9259117e-34) + (-1.814176e-39))) :: Float+-- 3.4438e-41+-- >>> (((1.9259302e-34) + ((-1.9259117e-34))) + (-1.814176e-39)) :: Float+-- 3.4014e-41+--+-- Note the difference between two additions!+assocPlusRegular :: IO ThmResult+assocPlusRegular = prove $ do [x, y, z] <- sFloats ["x", "y", "z"]+                              let lhs = x+(y+z)+                                  rhs = (x+y)+z+                              -- make sure we do not overflow at the intermediate points+                              constrain $ fpIsPoint lhs+                              constrain $ fpIsPoint rhs+                              return $ lhs .== rhs++-----------------------------------------------------------------------------+-- * FP addition by non-zero can result in no change+-----------------------------------------------------------------------------++-- | Demonstrate that @a+b = a@ does not necessarily mean @b@ is @0@ in the floating point world,+-- even when we disallow the obvious solution when @a@ and @b@ are @Infinity.@+-- We have:+--+-- >>> nonZeroAddition+-- Falsifiable. Counter-example:+--   a = 2.424457e-38 :: Float+--   b =     -1.0e-45 :: Float+--+-- Indeed, we have:+--+-- >>> (2.424457e-38 + (-1.0e-45)) == (2.424457e-38 :: Float)+-- True+--+-- But:+--+-- >>> -1.0e-45 == (0 :: Float)+-- False+--+nonZeroAddition :: IO ThmResult+nonZeroAddition = prove $ do [a, b] <- sFloats ["a", "b"]+                             constrain $ fpIsPoint a+                             constrain $ fpIsPoint b+                             constrain $ a + b .== a+                             return $ b .== 0++-----------------------------------------------------------------------------+-- * FP multiplicative inverses may not exist+-----------------------------------------------------------------------------++-- | This example illustrates that @a * (1/a)@ does not necessarily equal @1@. Again,+-- we protect against division by @0@ and @NaN@/@Infinity@.+--+-- We have:+--+-- >>> multInverse+-- Falsifiable. Counter-example:+--   a = 1.119056263978578e-308 :: Double+--+-- Indeed, we have:+--+-- >>> let a = 1.119056263978578e-308 :: Double+-- >>> a * (1/a)+-- 0.9999999999999999+multInverse :: IO ThmResult+multInverse = prove $ do a <- sDouble "a"+                         constrain $ fpIsPoint a+                         constrain $ fpIsPoint (1/a)+                         return $ a * (1/a) .== 1++-----------------------------------------------------------------------------+-- * Effect of rounding modes+-----------------------------------------------------------------------------++-- | One interesting aspect of floating-point is that the chosen rounding-mode+-- can effect the results of a computation if the exact result cannot be precisely+-- represented. SBV exports the functions 'fpAdd', 'fpSub', 'fpMul', 'fpDiv', 'fpFMA'+-- and 'fpSqrt' which allows users to specify the IEEE supported 'RoundingMode' for+-- the operation. (Also see the class 'RoundingFloat'.) This example illustrates how SBV+-- can be used to find rounding-modes where, for instance, addition can produce different+-- results. We have:+--+-- >>> roundingAdd+-- Satisfiable. Model:+--   rm = RoundTowardPositive :: RoundingMode+--   x  =                 1.0 :: Float+--   y  =       -6.1035094e-5 :: Float+--+-- (Note that depending on your version of Z3, you might get a different result.)+-- Unfortunately we can't directly validate this result at the Haskell level, as Haskell only supports+-- 'RoundNearestTiesToEven'. We have:+--+-- >>> (1 + (-6.1035094e-5)) :: Float+-- 0.99993896+--+-- While we cannot directly see the result when the mode is 'RoundTowardPositive' in Haskell, we can use+-- SBV to provide us with that result thusly:+--+-- >>> sat $ \z -> z .== fpAdd sRoundTowardPositive   1 (-6.1035094e-5 :: SFloat)+-- Satisfiable. Model:+--   s0 = 0.999939 :: Float+--+-- We can see why these two resuls are indeed different: The 'RoundTowardsPositive'+-- (which rounds towards positive-infinity) produces a larger result. Indeed, if we treat these numbers+-- as 'Double' values, we get:+--+-- >>> (1 + (-6.1035094e-5)) :: Double+-- 0.999938964906+--+-- we see that the "more precise" result is larger than what the 'Float' value is, justifying the+-- larger value with 'RoundTowardPositive'. A more detailed study is beyond our current scope, so we'll+--  merely -- note that floating point representation and semantics is indeed a thorny+-- subject, and point to <https://ece.uwaterloo.ca/~dwharder/NumericalAnalysis/02Numerics/Double/paper.pdf> as+-- an excellent guide.+roundingAdd :: IO SatResult+roundingAdd = sat $ do m :: SRoundingMode <- free "rm"+                       constrain $ m ./= literal RoundNearestTiesToEven+                       x <- sFloat "x"+                       y <- sFloat "y"+                       let lhs = fpAdd m x y+                       let rhs = x + y+                       constrain $ fpIsPoint lhs+                       constrain $ fpIsPoint rhs+                       return $ lhs ./= rhs
+ Documentation/SBV/Examples/Misc/ModelExtract.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Misc.ModelExtract+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates use of programmatic model extraction. When programming with+-- SBV, we typically use `sat`/`allSat` calls to compute models automatically.+-- In more advanced uses, however, the user might want to use programmable+-- extraction features to do fancier programming. We demonstrate some of+-- these utilities here.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Misc.ModelExtract where++import Data.SBV++-- | A simple function to generate a new integer value, that is not in the+-- given set of values. We also require the value to be non-negative+outside :: [Integer] -> IO SatResult+outside disallow = sat $ do x <- sInteger "x"+                            let notEq i = constrain $ x ./= literal i+                            mapM_ notEq disallow+                            return $ x .>= 0++-- | We now use "outside" repeatedly to generate 10 integers, such that we not only disallow+-- previously generated elements, but also any value that differs from previous solutions+-- by less than 5.  Here, we use the `getModelValue` function. We could have also extracted the dictionary+-- via `getModelDictionary` and did fancier programming as well, as necessary. We have:+--+-- >>> genVals+-- [45,40,35,30,25,20,15,10,5,0]+genVals :: IO [Integer]+genVals = go [] []+  where go _ model+         | length model >= 10 = return model+        go disallow model+          = do res <- outside disallow+               -- Look up the value of "x" in the generated model+               -- Note that we simply get an integer here; but any+               -- SBV known type would be OK as well.+               case "x" `getModelValue` res of+                 Just c -> go [c-4 .. c+4] (c : model)+                 _      -> return model
+ Documentation/SBV/Examples/Misc/NoDiv0.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Misc.NoDiv0+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates SBV's assertion checking facilities+-----------------------------------------------------------------------------++{-# LANGUAGE ImplicitParams #-}++module Documentation.SBV.Examples.Misc.NoDiv0 where++import Data.SBV+import GHC.Stack++-- | A simple variant of division, where we explicitly require the+-- caller to make sure the divisor is not 0.+checkedDiv :: (?loc :: CallStack) => SInt32 -> SInt32 -> SInt32+checkedDiv x y = sAssert (Just ?loc)+                         "Divisor should not be 0"+                         (y ./= 0)+                         (x `sDiv` y)++-- | Check whether an arbitrary call to 'checkedDiv' is safe. Clearly, we do not expect+-- this to be safe:+--+-- >>> test1+-- [Documentation/SBV/Examples/Misc/NoDiv0.hs:36:14:checkedDiv: Divisor should not be 0: Violated. Model:+--   s0 = 0 :: Int32+--   s1 = 0 :: Int32]+--+test1 :: IO [SafeResult]+test1 = safe checkedDiv++-- | Repeat the test, except this time we explicitly protect against the bad case. We have:+--+-- >>> test2+-- [Documentation/SBV/Examples/Misc/NoDiv0.hs:44:41:checkedDiv: Divisor should not be 0: No violations detected]+--+test2 :: IO [SafeResult]+test2 = safe $ \x y -> ite (y .== 0) 3 (checkedDiv x y)
+ Documentation/SBV/Examples/Misc/Polynomials.hs view
@@ -0,0 +1,78 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Misc.Polynomials+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Simple usage of polynomials over GF(2^n), using Rijndael's+-- finite field: <http://en.wikipedia.org/wiki/Finite_field_arithmetic#Rijndael.27s_finite_field>+--+-- The functions available are:+--+--  [/pMult/] GF(2^n) Multiplication+--+--  [/pDiv/] GF(2^n) Division+--+--  [/pMod/] GF(2^n) Modulus+--+--  [/pDivMod/] GF(2^n) Division/Modulus, packed together+--+-- Note that addition in GF(2^n) is simply `xor`, so no custom function is provided.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Misc.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.+type GF28 = SWord8++-- | Multiplication in Rijndael's field; usual polynomial multiplication followed by reduction+-- by the irreducible polynomial.  The irreducible used by Rijndael's field is the polynomial+-- @x^8 + x^4 + x^3 + x + 1@, which we write by giving it's /exponents/ in SBV.+-- See: <http://en.wikipedia.org/wiki/Finite_field_arithmetic#Rijndael.27s_finite_field>.+-- Note that the irreducible itself is not in GF28! It has a degree of 8.+--+-- NB. You can use the 'showPoly' function to print polynomials nicely, as a mathematician would write.+gfMult :: GF28 -> GF28 -> GF28+a `gfMult` b = pMult (a, b, [8, 4, 3, 1, 0])++-- | States that the unit polynomial @1@, is the unit element+multUnit :: GF28 -> SBool+multUnit x = (x `gfMult` unit) .== x+  where unit = polynomial [0]   -- x@0++-- | States that multiplication is commutative+multComm :: GF28 -> GF28 -> SBool+multComm x y = (x `gfMult` y) .== (y `gfMult` x)++-- | States that multiplication is associative, note that associativity+-- proofs are notoriously hard for SAT/SMT solvers+multAssoc :: GF28 -> GF28 -> GF28 -> SBool+multAssoc x y z = ((x `gfMult` y) `gfMult` z) .== (x `gfMult` (y `gfMult` z))++-- | States that the usual multiplication rule holds over GF(2^n) polynomials+-- Checks:+--+-- @+--    if (a, b) = x `pDivMod` y then x = y `pMult` a + b+-- @+--+-- being careful about @y = 0@. When divisor is 0, then quotient is+-- defined to be 0 and the remainder is the numerator.+-- (Note that addition is simply `xor` in GF(2^8).)+polyDivMod :: GF28 -> GF28 -> SBool+polyDivMod x y = ite (y .== 0) ((0, x) .== (a, b)) (x .== (y `gfMult` a) `xor` b)+  where (a, b) = x `pDivMod` y++-- | Queries+testGF28 :: IO ()+testGF28 = do+  print =<< prove multUnit+  print =<< prove multComm+  -- print =<< prove multAssoc -- takes too long; see above note..+  print =<< prove polyDivMod
+ Documentation/SBV/Examples/Misc/Word4.hs view
@@ -0,0 +1,145 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Misc.Enumerate+-- Copyright   :  (c) Brian Huffman+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates how new sizes of word/int types can be defined and+-- used with SBV.+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Documentation.SBV.Examples.Misc.Word4 where++import GHC.Enum (boundedEnumFrom, boundedEnumFromThen, toEnumError, succError, predError)++import Data.Bits+import Data.Generics (Data, Typeable)+import System.Random (Random(..))++import Data.SBV+import Data.SBV.Internals++-- | Word4 as a newtype. Invariant: @Word4 x@ should satisfy @x < 16@.+newtype Word4 = Word4 Word8+  deriving (Eq, Ord, Data, Typeable)++-- | Smart constructor; simplifies conversion from Word8+word4 :: Word8 -> Word4+word4 x = Word4 (x .&. 0x0f)++-- | Show instance+instance Show Word4 where+  show (Word4 x) = show x++-- | Read instance. We read as an 8-bit word, and coerce+instance Read Word4 where+  readsPrec p s = [ (word4 x, s') | (x, s') <- readsPrec p s ]++-- | Bounded instance; from 0 to 255+instance Bounded Word4 where+  minBound = Word4 0x00+  maxBound = Word4 0x0f++-- | Enum instance, trivial definitions.+instance Enum Word4 where+  succ (Word4 x) = if x < 0x0f then Word4 (succ x) else succError "Word4"+  pred (Word4 x) = if x > 0x00 then Word4 (pred x) else predError "Word4"+  toEnum i | 0x00 <= i && i <= 0x0f = Word4 (toEnum i)+           | otherwise              = toEnumError "Word4" i (Word4 0x00, Word4 0x0f)+  fromEnum (Word4 x) = fromEnum x+  -- Comprehensions+  enumFrom                                     = boundedEnumFrom+  enumFromThen                                 = boundedEnumFromThen+  enumFromTo     (Word4 x) (Word4 y)           = map Word4 (enumFromTo x y)+  enumFromThenTo (Word4 x) (Word4 y) (Word4 z) = map Word4 (enumFromThenTo x y z)++-- | Num instance, merely lifts underlying 8-bit operation and casts back+instance Num Word4 where+  Word4 x + Word4 y = word4 (x + y)+  Word4 x * Word4 y = word4 (x * y)+  Word4 x - Word4 y = word4 (x - y)+  negate (Word4 x)  = word4 (negate x)+  abs (Word4 x)     = Word4 x+  signum (Word4 x)  = Word4 (if x == 0 then 0 else 1)+  fromInteger n     = word4 (fromInteger n)++-- | Real instance simply uses the Word8 instance+instance Real Word4 where+  toRational (Word4 x) = toRational x++-- | Integral instance, again using Word8 instance and casting. NB. we do+-- not need to use the smart constructor here as neither the quotient nor+-- the remainder can overflow a Word4.+instance Integral Word4 where+  quotRem (Word4 x) (Word4 y) = (Word4 q, Word4 r)+    where (q, r) = quotRem x y+  toInteger (Word4 x) = toInteger x++-- | Bits instance+instance Bits Word4 where+  Word4 x  .&.  Word4 y = Word4 (x  .&.  y)+  Word4 x  .|.  Word4 y = Word4 (x  .|.  y)+  Word4 x `xor` Word4 y = Word4 (x `xor` y)+  complement (Word4 x)  = Word4 (x `xor` 0x0f)+  Word4 x `shift`  i    = word4 (shift x i)+  Word4 x `shiftL` i    = word4 (shiftL x i)+  Word4 x `shiftR` i    = Word4 (shiftR x i)+  Word4 x `rotate` i    = word4 (x `shiftL` k .|. x `shiftR` (4-k))+                            where k = i .&. 3+  bitSize _             = 4+  bitSizeMaybe _        = Just 4+  isSigned _            = False+  testBit (Word4 x)     = testBit x+  bit i                 = word4 (bit i)+  popCount (Word4 x)    = popCount x++-- | Random instance, used in quick-check+instance Random Word4 where+  randomR (Word4 lo, Word4 hi) gen = (Word4 x, gen')+    where (x, gen') = randomR (lo, hi) gen+  random gen = (Word4 x, gen')+    where (x, gen') = randomR (0x00, 0x0f) gen++-- | SWord4 type synonym+type SWord4 = SBV Word4++-- | SymWord instance, allowing this type to be used in proofs/sat etc.+instance SymWord Word4 where+  mkSymWord  = genMkSymVar (KBounded False 4)+  literal    = genLiteral  (KBounded False 4)+  fromCW     = genFromCW++-- | HasKind instance; simply returning the underlying kind for the type+instance HasKind Word4 where+  kindOf _ = KBounded False 4++-- | SatModel instance, merely uses the generic parsing method.+instance SatModel Word4 where+  parseCWs = genParse (KBounded False 4)++-- | SDvisible instance, using 0-extension+instance SDivisible Word4 where+  sQuotRem x 0 = (0, x)+  sQuotRem x y = x `quotRem` y+  sDivMod  x 0 = (0, x)+  sDivMod  x y = x `divMod` y++-- | SDvisible instance, using default methods+instance SDivisible SWord4 where+  sQuotRem = liftQRem+  sDivMod  = liftDMod++-- | SIntegral instance, using default methods+instance SIntegral Word4++-- | Joining/splitting to/from Word8+instance Splittable Word8 Word4 where+  split x           = (Word4 (x `shiftR` 4), word4 x)+  Word4 x # Word4 y = (x `shiftL` 4) .|. y+  extend (Word4 x)  = x
+ Documentation/SBV/Examples/Optimization/ExtField.hs view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Optimization.ExtField+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates the extension field (@oo@/@epsilon@) optimization results.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Optimization.ExtField where++import Data.SBV++-- | Optimization goals where min/max values might require assignments+-- to values that are infinite (integer case), or infinite/epsion (real case).+-- This simple example demostrates how SBV can be used to extract such values.+--+-- We have:+--+-- >>> optimize Independent problem+-- Objective "one-x": Optimal in an extension field:+--   one-x =                    oo :: Integer+--   min_y = 7.0 + (2.0 * epsilon) :: Real+--   min_z =         5.0 + epsilon :: Real+-- Objective "min_y": Optimal in an extension field:+--   one-x =                    oo :: Integer+--   min_y = 7.0 + (2.0 * epsilon) :: Real+--   min_z =         5.0 + epsilon :: Real+-- Objective "min_z": Optimal in an extension field:+--   one-x =                    oo :: Integer+--   min_y = 7.0 + (2.0 * epsilon) :: Real+--   min_z =         5.0 + epsilon :: Real+problem :: Goal+problem = do x <- sInteger "x"+             y <- sReal "y"+             z <- sReal "z"++             maximize "one-x" $ 1 - x++             constrain $ y .> 0 &&& z .> 5+             minimize "min_y" $ 2+y+z++             minimize "min_z" z
+ Documentation/SBV/Examples/Optimization/LinearOpt.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.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 Documentation.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 Lexicographic 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
+ Documentation/SBV/Examples/Optimization/Production.hs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Optimization.Production+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Solves a simple linear optimization problem+-----------------------------------------------------------------------------++module Documentation.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 Lexicographic 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)
+ Documentation/SBV/Examples/Optimization/VM.hs view
@@ -0,0 +1,87 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.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 Documentation.SBV.Examples.Optimization.VM where++import Data.SBV++-- | The allocation problem. Inspired by: <http://rise4fun.com/Z3/tutorialcontent/optimization#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 Lexicographic 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 $ pbStronglyMutexed x1+    constrain $ pbStronglyMutexed x2+    constrain $ pbStronglyMutexed 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)
+ Documentation/SBV/Examples/Puzzles/Birthday.hs view
@@ -0,0 +1,145 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.Birthday+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- This is a formalization of the Cheryl's birthday problem, which went viral in April 2015.+-- (See <http://www.nytimes.com/2015/04/15/science/a-math-problem-from-singapore-goes-viral-when-is-cheryls-birthday.html>.)+--+-- Here's the puzzle:+--+-- @+-- Albert and Bernard just met Cheryl. “When’s your birthday?” Albert asked Cheryl.+--+-- Cheryl thought a second and said, “I’m not going to tell you, but I’ll give you some clues.” She wrote down a list of 10 dates:+--+--   May 15, May 16, May 19+--   June 17, June 18+--   July 14, July 16+--   August 14, August 15, August 17+--+-- “My birthday is one of these,” she said.+--+-- Then Cheryl whispered in Albert’s ear the month — and only the month — of her birthday. To Bernard, she whispered the day, and only the day. +-- “Can you figure it out now?” she asked Albert.+--+-- Albert: I don’t know when your birthday is, but I know Bernard doesn’t know, either.+-- Bernard: I didn’t know originally, but now I do.+-- Albert: Well, now I know, too!+--+-- When is Cheryl’s birthday?+-- @+--+-- NB. Thanks to Amit Goel for suggesting the formalization strategy used in here.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Puzzles.Birthday where++import Data.SBV++-----------------------------------------------------------------------------------------------+-- * Types and values+-----------------------------------------------------------------------------------------------++-- | Represent month by 8-bit words; We can also use an uninterpreted type, but numbers work well here.+type Month = SWord8++-- | Represent day by 8-bit words; Again, an uninterpreted type would work as well.+type Day = SWord8++-- | Months referenced in the problem.+may, june, july, august :: SWord8+[may, june, july, august] = [5, 6, 7, 8]++-----------------------------------------------------------------------------------------------+-- * Helper predicates+-----------------------------------------------------------------------------------------------++-- | Check that a given month/day combo is a possible birth-date.+valid :: Month -> Day -> SBool+valid month day = (month, day) `sElem` candidates+  where candidates :: [(Month, Day)]+        candidates = [ (   may, 15), (   may, 16), (   may, 19)+                     , (  june, 17), (  june, 18)+                     , (  july, 14), (  july, 16)+                     , (august, 14), (august, 15), (august, 17)+                     ]++-- | Assert that the given function holds for one of the possible days.+existsDay :: (Day -> SBool) -> SBool+existsDay f = bAny (f . literal) [14 .. 19]++-- | Assert that the given function holds for all of the possible days.+forallDay :: (Day -> SBool) -> SBool+forallDay f = bAll (f . literal) [14 .. 19]++-- | Assert that the given function holds for one of the possible months.+existsMonth :: (Month -> SBool) -> SBool+existsMonth f = bAny f [may .. august]++-- | Assert that the given function holds for all of the possible months.+forallMonth :: (Month -> SBool) -> SBool+forallMonth f = bAll f [may .. august]++-----------------------------------------------------------------------------------------------+-- * The puzzle+-----------------------------------------------------------------------------------------------++-- | Encode the conversation as given in the puzzle.+--+-- NB. Lee Pike pointed out that not all the constraints are actually necessary! (Private+-- communication.) The puzzle still has a unique solution if the statements 'a1' and 'b1'+-- (i.e., Albert and Bernard saying they themselves do not know the answer) are removed.+-- To experiment you can simply comment out those statements and observe that there still+-- is a unique solution. Thanks to Lee for pointing this out! In fact, it is instructive to+-- assert the conversation line-by-line, and see how the search-space gets reduced in each+-- step.+puzzle :: Predicate+puzzle = do birthDay   <- exists "birthDay"+            birthMonth <- exists "birthMonth"++            -- Albert: I do not know+            let a1 m = existsDay $ \d1 -> existsDay $ \d2 ->+                           d1 ./= d2 &&& valid m d1 &&& valid m d2++            -- Albert: I know that Bernard doesn't know+            let a2 m = forallDay $ \d -> valid m d ==>+                          existsMonth (\m1 -> existsMonth $ \m2 ->+                                m1 ./= m2 &&& valid m1 d &&& valid m2 d)++            -- Bernard: I did not know+            let b1 d = existsMonth $ \m1 -> existsMonth $ \m2 ->+                           m1 ./= m2 &&& valid m1 d &&& valid m2 d++            -- Bernard: But now I know+            let b2p m d = valid m d &&& a1 m &&& a2 m+                b2  d   = forallMonth $ \m1 -> forallMonth $ \m2 ->+                                (b2p m1 d &&& b2p m2 d) ==> m1 .== m2++            -- Albert: Now I know too+            let a3p m d = valid m d &&& a1 m &&& a2 m &&& b1 d &&& b2 d+                a3 m    = forallDay $ \d1 -> forallDay $ \d2 ->+                                (a3p m d1 &&& a3p m d2) ==> d1 .== d2++            -- Assert all the statements made:+            constrain $ a1 birthMonth+            constrain $ a2 birthMonth+            constrain $ b1 birthDay+            constrain $ b2 birthDay+            constrain $ a3 birthMonth++            -- Find a valid birth-day that satisfies the above constraints:+            return $ valid birthMonth birthDay++-- | Find all solutions to the birthday problem. We have:+--+-- >>> cheryl+-- Solution #1:+--   birthDay   = 16 :: Word8+--   birthMonth =  7 :: Word8+-- This is the only solution.+cheryl :: IO ()+cheryl = print =<< allSat puzzle
+ Documentation/SBV/Examples/Puzzles/Coins.hs view
@@ -0,0 +1,103 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.Coins+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Solves the following puzzle:+--+-- @+-- You and a friend pass by a standard coin operated vending machine and you decide to get a candy bar.+-- The price is US $0.95, but after checking your pockets you only have a dollar (US $1) and the machine+-- only takes coins. You turn to your friend and have this conversation:+--   you: Hey, do you have change for a dollar?+--   friend: Let's see. I have 6 US coins but, although they add up to a US $1.15, I can't break a dollar.+--   you: Huh? Can you make change for half a dollar?+--   friend: No.+--   you: How about a quarter?+--   friend: Nope, and before you ask I cant make change for a dime or nickel either.+--   you: Really? and these six coins are all US government coins currently in production? +--   friend: Yes.+--   you: Well can you just put your coins into the vending machine and buy me a candy bar, and I'll pay you back?+--   friend: Sorry, I would like to but I cant with the coins I have.+-- What coins are your friend holding?+-- @+--+-- To be fair, the problem has no solution /mathematically/. But there is a solution when one takes into account that+-- vending machines typically do not take the 50 cent coins!+--+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Puzzles.Coins where++import Data.SBV++-- | We will represent coins with 16-bit words (more than enough precision for coins).+type Coin = SWord16++-- | Create a coin. The argument Int argument just used for naming the coin. Note that+-- we constrain the value to be one of the valid U.S. coin values as we create it.+mkCoin :: Int -> Symbolic Coin+mkCoin i = do c <- exists $ 'c' : show i+              constrain $ bAny (.== c) [1, 5, 10, 25, 50, 100]+              return c++-- | Return all combinations of a sequence of values.+combinations :: [a] -> [[a]]+combinations coins = concat [combs i coins | i <- [1 .. length coins]]+  where combs 0 _      = [[]]+        combs _ []     = []+        combs k (x:xs) = map (x:) (combs (k-1) xs) ++ combs k xs++-- | Constraint 1: Cannot make change for a dollar.+c1 :: [Coin] -> SBool+c1 xs = sum xs ./= 100++-- | Constraint 2: Cannot make change for half a dollar.+c2 :: [Coin] -> SBool+c2 xs = sum xs ./= 50++-- | Constraint 3: Cannot make change for a quarter.+c3 :: [Coin] -> SBool+c3 xs = sum xs ./= 25++-- | Constraint 4: Cannot make change for a dime.+c4 :: [Coin] -> SBool+c4 xs = sum xs ./= 10++-- | Constraint 5: Cannot make change for a nickel+c5 :: [Coin] -> SBool+c5 xs = sum xs ./= 5++-- | Constraint 6: Cannot buy the candy either. Here's where we need to have the extra knowledge+-- that the vending machines do not take 50 cent coins.+c6 :: [Coin] -> SBool+c6 xs = sum (map val xs) ./= 95+   where val x = ite (x .== 50) 0 x++-- | Solve the puzzle. We have:+--+-- >>> puzzle+-- Satisfiable. Model:+--   c1 = 50 :: Word16+--   c2 = 25 :: Word16+--   c3 = 10 :: Word16+--   c4 = 10 :: Word16+--   c5 = 10 :: Word16+--   c6 = 10 :: Word16+--+-- i.e., your friend has 4 dimes, a quarter, and a half dollar.+puzzle :: IO SatResult+puzzle = sat $ do+        cs <- mapM mkCoin [1..6]+        -- Assert each of the constraints for all combinations that has+        -- at least two coins (to make change)+        mapM_ constrain [c s | s <- combinations cs, length s >= 2, c <- [c1, c2, c3, c4, c5, c6]]+        -- the following constraint is not necessary for solving the puzzle+        -- however, it makes sure that the solution comes in decreasing value of coins,+        -- thus allowing the above test to succeed regardless of the solver used.+        constrain $ bAnd $ zipWith (.>=) cs (tail cs)+        -- assert that the sum must be 115 cents.+        return $ sum cs .== 115
+ Documentation/SBV/Examples/Puzzles/Counts.hs view
@@ -0,0 +1,83 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.Counts+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Consider the sentence:+--+-- @+--    In this sentence, the number of occurrences of 0 is _, of 1 is _, of 2 is _,+--    of 3 is _, of 4 is _, of 5 is _, of 6 is _, of 7 is _, of 8 is _, and of 9 is _.+-- @+--+-- The puzzle is to fill the blanks with numbers, such that the sentence+-- will be correct. There are precisely two solutions to this puzzle, both of+-- which are found by SBV successfully.+--+--  References:+--+--    * Douglas Hofstadter, Metamagical Themes, pg. 27.+--+--    * <http://mathcentral.uregina.ca/mp/archives/previous2002/dec02sol.html>+--+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Puzzles.Counts where++import Data.SBV++-- | We will assume each number can be represented by an 8-bit word, i.e., can be at most 128.+type Count  = SWord8++-- | Given a number, increment the count array depending on the digits of the number+count :: Count -> [Count] -> [Count]+count n cnts = ite (n .< 10)+                   (upd n cnts)                           -- only one digit+                   (ite (n .< 100)+                        (upd d1 (upd d2 cnts))            -- two digits+                        (upd d1 (upd d2 (upd d3 cnts))))  -- three digits+  where (r1, d1)   = n  `sQuotRem` 10+        (d3, d2)   = r1 `sQuotRem` 10+        upd d = zipWith inc [0..]+          where inc i c = ite (i .== d) (c+1) c++-- | Encoding of the puzzle. The solution is a sequence of 10 numbers+-- for the occurrences of the digits such that if we count each digit,+-- we find these numbers.+puzzle :: [Count] -> SBool+puzzle cnt = cnt .== last css+  where ones = replicate 10 1  -- all digits occur once to start with+        css  = ones : zipWith count cnt css++-- | Finds all two known solutions to this puzzle. We have:+--+-- >>> counts+-- Solution #1+-- In this sentence, the number of occurrences of 0 is 1, of 1 is 7, of 2 is 3, of 3 is 2, of 4 is 1, of 5 is 1, of 6 is 1, of 7 is 2, of 8 is 1, of 9 is 1.+-- Solution #2+-- In this sentence, the number of occurrences of 0 is 1, of 1 is 11, of 2 is 2, of 3 is 1, of 4 is 1, of 5 is 1, of 6 is 1, of 7 is 1, of 8 is 1, of 9 is 1.+-- Found: 2 solution(s).+counts :: IO ()+counts = do res <- allSat $ puzzle `fmap` mkExistVars 10+            cnt <- displayModels disp res+            putStrLn $ "Found: " ++ show cnt ++ " solution(s)."+  where disp n (_, s) = do putStrLn $ "Solution #" ++ show n+                           dispSolution s+        dispSolution :: [Word8] -> IO ()+        dispSolution ns = putStrLn soln+          where soln =  "In this sentence, the number of occurrences"+                     ++  " of 0 is " ++ show (ns !! 0)+                     ++ ", of 1 is " ++ show (ns !! 1)+                     ++ ", of 2 is " ++ show (ns !! 2)+                     ++ ", of 3 is " ++ show (ns !! 3)+                     ++ ", of 4 is " ++ show (ns !! 4)+                     ++ ", of 5 is " ++ show (ns !! 5)+                     ++ ", of 6 is " ++ show (ns !! 6)+                     ++ ", of 7 is " ++ show (ns !! 7)+                     ++ ", of 8 is " ++ show (ns !! 8)+                     ++ ", of 9 is " ++ show (ns !! 9)+                     ++ "."+{-# ANN counts ("HLint: ignore Use head" :: String) #-}
+ Documentation/SBV/Examples/Puzzles/DogCatMouse.hs view
@@ -0,0 +1,37 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.DogCatMouse+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Puzzle:+--   Spend exactly 100 dollars and buy exactly 100 animals.+--   Dogs cost 15 dollars, cats cost 1 dollar, and mice cost 25 cents each.+--   You have to buy at least one of each.+--   How many of each should you buy?+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Puzzles.DogCatMouse where++import Data.SBV++-- | Prints the only solution:+--+-- >>> puzzle+-- Solution #1:+--   dog   =  3 :: Integer+--   cat   = 41 :: Integer+--   mouse = 56 :: Integer+-- This is the only solution.+puzzle :: IO AllSatResult+puzzle = allSat $ do+           [dog, cat, mouse] <- sIntegers ["dog", "cat", "mouse"]+           solve [ dog   .>= 1                                           -- at least one dog+                 , cat   .>= 1                                           -- at least one cat+                 , mouse .>= 1                                           -- at least one mouse+                 , dog + cat + mouse .== 100                             -- buy precisely 100 animals+                 , 15 `per` dog + 1 `per` cat + 0.25 `per` mouse .== 100 -- spend exactly 100 dollars+                 ]+  where p `per` q = p * (sFromIntegral q :: SReal)
+ Documentation/SBV/Examples/Puzzles/Euler185.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.Euler185+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- A solution to Project Euler problem #185: <http://projecteuler.net/index.php?section=problems&id=185>+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Puzzles.Euler185 where++import Data.Char (ord)+import Data.SBV++-- | The given guesses and the correct digit counts, encoded as a simple list.+guesses :: [(String, SWord8)]+guesses = [ ("5616185650518293", 2), ("3847439647293047", 1), ("5855462940810587", 3)+          , ("9742855507068353", 3), ("4296849643607543", 3), ("3174248439465858", 1)+          , ("4513559094146117", 2), ("7890971548908067", 3), ("8157356344118483", 1)+          , ("2615250744386899", 2), ("8690095851526254", 3), ("6375711915077050", 1)+          , ("6913859173121360", 1), ("6442889055042768", 2), ("2321386104303845", 0)+          , ("2326509471271448", 2), ("5251583379644322", 2), ("1748270476758276", 3)+          , ("4895722652190306", 1), ("3041631117224635", 3), ("1841236454324589", 3)+          , ("2659862637316867", 2)+          ]++-- | Encode the problem, note that we check digits are within 0-9 as+-- we use 8-bit words to represent them. Otherwise, the constraints are simply+-- generated by zipping the alleged solution with each guess, and making sure the+-- number of matching digits match what's given in the problem statement.+euler185 :: Symbolic SBool+euler185 = do soln <- mkExistVars 16+              return $ bAll digit soln &&& bAnd (map (genConstr soln) guesses)+  where genConstr a (b, c) = sum (zipWith eq a b) .== (c :: SWord8)+        digit x = (x :: SWord8) .>= 0 &&& x .<= 9+        eq x y =  ite (x .== fromIntegral (ord y - ord '0')) 1 0++-- | Print out the solution nicely. We have:+--+-- >>> solveEuler185+-- 4640261571849533+-- Number of solutions: 1+solveEuler185 :: IO ()+solveEuler185 = do res <- allSat euler185+                   cnt <- displayModels disp res+                   putStrLn $ "Number of solutions: " ++ show cnt+   where disp _ (_, ss) = putStrLn $ concatMap show (ss :: [Word8])
+ Documentation/SBV/Examples/Puzzles/Fish.hs view
@@ -0,0 +1,122 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.Fish+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Solves the following logic puzzle:+--+--   - The Briton lives in the red house.+--   - The Swede keeps dogs as pets.+--   - The Dane drinks tea.+--   - The green house is left to the white house.+--   - The owner of the green house drinks coffee.+--   - The person who plays football rears birds.+--   - The owner of the yellow house plays baseball.+--   - The man living in the center house drinks milk.+--   - The Norwegian lives in the first house.+--   - The man who plays volleyball lives next to the one who keeps cats.+--   - The man who keeps the horse lives next to the one who plays baseball.+--   - The owner who plays tennis drinks beer.+--   - The German plays hockey.+--   - The Norwegian lives next to the blue house.+--   - The man who plays volleyball has a neighbor who drinks water.+--+-- Who owns the fish?+------------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Documentation.SBV.Examples.Puzzles.Fish where++import Data.SBV++-- | Colors of houses+data Color = Red | Green | White | Yellow | Blue++-- | Make 'Color' a symbolic value.+mkSymbolicEnumeration ''Color++-- | Nationalities of the occupants+data Nationality = Briton | Dane | Swede | Norwegian | German++-- | Make 'Nationality' a symbolic value.+mkSymbolicEnumeration ''Nationality++-- | Beverage choices+data Beverage = Tea | Coffee | Milk | Beer | Water++-- | Make 'Beverage' a symbolic value.+mkSymbolicEnumeration ''Beverage++-- | Pets they keep+data Pet = Dog | Horse | Cat | Bird | Fish++-- | Make 'Pet' a symbolic value.+mkSymbolicEnumeration ''Pet++-- | Sports they engage in+data Sport = Football | Baseball | Volleyball | Hockey | Tennis++-- | Make 'Sport' a symbolic value.+mkSymbolicEnumeration ''Sport++-- | We have:+--+-- >>> fishOwner+-- German+--+-- It's not hard to modify this program to grab the values of all the assignments, i.e., the full+-- solution to the puzzle. We leave that as an exercise to the interested reader!+fishOwner :: IO ()+fishOwner = do vs <- getModelValues "fishOwner" `fmap` allSat puzzle+               case vs of+                 [Just (v::Nationality)] -> print v+                 []                      -> error "no solution"+                 _                       -> error "no unique solution"+ where puzzle = do++          let c = uninterpret "color"+              n = uninterpret "nationality"+              b = uninterpret "beverage"+              p = uninterpret "pet"+              s = uninterpret "sport"++          let i `neighbor` j = i .== j+1 ||| j .== i+1+              a `is`       v = a .== literal v++          let fact0   = constrain+              fact1 f = do i <- free_+                           constrain $ 1 .<= i &&& i .<= (5 :: SInteger)+                           constrain $ f i+              fact2 f = do i <- free_+                           j <- free_+                           constrain $ 1 .<= i &&& i .<= (5 :: SInteger)+                           constrain $ 1 .<= j &&& j .<= 5+                           constrain $ i ./= j+                           constrain $ f i j++          fact1 $ \i   -> n i `is` Briton     &&& c i `is` Red+          fact1 $ \i   -> n i `is` Swede      &&& p i `is` Dog+          fact1 $ \i   -> n i `is` Dane       &&& b i `is` Tea+          fact2 $ \i j -> c i `is` Green      &&& c j `is` White    &&& i .== j-1+          fact1 $ \i   -> c i `is` Green      &&& b i `is` Coffee+          fact1 $ \i   -> s i `is` Football   &&& p i `is` Bird+          fact1 $ \i   -> c i `is` Yellow     &&& s i `is` Baseball+          fact0 $         b 3 `is` Milk+          fact0 $         n 1 `is` Norwegian+          fact2 $ \i j -> s i `is` Volleyball &&& p j `is` Cat      &&& i `neighbor` j+          fact2 $ \i j -> p i `is` Horse      &&& s j `is` Baseball &&& i `neighbor` j+          fact1 $ \i   -> s i `is` Tennis     &&& b i `is` Beer+          fact1 $ \i   -> n i `is` German     &&& s i `is` Hockey+          fact2 $ \i j -> n i `is` Norwegian  &&& c j `is` Blue     &&& i `neighbor` j+          fact2 $ \i j -> s i `is` Volleyball &&& b j `is` Water    &&& i `neighbor` j++          ownsFish <- free "fishOwner"+          fact1 $ \i -> n i .== ownsFish &&& p i `is` Fish
+ Documentation/SBV/Examples/Puzzles/MagicSquare.hs view
@@ -0,0 +1,75 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.MagicSquare+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Solves the magic-square puzzle. An NxN magic square is one where all entries+-- are filled with numbers from 1 to NxN such that sums of all rows, columns+-- and diagonals is the same.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Puzzles.MagicSquare where++import Data.List (genericLength, transpose)++import Data.SBV++-- | Use 32-bit words for elements.+type Elem  = SWord32++-- | A row is a list of elements+type Row   = [Elem]++-- | The puzzle board is a list of rows+type Board = [Row]++-- | Checks that all elements in a list are within bounds+check :: Elem -> Elem -> [Elem] -> SBool+check low high = bAll $ \x -> x .>= low &&& x .<= high++-- | Get the diagonal of a square matrix+diag :: [[a]] -> [a]+diag ((a:_):rs) = a : diag (map tail rs)+diag _          = []++-- | Test if a given board is a magic square+isMagic :: Board -> SBool+isMagic rows = bAnd $ fromBool isSquare : allEqual (map sum items) : distinct (concat rows) : map chk items+  where items = d1 : d2 : rows ++ columns+        n = genericLength rows+        isSquare = all (\r -> genericLength r == n) rows+        columns = transpose rows+        d1 = diag rows+        d2 = diag (map reverse rows)+        chk = check (literal 1) (literal (n*n))++-- | Group a list of elements in the sublists of length @i@+chunk :: Int -> [a] -> [[a]]+chunk _ [] = []+chunk i xs = let (f, r) = splitAt i xs in f : chunk i r++-- | Given @n@, magic @n@ prints all solutions to the @nxn@ magic square problem+magic :: Int -> IO ()+magic n+ | n < 0 = putStrLn $ "n must be non-negative, received: " ++ show n+ | True  = do putStrLn $ "Finding all " ++ show n ++ "-magic squares.."+              res <- allSat $ (isMagic . chunk n) `fmap` mkExistVars n2+              cnt <- displayModels disp res+              putStrLn $ "Found: " ++ show cnt ++ " solution(s)."+   where n2 = n * n+         disp i (_, model)+          | lmod /= n2+          = error $ "Impossible! Backend solver returned " ++ show n ++ " values, was expecting: " ++ show lmod+          | True+          = do putStrLn $ "Solution #" ++ show i+               mapM_ printRow board+               putStrLn $ "Valid Check: " ++ show (isMagic sboard)+               putStrLn "Done."+          where lmod  = length model+                board = chunk n model+                sboard = map (map literal) board+                sh2 z = let s = show z in if length s < 2 then ' ':s else s+                printRow r = putStr "   " >> mapM_ (\x -> putStr (sh2 x ++ " ")) r >> putStrLn ""
+ Documentation/SBV/Examples/Puzzles/NQueens.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.NQueens+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Solves the NQueens puzzle: <http://en.wikipedia.org/wiki/Eight_queens_puzzle>+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Puzzles.NQueens where++import Data.SBV++-- | A solution is a sequence of row-numbers where queens should be placed+type Solution = [SWord8]++-- | Checks that a given solution of @n@-queens is valid, i.e., no queen+-- captures any other.+isValid :: Int -> Solution -> SBool+isValid n s = bAll rangeFine s &&& distinct s &&& bAll checkDiag ijs+  where rangeFine x = x .>= 1 &&& x .<= fromIntegral n+        ijs = [(i, j) | i <- [1..n], j <- [i+1..n]]+        checkDiag (i, j) = diffR ./= diffC+           where qi = s !! (i-1)+                 qj = s !! (j-1)+                 diffR = ite (qi .>= qj) (qi-qj) (qj-qi)+                 diffC = fromIntegral (j-i)++-- | Given @n@, it solves the @n-queens@ puzzle, printing all possible solutions.+nQueens :: Int -> IO ()+nQueens n+ | n < 0 = putStrLn $ "n must be non-negative, received: " ++ show n+ | True  = do putStrLn $ "Finding all " ++ show n ++ "-queens solutions.."+              res <- allSat $ isValid n `fmap` mkExistVars n+              cnt <- displayModels disp res+              putStrLn $ "Found: " ++ show cnt ++ " solution(s)."+   where disp i (_, s) = do putStr $ "Solution #" ++ show i ++ ": "+                            dispSolution s+         dispSolution :: [Word8] -> IO ()+         dispSolution model+           | lmod /= n = error $ "Impossible! Backend solver returned " ++ show lmod ++ " values, was expecting: " ++ show n+           | True      = do putStr $ show model+                            putStrLn $ " (Valid: " ++ show (isValid n (map literal model)) ++ ")"+           where lmod  = length model
+ Documentation/SBV/Examples/Puzzles/SendMoreMoney.hs view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.SendMoreMoney+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Solves the classic @send + more = money@ puzzle.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Puzzles.SendMoreMoney where++import Data.SBV++-- | Solve the puzzle. We have:+--+-- >>> sendMoreMoney+-- Solution #1:+--   s = 9 :: Integer+--   e = 5 :: Integer+--   n = 6 :: Integer+--   d = 7 :: Integer+--   m = 1 :: Integer+--   o = 0 :: Integer+--   r = 8 :: Integer+--   y = 2 :: Integer+-- This is the only solution.+--+-- That is:+--+-- >>> 9567 + 1085 == 10652+-- True+sendMoreMoney :: IO AllSatResult+sendMoreMoney = allSat $ do+        ds@[s,e,n,d,m,o,r,y] <- mapM sInteger ["s", "e", "n", "d", "m", "o", "r", "y"]+        let isDigit x = x .>= 0 &&& x .<= 9+            val xs    = sum $ zipWith (*) (reverse xs) (iterate (*10) 1)+            send      = val [s,e,n,d]+            more      = val [m,o,r,e]+            money     = val [m,o,n,e,y]+        constrain $ bAll isDigit ds+        constrain $ distinct ds+        constrain $ s ./= 0 &&& m ./= 0+        solve [send + more .== money]
+ Documentation/SBV/Examples/Puzzles/Sudoku.hs view
@@ -0,0 +1,252 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.Sudoku+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- The Sudoku solver, quintessential SMT solver example!+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Puzzles.Sudoku where++import Data.List  (transpose)+import Data.Maybe (fromJust)++import Data.SBV++-------------------------------------------------------------------+-- * Modeling Sudoku+-------------------------------------------------------------------+-- | A row is a sequence of 8-bit words, too large indeed for representing 1-9, but does not harm+type Row   = [SWord8]++-- | A Sudoku board is a sequence of 9 rows+type Board = [Row]++-- | Given a series of elements, make sure they are all different+-- and they all are numbers between 1 and 9+check :: [SWord8] -> SBool+check grp = bAnd $ distinct grp : map rangeFine grp+  where rangeFine x = x .> 0 &&& x .<= 9++-- | Given a full Sudoku board, check that it is valid+valid :: Board -> SBool+valid rows = bAnd $ literal sizesOK : map check (rows ++ columns ++ squares)+  where sizesOK = length rows == 9 && all (\r -> length r == 9) rows+        columns = transpose rows+        regions = transpose [chunk 3 row | row <- rows]+        squares = [concat sq | sq <- chunk 3 (concat regions)]+        chunk :: Int -> [a] -> [[a]]+        chunk _ [] = []+        chunk i xs = let (f, r) = splitAt i xs in f : chunk i r++-- | A puzzle is a pair: First is the number of missing elements, second+-- is a function that given that many elements returns the final board.+type Puzzle = (Int, [SWord8] -> Board)++-------------------------------------------------------------------+-- * Solving Sudoku puzzles+-------------------------------------------------------------------++-- | Solve a given puzzle and print the results+sudoku :: Puzzle -> IO ()+sudoku p@(i, f) = do putStrLn "Solving the puzzle.."+                     model <- getModelAssignment `fmap` sat ((valid . f) `fmap` mkExistVars i)+                     case model of+                       Right sln -> dispSolution p sln+                       Left m    -> putStrLn $ "Unsolvable puzzle: " ++ m++-- | Helper function to display results nicely, not really needed, but helps presentation+dispSolution :: Puzzle -> (Bool, [Word8]) -> IO ()+dispSolution (i, f) (_, fs)+  | lmod /= i = error $ "Impossible! Backend solver returned " ++ show lmod ++ " values, was expecting: " ++ show i+  | True      = do putStrLn "Final board:"+                   mapM_ printRow final+                   putStrLn $ "Valid Check: " ++ show (valid final)+                   putStrLn "Done."+  where lmod = length fs+        final = f (map literal fs)+        printRow r = putStr "   " >> mapM_ (\x -> putStr (show (fromJust (unliteral x)) ++ " ")) r >> putStrLn ""++-- | Find all solutions to a puzzle+solveAll :: Puzzle -> IO ()+solveAll p@(i, f) = do putStrLn "Finding all solutions.."+                       res <- allSat $ (valid . f) `fmap` mkExistVars i+                       cnt <- displayModels disp res+                       putStrLn $ "Found: " ++ show cnt ++ " solution(s)."+   where disp n s = do putStrLn $ "Solution #" ++ show n+                       dispSolution p s++-------------------------------------------------------------------+-- * Example boards+-------------------------------------------------------------------++-- | Find an arbitrary good board+puzzle0 :: Puzzle+puzzle0 = (81, f)+  where f   [ a1, a2, a3, a4, a5, a6, a7, a8, a9,+              b1, b2, b3, b4, b5, b6, b7, b8, b9,+              c1, c2, c3, c4, c5, c6, c7, c8, c9,+              d1, d2, d3, d4, d5, d6, d7, d8, d9,+              e1, e2, e3, e4, e5, e6, e7, e8, e9,+              f1, f2, f3, f4, f5, f6, f7, f8, f9,+              g1, g2, g3, g4, g5, g6, g7, g8, g9,+              h1, h2, h3, h4, h5, h6, h7, h8, h9,+              i1, i2, i3, i4, i5, i6, i7, i8, i9 ]+         = [ [a1, a2, a3, a4, a5, a6, a7, a8, a9],+             [b1, b2, b3, b4, b5, b6, b7, b8, b9],+             [c1, c2, c3, c4, c5, c6, c7, c8, c9],+             [d1, d2, d3, d4, d5, d6, d7, d8, d9],+             [e1, e2, e3, e4, e5, e6, e7, e8, e9],+             [f1, f2, f3, f4, f5, f6, f7, f8, f9],+             [g1, g2, g3, g4, g5, g6, g7, g8, g9],+             [h1, h2, h3, h4, h5, h6, h7, h8, h9],+             [i1, i2, i3, i4, i5, i6, i7, i8, i9] ]+        f _ = error "puzzle0 needs exactly 81 elements!"++-- | A random puzzle, found on the internet..+puzzle1 :: Puzzle+puzzle1 = (49, f)+  where f   [ a1,     a3, a4, a5, a6, a7,     a9,+              b1, b2, b3,             b7, b8, b9,+                  c2,     c4, c5, c6,     c8,+                      d3,     d5,     d7,+              e1, e2,     e4, e5, e6,     e8, e9,+                      f3,     f5,     f7,+                  g2,     g4, g5, g6,     g8,+              h1, h2, h3,             h7, h8, h9,+              i1,     i3, i4, i5, i6, i7,     i9 ]+         = [ [a1,  6, a3, a4, a5, a6, a7,  1, a9],+             [b1, b2, b3,  6,  5,  1, b7, b8, b9],+             [ 1, c2,  7, c4, c5, c6,  6, c8,  2],+             [ 6,  2, d3,  3, d5,  5, d7,  9,  4],+             [e1, e2,  3, e4, e5, e6,  2, e8, e9],+             [ 4,  8, f3,  9, f5,  7, f7,  3,  6],+             [ 9, g2,  6, g4, g5, g6,  4, g8,  8],+             [h1, h2, h3,  7,  9,  4, h7, h8, h9],+             [i1,  5, i3, i4, i5, i6, i7,  7, i9] ]+        f _ = error "puzzle1 needs exactly 49 elements!"++-- | Another random puzzle, found on the internet..+puzzle2 :: Puzzle+puzzle2 = (55, f)+  where f   [     a2,     a4, a5, a6, a7,     a9,+              b1, b2,     b4,         b7, b8, b9,+              c1,     c3, c4, c5, c6, c7, c8, c9,+                  d2, d3, d4,             d8, d9,+              e1,     e3,     e5,     e7,     e9,+              f1, f2,             f6, f7, f8,+              g1, g2, g3, g4, g5, g6, g7,     g9,+              h1, h2, h3,         h6,     h8, h9,+              i1,     i3, i4, i5, i6,     i8     ]+         = [ [ 1, a2,  3, a4, a5, a6, a7,  8, a9],+             [b1, b2,  6, b4,  4,  8, b7, b8, b9],+             [c1,  4, c3, c4, c5, c6, c7, c8, c9],+             [ 2, d2, d3, d4,  9,  6,  1, d8, d9],+             [e1,  9, e3,  8, e5,  1, e7,  4, e9],+             [f1, f2,  4,  3,  2, f6, f7, f8,  8],+             [g1, g2, g3, g4, g5, g6, g7,  7, g9],+             [h1, h2, h3,  1,  5, h6,  4, h8, h9],+             [i1,  6, i3, i4, i5, i6,  2, i8,  3] ]+        f _ = error "puzzle2 needs exactly 55 elements!"++-- | Another random puzzle, found on the internet..+puzzle3 :: Puzzle+puzzle3 = (56, f)+  where f   [     a2, a3, a4,     a6,     a8, a9,+                  b2,     b4, b5, b6, b7, b8, b9,+              c1, c2, c3, c4,     c6, c7,     c9,+              d1,     d3,     d5,     d7,     d9,+                  e2, e3, e4,     e6, e7, e8,+              f1,     f3,     f5,     f7,     f9,+              g1,     g3, g4,     g6, g7, g8, g9,+              h1, h2, h3, h4, h5, h6,     h8,+              i1, i2,     i4,     i6, i7, i8     ]+         = [ [ 6, a2, a3, a4,  1, a6,  5, a8, a9],+             [ 8, b2,  3, b4, b5, b6, b7, b8, b9],+             [c1, c2, c3, c4,  6, c6, c7,  2, c9],+             [d1,  3, d3,  1, d5,  8, d7,  9, d9],+             [ 1, e2, e3, e4,  9, e6, e7, e8,  4],+             [f1,  5, f3,  2, f5,  3, f7,  1, f9],+             [g1,  7, g3, g4,  3, g6, g7, g8, g9],+             [h1, h2, h3, h4, h5, h6,  3, h8,  6],+             [i1, i2,  4, i4,  5, i6, i7, i8,  9] ]+        f _ = error "puzzle3 needs exactly 56 elements!"++-- | According to the web, this is the toughest +-- sudoku puzzle ever.. It even has a name: Al Escargot:+-- <http://zonkedyak.blogspot.com/2006/11/worlds-hardest-sudoku-puzzle-al.html>+puzzle4 :: Puzzle+puzzle4 = (58, f)+  where f   [     a2, a3, a4, a5,     a7,     a9,+              b1,     b3, b4,     b6, b7, b8,+              c1, c2,         c5, c6,     c8, c9,+              d1, d2,         d5, d6,     d8, d9,+              e1,     e3, e4,     e6, e7, e8,+                  f2, f3, f4, f5,     f7, f8, f9,+                  g2, g3, g4, g5, g6, g7,     g9,+              h1,     h3, h4, h5, h6, h7, h8,+              i1, i2,     i4, i5, i6,     i8, i9 ]+         = [ [ 1, a2, a3, a4, a5,  7, a7,  9, a9],+             [b1,  3, b3, b4,  2, b6, b7, b8,  8],+             [c1, c2,  9,  6, c5, c6,  5, c8, c9],+             [d1, d2,  5,  3, d5, d6,  9, d8, d9],+             [e1,  1, e3, e4,  8, e6, e7, e8,  2],+             [ 6, f2, f3, f4, f5,  4, f7, f8, f9],+             [ 3, g2, g3, g4, g5, g6, g7,  1, g9],+             [h1,  4, h3, h4, h5, h6, h7, h8,  7],+             [i1, i2,  7, i4, i5, i6,  3, i8, i9] ]+        f _ = error "puzzle4 needs exactly 58 elements!"++-- | This one has been called diabolical, apparently+puzzle5 :: Puzzle+puzzle5 = (53, f)+  where f   [ a1,     a3,     a5, a6,         a9,+              b1,         b4, b5,     b7,     b9,+                  c2,     c4, c5, c6, c7, c8, c9,+              d1, d2,     d4,     d6, d7, d8,+              e1, e2, e3,     e5,     e7, e8, e9,+                  f2, f3, f4,     f6,     f8, f9,+              g1, g2, g3, g4, g5, g6,     g8,+              h1,     h3,     h5, h6,         h9,+              i1,         i4, i5,     i7,     i9 ]+         = [ [a1,  9, a3,  7, a5, a6,  8,  6, a9],+             [b1,  3,  1, b4, b5,  5, b7,  2, b9],+             [ 8, c2,  6, c4, c5, c6, c7, c8, c9],+             [d1, d2,  7, d4,  5, d6, d7, d8,  6],+             [e1, e2, e3,  3, e5,  7, e7, e8, e9],+             [ 5, f2, f3, f4,  1, f6,  7, f8, f9],+             [g1, g2, g3, g4, g5, g6,  1, g8,  9],+             [h1,  2, h3,  6, h5, h6,  3,  5, h9],+             [i1,  5,  4, i4, i5,  8, i7,  7, i9] ]+        f _ = error "puzzle5 needs exactly 53 elements!"++-- | The following is nefarious according to+-- <http://haskell.org/haskellwiki/Sudoku>+puzzle6 :: Puzzle+puzzle6 = (64, f)+  where f   [ a1, a2, a3, a4,     a6, a7,     a9,+              b1,     b3, b4, b5, b6, b7, b8, b9,+              c1, c2,     c4, c5, c6, c7, c8, c9,+              d1,     d3, d4, d5, d6,     d8,+                  e2, e3, e4,     e6, e7, e8, e9,+              f1, f2, f3, f4, f5, f6,     f8, f9,+              g1, g2,         g5,     g7, g8, g9,+                  h2, h3,     h5, h6,     h8, h9,+              i1, i2, i3, i4, i5, i6, i7,     i9  ]+         = [ [a1, a2, a3, a4,  6, a6, a7,  8, a9],+             [b1,  2, b3, b4, b5, b6, b7, b8, b9],+             [c1, c2,  1, c4, c5, c6, c7, c8, c9],+             [d1,  7, d3, d4, d5, d6,  1, d8,  2],+             [ 5, e2, e3, e4,  3, e6, e7, e8, e9],+             [f1, f2, f3, f4, f5, f6,  4, f8, f9],+             [g1, g2,  4,  2, g5,  1, g7, g8, g9],+             [ 3, h2, h3,  7, h5, h6,  6, h8, h9],+             [i1, i2, i3, i4, i5, i6, i7,  5, i9] ]+        f _ = error "puzzle6 needs exactly 64 elements!"++-- | Solve them all, this takes a fraction of a second to run for each case+allPuzzles :: IO ()+allPuzzles = mapM_ sudoku [puzzle0, puzzle1, puzzle2, puzzle3, puzzle4, puzzle5, puzzle6]
+ Documentation/SBV/Examples/Puzzles/U2Bridge.hs view
@@ -0,0 +1,278 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.U2Bridge+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- The famous U2 bridge crossing puzzle: <http://www.braingle.com/brainteasers/515/u2.html>+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE DeriveGeneric        #-}++module Documentation.SBV.Examples.Puzzles.U2Bridge where++import Control.Monad       (unless)+import Control.Monad.State (State, runState, put, get, gets, modify, evalState)++import GHC.Generics (Generic)++import Data.SBV++-------------------------------------------------------------+-- * Modeling the puzzle+-------------------------------------------------------------++-- | U2 band members. We want to translate this to SMT-Lib as a data-type, and hence the+-- call to mkSymbolicEnumeration.+data U2Member = Bono | Edge | Adam | Larry++-- | Make 'U2Member' a symbolic value.+mkSymbolicEnumeration ''U2Member++-- | Symbolic shorthand for a 'U2Member'+type SU2Member = SBV U2Member++-- | Shorthands for symbolic versions of the members+bono, edge, adam, larry :: SU2Member+[bono, edge, adam, larry] = map literal [Bono, Edge, Adam, Larry]++-- | Model time using 32 bits+type Time  = Word32++-- | Symbolic variant for time+type STime = SBV Time++-- | Crossing times for each member of the band+crossTime :: U2Member -> Time+crossTime Bono  = 1+crossTime Edge  = 2+crossTime Adam  = 5+crossTime Larry = 10++-- | The symbolic variant.. The duplication is unfortunate.+sCrossTime :: SU2Member -> STime+sCrossTime m =   ite (m .== bono) (literal (crossTime Bono))+               $ ite (m .== edge) (literal (crossTime Edge))+               $ ite (m .== adam) (literal (crossTime Adam))+                                  (literal (crossTime Larry)) -- Must be Larry++-- | Location of the flash+data Location = Here | There++-- | Make 'Location' a symbolic value.+mkSymbolicEnumeration ''Location++-- | Symbolic variant of 'Location'+type SLocation = SBV Location++-- | Shorthands for symbolic versions of locations+here, there :: SLocation+[here, there]  = map literal [Here, There]++-- | The status of the puzzle after each move+--+-- This type is equipped with an automatically derived 'Mergeable' instance+-- because each field is 'Mergeable'. A 'Generic' instance must also be derived+-- for this to work, and the 'DeriveAnyClass' language extension must be+-- enabled. The derived 'Mergeable' instance simply walks down the structure+-- field by field and merges each one. An equivalent hand-written 'Mergeable'+-- instance is provided in a comment below.+data Status = Status { time   :: STime       -- ^ elapsed time+                     , flash  :: SLocation   -- ^ location of the flash+                     , lBono  :: SLocation   -- ^ location of Bono+                     , lEdge  :: SLocation   -- ^ location of Edge+                     , lAdam  :: SLocation   -- ^ location of Adam+                     , lLarry :: SLocation   -- ^ location of Larry+                     } deriving (Generic, Mergeable)++-- The derived Mergeable instance is equivalent to the following:+--+-- instance Mergeable Status where+--   symbolicMerge f t s1 s2 = Status { time   = symbolicMerge f t (time   s1) (time   s2)+--                                    , flash  = symbolicMerge f t (flash  s1) (flash  s2)+--                                    , lBono  = symbolicMerge f t (lBono  s1) (lBono  s2)+--                                    , lEdge  = symbolicMerge f t (lEdge  s1) (lEdge  s2)+--                                    , lAdam  = symbolicMerge f t (lAdam  s1) (lAdam  s2)+--                                    , lLarry = symbolicMerge f t (lLarry s1) (lLarry s2)+--                                    }++-- | Start configuration, time elapsed is 0 and everybody is 'here'+start :: Status+start = Status { time   = 0+               , flash  = here+               , lBono  = here+               , lEdge  = here+               , lAdam  = here+               , lLarry = here+               }++-- | A puzzle move is modeled as a state-transformer+type Move a = State Status a++-- | Mergeable instance for 'Move' simply pushes the merging the data after run of each branch+-- starting from the same state.+instance Mergeable a => Mergeable (Move a) where+  symbolicMerge f t a b+    = do s <- get+         let (ar, s1) = runState a s+             (br, s2) = runState b s+         put $ symbolicMerge f t s1 s2+         return $ symbolicMerge f t ar br++-- | Read the state via an accessor function+peek :: (Status -> a) -> Move a+peek = gets++-- | Given an arbitrary member, return his location+whereIs :: SU2Member -> Move SLocation+whereIs p =  ite (p .== bono) (peek lBono)+           $ ite (p .== edge) (peek lEdge)+           $ ite (p .== adam) (peek lAdam)+                              (peek lLarry)++-- | Transferring the flash to the other side+xferFlash :: Move ()+xferFlash = modify $ \s -> s{flash = ite (flash s .== here) there here}++-- | Transferring a person to the other side+xferPerson :: SU2Member -> Move ()+xferPerson p =  do [lb, le, la, ll] <- mapM peek [lBono, lEdge, lAdam, lLarry]+                   let move l = ite (l .== here) there here+                       lb' = ite (p .== bono)  (move lb) lb+                       le' = ite (p .== edge)  (move le) le+                       la' = ite (p .== adam)  (move la) la+                       ll' = ite (p .== larry) (move ll) ll+                   modify $ \s -> s{lBono = lb', lEdge = le', lAdam = la', lLarry = ll'}++-- | Increment the time, when only one person crosses+bumpTime1 :: SU2Member -> Move ()+bumpTime1 p = modify $ \s -> s{time = time s + sCrossTime p}++-- | Increment the time, when two people cross together+bumpTime2 :: SU2Member -> SU2Member -> Move ()+bumpTime2 p1 p2 = modify $ \s -> s{time = time s + sCrossTime p1 `smax` sCrossTime p2}++-- | Symbolic version of 'when'+whenS :: SBool -> Move () -> Move ()+whenS t a = ite t a (return ())++-- | Move one member, remembering to take the flash+move1 :: SU2Member -> Move ()+move1 p = do f <- peek flash+             l <- whereIs p+             -- only do the move if the person and the flash are at the same side+             whenS (f .== l) $ do bumpTime1 p+                                  xferFlash+                                  xferPerson p++-- | Move two members, again with the flash+move2 :: SU2Member -> SU2Member -> Move ()+move2 p1 p2 = do f  <- peek flash+                 l1 <- whereIs p1+                 l2 <- whereIs p2+                 -- only do the move if both people and the flash are at the same side+                 whenS (f .== l1 &&& f .== l2) $ do bumpTime2 p1 p2+                                                    xferFlash+                                                    xferPerson p1+                                                    xferPerson p2++-------------------------------------------------------------+-- * Actions+-------------------------------------------------------------++-- | A move action is a sequence of triples. The first component is symbolically+-- True if only one member crosses. (In this case the third element of the triple+-- is irrelevant.) If the first component is (symbolically) False, then both members+-- move together+type Actions = [(SBool, SU2Member, SU2Member)]++-- | Run a sequence of given actions.+run :: Actions -> Move [Status]+run = mapM step+ where step (b, p1, p2) = ite b (move1 p1) (move2 p1 p2) >> get++-------------------------------------------------------------+-- * Recognizing valid solutions+-------------------------------------------------------------++-- | Check if a given sequence of actions is valid, i.e., they must all+-- cross the bridge according to the rules and in less than 17 seconds+isValid :: Actions -> SBool+isValid as = time end .<= 17 &&& bAll check as &&& zigZag (cycle [there, here]) (map flash states) &&& bAll (.== there) [lBono end, lEdge end, lAdam end, lLarry end]+  where check (s, p1, p2) =   (bnot s ==> p1 .> p2)      -- for two person moves, ensure first person is "larger"+                          &&& (s      ==> p2 .== bono)   -- for one person moves, ensure second person is always "bono"+        states = evalState (run as) start+        end = last states+        zigZag reqs locs = bAnd $ zipWith (.==) locs reqs++-------------------------------------------------------------+-- * Solving the puzzle+-------------------------------------------------------------++-- | See if there is a solution that has precisely @n@ steps+solveN :: Int -> IO Bool+solveN n = do putStrLn $ "Checking for solutions with " ++ show n ++ " move" ++ plu n ++ "."+              let genAct = do b  <- exists_+                              p1 <- exists_+                              p2 <- exists_+                              return (b, p1, p2)+              res <- allSat $ isValid `fmap` mapM (const genAct) [1..n]+              cnt <- displayModels disp res+              if cnt == 0 then return False+                          else do putStrLn $ "Found: " ++ show cnt ++ " solution" ++ plu cnt ++ " with " ++ show n ++ " move" ++ plu n ++ "."+                                  return True+  where plu v = if v == 1 then "" else "s"+        disp :: Int -> (Bool, [(Bool, U2Member, U2Member)]) -> IO ()+        disp i (_, ss)+         | lss /= n = error $ "Expected " ++ show n ++ " results; got: " ++ show lss+         | True     = do putStrLn $ "Solution #" ++ show i ++ ": "+                         go False 0 ss+                         return ()+         where lss  = length ss+               go _ t []                   = putStrLn $ "Total time: " ++ show t+               go l t ((True,  a, _):rest) = do putStrLn $ sh2 t ++ shL l ++ show a+                                                go (not l) (t + crossTime a) rest+               go l t ((False, a, b):rest) = do putStrLn $ sh2 t ++ shL l ++ show a ++ ", " ++ show b+                                                go (not l) (t + crossTime a `max` crossTime b) rest+               sh2 t = let s = show t in if length s < 2 then ' ' : s else s+               shL False = " --> "+               shL True  = " <-- "++-- | Solve the U2-bridge crossing puzzle, starting by testing solutions with+-- increasing number of steps, until we find one. We have:+--+-- >>> solveU2+-- Checking for solutions with 1 move.+-- Checking for solutions with 2 moves.+-- Checking for solutions with 3 moves.+-- Checking for solutions with 4 moves.+-- Checking for solutions with 5 moves.+-- Solution #1:+--  0 --> Edge, Bono+--  2 <-- Bono+--  3 --> Larry, Adam+-- 13 <-- Edge+-- 15 --> Edge, Bono+-- Total time: 17+-- Solution #2:+--  0 --> Edge, Bono+--  2 <-- Edge+--  4 --> Larry, Adam+-- 14 <-- Bono+-- 15 --> Edge, Bono+-- Total time: 17+-- Found: 2 solutions with 5 moves.+--+-- Finding all possible solutions to the puzzle.+solveU2 :: IO ()+solveU2 = go 1+ where go i = do p <- solveN i+                 unless p $ go (i+1)
+ Documentation/SBV/Examples/Queries/AllSat.hs view
@@ -0,0 +1,86 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Queries.AllSat+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- When we would like to find all solutions to a problem, we can query the+-- solver repeatedly, telling it to give us a new model each time. SBV already+-- provides 'allSat' that precisely does this. However, this example demonstrates+-- how the query mode can be used to achieve the same, and can also incorporate+-- extra conditions with easy as we walk through solutions.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Queries.AllSat where++import Data.SBV+import Data.SBV.Control++import Data.List++-- | Find all solutions to @x + y .== 10@ for positive @x@ and @y@, but at each+-- iteration we would like to ensure that the value of @x@ we get is at least twice as large as+-- the previous one. This is rather silly, but demonstrates how we can dynamically+-- query the result and put in new constraints based on those.+goodSum :: Symbolic [(Integer, Integer)]+goodSum = do x <- sInteger "x"+             y <- sInteger "y"++             -- constrain positive and sum:+             constrain $ x .>= 0+             constrain $ y .>= 0+             constrain $ x + y .== 10++             -- Capture the "next" solution function:+             let next i sofar = do+                    io $ putStrLn $ "Iteration: " ++ show (i :: Int)++                    cs <- checkSat+                    case cs of+                      Unk   -> error "Too bad, solver said unknown.." -- Won't happen+                      Unsat -> do io $ putStrLn "No other solution!"+                                  return sofar++                      Sat   -> do xv <- getValue x+                                  yv <- getValue y++                                  io $ putStrLn $ "Current solution is: " ++ show (xv, yv)++                                  -- For next iteration: Put in constraints outlawing the current one:+                                  -- Note that we do *not* put these separately, as we do want+                                  -- to allow repetition on one value if the other is different!+                                  constrain $   x ./= literal xv+                                            ||| y ./= literal yv++                                  -- Also request @x@ to be twice as large, for demo purposes:+                                  constrain $ x .>= 2 * literal xv++                                  -- loop around!+                                  next (i+1) ((xv, yv) : sofar)++             -- Go into query mode and execute the loop:+             query $ do io $ putStrLn "Starting the all-sat engine!"+                        next 1 []++-- | Run the query. We have:+--+-- >>> demo+-- Starting the all-sat engine!+-- Iteration: 1+-- Current solution is: (0,10)+-- Iteration: 2+-- Current solution is: (1,9)+-- Iteration: 3+-- Current solution is: (2,8)+-- Iteration: 4+-- Current solution is: (4,6)+-- Iteration: 5+-- Current solution is: (8,2)+-- Iteration: 6+-- No other solution!+-- [(0,10),(1,9),(2,8),(4,6),(8,2)]+demo :: IO ()+demo = do ss <- runSMT goodSum+          print $ sort ss
+ Documentation/SBV/Examples/Queries/CaseSplit.hs view
@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Queries.CaseSplit+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- A couple of demonstrations for the 'caseSplit' function.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Queries.CaseSplit where++import Data.SBV+import Data.SBV.Control++-- | A simple floating-point problem, but we do the sat-analysis via a case-split.+-- Due to the nature of floating-point numbers, a case-split on the characteristics+-- of the number (such as NaN, negative-zero, etc. is most suitable.)+--+-- We have:+-- >>> csDemo1+-- Case fpIsNegativeZero: Starting+-- Case fpIsNegativeZero: Unsatisfiable+-- Case fpIsPositiveZero: Starting+-- Case fpIsPositiveZero: Unsatisfiable+-- Case fpIsNormal: Starting+-- Case fpIsNormal: Unsatisfiable+-- Case fpIsSubnormal: Starting+-- Case fpIsSubnormal: Unsatisfiable+-- Case fpIsPoint: Starting+-- Case fpIsPoint: Unsatisfiable+-- Case fpIsNaN: Starting+-- Case fpIsNaN: Satisfiable+-- ("fpIsNaN",NaN)+csDemo1 :: IO (String, Float)+csDemo1 = runSMT $ do++       x <- sFloat "x"++       constrain $ x ./= x -- yes, in the FP land, this does hold++       query $ do mbR <- caseSplit True [ ("fpIsNegativeZero", fpIsNegativeZero x)+                                        , ("fpIsPositiveZero", fpIsPositiveZero x)+                                        , ("fpIsNormal",       fpIsNormal       x)+                                        , ("fpIsSubnormal",    fpIsSubnormal    x)+                                        , ("fpIsPoint",        fpIsPoint        x)+                                        , ("fpIsNaN",          fpIsNaN          x)+                                        ]++                  case mbR of+                    Nothing     -> error "Cannot find a FP number x such that x == x + 1"  -- Won't happen!+                    Just (s, _) -> do xv <- getValue x+                                      return (s, xv)++-- | Demonstrates the "coverage" case.+--+-- We have:+-- >>> csDemo2+-- Case negative: Starting+-- Case negative: Unsatisfiable+-- Case less than 8: Starting+-- Case less than 8: Unsatisfiable+-- Case Coverage: Starting+-- Case Coverage: Satisfiable+-- ("Coverage",10)+csDemo2 :: IO (String, Integer)+csDemo2 = runSMT $ do++       x <- sInteger "x"++       constrain $ x .== 10++       query $ do mbR <- caseSplit True [ ("negative"   , x .< 0)+                                        , ("less than 8", x .< 8)+                                        ]++                  case mbR of+                    Nothing     -> error "Cannot find a solution!" -- Won't happen!+                    Just (s, _) -> do xv <- getValue x+                                      return (s, xv)
+ Documentation/SBV/Examples/Queries/Enums.hs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Queries.Enums+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates the use of enumeration values during queries.+-----------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Documentation.SBV.Examples.Queries.Enums where++import Data.SBV+import Data.SBV.Control++-- | Days of the week. We make it symbolic using the 'mkSymbolicEnumeration' splice.+data Day = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday++-- | Make 'Day' a symbolic value.+mkSymbolicEnumeration ''Day++-- | The type synonym 'SDay' is the symbolic variant of 'Day'. (Similar to 'SInteger'/'Integer'+-- and others.)+type SDay = SBV Day++-- | A trivial query to find three consecutive days that's all before 'Thursday'. The point+-- here is that we can perform queries on such enumerated values and use 'getValue' on them+-- and return their values from queries just like any other value. We have:+--+-- >>> findDays+-- [Monday,Tuesday,Wednesday]+findDays :: IO [Day]+findDays = runSMT $ do (d1 :: SDay) <- free "d1"+                       (d2 :: SDay) <- free "d2"+                       (d3 :: SDay) <- free "d3"++                       -- Assert that they are ordered+                       constrain $ d1 .<= d2+                       constrain $ d2 .<= d3++                       -- Assert that last day is before 'Thursday'+                       constrain $ d3 .< literal Thursday++                       -- Constraints can be given before or after+                       -- the query mode starts. We will assert that+                       -- they are different after we start interacting+                       -- with the solver. Note that we can query the+                       -- values based on other values obtained too,+                       -- if we want to guide the search.++                       query $ do constrain $ distinct [d1, d2, d3]++                                  cs <- checkSat+                                  case cs of+                                    Sat -> do a <- getValue d1+                                              b <- getValue d2+                                              c <- getValue d3+                                              return [a, b, c]++                                    _   -> error "Impossible, can't find days!"
+ Documentation/SBV/Examples/Queries/FourFours.hs view
@@ -0,0 +1,218 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Queries.FourFours+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- A query based solution to the four-fours puzzle.+-- Inspired by <http://www.gigamonkeys.com/trees/>+--+-- @+-- Try to make every number between 0 and 20 using only four 4s and any+-- mathematical operation, with all four 4s being used each time.+-- @+--+-- We pretty much follow the structure of <http://www.gigamonkeys.com/trees/>,+-- with the exception that we generate the trees filled with symbolic operators+-- and ask the SMT solver to find the appropriate fillings.+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Documentation.SBV.Examples.Queries.FourFours where++import Data.SBV+import Data.SBV.Control++import Data.List (inits, tails)+import Data.Maybe++-- | Supported binary operators. To keep the search-space small, we will only allow division by @2@ or @4@,+-- and exponentiation will only be to the power @0@. This does restrict the search space, but is sufficient to+-- solve all the instances.+data BinOp = Plus | Minus | Times | Divide | Expt++-- | Make 'BinOp' a symbolic value.+mkSymbolicEnumeration ''BinOp++-- | Supported unary operators. Similar to 'BinOp' case, we will restrict square-root and factorial to+-- be only applied to the value @4.+data UnOp  = Negate | Sqrt | Factorial++-- | Make 'UnOp' a symbolic value.+mkSymbolicEnumeration ''UnOp++-- | Symbolic variant of 'BinOp'.+type SBinOp = SBV BinOp++-- | Symbolic variant of 'UnOp'.+type SUnOp  = SBV UnOp++-- | The shape of a tree, either a binary node, or a unary node, or the number @4@, represented hear by+-- the constructor @F@. We parameterize by the operator type: When doing symbolic computations, we'll fill+-- those with 'SBinOp' and 'SUnOp'. When finding the shapes, we will simply put unit values, i.e., holes.+data T b u = B b (T b u) (T b u)+           | U u (T b u)+           | F++-- | A rudimentary 'Show' instance for trees, nothing fancy.+instance Show (T BinOp UnOp) where+   show F       = "4"+   show (U u t) = case u of+                    Negate    -> "-" ++ show t+                    Sqrt      -> "sqrt(" ++ show t ++ ")"+                    Factorial -> show t ++ "!"+   show (B o l r) = "(" ++ show l ++ " " ++ so ++ " " ++ show r ++ ")"+     where so = fromMaybe (error $ "Unexpected operator: " ++ show o)+                        $ o `lookup` [(Plus, "+"), (Minus, "-"), (Times, "*"), (Divide, "/"), (Expt, "^")]++-- | Construct all possible tree shapes. The argument here follows the logic in <http://www.gigamonkeys.com/trees/>:+-- We simply construct all possible shapes and extend with the operators. The number of such trees is:+--+-- >>> length allPossibleTrees+-- 640+--+-- Note that this is a /lot/ smaller than what is generated by <http://www.gigamonkeys.com/trees/>. (There, the+-- number of trees is 10240000: 16000 times more than what we have to consider!)+allPossibleTrees :: [T () ()]+allPossibleTrees = trees $ replicate 4 F+  where trees :: [T () ()] -> [T () ()]+        trees [x] = [x, U () x]+        trees xs  = do (left, right) <- splits+                       t1            <- trees left+                       t2            <- trees right+                       trees [B () t1 t2]+          where splits = init $ tail $ zip (inits xs) (tails xs)++-- | Given a tree with hols, fill it with symbolic operators. This is the /trick/ that allows+-- us to consider only 640 trees as opposed to over 10 million.+fill :: T () () -> Symbolic (T SBinOp SUnOp)+fill (B _ l r) = B <$> free_ <*> fill l <*> fill r+fill (U _ t)   = U <$> free_ <*> fill t+fill F         = return F++-- | Minor helper for writing "symbolic" case statements. Simply walks down a list+-- of values to match against a symbolic version of the key.+sCase :: (SymWord a, Mergeable v) => SBV a -> [(a, v)] -> v+sCase k = walk+  where walk []              = error "sCase: Expected a non-empty list of cases!"+        walk [(_, v)]        = v+        walk ((k1, v1):rest) = ite (k .== literal k1) v1 (walk rest)++-- | Evaluate a symbolic tree, obtaining a symbolic value. Note how we structure+-- this evaluation so we impose extra constraints on what values square-root, divide+-- etc. can take. This is the power of the symbolic approach: We can put arbitrary+-- symbolic constraints as we evaluate the tree.+eval :: T SBinOp SUnOp -> Symbolic SInteger+eval tree = case tree of+              B b l r -> eval l >>= \l' -> eval r >>= \r' -> binOp b l' r'+              U u t   -> eval t >>= uOp u+              F       -> return 4++  where binOp :: SBinOp -> SInteger -> SInteger -> Symbolic SInteger+        binOp o l r = do constrain $ o .== literal Divide ==> r .== 4 ||| r .== 2+                         constrain $ o .== literal Expt   ==> r .== 0+                         return $ sCase o+                                    [ (Plus,    l+r)+                                    , (Minus,   l-r)+                                    , (Times,   l*r)+                                    , (Divide,  l `sDiv` r)+                                    , (Expt,    1)   -- exponent is restricted to 0, so the value is 1+                                    ]++        uOp :: SUnOp -> SInteger -> Symbolic SInteger+        uOp o v = do constrain $ o .== literal Sqrt      ==> v .== 4+                     constrain $ o .== literal Factorial ==> v .== 4+                     return $ sCase o+                                [ (Negate,    -v)+                                , (Sqrt,       2)  -- argument is restricted to 4, so the value is 2+                                , (Factorial, 24)  -- argument is restricted to 4, so the value is 24+                                ]++-- | In the query mode, find a filling of a given tree shape /t/, such that it evalutes to the+-- requested number /i/. Note that we return back a concrete tree.+generate :: Integer -> T () () -> IO (Maybe (T BinOp UnOp))+generate i t = runSMT $ do symT <- fill t+                           val  <- eval symT+                           constrain $ val .== literal i+                           query $ do cs <- checkSat+                                      case cs of+                                        Sat -> Just <$> construct symT+                                        _   -> return Nothing+    where -- Walk through the tree, ask the solver for+          -- the assignment to symbolic operators and fill back.+          construct F           = return F+          construct (U o s')    = do uo <- getValue o+                                     U uo <$> construct s'+          construct (B b l' r') = do bo <- getValue b+                                     B bo <$> construct l' <*> construct r'++-- | Given an integer, walk through all possible tree shapes (at most 640 of them), and find a+-- filling that solves the puzzle.+find :: Integer -> IO ()+find target = go allPossibleTrees+  where go []     = putStrLn $ show target ++ ": No solution found."+        go (t:ts) = do chk <- generate target t+                       case chk of+                         Nothing -> go ts+                         Just r  -> do let ok  = concEval r == target+                                           tag = if ok then " [OK]: " else " [BAD]: "+                                           sh i | i < 10 = ' ' : show i+                                                | True   =       show i++                                       putStrLn $ sh target ++ tag ++ show r++        -- Make sure the result is correct!+        concEval :: T BinOp UnOp -> Integer+        concEval F         = 4+        concEval (U u t)   = uEval u (concEval t)+        concEval (B b l r) = bEval b (concEval l) (concEval r)++        uEval :: UnOp -> Integer -> Integer+        uEval Negate    i = -i+        uEval Sqrt      i = if i == 4 then  2 else error $ "uEval: Found sqrt applied to value: " ++ show i+        uEval Factorial i = if i == 4 then 24 else error $ "uEval: Found factorial applied to value: " ++ show i++        bEval :: BinOp -> Integer -> Integer -> Integer+        bEval Plus   i j = i + j+        bEval Minus  i j = i - j+        bEval Times  i j = i * j+        bEval Divide i j = i `div` j+        bEval Expt   i j = i ^ j++-- | Solution to the puzzle. When you run this puzzle, the solver can produce different results+-- than what's shown here, but the expressions should still be all valid!+--+-- @+-- ghci> puzzle+--  0 [OK]: (4 - (4 + (4 - 4)))+--  1 [OK]: (4 / (4 + (4 - 4)))+--  2 [OK]: sqrt((4 + (4 * (4 - 4))))+--  3 [OK]: (4 - (4 ^ (4 - 4)))+--  4 [OK]: (4 + (4 * (4 - 4)))+--  5 [OK]: (4 + (4 ^ (4 - 4)))+--  6 [OK]: (4 + sqrt((4 * (4 / 4))))+--  7 [OK]: (4 + (4 - (4 / 4)))+--  8 [OK]: (4 - (4 - (4 + 4)))+--  9 [OK]: (4 + (4 + (4 / 4)))+-- 10 [OK]: (4 + (4 + (4 - sqrt(4))))+-- 11 [OK]: (4 + ((4 + 4!) / 4))+-- 12 [OK]: (4 * (4 - (4 / 4)))+-- 13 [OK]: (4! + ((sqrt(4) - 4!) / sqrt(4)))+-- 14 [OK]: (4 + (4 + (4 + sqrt(4))))+-- 15 [OK]: (4 + ((4! - sqrt(4)) / sqrt(4)))+-- 16 [OK]: (4 * (4 * (4 / 4)))+-- 17 [OK]: (4 + ((sqrt(4) + 4!) / sqrt(4)))+-- 18 [OK]: -(4 + (4 - (sqrt(4) + 4!)))+-- 19 [OK]: -(4 - (4! - (4 / 4)))+-- 20 [OK]: (4 * (4 + (4 / 4)))+-- @+puzzle :: IO ()+puzzle = mapM_ find [0 .. 20]
+ Documentation/SBV/Examples/Queries/GuessNumber.hs view
@@ -0,0 +1,78 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Queries.GuessNumber+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- A simple number-guessing game implementation via queries. Clearly an+-- SMT solver is hardly needed for this problem, but it is a nice demo+-- for the interactive-query programming.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Queries.GuessNumber where++import Data.SBV+import Data.SBV.Control++-- | Use the backend solver to guess the number given as argument.+-- The number is assumed to be between @0@ and @1000@, and we use a simple+-- binary search. Returns the sequence of guesses we performed during+-- the search process.+guess :: Integer -> Symbolic [Integer]+guess input = do g <- sInteger "guess"++                 -- A simple loop to find the value in a query. lb and up+                 -- correspond to the current lower/upper bound we operate in.+                 let loop lb ub sofar = do++                          io $ putStrLn $ "Current bounds: " ++ show (lb, ub)++                          -- Assert the current bound:+                          constrain $ g .>= literal lb+                          constrain $ g .<= literal ub++                          -- Issue a check-sat+                          cs <- checkSat+                          case cs of+                            Unk   -> error "Too bad, solver said Unknown.." -- Won't really happen+                            Unsat ->+                                  -- This cannot happen! If it does, the input was+                                  -- not properly constrainted. Note that we found this+                                  -- by getting an Unsat, not by checking the value!+                                  error $ unlines [ "There's no solution!"+                                                  , "Guess sequence: " ++ show (reverse sofar)+                                                  ]+                            Sat   -> do gv <- getValue g+                                        case gv `compare` input of+                                          EQ -> -- Got it, return:+                                                return (reverse (gv : sofar))+                                          LT -> -- Solver guess is too small, increase the lower bound:+                                                loop ((lb+1) `max` (lb + (input - lb) `div` 2)) ub (gv : sofar)+                                          GT -> -- Solver guess is too big, decrease the upper bound:+                                                loop lb ((ub-1) `min` (ub - (ub - input) `div` 2)) (gv : sofar)++                 -- Start the search+                 query $ loop 0 1000 []++-- | Play a round of the game, making the solver guess the secret number 42.+-- Note that you can generate a random-number and make the solver guess it too!+-- We have:+--+-- >>> play+-- Current bounds: (0,1000)+-- Current bounds: (0,521)+-- Current bounds: (21,521)+-- Current bounds: (31,521)+-- Current bounds: (36,521)+-- Current bounds: (39,521)+-- Current bounds: (40,521)+-- Current bounds: (41,521)+-- Current bounds: (42,521)+-- Solved in: 9 guesses:+--   1000 0 21 31 36 39 40 41 42+play :: IO ()+play = do gs <- runSMT (guess 42)+          putStrLn $ "Solved in: " ++ show (length gs) ++ " guesses:"+          putStrLn $ "  " ++ unwords (map show gs)
+ Documentation/SBV/Examples/Queries/Interpolants.hs view
@@ -0,0 +1,65 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Queries.Interpolants+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates extraction of interpolants via queries.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Queries.Interpolants where++import Data.SBV+import Data.SBV.Control++-- | Compute the interpolant for formulas @y = 2x@ and @y = 2z+1@.+-- These formulas are not satisfiable together since it would mean+-- @y@ is both even and odd at the same time. An interpolant for+-- this pair of formulas is a formula that's expressed only in terms+-- of @y@, which is the only common symbol among them. We have:+--+-- >>> runSMT evenOdd+-- ["(<= 0 (+ (div s1 2) (div (* (- 1) s1) 2)))"]+--+-- This is a bit hard to read unfortunately, due to translation artifacts and use of strings. To analyze,+-- we need to know that @s1@ is @y@ through SBV's translation. Let's express it in+-- regular infix notation with @y@ for @s1@:+--+-- @ 0 <= (y `div` 2) + ((-y) `div` 2)@+--+-- Notice that the only symbol is @y@, as required. To establish that this is+-- indeed an interpolant, we should establish that when @y@ is even, this formula+-- is @True@; and if @y@ is odd, then then it should be @False@. You can argue+-- mathematically that this indeed the case, but let's just use SBV to prove these:+--+-- >>> prove $ \y -> (y `sMod` 2 .== 0) ==> (0 .<= (y `sDiv` 2) + ((-y) `sDiv` 2::SInteger))+-- Q.E.D.+--+-- And:+--+-- >>> prove $ \y -> (y `sMod` 2 .== 1) ==> bnot (0 .<= (y `sDiv` 2) + ((-y) `sDiv` 2::SInteger))+-- Q.E.D.+--+-- This establishes that we indeed have an interpolant!+evenOdd :: Symbolic [String]+evenOdd = do+       x <- sInteger "x"+       y <- sInteger "y"+       z <- sInteger "z"++       -- tell the solver we want interpolants+       setOption $ ProduceInterpolants True++       -- create named constraints, which will allow+       -- computation of the interpolants for our formulas+       namedConstraint "y is even" $ y .== 2*x+       namedConstraint "y is odd"  $ y .== 2*z + 1++       -- To obtain the interpolant, we run a query+       query $ do cs <- checkSat+                  case cs of+                    Unsat -> getInterpolant ["y is even", "y is odd"]+                    Sat   -> error "Unexpected sat result!"+                    Unk   -> error "Unexpected unknown result!"
+ Documentation/SBV/Examples/Queries/UnsatCore.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Queries.UnsatCore+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates extraction of unsat-cores via queries.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Queries.UnsatCore where++import Data.SBV+import Data.SBV.Control++-- | A simple goal with three constraints, two of which are+-- conflicting with each other. The third is irrelevant, in the sense+-- that it does not contribute to the fact that the goal is unsatisfiable.+p :: Symbolic (Maybe [String])+p = do a <- sInteger "a"+       b <- sInteger "b"++       -- tell the solver we want unsat-cores+       setOption $ ProduceUnsatCores True++       -- create named constraints, which will allow+       -- unsat-core extraction with the given names+       namedConstraint "less than 5"  $ a .< 5+       namedConstraint "more than 10" $ a .> 10+       namedConstraint "irrelevant"   $ a .> b++       -- To obtain the unsat-core, we run a query+       query $ do cs <- checkSat+                  case cs of+                    Unsat -> Just <$> getUnsatCore+                    _     -> return Nothing+++-- | Extract the unsat-core of 'p'. We have:+--+-- >>> ucCore+-- Unsat core is: ["less than 5","more than 10"]+--+-- Demonstrating that the constraint @a .> b@ is /not/ needed for unsatisfiablity in this case.+ucCore :: IO ()+ucCore = do mbCore <- runSMT p+            case mbCore of+              Nothing   -> putStrLn "Problem is satisfiable."+              Just core -> putStrLn $ "Unsat core is: " ++ show core
+ Documentation/SBV/Examples/Strings/RegexCrossword.hs view
@@ -0,0 +1,104 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.RegexCrossword+-- Copyright   :  (c) Joel Burget+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- This example solves regex crosswords from <http://regexcrossword.com>+-----------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}++module Documentation.SBV.Examples.Strings.RegexCrossword where++import Data.List (genericLength, transpose)++import Data.SBV+import Data.SBV.Control++import qualified Data.SBV.String as S+import qualified Data.SBV.RegExp as R++-- | Solve a given crossword, returning the corresponding rows+solveCrossword :: [R.RegExp] -> [R.RegExp] -> IO [String]+solveCrossword rowRegExps colRegExps = runSMT $ do+        let numRows = genericLength rowRegExps+            numCols = genericLength colRegExps++        -- constrain rows+        let mkRow rowRegExp = do row <- free_+                                 constrain $ row `R.match` rowRegExp+                                 constrain $ S.length row .== literal numCols+                                 return row++        rows <- mapM mkRow rowRegExps++        -- constrain colums+        let mkCol colRegExp = do col <- free_+                                 constrain $ col `R.match` colRegExp+                                 constrain $ S.length col .== literal numRows+                                 return col++        cols <- mapM mkCol colRegExps++        -- constrain each "cell" as they rows/columns intersect:+        let rowss =           [[r .!! literal i | i <- [0..numCols-1]] | r <- rows]+        let colss = transpose [[c .!! literal i | i <- [0..numRows-1]] | c <- cols]++        constrain $ bAnd $ zipWith (.==) (concat rowss) (concat colss)++        -- Now query to extract the solution+        query $ do cs <- checkSat+                   case cs of+                     Unk   -> error "Solver returned unknown!"+                     Unsat -> error "There are no solutions to this puzzle!"+                     Sat   -> mapM getValue rows++-- | Solve <http://regexcrossword.com/challenges/intermediate/puzzles/1>+--+-- >>> puzzle1+-- ["ATO","WEL"]+puzzle1 :: IO [String]+puzzle1 = solveCrossword rs cs+  where rs = [ R.KStar (R.oneOf "NOTAD")  -- [NOTAD]*+             , "WEL" + "BAL" + "EAR"      -- WEL|BAL|EAR+             ]++        cs = [ "UB" + "IE" + "AW"         -- UB|IE|AW+             , R.KStar (R.oneOf "TUBE")   -- [TUBE]*+             , R.oneOf "BORF" * R.All     -- [BORF].+             ]++-- | Solve <http://regexcrossword.com/challenges/intermediate/puzzles/2>+--+-- >>> puzzle2+-- ["WA","LK","ER"]+puzzle2 :: IO [String]+puzzle2 = solveCrossword rs cs+  where rs = [ R.KPlus (R.oneOf "AWE")       -- [AWE]++             , R.KPlus (R.oneOf "ALP") * "K" -- [ALP]+K+             , "PR" + "ER" + "EP"            -- (PR|ER|EP)+             ]++        cs = [ R.oneOf "BQW" * ("PR" + "LE") -- [BQW](PR|LE)+             , R.KPlus (R.oneOf "RANK")      -- [RANK]++             ]++-- | Solve <http://regexcrossword.com/challenges/palindromeda/puzzles/3>+--+-- >>> puzzle3+-- ["RATS","ABUT","TUBA","STAR"]+puzzle3 :: IO [String]+puzzle3 = solveCrossword rs cs+ where rs = [ R.KStar (R.oneOf "TRASH")                -- [TRASH]*+            , ("FA" + "AB") * R.KStar (R.oneOf "TUP")  -- (FA|AB)[TUP]*+            , R.KStar ("BA" + "TH" + "TU")             -- (BA|TH|TU)*+            , R.KStar R.All * "A" * R.KStar R.All      -- .*A.*+            ]++       cs = [ R.KStar ("TS" + "RA" + "QA")                     -- (TS|RA|QA)*+            , R.KStar ("AB" + "UT" + "AR")                     -- (AB|UT|AR)*+            , ("K" + "T") * "U" * R.KStar R.All * ("A" + "R")  -- (K|T)U.*(A|R)+            , R.KPlus ("AR" + "FS" + "ST")                     -- (AR|FS|ST)++            ]
+ Documentation/SBV/Examples/Strings/SQLInjection.hs view
@@ -0,0 +1,138 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Puzzles.SQLInjection+-- Copyright   :  (c) Joel Burget+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Implement the symbolic evaluation of a language which operates on+-- strings in a way similar to bash. It's possible to do different analyses,+-- but this example finds program inputs which result in a query containing a+-- SQL injection.+-----------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Documentation.SBV.Examples.Strings.SQLInjection where++import Control.Monad.State+import Control.Monad.Writer+import Data.String++import Data.SBV+import Data.SBV.Control++import qualified Data.SBV.RegExp as R++-- | Simple expression language+data SQLExpr = Query   SQLExpr+             | Const   String+             | Concat  SQLExpr SQLExpr+             | ReadVar SQLExpr++-- | Literals strings can be lifted to be constant programs+instance IsString SQLExpr where+  fromString = Const++-- | Evaluation monad. The state argument is the environment to store+-- variables as we evaluate.+type M = StateT (SFunArray String String) (WriterT [SString] Symbolic)++-- | Given an expression, symbolically evaluate it+eval :: SQLExpr -> M SString+eval (Query q)         = do q' <- eval q+                            tell [q']+                            lift $ lift exists_+eval (Const str)       = return $ literal str+eval (Concat e1 e2)    = (.++) <$> eval e1 <*> eval e2+eval (ReadVar nm)      = do n   <- eval nm+                            arr <- get+                            return $ readArray arr n++-- | A simple program to query all messages with a given topic id. In SQL like notation:+--+-- @+--   query ("SELECT msg FROM msgs where topicid='" ++ my_topicid ++ "'")+-- @+exampleProgram :: SQLExpr+exampleProgram = Query $ foldr1 Concat [ "SELECT msg FROM msgs WHERE topicid='"+                                       , ReadVar "my_topicid"+                                       , "'"+                                       ]++-- | Limit names to be at most 7 chars long, with simple letters.+nameRe :: R.RegExp+nameRe = R.Loop 1 7 (R.Range 'a' 'z')++-- | Strings: Again, at most of lenght 5, surrounded by quotes.+strRe :: R.RegExp+strRe = "'" * R.Loop 1 5 (R.Range 'a' 'z' + " ") * "'"++-- | A "select" command:+selectRe :: R.RegExp+selectRe = "SELECT "+         * (nameRe + "*")+         * " FROM "+         * nameRe+         * R.Opt (  " WHERE "+                  * nameRe+                  * "="+                  * (nameRe + strRe)+                  )++-- | A "drop" instruction, which can be exploited!+dropRe :: R.RegExp+dropRe = "DROP TABLE " * (nameRe + strRe)++-- | We'll greatly simplify here and say a statement is either a select or a drop:+statementRe :: R.RegExp+statementRe = selectRe + dropRe++-- | The exploit: We're looking for a DROP TABLE after at least one legitimate command.+exploitRe :: R.RegExp+exploitRe = R.KPlus (statementRe * "; ")+          * "DROP TABLE 'users'"++-- | Analyze the program for inputs which result in a SQL injection. There are+-- other possible injections, but in this example we're only looking for a+-- @DROP TABLE@ command.+--+-- Remember that our example program (in pseudo-code) is:+--+-- @+--   query ("SELECT msg FROM msgs where topicid='" ++ my_topicid ++ "'")+-- @+--+-- We have:+--+-- >>> findInjection exampleProgram+-- "h'; DROP TABLE 'users"+--+-- Indeed, if we substitute the suggested string, we get the program:+--+-- @+--   query ("SELECT msg FROM msgs where topicid='h'; DROP TABLE 'users'")+-- @+--+-- which would query for topic 'h' and then delete the users table!+findInjection :: SQLExpr -> IO String+findInjection expr = runSMT $ do+    badTopic <- sString "badTopic"++    -- Create an initial environment that returns the symbolic+    -- value my_topicid only, and undefined for all other variables+    undef      <- sString "uninitialized"+    let env :: SFunArray String String+        env = mkSFunArray $ \varName -> ite (varName .== "my_topicid") badTopic undef++    (_, queries) <- runWriterT (evalStateT (eval expr) env)++    -- For all the queries thus generated, ask that one of them be "explotiable"+    constrain $ bAny (`R.match` exploitRe) queries++    query $ do cs <- checkSat+               case cs of+                 Unk   -> error "Solver returned unknown!"+                 Unsat -> error "No exploits are found"+                 Sat   -> getValue badTopic
+ Documentation/SBV/Examples/Uninterpreted/AUF.hs view
@@ -0,0 +1,91 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Uninterpreted.AUF+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Formalizes and proves the following theorem, about arithmetic,+-- uninterpreted functions, and arrays. (For reference, see <http://research.microsoft.com/en-us/um/redmond/projects/z3/fmcad06-slides.pdf>+-- slide number 24):+--+-- @+--    x + 2 = y  implies  f (read (write (a, x, 3), y - 2)) = f (y - x + 1)+-- @+--+-- We interpret the types as follows (other interpretations certainly possible):+--+--    [/x/] 'SWord32' (32-bit unsigned address)+--+--    [/y/] 'SWord32' (32-bit unsigned address)+--+--    [/a/] An array, indexed by 32-bit addresses, returning 32-bit unsigned integers+--+--    [/f/] An uninterpreted function of type @'SWord32' -> 'SWord64'@+--+-- The function @read@ and @write@ are usual array operations.+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Uninterpreted.AUF where++import Data.SBV++--------------------------------------------------------------+-- * Model using functional arrays+--------------------------------------------------------------++-- | The array type, takes symbolic 32-bit unsigned indexes+-- and stores 32-bit unsigned symbolic values. These are+-- functional arrays where reading before writing a cell+-- throws an exception.+type A = SFunArray Word32 Word32++-- | Uninterpreted function in the theorem+f :: SWord32 -> SWord64+f = uninterpret "f"++-- | Correctness theorem. We state it for all values of @x@, @y@, and+-- the given array @a@. +thm1 :: SWord32 -> SWord32 -> A -> SBool+thm1 x y a = lhs ==> rhs+  where lhs = x + 2 .== y+        rhs =     f (readArray (writeArray a x 3) (y - 2))+              .== f (y - x + 1)++-- | Prints Q.E.D. when run, as expected+--+-- >>> proveThm1+-- Q.E.D.+proveThm1 :: IO ThmResult+proveThm1 = prove $ do+                x <- free "x"+                y <- free "y"+                -- Take an "initialized" array, one that returns 0's for all initial reads+                let a = mkSFunArray (const 0)+                return $ thm1 x y a++--------------------------------------------------------------+-- * Model using SMT arrays+--------------------------------------------------------------++-- | This version directly uses SMT-arrays and hence does not need an initializer.+-- Reading an element before writing to it returns an arbitrary value.+type B = SArray Word32 Word32++-- | Same as 'thm1', except we don't need an initializer with the 'SArray' model.+thm2 :: SWord32 -> SWord32 -> B -> SBool+thm2 x y a = lhs ==> rhs+  where lhs = x + 2 .== y+        rhs =     f (readArray (writeArray a x 3) (y - 2))+              .== f (y - x + 1)++-- | Prints Q.E.D. when run, as expected:+--+-- >>> proveThm2+-- Q.E.D.+proveThm2 :: IO ThmResult+proveThm2 = prove $ do+                x <- free "x"+                y <- free "y"+                thm2 x y <$> newArray "b"
+ Documentation/SBV/Examples/Uninterpreted/Deduce.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Uninterpreted.Deduce+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates uninterpreted sorts and how they can be used for deduction.+-- This example is inspired by the discussion at <http://stackoverflow.com/questions/10635783/using-axioms-for-deductions-in-z3>,+-- essentially showing how to show the required deduction using SBV.+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Documentation.SBV.Examples.Uninterpreted.Deduce where++import Data.Generics+import Data.SBV++-- we will have our own "uninterpreted" functions corresponding+-- to not/or/and, so hide their Prelude counterparts.+import Prelude hiding (not, or, and)++-----------------------------------------------------------------------------+-- * Representing uninterpreted booleans+-----------------------------------------------------------------------------++-- | The uninterpreted sort 'B', corresponding to the carrier.+-- To prevent SBV from translating it to an enumerated type, we simply attach an unused field+newtype B = B () deriving (Eq, Ord, Show, Read, Data, SymWord, HasKind)++-- | Handy shortcut for the type of symbolic values over 'B'+type SB = SBV B++-----------------------------------------------------------------------------+-- * Uninterpreted connectives over 'B'+-----------------------------------------------------------------------------++-- | Uninterpreted logical connective 'and'+and :: SB -> SB -> SB+and = uninterpret "AND"++-- | Uninterpreted logical connective 'or'+or :: SB -> SB -> SB+or  = uninterpret "OR"++-- | Uninterpreted logical connective 'not'+not :: SB -> SB+not = uninterpret "NOT"++-----------------------------------------------------------------------------+-- * Axioms of the logical system+-----------------------------------------------------------------------------++-- | Distributivity of OR over AND, as an axiom in terms of+-- the uninterpreted functions we have introduced. Note how+-- variables range over the uninterpreted sort 'B'.+ax1 :: [String]+ax1 = [ "(assert (forall ((p B) (q B) (r B))"+      , "   (= (AND (OR p q) (OR p r))"+      , "      (OR p (AND q r)))))"+      ]++-- | One of De Morgan's laws, again as an axiom in terms+-- of our uninterpeted logical connectives.+ax2 :: [String]+ax2 = [ "(assert (forall ((p B) (q B))"+      , "   (= (NOT (OR p q))"+      , "      (AND (NOT p) (NOT q)))))"+      ]++-- | Double negation axiom, similar to the above.+ax3 :: [String]+ax3 = ["(assert (forall ((p B)) (= (NOT (NOT p)) p)))"]++-----------------------------------------------------------------------------+-- * Demonstrated deduction+-----------------------------------------------------------------------------++-- | Proves the equivalence @NOT (p OR (q AND r)) == (NOT p AND NOT q) OR (NOT p AND NOT r)@,+-- following from the axioms we have specified above. We have:+--+-- >>> test+-- Q.E.D.+test :: IO ThmResult+test = prove $ do addAxiom "OR distributes over AND" ax1+                  addAxiom "de Morgan"               ax2+                  addAxiom "double negation"         ax3+                  p <- free "p"+                  q <- free "q"+                  r <- free "r"+                  return $   not (p `or` (q `and` r))+                         .== (not p `and` not q) `or` (not p `and` not r)
+ Documentation/SBV/Examples/Uninterpreted/Function.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Uninterpreted.Function+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates function counter-examples+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Uninterpreted.Function where++import Data.SBV++-- | An uninterpreted function+f :: SWord8 -> SWord8 -> SWord16+f = uninterpret "f"++-- | Asserts that @f x z == f (y+2) z@ whenever @x == y+2@. Naturally correct:+--+-- >>> prove thmGood+-- Q.E.D.+thmGood :: SWord8 -> SWord8 -> SWord8 -> SBool+thmGood x y z = x .== y+2 ==> f x z .== f (y + 2) z
+ Documentation/SBV/Examples/Uninterpreted/Shannon.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Uninterpreted.Shannon+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Proves (instances of) Shannon's expansion theorem and other relevant+-- facts.  See: <http://en.wikipedia.org/wiki/Shannon's_expansion>+-----------------------------------------------------------------------------++module Documentation.SBV.Examples.Uninterpreted.Shannon where++import Data.SBV++-----------------------------------------------------------------------------+-- * Boolean functions+-----------------------------------------------------------------------------++-- | A ternary boolean function+type Ternary = SBool -> SBool -> SBool -> SBool++-- | A binary boolean function+type Binary = SBool -> SBool-> SBool++-----------------------------------------------------------------------------+-- * Shannon cofactors+-----------------------------------------------------------------------------++-- | Positive Shannon cofactor of a boolean function, with+-- respect to its first argument+pos :: (SBool -> a) -> a+pos f = f true++-- | Negative Shannon cofactor of a boolean function, with+-- respect to its first argument+neg :: (SBool -> a) -> a+neg f = f false++-----------------------------------------------------------------------------+-- * Shannon expansion theorem+-----------------------------------------------------------------------------++-- | Shannon's expansion over the first argument of a function. We have:+--+-- >>> shannon+-- Q.E.D.+shannon :: IO ThmResult+shannon = prove $ \x y z -> f x y z .== (x &&& pos f y z ||| bnot x &&& neg f y z)+ where f :: Ternary+       f = uninterpret "f"++-- | Alternative form of Shannon's expansion over the first argument of a function. We have:+--+-- >>> shannon2+-- Q.E.D.+shannon2 :: IO ThmResult+shannon2 = prove $ \x y z -> f x y z .== ((x ||| neg f y z) &&& (bnot x ||| pos f y z))+ where f :: Ternary+       f = uninterpret "f"++-----------------------------------------------------------------------------+-- * Derivatives+-----------------------------------------------------------------------------++-- | Computing the derivative of a boolean function (boolean difference).+-- Defined as exclusive-or of Shannon cofactors with respect to that+-- variable.+derivative :: Ternary -> Binary+derivative f y z = pos f y z <+> neg f y z++-- | The no-wiggle theorem: If the derivative of a function with respect to+-- a variable is constant False, then that variable does not "wiggle" the+-- function; i.e., any changes to it won't affect the result of the function.+-- In fact, we have an equivalence: The variable only changes the+-- result of the function iff the derivative with respect to it is not False:+--+-- >>> noWiggle+-- Q.E.D.+noWiggle :: IO ThmResult+noWiggle = prove $ \y z -> bnot (f' y z) <=> pos f y z .== neg f y z+  where f :: Ternary+        f  = uninterpret "f"+        f' = derivative f++-----------------------------------------------------------------------------+-- * Universal quantification+-----------------------------------------------------------------------------++-- | Universal quantification of a boolean function with respect to a variable.+-- Simply defined as the conjunction of the Shannon cofactors.+universal :: Ternary -> Binary+universal f y z = pos f y z &&& neg f y z++-- | Show that universal quantification is really meaningful: That is, if the universal+-- quantification with respect to a variable is True, then both cofactors are true for+-- those arguments. Of course, this is a trivial theorem if you think about it for a+-- moment, or you can just let SBV prove it for you:+--+-- >>> univOK+-- Q.E.D.+univOK :: IO ThmResult+univOK = prove $ \y z -> f' y z ==> pos f y z &&& neg f y z+  where f :: Ternary+        f  = uninterpret "f"+        f' = universal f++-----------------------------------------------------------------------------+-- * Existential quantification+-----------------------------------------------------------------------------++-- | Existential quantification of a boolean function with respect to a variable.+-- Simply defined as the conjunction of the Shannon cofactors.+existential :: Ternary -> Binary+existential f y z = pos f y z ||| neg f y z++-- | Show that existential quantification is really meaningful: That is, if the existential+-- quantification with respect to a variable is True, then one of the cofactors must be true for+-- those arguments. Again, this is a trivial theorem if you think about it for a moment, but+-- we will just let SBV prove it:+--+-- >>> existsOK+-- Q.E.D.+existsOK :: IO ThmResult+existsOK = prove $ \y z -> f' y z ==> pos f y z ||| neg f y z+  where f :: Ternary+        f  = uninterpret "f"+        f' = existential f
+ Documentation/SBV/Examples/Uninterpreted/Sort.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Uninterpreted.Sort+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates uninterpreted sorts, together with axioms.+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Documentation.SBV.Examples.Uninterpreted.Sort where++import Data.Generics+import Data.SBV++-- | A new data-type that we expect to use in an uninterpreted fashion+-- in the backend SMT solver. Note the custom @deriving@ clause, which+-- takes care of most of the boilerplate. The () field is needed so+-- SBV will not translate it to an enumerated data-type+newtype Q = Q () deriving (Eq, Ord, Data, Read, Show, SymWord, HasKind)++-- | Declare an uninterpreted function that works over Q's+f :: SBV Q -> SBV Q+f = uninterpret "f"++-- | A satisfiable example, stating that there is an element of the domain+-- 'Q' such that 'f' returns a different element. Note that this is valid only+-- when the domain 'Q' has at least two elements. We have:+--+-- >>> t1+-- Satisfiable. Model:+--   x = Q!val!0 :: Q+t1 :: IO SatResult+t1 = sat $ do x <- free "x"+              return $ f x ./= x++-- | This is a variant on the first example, except we also add an axiom+-- for the sort, stating that the domain 'Q' has only one element. In this case+-- the problem naturally becomes unsat. We have:+--+-- >>> t2+-- Unsatisfiable+t2 :: IO SatResult+t2 = sat $ do x <- free "x"+              addAxiom "Q" ["(assert (forall ((x Q) (y Q)) (= x y)))"]+              return $ f x ./= x
+ Documentation/SBV/Examples/Uninterpreted/UISortAllSat.hs view
@@ -0,0 +1,75 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Documentation.SBV.Examples.Uninterpreted.UISortAllSat+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates uninterpreted sorts and how all-sat behaves for them.+-- Thanks to Eric Seidel for the idea.+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Documentation.SBV.Examples.Uninterpreted.UISortAllSat where++import Data.Generics+import Data.SBV++-- | A "list-like" data type, but one we plan to uninterpret at the SMT level.+-- The actual shape is really immaterial for us, but could be used as a proxy+-- to generate test cases or explore data-space in some other part of a program.+-- Note that we neither rely on the shape of this data, nor need the actual+-- constructors.+data L = Nil+       | Cons Int L+       deriving (Eq, Ord, Show, Read, Data)++-- | Declare instances to make 'L' a usable uninterpreted sort. First we need the+-- 'SymWord' instance, with the default definition sufficing.+instance SymWord L++-- | Similarly, 'HasKind's default implementation is sufficient.+instance HasKind L++-- | An uninterpreted "classify" function. Really, we only care about+-- the fact that such a function exists, not what it does.+classify :: SBV L -> SInteger+classify = uninterpret "classify"++-- | Formulate a query that essentially asserts a cardinality constraint on+-- the uninterpreted sort 'L'. The goal is to say there are precisely 3+-- such things, as it might be the case. We manage this by declaring four+-- elements, and asserting that for a free variable of this sort, the+-- shape of the data matches one of these three instances. That is, we+-- assert that all the instances of the data 'L' can be classified into+-- 3 equivalence classes. Then, allSat returns all the possible instances,+-- which of course are all uninterpreted.+--+-- As expected, we have:+--+-- >>> genLs+-- Solution #1:+--   l  = L!val!0 :: L+--   l0 = L!val!0 :: L+--   l1 = L!val!1 :: L+--   l2 = L!val!2 :: L+-- Solution #2:+--   l  = L!val!1 :: L+--   l0 = L!val!0 :: L+--   l1 = L!val!1 :: L+--   l2 = L!val!2 :: L+-- Solution #3:+--   l  = L!val!2 :: L+--   l0 = L!val!0 :: L+--   l1 = L!val!1 :: L+--   l2 = L!val!2 :: L+-- Found 3 different solutions.+genLs :: IO AllSatResult+genLs = allSatWith z3+               $ do [l, l0, l1, l2] <- symbolics ["l", "l0", "l1", "l2"]+                    constrain $ classify l0 .== 0+                    constrain $ classify l1 .== 1+                    constrain $ classify l2 .== 2+                    return $ l .== l0 ||| l .== l1 ||| l .== l2
SBVTestSuite/GoldFiles/addSub.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/aes128Dec.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/aes128Enc.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/aes128Lib.gold view
@@ -3583,13 +3583,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/cgUninterpret.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/codeGen1.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/crcUSB5_1.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/crcUSB5_2.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/fib1.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/fib2.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/floats_cgen.gold view
@@ -1334,13 +1334,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/gcd.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/legato_c.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/merge.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
+ SBVTestSuite/GoldFiles/pbEq2.gold view
@@ -0,0 +1,57 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () Bool) ; tracks user variable "b0"+[GOOD] (declare-fun s1 () Bool) ; tracks user variable "b1"+[GOOD] (declare-fun s2 () Bool) ; tracks user variable "b2"+[GOOD] (declare-fun s3 () Bool) ; tracks user variable "b3"+[GOOD] (declare-fun s4 () Bool) ; tracks user variable "b4"+[GOOD] (declare-fun s5 () Bool) ; tracks user variable "b5"+[GOOD] (declare-fun s6 () Bool) ; tracks user variable "b6"+[GOOD] (declare-fun s7 () Bool) ; tracks user variable "b7"+[GOOD] (declare-fun s8 () Bool) ; tracks user variable "b8"+[GOOD] (declare-fun s9 () Bool) ; tracks user variable "b9"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s10 () Bool ((_ pbeq 3 1 1) s1 s2))+[GOOD] (define-fun s11 () Bool ((_ pbeq 1 1 1) s1 s2))+[GOOD] (define-fun s12 () Bool (ite s0 s10 s11))+[GOOD] (define-fun s13 () Bool ((_ pbeq 3 1 1 1) s0 s3 s4))+[GOOD] (define-fun s14 () Bool ((_ pbeq 1 1 1 1) s0 s3 s4))+[GOOD] (define-fun s15 () Bool (ite s2 s13 s14))+[GOOD] (define-fun s16 () Bool (and s12 s15))+[GOOD] (define-fun s17 () Bool (not s16))+[GOOD] (define-fun s18 () Bool (= s_2 s0))+[GOOD] (define-fun s19 () Bool (= s_2 s2))+[GOOD] (define-fun s20 () Bool (= s_2 s4))+[GOOD] (define-fun s21 () Bool (and s3 s20))+[GOOD] (define-fun s22 () Bool (and s19 s21))+[GOOD] (define-fun s23 () Bool (and s1 s22))+[GOOD] (define-fun s24 () Bool (and s18 s23))+[GOOD] (define-fun s25 () Bool (= s_2 s3))+[GOOD] (define-fun s26 () Bool (and s4 s25))+[GOOD] (define-fun s27 () Bool (and s19 s26))+[GOOD] (define-fun s28 () Bool (and s1 s27))+[GOOD] (define-fun s29 () Bool (and s18 s28))+[GOOD] (define-fun s30 () Bool (or s24 s29))+[GOOD] (define-fun s31 () Bool (or s17 s30))+[GOOD] (define-fun s32 () Bool (not s31))+[GOOD] (assert s32)+[SEND] (check-sat)+[RECV] unsat+*** Solver   : Z3+*** Exit code: ExitSuccess
SBVTestSuite/GoldFiles/popCount1.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/popCount2.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/query1.gold view
@@ -76,7 +76,7 @@ [SEND] (get-info :reason-unknown) [RECV] (:reason-unknown "state of the most recent check-sat command is not known") [SEND] (get-info :version)-[RECV] (:version "4.6.2")+[RECV] (:version "4.7.0") [SEND] (get-info :status) [RECV] (:status sat) [GOOD] (define-fun s16 () Int 4)@@ -107,7 +107,7 @@ [SEND] (get-info :reason-unknown) [RECV] (:reason-unknown "unknown") [SEND] (get-info :version)-[RECV] (:version "4.6.2")+[RECV] (:version "4.7.0") [SEND] (get-info :memory) [RECV] unsupported [SEND] (get-info :time)
+ SBVTestSuite/GoldFiles/query_Chars1.gold view
@@ -0,0 +1,36 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL) ; has unbounded values, using catch-all.+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] (define-fun s2 () Int 65)+[GOOD] (define-fun s4 () Int 66)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () (_ BitVec 8)) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s1 () Int (+ (ite (= ((_ extract 0 0) s0) #b1) 1 0) (ite (= ((_ extract 1 1) s0) #b1) 2 0) (ite (= ((_ extract 2 2) s0) #b1) 4 0) (ite (= ((_ extract 3 3) s0) #b1) 8 0) (ite (= ((_ extract 4 4) s0) #b1) 16 0) (ite (= ((_ extract 5 5) s0) #b1) 32 0) (ite (= ((_ extract 6 6) s0) #b1) 64 0) (ite (= ((_ extract 7 7) s0) #b1) 128 0)))+[GOOD] (define-fun s3 () Bool (>= s1 s2))+[GOOD] (define-fun s5 () Bool (< s1 s4))+[GOOD] (assert s3)+[GOOD] (assert s5)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 #x41))+*** Solver   : Z3+*** Exit code: ExitSuccess++FINAL OUTPUT:+'A'
+ SBVTestSuite/GoldFiles/query_Strings1.gold view
@@ -0,0 +1,31 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s1 () Bool (str.in.re s0 ((_ re.loop 5 5) (str.to.re "xyz"))))+[GOOD] (assert s1)+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "xyzxyzxyzxyzxyz"))+*** Solver   : Z3+*** Exit code: ExitSuccess++FINAL OUTPUT:+["xyzxyzxyzxyzxyz"]
SBVTestSuite/GoldFiles/selChecked.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/GoldFiles/selUnchecked.gold view
@@ -48,13 +48,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
+ SBVTestSuite/GoldFiles/strConcat.gold view
@@ -0,0 +1,24 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic QF_BV)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] ; --- skolem constants ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (assert s_1)+[SEND] (check-sat)+[RECV] sat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strConcatBad.gold view
@@ -0,0 +1,24 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic QF_BV)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] ; --- skolem constants ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (assert s_2)+[SEND] (check-sat)+[RECV] unsat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples1.gold view
@@ -0,0 +1,24 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic QF_BV)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] ; --- skolem constants ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (assert s_1)+[SEND] (check-sat)+[RECV] sat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples10.gold view
@@ -0,0 +1,30 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] (define-fun s3 () Int 6)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s1 () Bool (str.in.re s0 ((_ re.loop 1 3) (str.to.re "ab"))))+[GOOD] (define-fun s2 () Int (str.len s0))+[GOOD] (define-fun s4 () Bool (> s2 s3))+[GOOD] (assert s1)+[GOOD] (assert s4)+[SEND] (check-sat)+[RECV] unsat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples11.gold view
@@ -0,0 +1,32 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] (define-fun s1 () Int 11)+[GOOD] (define-fun s4 () String "11")+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () Int) ; tracks user variable "i"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () String (int.to.str s0))+[GOOD] (define-fun s5 () Bool (= s3 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (assert s2)+[GOOD] (assert s6)+[SEND] (check-sat)+[RECV] unsat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples12.gold view
@@ -0,0 +1,32 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] (define-fun s1 () Int (- 2))+[GOOD] (define-fun s4 () String "")+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () Int) ; tracks user variable "i"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () String (int.to.str s0))+[GOOD] (define-fun s5 () Bool (= s3 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (assert s2)+[GOOD] (assert s6)+[SEND] (check-sat)+[RECV] unsat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples13.gold view
@@ -0,0 +1,32 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] (define-fun s4 () Int 13)+[GOOD] (define-fun s1 () String "13")+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "s"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s2 () Bool (= s0 s1))+[GOOD] (define-fun s3 () Int (str.to.int s0))+[GOOD] (define-fun s5 () Bool (= s3 s4))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (assert s2)+[GOOD] (assert s6)+[SEND] (check-sat)+[RECV] unsat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples14.gold view
@@ -0,0 +1,2078 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] (define-fun s2 () Int 1)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "s"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s1 () Int (str.len s0))+[GOOD] (define-fun s3 () Bool (= s1 s2))+[GOOD] (assert s3)+*** Checking Satisfiability, all solutions..+Looking for solution 1+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x00"))+[GOOD] (define-fun s4 () String "\x00")+[GOOD] (define-fun s5 () Bool (distinct s0 s4))+[GOOD] (assert s5)+Looking for solution 2+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 " "))+[GOOD] (define-fun s6 () String " ")+[GOOD] (define-fun s7 () Bool (distinct s0 s6))+[GOOD] (assert s7)+Looking for solution 3+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x01"))+[GOOD] (define-fun s8 () String "\x01")+[GOOD] (define-fun s9 () Bool (distinct s0 s8))+[GOOD] (assert s9)+Looking for solution 4+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "!"))+[GOOD] (define-fun s10 () String "!")+[GOOD] (define-fun s11 () Bool (distinct s0 s10))+[GOOD] (assert s11)+Looking for solution 5+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x10"))+[GOOD] (define-fun s12 () String "\x10")+[GOOD] (define-fun s13 () Bool (distinct s0 s12))+[GOOD] (assert s13)+Looking for solution 6+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "0"))+[GOOD] (define-fun s14 () String "0")+[GOOD] (define-fun s15 () Bool (distinct s0 s14))+[GOOD] (assert s15)+Looking for solution 7+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x11"))+[GOOD] (define-fun s16 () String "\x11")+[GOOD] (define-fun s17 () Bool (distinct s0 s16))+[GOOD] (assert s17)+Looking for solution 8+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "1"))+[GOOD] (define-fun s18 () String "1")+[GOOD] (define-fun s19 () Bool (distinct s0 s18))+[GOOD] (assert s19)+Looking for solution 9+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x08"))+[GOOD] (define-fun s20 () String "\x08")+[GOOD] (define-fun s21 () Bool (distinct s0 s20))+[GOOD] (assert s21)+Looking for solution 10+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "("))+[GOOD] (define-fun s22 () String "(")+[GOOD] (define-fun s23 () Bool (distinct s0 s22))+[GOOD] (assert s23)+Looking for solution 11+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x09"))+[GOOD] (define-fun s24 () String "\x09")+[GOOD] (define-fun s25 () Bool (distinct s0 s24))+[GOOD] (assert s25)+Looking for solution 12+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 ")"))+[GOOD] (define-fun s26 () String ")")+[GOOD] (define-fun s27 () Bool (distinct s0 s26))+[GOOD] (assert s27)+Looking for solution 13+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x18"))+[GOOD] (define-fun s28 () String "\x18")+[GOOD] (define-fun s29 () Bool (distinct s0 s28))+[GOOD] (assert s29)+Looking for solution 14+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "8"))+[GOOD] (define-fun s30 () String "8")+[GOOD] (define-fun s31 () Bool (distinct s0 s30))+[GOOD] (assert s31)+Looking for solution 15+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x19"))+[GOOD] (define-fun s32 () String "\x19")+[GOOD] (define-fun s33 () Bool (distinct s0 s32))+[GOOD] (assert s33)+Looking for solution 16+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "9"))+[GOOD] (define-fun s34 () String "9")+[GOOD] (define-fun s35 () Bool (distinct s0 s34))+[GOOD] (assert s35)+Looking for solution 17+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x02"))+[GOOD] (define-fun s36 () String "\x02")+[GOOD] (define-fun s37 () Bool (distinct s0 s36))+[GOOD] (assert s37)+Looking for solution 18+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 """"))+[GOOD] (define-fun s38 () String """")+[GOOD] (define-fun s39 () Bool (distinct s0 s38))+[GOOD] (assert s39)+Looking for solution 19+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x03"))+[GOOD] (define-fun s40 () String "\x03")+[GOOD] (define-fun s41 () Bool (distinct s0 s40))+[GOOD] (assert s41)+Looking for solution 20+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "#"))+[GOOD] (define-fun s42 () String "#")+[GOOD] (define-fun s43 () Bool (distinct s0 s42))+[GOOD] (assert s43)+Looking for solution 21+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x12"))+[GOOD] (define-fun s44 () String "\x12")+[GOOD] (define-fun s45 () Bool (distinct s0 s44))+[GOOD] (assert s45)+Looking for solution 22+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "2"))+[GOOD] (define-fun s46 () String "2")+[GOOD] (define-fun s47 () Bool (distinct s0 s46))+[GOOD] (assert s47)+Looking for solution 23+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x13"))+[GOOD] (define-fun s48 () String "\x13")+[GOOD] (define-fun s49 () Bool (distinct s0 s48))+[GOOD] (assert s49)+Looking for solution 24+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "3"))+[GOOD] (define-fun s50 () String "3")+[GOOD] (define-fun s51 () Bool (distinct s0 s50))+[GOOD] (assert s51)+Looking for solution 25+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\n"))+[GOOD] (define-fun s52 () String "\n")+[GOOD] (define-fun s53 () Bool (distinct s0 s52))+[GOOD] (assert s53)+Looking for solution 26+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "*"))+[GOOD] (define-fun s54 () String "*")+[GOOD] (define-fun s55 () Bool (distinct s0 s54))+[GOOD] (assert s55)+Looking for solution 27+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\v"))+[GOOD] (define-fun s56 () String "\v")+[GOOD] (define-fun s57 () Bool (distinct s0 s56))+[GOOD] (assert s57)+Looking for solution 28+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "+"))+[GOOD] (define-fun s58 () String "+")+[GOOD] (define-fun s59 () Bool (distinct s0 s58))+[GOOD] (assert s59)+Looking for solution 29+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x1A"))+[GOOD] (define-fun s60 () String "\x1A")+[GOOD] (define-fun s61 () Bool (distinct s0 s60))+[GOOD] (assert s61)+Looking for solution 30+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 ":"))+[GOOD] (define-fun s62 () String ":")+[GOOD] (define-fun s63 () Bool (distinct s0 s62))+[GOOD] (assert s63)+Looking for solution 31+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x1B"))+[GOOD] (define-fun s64 () String "\x1B")+[GOOD] (define-fun s65 () Bool (distinct s0 s64))+[GOOD] (assert s65)+Looking for solution 32+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 ";"))+[GOOD] (define-fun s66 () String ";")+[GOOD] (define-fun s67 () Bool (distinct s0 s66))+[GOOD] (assert s67)+Looking for solution 33+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x04"))+[GOOD] (define-fun s68 () String "\x04")+[GOOD] (define-fun s69 () Bool (distinct s0 s68))+[GOOD] (assert s69)+Looking for solution 34+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "$"))+[GOOD] (define-fun s70 () String "$")+[GOOD] (define-fun s71 () Bool (distinct s0 s70))+[GOOD] (assert s71)+Looking for solution 35+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x05"))+[GOOD] (define-fun s72 () String "\x05")+[GOOD] (define-fun s73 () Bool (distinct s0 s72))+[GOOD] (assert s73)+Looking for solution 36+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "%"))+[GOOD] (define-fun s74 () String "%")+[GOOD] (define-fun s75 () Bool (distinct s0 s74))+[GOOD] (assert s75)+Looking for solution 37+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x14"))+[GOOD] (define-fun s76 () String "\x14")+[GOOD] (define-fun s77 () Bool (distinct s0 s76))+[GOOD] (assert s77)+Looking for solution 38+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "4"))+[GOOD] (define-fun s78 () String "4")+[GOOD] (define-fun s79 () Bool (distinct s0 s78))+[GOOD] (assert s79)+Looking for solution 39+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x15"))+[GOOD] (define-fun s80 () String "\x15")+[GOOD] (define-fun s81 () Bool (distinct s0 s80))+[GOOD] (assert s81)+Looking for solution 40+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "5"))+[GOOD] (define-fun s82 () String "5")+[GOOD] (define-fun s83 () Bool (distinct s0 s82))+[GOOD] (assert s83)+Looking for solution 41+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\f"))+[GOOD] (define-fun s84 () String "\f")+[GOOD] (define-fun s85 () Bool (distinct s0 s84))+[GOOD] (assert s85)+Looking for solution 42+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 ","))+[GOOD] (define-fun s86 () String ",")+[GOOD] (define-fun s87 () Bool (distinct s0 s86))+[GOOD] (assert s87)+Looking for solution 43+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\r"))+[GOOD] (define-fun s88 () String "\r")+[GOOD] (define-fun s89 () Bool (distinct s0 s88))+[GOOD] (assert s89)+Looking for solution 44+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "-"))+[GOOD] (define-fun s90 () String "-")+[GOOD] (define-fun s91 () Bool (distinct s0 s90))+[GOOD] (assert s91)+Looking for solution 45+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x1C"))+[GOOD] (define-fun s92 () String "\x1C")+[GOOD] (define-fun s93 () Bool (distinct s0 s92))+[GOOD] (assert s93)+Looking for solution 46+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "<"))+[GOOD] (define-fun s94 () String "<")+[GOOD] (define-fun s95 () Bool (distinct s0 s94))+[GOOD] (assert s95)+Looking for solution 47+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x1D"))+[GOOD] (define-fun s96 () String "\x1D")+[GOOD] (define-fun s97 () Bool (distinct s0 s96))+[GOOD] (assert s97)+Looking for solution 48+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "="))+[GOOD] (define-fun s98 () String "=")+[GOOD] (define-fun s99 () Bool (distinct s0 s98))+[GOOD] (assert s99)+Looking for solution 49+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x06"))+[GOOD] (define-fun s100 () String "\x06")+[GOOD] (define-fun s101 () Bool (distinct s0 s100))+[GOOD] (assert s101)+Looking for solution 50+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "&"))+[GOOD] (define-fun s102 () String "&")+[GOOD] (define-fun s103 () Bool (distinct s0 s102))+[GOOD] (assert s103)+Looking for solution 51+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x07"))+[GOOD] (define-fun s104 () String "\x07")+[GOOD] (define-fun s105 () Bool (distinct s0 s104))+[GOOD] (assert s105)+Looking for solution 52+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "'"))+[GOOD] (define-fun s106 () String "'")+[GOOD] (define-fun s107 () Bool (distinct s0 s106))+[GOOD] (assert s107)+Looking for solution 53+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x16"))+[GOOD] (define-fun s108 () String "\x16")+[GOOD] (define-fun s109 () Bool (distinct s0 s108))+[GOOD] (assert s109)+Looking for solution 54+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "6"))+[GOOD] (define-fun s110 () String "6")+[GOOD] (define-fun s111 () Bool (distinct s0 s110))+[GOOD] (assert s111)+Looking for solution 55+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x17"))+[GOOD] (define-fun s112 () String "\x17")+[GOOD] (define-fun s113 () Bool (distinct s0 s112))+[GOOD] (assert s113)+Looking for solution 56+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "7"))+[GOOD] (define-fun s114 () String "7")+[GOOD] (define-fun s115 () Bool (distinct s0 s114))+[GOOD] (assert s115)+Looking for solution 57+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x0E"))+[GOOD] (define-fun s116 () String "\x0E")+[GOOD] (define-fun s117 () Bool (distinct s0 s116))+[GOOD] (assert s117)+Looking for solution 58+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "."))+[GOOD] (define-fun s118 () String ".")+[GOOD] (define-fun s119 () Bool (distinct s0 s118))+[GOOD] (assert s119)+Looking for solution 59+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x0F"))+[GOOD] (define-fun s120 () String "\x0F")+[GOOD] (define-fun s121 () Bool (distinct s0 s120))+[GOOD] (assert s121)+Looking for solution 60+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "/"))+[GOOD] (define-fun s122 () String "/")+[GOOD] (define-fun s123 () Bool (distinct s0 s122))+[GOOD] (assert s123)+Looking for solution 61+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x1E"))+[GOOD] (define-fun s124 () String "\x1E")+[GOOD] (define-fun s125 () Bool (distinct s0 s124))+[GOOD] (assert s125)+Looking for solution 62+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 ">"))+[GOOD] (define-fun s126 () String ">")+[GOOD] (define-fun s127 () Bool (distinct s0 s126))+[GOOD] (assert s127)+Looking for solution 63+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x1F"))+[GOOD] (define-fun s128 () String "\x1F")+[GOOD] (define-fun s129 () Bool (distinct s0 s128))+[GOOD] (assert s129)+Looking for solution 64+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "?"))+[GOOD] (define-fun s130 () String "?")+[GOOD] (define-fun s131 () Bool (distinct s0 s130))+[GOOD] (assert s131)+Looking for solution 65+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x80"))+[GOOD] (define-fun s132 () String "\x80")+[GOOD] (define-fun s133 () Bool (distinct s0 s132))+[GOOD] (assert s133)+Looking for solution 66+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xa0"))+[GOOD] (define-fun s134 () String "\xa0")+[GOOD] (define-fun s135 () Bool (distinct s0 s134))+[GOOD] (assert s135)+Looking for solution 67+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x81"))+[GOOD] (define-fun s136 () String "\x81")+[GOOD] (define-fun s137 () Bool (distinct s0 s136))+[GOOD] (assert s137)+Looking for solution 68+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xa1"))+[GOOD] (define-fun s138 () String "\xa1")+[GOOD] (define-fun s139 () Bool (distinct s0 s138))+[GOOD] (assert s139)+Looking for solution 69+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x90"))+[GOOD] (define-fun s140 () String "\x90")+[GOOD] (define-fun s141 () Bool (distinct s0 s140))+[GOOD] (assert s141)+Looking for solution 70+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xb0"))+[GOOD] (define-fun s142 () String "\xb0")+[GOOD] (define-fun s143 () Bool (distinct s0 s142))+[GOOD] (assert s143)+Looking for solution 71+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x91"))+[GOOD] (define-fun s144 () String "\x91")+[GOOD] (define-fun s145 () Bool (distinct s0 s144))+[GOOD] (assert s145)+Looking for solution 72+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xb1"))+[GOOD] (define-fun s146 () String "\xb1")+[GOOD] (define-fun s147 () Bool (distinct s0 s146))+[GOOD] (assert s147)+Looking for solution 73+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x88"))+[GOOD] (define-fun s148 () String "\x88")+[GOOD] (define-fun s149 () Bool (distinct s0 s148))+[GOOD] (assert s149)+Looking for solution 74+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xa8"))+[GOOD] (define-fun s150 () String "\xa8")+[GOOD] (define-fun s151 () Bool (distinct s0 s150))+[GOOD] (assert s151)+Looking for solution 75+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x89"))+[GOOD] (define-fun s152 () String "\x89")+[GOOD] (define-fun s153 () Bool (distinct s0 s152))+[GOOD] (assert s153)+Looking for solution 76+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xa9"))+[GOOD] (define-fun s154 () String "\xa9")+[GOOD] (define-fun s155 () Bool (distinct s0 s154))+[GOOD] (assert s155)+Looking for solution 77+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x98"))+[GOOD] (define-fun s156 () String "\x98")+[GOOD] (define-fun s157 () Bool (distinct s0 s156))+[GOOD] (assert s157)+Looking for solution 78+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xb8"))+[GOOD] (define-fun s158 () String "\xb8")+[GOOD] (define-fun s159 () Bool (distinct s0 s158))+[GOOD] (assert s159)+Looking for solution 79+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x99"))+[GOOD] (define-fun s160 () String "\x99")+[GOOD] (define-fun s161 () Bool (distinct s0 s160))+[GOOD] (assert s161)+Looking for solution 80+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xb9"))+[GOOD] (define-fun s162 () String "\xb9")+[GOOD] (define-fun s163 () Bool (distinct s0 s162))+[GOOD] (assert s163)+Looking for solution 81+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x82"))+[GOOD] (define-fun s164 () String "\x82")+[GOOD] (define-fun s165 () Bool (distinct s0 s164))+[GOOD] (assert s165)+Looking for solution 82+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xa2"))+[GOOD] (define-fun s166 () String "\xa2")+[GOOD] (define-fun s167 () Bool (distinct s0 s166))+[GOOD] (assert s167)+Looking for solution 83+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x83"))+[GOOD] (define-fun s168 () String "\x83")+[GOOD] (define-fun s169 () Bool (distinct s0 s168))+[GOOD] (assert s169)+Looking for solution 84+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xa3"))+[GOOD] (define-fun s170 () String "\xa3")+[GOOD] (define-fun s171 () Bool (distinct s0 s170))+[GOOD] (assert s171)+Looking for solution 85+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x92"))+[GOOD] (define-fun s172 () String "\x92")+[GOOD] (define-fun s173 () Bool (distinct s0 s172))+[GOOD] (assert s173)+Looking for solution 86+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xb2"))+[GOOD] (define-fun s174 () String "\xb2")+[GOOD] (define-fun s175 () Bool (distinct s0 s174))+[GOOD] (assert s175)+Looking for solution 87+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x93"))+[GOOD] (define-fun s176 () String "\x93")+[GOOD] (define-fun s177 () Bool (distinct s0 s176))+[GOOD] (assert s177)+Looking for solution 88+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xb3"))+[GOOD] (define-fun s178 () String "\xb3")+[GOOD] (define-fun s179 () Bool (distinct s0 s178))+[GOOD] (assert s179)+Looking for solution 89+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x8a"))+[GOOD] (define-fun s180 () String "\x8a")+[GOOD] (define-fun s181 () Bool (distinct s0 s180))+[GOOD] (assert s181)+Looking for solution 90+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xaa"))+[GOOD] (define-fun s182 () String "\xaa")+[GOOD] (define-fun s183 () Bool (distinct s0 s182))+[GOOD] (assert s183)+Looking for solution 91+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x8b"))+[GOOD] (define-fun s184 () String "\x8b")+[GOOD] (define-fun s185 () Bool (distinct s0 s184))+[GOOD] (assert s185)+Looking for solution 92+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xab"))+[GOOD] (define-fun s186 () String "\xab")+[GOOD] (define-fun s187 () Bool (distinct s0 s186))+[GOOD] (assert s187)+Looking for solution 93+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x9a"))+[GOOD] (define-fun s188 () String "\x9a")+[GOOD] (define-fun s189 () Bool (distinct s0 s188))+[GOOD] (assert s189)+Looking for solution 94+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xba"))+[GOOD] (define-fun s190 () String "\xba")+[GOOD] (define-fun s191 () Bool (distinct s0 s190))+[GOOD] (assert s191)+Looking for solution 95+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x9b"))+[GOOD] (define-fun s192 () String "\x9b")+[GOOD] (define-fun s193 () Bool (distinct s0 s192))+[GOOD] (assert s193)+Looking for solution 96+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xbb"))+[GOOD] (define-fun s194 () String "\xbb")+[GOOD] (define-fun s195 () Bool (distinct s0 s194))+[GOOD] (assert s195)+Looking for solution 97+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x84"))+[GOOD] (define-fun s196 () String "\x84")+[GOOD] (define-fun s197 () Bool (distinct s0 s196))+[GOOD] (assert s197)+Looking for solution 98+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xa4"))+[GOOD] (define-fun s198 () String "\xa4")+[GOOD] (define-fun s199 () Bool (distinct s0 s198))+[GOOD] (assert s199)+Looking for solution 99+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x85"))+[GOOD] (define-fun s200 () String "\x85")+[GOOD] (define-fun s201 () Bool (distinct s0 s200))+[GOOD] (assert s201)+Looking for solution 100+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xa5"))+[GOOD] (define-fun s202 () String "\xa5")+[GOOD] (define-fun s203 () Bool (distinct s0 s202))+[GOOD] (assert s203)+Looking for solution 101+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x94"))+[GOOD] (define-fun s204 () String "\x94")+[GOOD] (define-fun s205 () Bool (distinct s0 s204))+[GOOD] (assert s205)+Looking for solution 102+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xb4"))+[GOOD] (define-fun s206 () String "\xb4")+[GOOD] (define-fun s207 () Bool (distinct s0 s206))+[GOOD] (assert s207)+Looking for solution 103+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x95"))+[GOOD] (define-fun s208 () String "\x95")+[GOOD] (define-fun s209 () Bool (distinct s0 s208))+[GOOD] (assert s209)+Looking for solution 104+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xb5"))+[GOOD] (define-fun s210 () String "\xb5")+[GOOD] (define-fun s211 () Bool (distinct s0 s210))+[GOOD] (assert s211)+Looking for solution 105+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x8c"))+[GOOD] (define-fun s212 () String "\x8c")+[GOOD] (define-fun s213 () Bool (distinct s0 s212))+[GOOD] (assert s213)+Looking for solution 106+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xac"))+[GOOD] (define-fun s214 () String "\xac")+[GOOD] (define-fun s215 () Bool (distinct s0 s214))+[GOOD] (assert s215)+Looking for solution 107+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x8d"))+[GOOD] (define-fun s216 () String "\x8d")+[GOOD] (define-fun s217 () Bool (distinct s0 s216))+[GOOD] (assert s217)+Looking for solution 108+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xad"))+[GOOD] (define-fun s218 () String "\xad")+[GOOD] (define-fun s219 () Bool (distinct s0 s218))+[GOOD] (assert s219)+Looking for solution 109+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x9c"))+[GOOD] (define-fun s220 () String "\x9c")+[GOOD] (define-fun s221 () Bool (distinct s0 s220))+[GOOD] (assert s221)+Looking for solution 110+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xbc"))+[GOOD] (define-fun s222 () String "\xbc")+[GOOD] (define-fun s223 () Bool (distinct s0 s222))+[GOOD] (assert s223)+Looking for solution 111+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x9d"))+[GOOD] (define-fun s224 () String "\x9d")+[GOOD] (define-fun s225 () Bool (distinct s0 s224))+[GOOD] (assert s225)+Looking for solution 112+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xbd"))+[GOOD] (define-fun s226 () String "\xbd")+[GOOD] (define-fun s227 () Bool (distinct s0 s226))+[GOOD] (assert s227)+Looking for solution 113+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x86"))+[GOOD] (define-fun s228 () String "\x86")+[GOOD] (define-fun s229 () Bool (distinct s0 s228))+[GOOD] (assert s229)+Looking for solution 114+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xa6"))+[GOOD] (define-fun s230 () String "\xa6")+[GOOD] (define-fun s231 () Bool (distinct s0 s230))+[GOOD] (assert s231)+Looking for solution 115+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x87"))+[GOOD] (define-fun s232 () String "\x87")+[GOOD] (define-fun s233 () Bool (distinct s0 s232))+[GOOD] (assert s233)+Looking for solution 116+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xa7"))+[GOOD] (define-fun s234 () String "\xa7")+[GOOD] (define-fun s235 () Bool (distinct s0 s234))+[GOOD] (assert s235)+Looking for solution 117+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x96"))+[GOOD] (define-fun s236 () String "\x96")+[GOOD] (define-fun s237 () Bool (distinct s0 s236))+[GOOD] (assert s237)+Looking for solution 118+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xb6"))+[GOOD] (define-fun s238 () String "\xb6")+[GOOD] (define-fun s239 () Bool (distinct s0 s238))+[GOOD] (assert s239)+Looking for solution 119+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x97"))+[GOOD] (define-fun s240 () String "\x97")+[GOOD] (define-fun s241 () Bool (distinct s0 s240))+[GOOD] (assert s241)+Looking for solution 120+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xb7"))+[GOOD] (define-fun s242 () String "\xb7")+[GOOD] (define-fun s243 () Bool (distinct s0 s242))+[GOOD] (assert s243)+Looking for solution 121+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x8e"))+[GOOD] (define-fun s244 () String "\x8e")+[GOOD] (define-fun s245 () Bool (distinct s0 s244))+[GOOD] (assert s245)+Looking for solution 122+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xae"))+[GOOD] (define-fun s246 () String "\xae")+[GOOD] (define-fun s247 () Bool (distinct s0 s246))+[GOOD] (assert s247)+Looking for solution 123+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x8f"))+[GOOD] (define-fun s248 () String "\x8f")+[GOOD] (define-fun s249 () Bool (distinct s0 s248))+[GOOD] (assert s249)+Looking for solution 124+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xaf"))+[GOOD] (define-fun s250 () String "\xaf")+[GOOD] (define-fun s251 () Bool (distinct s0 s250))+[GOOD] (assert s251)+Looking for solution 125+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x9e"))+[GOOD] (define-fun s252 () String "\x9e")+[GOOD] (define-fun s253 () Bool (distinct s0 s252))+[GOOD] (assert s253)+Looking for solution 126+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xbe"))+[GOOD] (define-fun s254 () String "\xbe")+[GOOD] (define-fun s255 () Bool (distinct s0 s254))+[GOOD] (assert s255)+Looking for solution 127+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\x9f"))+[GOOD] (define-fun s256 () String "\x9f")+[GOOD] (define-fun s257 () Bool (distinct s0 s256))+[GOOD] (assert s257)+Looking for solution 128+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xbf"))+[GOOD] (define-fun s258 () String "\xbf")+[GOOD] (define-fun s259 () Bool (distinct s0 s258))+[GOOD] (assert s259)+Looking for solution 129+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "@"))+[GOOD] (define-fun s260 () String "@")+[GOOD] (define-fun s261 () Bool (distinct s0 s260))+[GOOD] (assert s261)+Looking for solution 130+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "`"))+[GOOD] (define-fun s262 () String "`")+[GOOD] (define-fun s263 () Bool (distinct s0 s262))+[GOOD] (assert s263)+Looking for solution 131+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "A"))+[GOOD] (define-fun s264 () String "A")+[GOOD] (define-fun s265 () Bool (distinct s0 s264))+[GOOD] (assert s265)+Looking for solution 132+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "a"))+[GOOD] (define-fun s266 () String "a")+[GOOD] (define-fun s267 () Bool (distinct s0 s266))+[GOOD] (assert s267)+Looking for solution 133+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "P"))+[GOOD] (define-fun s268 () String "P")+[GOOD] (define-fun s269 () Bool (distinct s0 s268))+[GOOD] (assert s269)+Looking for solution 134+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "p"))+[GOOD] (define-fun s270 () String "p")+[GOOD] (define-fun s271 () Bool (distinct s0 s270))+[GOOD] (assert s271)+Looking for solution 135+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "Q"))+[GOOD] (define-fun s272 () String "Q")+[GOOD] (define-fun s273 () Bool (distinct s0 s272))+[GOOD] (assert s273)+Looking for solution 136+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "q"))+[GOOD] (define-fun s274 () String "q")+[GOOD] (define-fun s275 () Bool (distinct s0 s274))+[GOOD] (assert s275)+Looking for solution 137+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "H"))+[GOOD] (define-fun s276 () String "H")+[GOOD] (define-fun s277 () Bool (distinct s0 s276))+[GOOD] (assert s277)+Looking for solution 138+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "h"))+[GOOD] (define-fun s278 () String "h")+[GOOD] (define-fun s279 () Bool (distinct s0 s278))+[GOOD] (assert s279)+Looking for solution 139+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "I"))+[GOOD] (define-fun s280 () String "I")+[GOOD] (define-fun s281 () Bool (distinct s0 s280))+[GOOD] (assert s281)+Looking for solution 140+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "i"))+[GOOD] (define-fun s282 () String "i")+[GOOD] (define-fun s283 () Bool (distinct s0 s282))+[GOOD] (assert s283)+Looking for solution 141+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "X"))+[GOOD] (define-fun s284 () String "X")+[GOOD] (define-fun s285 () Bool (distinct s0 s284))+[GOOD] (assert s285)+Looking for solution 142+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "x"))+[GOOD] (define-fun s286 () String "x")+[GOOD] (define-fun s287 () Bool (distinct s0 s286))+[GOOD] (assert s287)+Looking for solution 143+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "Y"))+[GOOD] (define-fun s288 () String "Y")+[GOOD] (define-fun s289 () Bool (distinct s0 s288))+[GOOD] (assert s289)+Looking for solution 144+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "y"))+[GOOD] (define-fun s290 () String "y")+[GOOD] (define-fun s291 () Bool (distinct s0 s290))+[GOOD] (assert s291)+Looking for solution 145+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "B"))+[GOOD] (define-fun s292 () String "B")+[GOOD] (define-fun s293 () Bool (distinct s0 s292))+[GOOD] (assert s293)+Looking for solution 146+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "b"))+[GOOD] (define-fun s294 () String "b")+[GOOD] (define-fun s295 () Bool (distinct s0 s294))+[GOOD] (assert s295)+Looking for solution 147+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "C"))+[GOOD] (define-fun s296 () String "C")+[GOOD] (define-fun s297 () Bool (distinct s0 s296))+[GOOD] (assert s297)+Looking for solution 148+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "c"))+[GOOD] (define-fun s298 () String "c")+[GOOD] (define-fun s299 () Bool (distinct s0 s298))+[GOOD] (assert s299)+Looking for solution 149+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "R"))+[GOOD] (define-fun s300 () String "R")+[GOOD] (define-fun s301 () Bool (distinct s0 s300))+[GOOD] (assert s301)+Looking for solution 150+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "r"))+[GOOD] (define-fun s302 () String "r")+[GOOD] (define-fun s303 () Bool (distinct s0 s302))+[GOOD] (assert s303)+Looking for solution 151+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "S"))+[GOOD] (define-fun s304 () String "S")+[GOOD] (define-fun s305 () Bool (distinct s0 s304))+[GOOD] (assert s305)+Looking for solution 152+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "s"))+[GOOD] (define-fun s306 () String "s")+[GOOD] (define-fun s307 () Bool (distinct s0 s306))+[GOOD] (assert s307)+Looking for solution 153+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "J"))+[GOOD] (define-fun s308 () String "J")+[GOOD] (define-fun s309 () Bool (distinct s0 s308))+[GOOD] (assert s309)+Looking for solution 154+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "j"))+[GOOD] (define-fun s310 () String "j")+[GOOD] (define-fun s311 () Bool (distinct s0 s310))+[GOOD] (assert s311)+Looking for solution 155+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "K"))+[GOOD] (define-fun s312 () String "K")+[GOOD] (define-fun s313 () Bool (distinct s0 s312))+[GOOD] (assert s313)+Looking for solution 156+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "k"))+[GOOD] (define-fun s314 () String "k")+[GOOD] (define-fun s315 () Bool (distinct s0 s314))+[GOOD] (assert s315)+Looking for solution 157+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "Z"))+[GOOD] (define-fun s316 () String "Z")+[GOOD] (define-fun s317 () Bool (distinct s0 s316))+[GOOD] (assert s317)+Looking for solution 158+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "z"))+[GOOD] (define-fun s318 () String "z")+[GOOD] (define-fun s319 () Bool (distinct s0 s318))+[GOOD] (assert s319)+Looking for solution 159+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "["))+[GOOD] (define-fun s320 () String "[")+[GOOD] (define-fun s321 () Bool (distinct s0 s320))+[GOOD] (assert s321)+Looking for solution 160+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "{"))+[GOOD] (define-fun s322 () String "{")+[GOOD] (define-fun s323 () Bool (distinct s0 s322))+[GOOD] (assert s323)+Looking for solution 161+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "D"))+[GOOD] (define-fun s324 () String "D")+[GOOD] (define-fun s325 () Bool (distinct s0 s324))+[GOOD] (assert s325)+Looking for solution 162+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "d"))+[GOOD] (define-fun s326 () String "d")+[GOOD] (define-fun s327 () Bool (distinct s0 s326))+[GOOD] (assert s327)+Looking for solution 163+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "E"))+[GOOD] (define-fun s328 () String "E")+[GOOD] (define-fun s329 () Bool (distinct s0 s328))+[GOOD] (assert s329)+Looking for solution 164+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "e"))+[GOOD] (define-fun s330 () String "e")+[GOOD] (define-fun s331 () Bool (distinct s0 s330))+[GOOD] (assert s331)+Looking for solution 165+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "T"))+[GOOD] (define-fun s332 () String "T")+[GOOD] (define-fun s333 () Bool (distinct s0 s332))+[GOOD] (assert s333)+Looking for solution 166+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "t"))+[GOOD] (define-fun s334 () String "t")+[GOOD] (define-fun s335 () Bool (distinct s0 s334))+[GOOD] (assert s335)+Looking for solution 167+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "U"))+[GOOD] (define-fun s336 () String "U")+[GOOD] (define-fun s337 () Bool (distinct s0 s336))+[GOOD] (assert s337)+Looking for solution 168+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "u"))+[GOOD] (define-fun s338 () String "u")+[GOOD] (define-fun s339 () Bool (distinct s0 s338))+[GOOD] (assert s339)+Looking for solution 169+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "L"))+[GOOD] (define-fun s340 () String "L")+[GOOD] (define-fun s341 () Bool (distinct s0 s340))+[GOOD] (assert s341)+Looking for solution 170+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "l"))+[GOOD] (define-fun s342 () String "l")+[GOOD] (define-fun s343 () Bool (distinct s0 s342))+[GOOD] (assert s343)+Looking for solution 171+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "M"))+[GOOD] (define-fun s344 () String "M")+[GOOD] (define-fun s345 () Bool (distinct s0 s344))+[GOOD] (assert s345)+Looking for solution 172+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "m"))+[GOOD] (define-fun s346 () String "m")+[GOOD] (define-fun s347 () Bool (distinct s0 s346))+[GOOD] (assert s347)+Looking for solution 173+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\\"))+[GOOD] (define-fun s348 () String "\\")+[GOOD] (define-fun s349 () Bool (distinct s0 s348))+[GOOD] (assert s349)+Looking for solution 174+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "|"))+[GOOD] (define-fun s350 () String "|")+[GOOD] (define-fun s351 () Bool (distinct s0 s350))+[GOOD] (assert s351)+Looking for solution 175+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "]"))+[GOOD] (define-fun s352 () String "]")+[GOOD] (define-fun s353 () Bool (distinct s0 s352))+[GOOD] (assert s353)+Looking for solution 176+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "}"))+[GOOD] (define-fun s354 () String "}")+[GOOD] (define-fun s355 () Bool (distinct s0 s354))+[GOOD] (assert s355)+Looking for solution 177+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "F"))+[GOOD] (define-fun s356 () String "F")+[GOOD] (define-fun s357 () Bool (distinct s0 s356))+[GOOD] (assert s357)+Looking for solution 178+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "f"))+[GOOD] (define-fun s358 () String "f")+[GOOD] (define-fun s359 () Bool (distinct s0 s358))+[GOOD] (assert s359)+Looking for solution 179+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "G"))+[GOOD] (define-fun s360 () String "G")+[GOOD] (define-fun s361 () Bool (distinct s0 s360))+[GOOD] (assert s361)+Looking for solution 180+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "g"))+[GOOD] (define-fun s362 () String "g")+[GOOD] (define-fun s363 () Bool (distinct s0 s362))+[GOOD] (assert s363)+Looking for solution 181+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "V"))+[GOOD] (define-fun s364 () String "V")+[GOOD] (define-fun s365 () Bool (distinct s0 s364))+[GOOD] (assert s365)+Looking for solution 182+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "v"))+[GOOD] (define-fun s366 () String "v")+[GOOD] (define-fun s367 () Bool (distinct s0 s366))+[GOOD] (assert s367)+Looking for solution 183+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "W"))+[GOOD] (define-fun s368 () String "W")+[GOOD] (define-fun s369 () Bool (distinct s0 s368))+[GOOD] (assert s369)+Looking for solution 184+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "w"))+[GOOD] (define-fun s370 () String "w")+[GOOD] (define-fun s371 () Bool (distinct s0 s370))+[GOOD] (assert s371)+Looking for solution 185+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "N"))+[GOOD] (define-fun s372 () String "N")+[GOOD] (define-fun s373 () Bool (distinct s0 s372))+[GOOD] (assert s373)+Looking for solution 186+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "n"))+[GOOD] (define-fun s374 () String "n")+[GOOD] (define-fun s375 () Bool (distinct s0 s374))+[GOOD] (assert s375)+Looking for solution 187+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "O"))+[GOOD] (define-fun s376 () String "O")+[GOOD] (define-fun s377 () Bool (distinct s0 s376))+[GOOD] (assert s377)+Looking for solution 188+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "o"))+[GOOD] (define-fun s378 () String "o")+[GOOD] (define-fun s379 () Bool (distinct s0 s378))+[GOOD] (assert s379)+Looking for solution 189+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "^"))+[GOOD] (define-fun s380 () String "^")+[GOOD] (define-fun s381 () Bool (distinct s0 s380))+[GOOD] (assert s381)+Looking for solution 190+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "~"))+[GOOD] (define-fun s382 () String "~")+[GOOD] (define-fun s383 () Bool (distinct s0 s382))+[GOOD] (assert s383)+Looking for solution 191+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "_"))+[GOOD] (define-fun s384 () String "_")+[GOOD] (define-fun s385 () Bool (distinct s0 s384))+[GOOD] (assert s385)+Looking for solution 192+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 ""))+[GOOD] (define-fun s386 () String "")+[GOOD] (define-fun s387 () Bool (distinct s0 s386))+[GOOD] (assert s387)+Looking for solution 193+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xc0"))+[GOOD] (define-fun s388 () String "\xc0")+[GOOD] (define-fun s389 () Bool (distinct s0 s388))+[GOOD] (assert s389)+Looking for solution 194+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xe0"))+[GOOD] (define-fun s390 () String "\xe0")+[GOOD] (define-fun s391 () Bool (distinct s0 s390))+[GOOD] (assert s391)+Looking for solution 195+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xc1"))+[GOOD] (define-fun s392 () String "\xc1")+[GOOD] (define-fun s393 () Bool (distinct s0 s392))+[GOOD] (assert s393)+Looking for solution 196+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xe1"))+[GOOD] (define-fun s394 () String "\xe1")+[GOOD] (define-fun s395 () Bool (distinct s0 s394))+[GOOD] (assert s395)+Looking for solution 197+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xd0"))+[GOOD] (define-fun s396 () String "\xd0")+[GOOD] (define-fun s397 () Bool (distinct s0 s396))+[GOOD] (assert s397)+Looking for solution 198+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xf0"))+[GOOD] (define-fun s398 () String "\xf0")+[GOOD] (define-fun s399 () Bool (distinct s0 s398))+[GOOD] (assert s399)+Looking for solution 199+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xd1"))+[GOOD] (define-fun s400 () String "\xd1")+[GOOD] (define-fun s401 () Bool (distinct s0 s400))+[GOOD] (assert s401)+Looking for solution 200+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xf1"))+[GOOD] (define-fun s402 () String "\xf1")+[GOOD] (define-fun s403 () Bool (distinct s0 s402))+[GOOD] (assert s403)+Looking for solution 201+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xc8"))+[GOOD] (define-fun s404 () String "\xc8")+[GOOD] (define-fun s405 () Bool (distinct s0 s404))+[GOOD] (assert s405)+Looking for solution 202+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xe8"))+[GOOD] (define-fun s406 () String "\xe8")+[GOOD] (define-fun s407 () Bool (distinct s0 s406))+[GOOD] (assert s407)+Looking for solution 203+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xc9"))+[GOOD] (define-fun s408 () String "\xc9")+[GOOD] (define-fun s409 () Bool (distinct s0 s408))+[GOOD] (assert s409)+Looking for solution 204+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xe9"))+[GOOD] (define-fun s410 () String "\xe9")+[GOOD] (define-fun s411 () Bool (distinct s0 s410))+[GOOD] (assert s411)+Looking for solution 205+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xd8"))+[GOOD] (define-fun s412 () String "\xd8")+[GOOD] (define-fun s413 () Bool (distinct s0 s412))+[GOOD] (assert s413)+Looking for solution 206+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xf8"))+[GOOD] (define-fun s414 () String "\xf8")+[GOOD] (define-fun s415 () Bool (distinct s0 s414))+[GOOD] (assert s415)+Looking for solution 207+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xd9"))+[GOOD] (define-fun s416 () String "\xd9")+[GOOD] (define-fun s417 () Bool (distinct s0 s416))+[GOOD] (assert s417)+Looking for solution 208+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xf9"))+[GOOD] (define-fun s418 () String "\xf9")+[GOOD] (define-fun s419 () Bool (distinct s0 s418))+[GOOD] (assert s419)+Looking for solution 209+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xc2"))+[GOOD] (define-fun s420 () String "\xc2")+[GOOD] (define-fun s421 () Bool (distinct s0 s420))+[GOOD] (assert s421)+Looking for solution 210+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xe2"))+[GOOD] (define-fun s422 () String "\xe2")+[GOOD] (define-fun s423 () Bool (distinct s0 s422))+[GOOD] (assert s423)+Looking for solution 211+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xc3"))+[GOOD] (define-fun s424 () String "\xc3")+[GOOD] (define-fun s425 () Bool (distinct s0 s424))+[GOOD] (assert s425)+Looking for solution 212+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xe3"))+[GOOD] (define-fun s426 () String "\xe3")+[GOOD] (define-fun s427 () Bool (distinct s0 s426))+[GOOD] (assert s427)+Looking for solution 213+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xd2"))+[GOOD] (define-fun s428 () String "\xd2")+[GOOD] (define-fun s429 () Bool (distinct s0 s428))+[GOOD] (assert s429)+Looking for solution 214+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xf2"))+[GOOD] (define-fun s430 () String "\xf2")+[GOOD] (define-fun s431 () Bool (distinct s0 s430))+[GOOD] (assert s431)+Looking for solution 215+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xd3"))+[GOOD] (define-fun s432 () String "\xd3")+[GOOD] (define-fun s433 () Bool (distinct s0 s432))+[GOOD] (assert s433)+Looking for solution 216+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xf3"))+[GOOD] (define-fun s434 () String "\xf3")+[GOOD] (define-fun s435 () Bool (distinct s0 s434))+[GOOD] (assert s435)+Looking for solution 217+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xca"))+[GOOD] (define-fun s436 () String "\xca")+[GOOD] (define-fun s437 () Bool (distinct s0 s436))+[GOOD] (assert s437)+Looking for solution 218+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xea"))+[GOOD] (define-fun s438 () String "\xea")+[GOOD] (define-fun s439 () Bool (distinct s0 s438))+[GOOD] (assert s439)+Looking for solution 219+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xcb"))+[GOOD] (define-fun s440 () String "\xcb")+[GOOD] (define-fun s441 () Bool (distinct s0 s440))+[GOOD] (assert s441)+Looking for solution 220+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xeb"))+[GOOD] (define-fun s442 () String "\xeb")+[GOOD] (define-fun s443 () Bool (distinct s0 s442))+[GOOD] (assert s443)+Looking for solution 221+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xda"))+[GOOD] (define-fun s444 () String "\xda")+[GOOD] (define-fun s445 () Bool (distinct s0 s444))+[GOOD] (assert s445)+Looking for solution 222+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xfa"))+[GOOD] (define-fun s446 () String "\xfa")+[GOOD] (define-fun s447 () Bool (distinct s0 s446))+[GOOD] (assert s447)+Looking for solution 223+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xdb"))+[GOOD] (define-fun s448 () String "\xdb")+[GOOD] (define-fun s449 () Bool (distinct s0 s448))+[GOOD] (assert s449)+Looking for solution 224+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xfb"))+[GOOD] (define-fun s450 () String "\xfb")+[GOOD] (define-fun s451 () Bool (distinct s0 s450))+[GOOD] (assert s451)+Looking for solution 225+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xc4"))+[GOOD] (define-fun s452 () String "\xc4")+[GOOD] (define-fun s453 () Bool (distinct s0 s452))+[GOOD] (assert s453)+Looking for solution 226+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xe4"))+[GOOD] (define-fun s454 () String "\xe4")+[GOOD] (define-fun s455 () Bool (distinct s0 s454))+[GOOD] (assert s455)+Looking for solution 227+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xc5"))+[GOOD] (define-fun s456 () String "\xc5")+[GOOD] (define-fun s457 () Bool (distinct s0 s456))+[GOOD] (assert s457)+Looking for solution 228+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xe5"))+[GOOD] (define-fun s458 () String "\xe5")+[GOOD] (define-fun s459 () Bool (distinct s0 s458))+[GOOD] (assert s459)+Looking for solution 229+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xd4"))+[GOOD] (define-fun s460 () String "\xd4")+[GOOD] (define-fun s461 () Bool (distinct s0 s460))+[GOOD] (assert s461)+Looking for solution 230+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xf4"))+[GOOD] (define-fun s462 () String "\xf4")+[GOOD] (define-fun s463 () Bool (distinct s0 s462))+[GOOD] (assert s463)+Looking for solution 231+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xd5"))+[GOOD] (define-fun s464 () String "\xd5")+[GOOD] (define-fun s465 () Bool (distinct s0 s464))+[GOOD] (assert s465)+Looking for solution 232+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xf5"))+[GOOD] (define-fun s466 () String "\xf5")+[GOOD] (define-fun s467 () Bool (distinct s0 s466))+[GOOD] (assert s467)+Looking for solution 233+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xcc"))+[GOOD] (define-fun s468 () String "\xcc")+[GOOD] (define-fun s469 () Bool (distinct s0 s468))+[GOOD] (assert s469)+Looking for solution 234+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xec"))+[GOOD] (define-fun s470 () String "\xec")+[GOOD] (define-fun s471 () Bool (distinct s0 s470))+[GOOD] (assert s471)+Looking for solution 235+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xcd"))+[GOOD] (define-fun s472 () String "\xcd")+[GOOD] (define-fun s473 () Bool (distinct s0 s472))+[GOOD] (assert s473)+Looking for solution 236+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xed"))+[GOOD] (define-fun s474 () String "\xed")+[GOOD] (define-fun s475 () Bool (distinct s0 s474))+[GOOD] (assert s475)+Looking for solution 237+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xdc"))+[GOOD] (define-fun s476 () String "\xdc")+[GOOD] (define-fun s477 () Bool (distinct s0 s476))+[GOOD] (assert s477)+Looking for solution 238+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xfc"))+[GOOD] (define-fun s478 () String "\xfc")+[GOOD] (define-fun s479 () Bool (distinct s0 s478))+[GOOD] (assert s479)+Looking for solution 239+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xdd"))+[GOOD] (define-fun s480 () String "\xdd")+[GOOD] (define-fun s481 () Bool (distinct s0 s480))+[GOOD] (assert s481)+Looking for solution 240+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xfd"))+[GOOD] (define-fun s482 () String "\xfd")+[GOOD] (define-fun s483 () Bool (distinct s0 s482))+[GOOD] (assert s483)+Looking for solution 241+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xc6"))+[GOOD] (define-fun s484 () String "\xc6")+[GOOD] (define-fun s485 () Bool (distinct s0 s484))+[GOOD] (assert s485)+Looking for solution 242+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xe6"))+[GOOD] (define-fun s486 () String "\xe6")+[GOOD] (define-fun s487 () Bool (distinct s0 s486))+[GOOD] (assert s487)+Looking for solution 243+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xc7"))+[GOOD] (define-fun s488 () String "\xc7")+[GOOD] (define-fun s489 () Bool (distinct s0 s488))+[GOOD] (assert s489)+Looking for solution 244+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xe7"))+[GOOD] (define-fun s490 () String "\xe7")+[GOOD] (define-fun s491 () Bool (distinct s0 s490))+[GOOD] (assert s491)+Looking for solution 245+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xd6"))+[GOOD] (define-fun s492 () String "\xd6")+[GOOD] (define-fun s493 () Bool (distinct s0 s492))+[GOOD] (assert s493)+Looking for solution 246+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xf6"))+[GOOD] (define-fun s494 () String "\xf6")+[GOOD] (define-fun s495 () Bool (distinct s0 s494))+[GOOD] (assert s495)+Looking for solution 247+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xd7"))+[GOOD] (define-fun s496 () String "\xd7")+[GOOD] (define-fun s497 () Bool (distinct s0 s496))+[GOOD] (assert s497)+Looking for solution 248+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xf7"))+[GOOD] (define-fun s498 () String "\xf7")+[GOOD] (define-fun s499 () Bool (distinct s0 s498))+[GOOD] (assert s499)+Looking for solution 249+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xce"))+[GOOD] (define-fun s500 () String "\xce")+[GOOD] (define-fun s501 () Bool (distinct s0 s500))+[GOOD] (assert s501)+Looking for solution 250+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xee"))+[GOOD] (define-fun s502 () String "\xee")+[GOOD] (define-fun s503 () Bool (distinct s0 s502))+[GOOD] (assert s503)+Looking for solution 251+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xcf"))+[GOOD] (define-fun s504 () String "\xcf")+[GOOD] (define-fun s505 () Bool (distinct s0 s504))+[GOOD] (assert s505)+Looking for solution 252+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xef"))+[GOOD] (define-fun s506 () String "\xef")+[GOOD] (define-fun s507 () Bool (distinct s0 s506))+[GOOD] (assert s507)+Looking for solution 253+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xde"))+[GOOD] (define-fun s508 () String "\xde")+[GOOD] (define-fun s509 () Bool (distinct s0 s508))+[GOOD] (assert s509)+Looking for solution 254+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xfe"))+[GOOD] (define-fun s510 () String "\xfe")+[GOOD] (define-fun s511 () Bool (distinct s0 s510))+[GOOD] (assert s511)+Looking for solution 255+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xdf"))+[GOOD] (define-fun s512 () String "\xdf")+[GOOD] (define-fun s513 () Bool (distinct s0 s512))+[GOOD] (assert s513)+Looking for solution 256+[SEND] (check-sat)+[RECV] sat+[SEND] (get-value (s0))+[RECV] ((s0 "\xff"))+[GOOD] (define-fun s514 () String "\xff")+[GOOD] (define-fun s515 () Bool (distinct s0 s514))+[GOOD] (assert s515)+Looking for solution 257+[SEND] (check-sat)+[RECV] unsat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples2.gold view
@@ -0,0 +1,30 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] (define-fun s1 () String "b")+[GOOD] (define-fun s3 () String "a")+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s2 () String (str.++ s0 s1))+[GOOD] (define-fun s4 () String (str.++ s3 s0))+[GOOD] (define-fun s5 () Bool (= s2 s4))+[GOOD] (assert s5)+[SEND] (check-sat)+[RECV] unsat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples3.gold view
@@ -0,0 +1,38 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] (define-fun s4 () String "abcd")+[GOOD] (define-fun s7 () String "cdef")+[GOOD] (define-fun s9 () String "")+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "a"+[GOOD] (declare-fun s1 () String) ; tracks user variable "b"+[GOOD] (declare-fun s2 () String) ; tracks user variable "c"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s3 () String (str.++ s0 s1))+[GOOD] (define-fun s5 () Bool (= s3 s4))+[GOOD] (define-fun s6 () String (str.++ s1 s2))+[GOOD] (define-fun s8 () Bool (= s6 s7))+[GOOD] (define-fun s10 () Bool (= s1 s9))+[GOOD] (define-fun s11 () Bool (not s10))+[GOOD] (assert s5)+[GOOD] (assert s8)+[GOOD] (assert s11)+[SEND] (check-sat)+[RECV] sat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples4.gold view
@@ -0,0 +1,35 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] (define-fun s8 () Int 2)+[GOOD] (define-fun s2 () String "abc")+[GOOD] (define-fun s4 () String "cef")+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "a"+[GOOD] (declare-fun s1 () String) ; tracks user variable "b"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s3 () String (str.++ s2 s0))+[GOOD] (define-fun s5 () String (str.++ s1 s4))+[GOOD] (define-fun s6 () Bool (= s3 s5))+[GOOD] (define-fun s7 () Int (str.len s0))+[GOOD] (define-fun s9 () Bool (<= s7 s8))+[GOOD] (assert s6)+[GOOD] (assert s9)+[SEND] (check-sat)+[RECV] sat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples5.gold view
@@ -0,0 +1,43 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] (define-fun s3 () String "ab")+[GOOD] (define-fun s6 () String "ba")+[GOOD] (define-fun s12 () String "a")+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "a"+[GOOD] (declare-fun s1 () String) ; tracks user variable "b"+[GOOD] (declare-fun s2 () String) ; tracks user variable "c"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s4 () String (str.++ s3 s1))+[GOOD] (define-fun s5 () String (str.++ s0 s4))+[GOOD] (define-fun s7 () String (str.++ s6 s2))+[GOOD] (define-fun s8 () String (str.++ s1 s7))+[GOOD] (define-fun s9 () Bool (= s5 s8))+[GOOD] (define-fun s10 () String (str.++ s0 s1))+[GOOD] (define-fun s11 () Bool (= s2 s10))+[GOOD] (define-fun s13 () String (str.++ s0 s12))+[GOOD] (define-fun s14 () String (str.++ s12 s0))+[GOOD] (define-fun s15 () Bool (= s13 s14))+[GOOD] (define-fun s16 () Bool (not s15))+[GOOD] (assert s9)+[GOOD] (assert s11)+[GOOD] (assert s16)+[SEND] (check-sat)+[RECV] sat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples6.gold view
@@ -0,0 +1,33 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "a"+[GOOD] (declare-fun s1 () String) ; tracks user variable "b"+[GOOD] (declare-fun s2 () String) ; tracks user variable "c"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s3 () Bool (str.contains s0 s1))+[GOOD] (define-fun s4 () Bool (str.contains s1 s2))+[GOOD] (define-fun s5 () Bool (str.contains s0 s2))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (assert s3)+[GOOD] (assert s4)+[GOOD] (assert s6)+[SEND] (check-sat)+[RECV] unsat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples7.gold view
@@ -0,0 +1,36 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "a"+[GOOD] (declare-fun s1 () String) ; tracks user variable "b"+[GOOD] (declare-fun s2 () String) ; tracks user variable "c"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s3 () Bool (str.contains s0 s1))+[GOOD] (define-fun s4 () Bool (str.contains s0 s2))+[GOOD] (define-fun s5 () Bool (str.contains s1 s2))+[GOOD] (define-fun s6 () Bool (not s5))+[GOOD] (define-fun s7 () Bool (str.contains s2 s1))+[GOOD] (define-fun s8 () Bool (not s7))+[GOOD] (assert s3)+[GOOD] (assert s4)+[GOOD] (assert s6)+[GOOD] (assert s8)+[SEND] (check-sat)+[RECV] sat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples8.gold view
@@ -0,0 +1,40 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "a"+[GOOD] (declare-fun s1 () String) ; tracks user variable "b"+[GOOD] (declare-fun s2 () String) ; tracks user variable "c"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s3 () Bool (str.prefixof s1 s0))+[GOOD] (define-fun s4 () Bool (str.suffixof s2 s0))+[GOOD] (define-fun s5 () Int (str.len s0))+[GOOD] (define-fun s6 () Int (str.len s1))+[GOOD] (define-fun s7 () Int (str.len s2))+[GOOD] (define-fun s8 () Int (+ s6 s7))+[GOOD] (define-fun s9 () Bool (= s5 s8))+[GOOD] (define-fun s10 () String (str.++ s1 s2))+[GOOD] (define-fun s11 () Bool (= s0 s10))+[GOOD] (define-fun s12 () Bool (not s11))+[GOOD] (assert s3)+[GOOD] (assert s4)+[GOOD] (assert s9)+[GOOD] (assert s12)+[SEND] (check-sat)+[RECV] unsat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strExamples9.gold view
@@ -0,0 +1,30 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic ALL)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] (define-fun s3 () Int 6)+[GOOD] ; --- skolem constants ---+[GOOD] (declare-fun s0 () String) ; tracks user variable "a"+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (define-fun s1 () Bool (str.in.re s0 ((_ re.loop 1 3) (str.to.re "ab"))))+[GOOD] (define-fun s2 () Int (str.len s0))+[GOOD] (define-fun s4 () Bool (= s2 s3))+[GOOD] (assert s1)+[GOOD] (assert s4)+[SEND] (check-sat)+[RECV] sat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strIndexOf.gold view
@@ -0,0 +1,24 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic QF_BV)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] ; --- skolem constants ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (assert s_1)+[SEND] (check-sat)+[RECV] sat+*** Solver   : Z3+*** Exit code: ExitSuccess
+ SBVTestSuite/GoldFiles/strIndexOfBad.gold view
@@ -0,0 +1,24 @@+** Calling: z3 -nw -in -smt2+[GOOD] ; Automatically generated by SBV. Do not edit.+[GOOD] (set-option :print-success true)+[GOOD] (set-option :global-declarations true)+[GOOD] (set-option :smtlib2_compliant true)+[GOOD] (set-option :diagnostic-output-channel "stdout")+[GOOD] (set-option :produce-models true)+[GOOD] (set-logic QF_BV)+[GOOD] ; --- uninterpreted sorts ---+[GOOD] ; --- literal constants ---+[GOOD] (define-fun s_2 () Bool false)+[GOOD] (define-fun s_1 () Bool true)+[GOOD] ; --- skolem constants ---+[GOOD] ; --- constant tables ---+[GOOD] ; --- skolemized tables ---+[GOOD] ; --- arrays ---+[GOOD] ; --- uninterpreted constants ---+[GOOD] ; --- user given axioms ---+[GOOD] ; --- formula ---+[GOOD] (assert s_2)+[SEND] (check-sat)+[RECV] unsat+*** Solver   : Z3+*** Exit code: ExitSuccess
SBVTestSuite/GoldFiles/tgen_c.gold view
@@ -17,13 +17,13 @@ typedef double SDouble;  /* Unsigned bit-vectors */-typedef uint8_t  SWord8 ;+typedef uint8_t  SWord8; typedef uint16_t SWord16; typedef uint32_t SWord32; typedef uint64_t SWord64;  /* Signed bit-vectors */-typedef int8_t  SInt8 ;+typedef int8_t  SInt8; typedef int16_t SInt16; typedef int32_t SInt32; typedef int64_t SInt64;
SBVTestSuite/SBVDocTest.hs view
@@ -23,8 +23,10 @@                               else runDocTest (env == CIWindows)             TestEnvUnknown  -> do putStrLn "Unknown test environment, skipping doctests"                                   exitSuccess- where runDocTest windowsSkip = do allFiles <- glob "Data/SBV/**/*.hs"-                                   let testFiles+ where runDocTest windowsSkip = do srcFiles <- glob "Data/SBV/**/*.hs"+                                   docFiles <- glob "Documentation/SBV/**/*.hs"+                                   let allFiles = srcFiles ++ docFiles+                                       testFiles                                          | windowsSkip = filter (not . bad) allFiles                                          | True        = allFiles                                    doctest testFiles
SBVTestSuite/SBVTest.hs view
@@ -25,6 +25,7 @@ import qualified TestSuite.Basics.Recursive import qualified TestSuite.Basics.SmallShifts import qualified TestSuite.Basics.SquashReals+import qualified TestSuite.Basics.String import qualified TestSuite.Basics.TOut import qualified TestSuite.BitPrecise.BitTricks import qualified TestSuite.BitPrecise.Legato@@ -75,7 +76,9 @@ import qualified TestSuite.Queries.Int_Yices import qualified TestSuite.Queries.Int_Z3 import qualified TestSuite.Queries.Interpolants+import qualified TestSuite.Queries.Strings import qualified TestSuite.Queries.Uninterpreted+import qualified TestSuite.QuickCheck.QC import qualified TestSuite.Uninterpreted.AUF import qualified TestSuite.Uninterpreted.Axioms import qualified TestSuite.Uninterpreted.Function@@ -122,11 +125,13 @@                    , TestSuite.Queries.Int_CVC4.tests                    , TestSuite.Queries.Int_Mathsat.tests                    , TestSuite.Queries.Int_Yices.tests+                   -- quick-check tests take a long time, so just run them locally.+                   , TestSuite.QuickCheck.QC.tests                    ]  -- | Remaining tests otherTests :: TestTree-otherTests = testGroup "SBVOtherTests" [+otherTests = testGroup "SBVTests" [                  TestSuite.Arrays.Memory.tests                , TestSuite.Arrays.Query.tests                , TestSuite.Basics.AllSat.tests@@ -144,6 +149,7 @@                , TestSuite.Basics.Recursive.tests                , TestSuite.Basics.SmallShifts.tests                , TestSuite.Basics.SquashReals.tests+               , TestSuite.Basics.String.tests                , TestSuite.Basics.TOut.tests                , TestSuite.BitPrecise.BitTricks.tests                , TestSuite.BitPrecise.Legato.tests@@ -187,6 +193,7 @@                , TestSuite.Queries.FreshVars.tests                , TestSuite.Queries.Int_Z3.tests                , TestSuite.Queries.Interpolants.tests+               , TestSuite.Queries.Strings.tests                , TestSuite.Queries.Uninterpreted.tests                , TestSuite.Uninterpreted.AUF.tests                , TestSuite.Uninterpreted.Axioms.tests
SBVTestSuite/TestSuite/Basics/ArithNoSolver.hs view
@@ -23,6 +23,12 @@  import Data.Maybe (fromJust, isJust) +import Data.List (genericIndex, isInfixOf, isPrefixOf, isSuffixOf, genericTake, genericDrop, genericLength)++import qualified Data.Char       as C+import qualified Data.SBV.Char   as SC+import qualified Data.SBV.String as SS+ -- Test suite tests :: TestTree tests = testGroup "Arith.NoSolver" $@@ -62,14 +68,16 @@         ++ genBlasts         ++ genCounts         ++ genIntCasts+        ++ genChars+        ++ genStrings  genBinTest :: String -> (forall a. (Num a, Bits a) => a -> a -> a) -> [TestTree] genBinTest nm op = map mkTest $-        zipWith pair [(show x, show y, x `op` y) | x <- w8s,  y <- w8s ] [x `op` y | x <- sw8s,  y <- sw8s]+        zipWith pair [(show x, show y, x `op` y) | x <- w8s,  y <- w8s ] [x `op` y | x <- sw8s,  y <- sw8s ]      ++ zipWith pair [(show x, show y, x `op` y) | x <- w16s, y <- w16s] [x `op` y | x <- sw16s, y <- sw16s]      ++ zipWith pair [(show x, show y, x `op` y) | x <- w32s, y <- w32s] [x `op` y | x <- sw32s, y <- sw32s]      ++ zipWith pair [(show x, show y, x `op` y) | x <- w64s, y <- w64s] [x `op` y | x <- sw64s, y <- sw64s]-     ++ zipWith pair [(show x, show y, x `op` y) | x <- i8s,  y <- i8s ] [x `op` y | x <- si8s,  y <- si8s]+     ++ zipWith pair [(show x, show y, x `op` y) | x <- i8s,  y <- i8s ] [x `op` y | x <- si8s,  y <- si8s ]      ++ zipWith pair [(show x, show y, x `op` y) | x <- i16s, y <- i16s] [x `op` y | x <- si16s, y <- si16s]      ++ zipWith pair [(show x, show y, x `op` y) | x <- i32s, y <- i32s] [x `op` y | x <- si32s, y <- si32s]      ++ zipWith pair [(show x, show y, x `op` y) | x <- i64s, y <- i64s] [x `op` y | x <- si64s, y <- si64s]@@ -79,15 +87,17 @@  genBoolTest :: String -> (forall a. Ord a => a -> a -> Bool) -> (forall a. OrdSymbolic a => a -> a -> SBool) -> [TestTree] genBoolTest nm op opS = map mkTest $-        zipWith pair [(show x, show y, x `op` y) | x <- w8s,  y <- w8s ] [x `opS` y | x <- sw8s,  y <- sw8s]+        zipWith pair [(show x, show y, x `op` y) | x <- w8s,  y <- w8s ] [x `opS` y | x <- sw8s,  y <- sw8s ]      ++ zipWith pair [(show x, show y, x `op` y) | x <- w16s, y <- w16s] [x `opS` y | x <- sw16s, y <- sw16s]      ++ zipWith pair [(show x, show y, x `op` y) | x <- w32s, y <- w32s] [x `opS` y | x <- sw32s, y <- sw32s]      ++ zipWith pair [(show x, show y, x `op` y) | x <- w64s, y <- w64s] [x `opS` y | x <- sw64s, y <- sw64s]-     ++ zipWith pair [(show x, show y, x `op` y) | x <- i8s,  y <- i8s ] [x `opS` y | x <- si8s,  y <- si8s]+     ++ zipWith pair [(show x, show y, x `op` y) | x <- i8s,  y <- i8s ] [x `opS` y | x <- si8s,  y <- si8s ]      ++ zipWith pair [(show x, show y, x `op` y) | x <- i16s, y <- i16s] [x `opS` y | x <- si16s, y <- si16s]      ++ zipWith pair [(show x, show y, x `op` y) | x <- i32s, y <- i32s] [x `opS` y | x <- si32s, y <- si32s]      ++ zipWith pair [(show x, show y, x `op` y) | x <- i64s, y <- i64s] [x `opS` y | x <- si64s, y <- si64s]      ++ zipWith pair [(show x, show y, x `op` y) | x <- iUBs, y <- iUBs] [x `opS` y | x <- siUBs, y <- siUBs]+     ++ zipWith pair [(show x, show y, x `op` y) | x <- iCs,  y <- iCs ] [x `opS` y | x <- siCs,  y <- siCs ]+     ++ zipWith pair [(show x, show y, x `op` y) | x <- ss,   y <- ss  ] [x `opS` y | x <- sss,   y <- sss  ]   where pair (x, y, a) b = (x, y, Just a == unliteral b)         mkTest (x, y, s) = testCase ("arithCF-" ++ nm ++ "." ++ x ++ "_" ++ y) (s `showsAs` "True") @@ -461,6 +471,129 @@                      , ("fpIsPoint",        fpIsPoint,         \x -> not (isNaN x || isInfinite x))                      ] +genChars :: [TestTree]+genChars = map mkTest $  [("ord",           show c, check SC.ord           cord            c) | c <- cs]+                      ++ [("toLower",       show c, check SC.toLower       C.toLower       c) | c <- cs]+                      ++ [("toUpper",       show c, check SC.toUpper       C.toUpper       c) | c <- cs, toUpperExceptions c]+                      ++ [("digitToInt",    show c, check SC.digitToInt    dig2Int         c) | c <- cs, digitToIntRange c]+                      ++ [("intToDigit",    show c, check SC.intToDigit    int2Dig         c) | c <- [0 .. 15]]+                      ++ [("isControl",     show c, check SC.isControl     C.isControl     c) | c <- cs]+                      ++ [("isSpace",       show c, check SC.isSpace       C.isSpace       c) | c <- cs]+                      ++ [("isLower",       show c, check SC.isLower       C.isLower       c) | c <- cs]+                      ++ [("isUpper",       show c, check SC.isUpper       C.isUpper       c) | c <- cs]+                      ++ [("isAlpha",       show c, check SC.isAlpha       C.isAlpha       c) | c <- cs]+                      ++ [("isAlphaNum",    show c, check SC.isAlphaNum    C.isAlphaNum    c) | c <- cs]+                      ++ [("isPrint",       show c, check SC.isPrint       C.isPrint       c) | c <- cs]+                      ++ [("isDigit",       show c, check SC.isDigit       C.isDigit       c) | c <- cs]+                      ++ [("isOctDigit",    show c, check SC.isOctDigit    C.isOctDigit    c) | c <- cs]+                      ++ [("isHexDigit",    show c, check SC.isHexDigit    C.isHexDigit    c) | c <- cs]+                      ++ [("isLetter",      show c, check SC.isLetter      C.isLetter      c) | c <- cs]+                      ++ [("isMark",        show c, check SC.isMark        C.isMark        c) | c <- cs]+                      ++ [("isNumber",      show c, check SC.isNumber      C.isNumber      c) | c <- cs]+                      ++ [("isPunctuation", show c, check SC.isPunctuation C.isPunctuation c) | c <- cs]+                      ++ [("isSymbol",      show c, check SC.isSymbol      C.isSymbol      c) | c <- cs]+                      ++ [("isSeparator",   show c, check SC.isSeparator   C.isSeparator   c) | c <- cs]+                      ++ [("isAscii",       show c, check SC.isAscii       C.isAscii       c) | c <- cs]+                      ++ [("isLatin1",      show c, check SC.isLatin1      C.isLatin1      c) | c <- cs]+                      ++ [("isAsciiUpper",  show c, check SC.isAsciiUpper  C.isAsciiUpper  c) | c <- cs]+                      ++ [("isAsciiLower",  show c, check SC.isAsciiLower  C.isAsciiLower  c) | c <- cs]+  where toUpperExceptions = (`notElem` "\181\255")+        digitToIntRange   = (`elem` "0123456789abcdefABCDEF")+        cord :: Char -> Integer+        cord = fromIntegral . C.ord+        dig2Int :: Char -> Integer+        dig2Int = fromIntegral . C.digitToInt+        int2Dig :: Integer -> Char+        int2Dig = C.intToDigit . fromIntegral+        mkTest (nm, x, t) = testCase ("genChars-" ++ nm ++ "." ++ x) (assert t)+        check sop cop arg = case unliteral (sop (literal arg)) of+                              Nothing -> False+                              Just x  -> x == cop arg++genStrings :: [TestTree]+genStrings = map mkTest1 (  [("length",        show s,                   check1 SS.length        strLen        s      ) | s <- ss                                                       ]+                         ++ [("null",          show s,                   check1 SS.null          null          s      ) | s <- ss                                                       ]+                         ++ [("head",          show s,                   check1 SS.head          head          s      ) | s <- ss, not (null s)                                         ]+                         ++ [("tail",          show s,                   check1 SS.tail          tail          s      ) | s <- ss, not (null s)                                         ]+                         ++ [("charToStr",     show c,                   check1 SS.charToStr     (: [])        c      ) | c <- cs                                                       ]+                         ++ [("implode",       show s,                   checkI SS.implode                     s      ) | s <- ss                                                       ]+                         ++ [("strToNat",      show s,                   check1 SS.strToNat      strToNat      s      ) | s <- ss                                                       ]+                         ++ [("natToStr",      show i,                   check1 SS.natToStr      natToStr      i      ) | i <- iUBs                                                     ])+          ++ map mkTest2 (  [("strToStrAt",    show s, show i,           check2 SS.strToStrAt    strToStrAt    s i    ) | s <- ss, i  <- range s                                        ]+                         ++ [("strToCharAt",   show s, show i,           check2 SS.strToCharAt   strToCharAt   s i    ) | s <- ss, i  <- range s                                        ]+                         ++ [("concat",        show s, show s1,          check2 SS.concat        (++)          s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isInfixOf",     show s, show s1,          check2 SS.isInfixOf     isInfixOf     s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isSuffixOf",    show s, show s1,          check2 SS.isSuffixOf    isSuffixOf    s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isPrefixOf",    show s, show s1,          check2 SS.isPrefixOf    isPrefixOf    s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("take",          show s, show i,           check2 SS.take          genericTake   i s    ) | s <- ss, i <- iUBs                                            ]+                         ++ [("drop",          show s, show i,           check2 SS.drop          genericDrop   i s    ) | s <- ss, i <- iUBs                                            ]+                         ++ [("indexOf",       show s, show s1,          check2 SS.indexOf       indexOf       s s1   ) | s <- ss, s1 <- ss                                             ])+          ++ map mkTest3 (  [("subStr",        show s, show  i, show j,  check3 SS.subStr        subStr        s i  j ) | s <- ss, i  <- range s, j <- range s, i + j <= genericLength s]+                         ++ [("replace",       show s, show s1, show s2, check3 SS.replace       replace       s s1 s2) | s <- ss, s1 <- ss, s2 <- ss                                   ]+                         ++ [("offsetIndexOf", show s, show s1, show i,  check3 SS.offsetIndexOf offsetIndexOf s s1 i ) | s <- ss, s1 <- ss, i <- range s                               ])+  where strLen :: String -> Integer+        strLen = fromIntegral . length++        strToNat :: String -> Integer+        strToNat s+          | all C.isDigit s && not (null s) = read s+          | True                            = -1++        natToStr :: Integer -> String+        natToStr i+          | i >= 0 = show i+          | True   = ""++        range :: String -> [Integer]+        range s = map fromIntegral [0 .. length s - 1]++        indexOf :: String -> String -> Integer+        indexOf s1 s2 = go 0 s1+          where go i x+                 | s2 `isPrefixOf` x = i+                 | True              = case x of+                                          "" -> -1+                                          (_:r) -> go (i+1) r++        strToStrAt :: String -> Integer -> String+        s `strToStrAt` i = [s `strToCharAt` i]++        strToCharAt :: String -> Integer -> Char+        s `strToCharAt` i = s `genericIndex` i++        subStr :: String -> Integer -> Integer -> String+        subStr s i j = genericTake j (genericDrop i s)++        replace :: String -> String -> String -> String+        replace s "" y = y ++ s+        replace s x  y = go s+          where go "" = ""+                go h@(c:rest) | x `isPrefixOf` h = y ++ drop (length x) h+                              | True             = c : go rest++        offsetIndexOf :: String -> String -> Integer -> Integer+        offsetIndexOf x y i = case indexOf (genericDrop i x) y of+                                -1 -> -1+                                r  -> r+i++        mkTest1 (nm, x, t)       = testCase ("genStrings-" ++ nm ++ "." ++ x)                         (assert t)+        mkTest2 (nm, x, y, t)    = testCase ("genStrings-" ++ nm ++ "." ++ x ++ "_" ++ y)             (assert t)+        mkTest3 (nm, x, y, z, t) = testCase ("genStrings-" ++ nm ++ "." ++ x ++ "_" ++ y ++ "_" ++ z) (assert t)++        checkI sop s = case unliteral (sop (map literal s)) of+                         Nothing -> False+                         Just x  -> s == x++        check1 sop cop arg            = case unliteral (sop (literal arg)) of+                                          Nothing -> False+                                          Just x  -> x == cop arg+        check2 sop cop arg1 arg2      = case unliteral (sop (literal arg1) (literal arg2)) of+                                          Nothing -> False+                                          Just x  -> x == cop arg1 arg2+        check3 sop cop arg1 arg2 arg3 = case unliteral (sop (literal arg1) (literal arg2) (literal arg3)) of+                                          Nothing -> False+                                          Just x  -> x == cop arg1 arg2 arg3+ -- Concrete test data xsUnsigned :: (Num a, Bounded a) => [a] xsUnsigned = take 5 (iterate (1+) minBound) ++ take 5 (iterate (\x -> x-1) maxBound)@@ -543,3 +676,21 @@  sds :: [SDouble] sds = map literal ds++-- Currently we test over all latin-1 characters. But when Unicode comes along, we'll have to be more selective.+cs :: String+cs = map C.chr [0..255]++-- For pair character ops, just take a subset+iCs :: String+iCs = map C.chr $ [0..5] ++ [98..102] ++ [250..255]++siCs :: [SChar]+siCs = map literal iCs++-- Ditto for strings, just a few things+ss :: [String]+ss = ["", "palTRY", "teSTing", "SBV", "sTRIngs", "123", "surely", "thIS", "hI", "ly", "0"]++sss :: [SString]+sss = map literal ss
SBVTestSuite/TestSuite/Basics/ArithSolver.hs view
@@ -21,6 +21,12 @@ import Data.SBV.Internals import Utils.SBVTestFramework +import Data.List (genericIndex, isInfixOf, isPrefixOf, isSuffixOf, genericTake, genericDrop, genericLength)++import qualified Data.Char     as C+import qualified Data.SBV.Char as SC+import qualified Data.SBV.String as SS+ -- Test suite tests :: TestTree tests =@@ -62,7 +68,10 @@      ++ genShiftMixSize      ++ genBlasts      ++ genCounts-     ++ genIntCasts)+     ++ genIntCasts+     ++ genChars+     ++ genStrings+     )  genBinTest :: Bool -> String -> (forall a. (Num a, Bits a) => a -> a -> a) -> [TestTree] genBinTest unboundedOK nm op = map mkTest $  [(show x, show y, mkThm2 x y (x `op` y)) | x <- w8s,  y <- w8s ]@@ -81,16 +90,21 @@                                       return $ literal r .== a `op` b  genBoolTest :: String -> (forall a. Ord a => a -> a -> Bool) -> (forall a. OrdSymbolic a => a -> a -> SBool) -> [TestTree]-genBoolTest nm op opS = map mkTest $  [(show x, show y, mkThm2 x y (x `op` y)) | x <- w8s,  y <- w8s ]-                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- w16s, y <- w16s]-                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- w32s, y <- w32s]-                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- w64s, y <- w64s]-                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- i8s,  y <- i8s ]-                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- i16s, y <- i16s]-                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- i32s, y <- i32s]-                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- i64s, y <- i64s]-                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- iUBs, y <- iUBs]-  where mkTest (x, y, t) = testCase ("genBoolTest.arithmetic-" ++ nm ++ "." ++ x ++ "_" ++ y) (assert t)+genBoolTest nm op opS = map mkTest $  [(show x, show y, mkThm2 x y (x `op` y)) | x <- w8s,       y <- w8s ]+                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- w16s,      y <- w16s]+                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- w32s,      y <- w32s]+                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- w64s,      y <- w64s]+                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- i8s,       y <- i8s ]+                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- i16s,      y <- i16s]+                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- i32s,      y <- i32s]+                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- i64s,      y <- i64s]+                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- iUBs,      y <- iUBs]+                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- reducedCS, y <- reducedCS]+                                   ++ [(show x, show y, mkThm2 x y (x `op` y)) | x <- ss,        y <- ss, nm `elem` allowedStringComps]+  where -- Currently Z3 doesn't allow for string comparisons, so only test equals and distinct+        -- See: https://github.com/LeventErkok/sbv/issues/368 for tracking issue.+        allowedStringComps = ["==", "/="]+        mkTest (x, y, t) = testCase ("genBoolTest.arithmetic-" ++ nm ++ "." ++ x ++ "_" ++ y) (assert t)         mkThm2 x y r = isTheorem $ do [a, b] <- mapM free ["x", "y"]                                       constrain $ a .== literal x                                       constrain $ b .== literal y@@ -502,6 +516,137 @@         -- Haskell's divMod and quotRem overflows if x == minBound and y == -1 for signed types; so avoid that case         noOverflow x y = not (x == minBound && y == -1) +genChars :: [TestTree]+genChars = map mkTest $  [("ord",           show c, mkThm SC.ord           cord            c) | c <- cs]+                      ++ [("toLower",       show c, mkThm SC.toLower       C.toLower       c) | c <- cs]+                      ++ [("toUpper",       show c, mkThm SC.toUpper       C.toUpper       c) | c <- cs, toUpperExceptions c]+                      ++ [("digitToInt",    show c, mkThm SC.digitToInt    dig2Int         c) | c <- cs, digitToIntRange c]+                      ++ [("intToDigit",    show c, mkThm SC.intToDigit    int2Dig         c) | c <- [0 .. 15]]+                      ++ [("isControl",     show c, mkThm SC.isControl     C.isControl     c) | c <- cs]+                      ++ [("isSpace",       show c, mkThm SC.isSpace       C.isSpace       c) | c <- cs]+                      ++ [("isLower",       show c, mkThm SC.isLower       C.isLower       c) | c <- cs]+                      ++ [("isUpper",       show c, mkThm SC.isUpper       C.isUpper       c) | c <- cs]+                      ++ [("isAlpha",       show c, mkThm SC.isAlpha       C.isAlpha       c) | c <- cs]+                      ++ [("isAlphaNum",    show c, mkThm SC.isAlphaNum    C.isAlphaNum    c) | c <- cs]+                      ++ [("isPrint",       show c, mkThm SC.isPrint       C.isPrint       c) | c <- cs]+                      ++ [("isDigit",       show c, mkThm SC.isDigit       C.isDigit       c) | c <- cs]+                      ++ [("isOctDigit",    show c, mkThm SC.isOctDigit    C.isOctDigit    c) | c <- cs]+                      ++ [("isHexDigit",    show c, mkThm SC.isHexDigit    C.isHexDigit    c) | c <- cs]+                      ++ [("isLetter",      show c, mkThm SC.isLetter      C.isLetter      c) | c <- cs]+                      ++ [("isMark",        show c, mkThm SC.isMark        C.isMark        c) | c <- cs]+                      ++ [("isNumber",      show c, mkThm SC.isNumber      C.isNumber      c) | c <- cs]+                      ++ [("isPunctuation", show c, mkThm SC.isPunctuation C.isPunctuation c) | c <- cs]+                      ++ [("isSymbol",      show c, mkThm SC.isSymbol      C.isSymbol      c) | c <- cs]+                      ++ [("isSeparator",   show c, mkThm SC.isSeparator   C.isSeparator   c) | c <- cs]+                      ++ [("isAscii",       show c, mkThm SC.isAscii       C.isAscii       c) | c <- cs]+                      ++ [("isLatin1",      show c, mkThm SC.isLatin1      C.isLatin1      c) | c <- cs]+                      ++ [("isAsciiUpper",  show c, mkThm SC.isAsciiUpper  C.isAsciiUpper  c) | c <- cs]+                      ++ [("isAsciiLower",  show c, mkThm SC.isAsciiLower  C.isAsciiLower  c) | c <- cs]+  where toUpperExceptions = (`notElem` "\181\255")+        digitToIntRange   = (`elem` "0123456789abcdefABCDEF")+        cord :: Char -> Integer+        cord = fromIntegral . C.ord+        dig2Int :: Char -> Integer+        dig2Int = fromIntegral . C.digitToInt+        int2Dig :: Integer -> Char+        int2Dig = C.intToDigit . fromIntegral+        mkTest (nm, x, t) = testCase ("genChars-" ++ nm ++ "." ++ x) (assert t)+        mkThm sop cop arg = isTheorem $ do a <- free "a"+                                           constrain $ a .== literal arg+                                           return $ literal (cop arg) .== sop a++genStrings :: [TestTree]+genStrings = map mkTest1 (  [("length",        show s,                   mkThm1 SS.length        strLen        s      ) | s <- ss                                                       ]+                         ++ [("null",          show s,                   mkThm1 SS.null          null          s      ) | s <- ss                                                       ]+                         ++ [("head",          show s,                   mkThm1 SS.head          head          s      ) | s <- ss, not (null s)                                         ]+                         ++ [("tail",          show s,                   mkThm1 SS.tail          tail          s      ) | s <- ss, not (null s)                                         ]+                         ++ [("charToStr",     show c,                   mkThm1 SS.charToStr     (: [])        c      ) | c <- cs                                                       ]+                         ++ [("implode",       show s,                   mkThmI SS.implode                     s      ) | s <- ss                                                       ]+                         ++ [("strToNat",      show s,                   mkThm1 SS.strToNat      strToNat      s      ) | s <- ss                                                       ]+                         ++ [("natToStr",      show i,                   mkThm1 SS.natToStr      natToStr      i      ) | i <- iUBs                                                     ])+          ++ map mkTest2 (  [("strToStrAt",    show s, show i,           mkThm2 SS.strToStrAt    strToStrAt    s i    ) | s <- ss, i  <- range s                                        ]+                         ++ [("strToCharAt",   show s, show i,           mkThm2 SS.strToCharAt   strToCharAt   s i    ) | s <- ss, i  <- range s                                        ]+                         ++ [("concat",        show s, show s1,          mkThm2 SS.concat        (++)          s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isInfixOf",     show s, show s1,          mkThm2 SS.isInfixOf     isInfixOf     s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isSuffixOf",    show s, show s1,          mkThm2 SS.isSuffixOf    isSuffixOf    s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("isPrefixOf",    show s, show s1,          mkThm2 SS.isPrefixOf    isPrefixOf    s s1   ) | s <- ss, s1 <- ss                                             ]+                         ++ [("take",          show s, show i,           mkThm2 SS.take          genericTake   i s    ) | s <- ss, i <- iUBs                                            ]+                         ++ [("drop",          show s, show i,           mkThm2 SS.drop          genericDrop   i s    ) | s <- ss, i <- iUBs                                            ]+                         ++ [("indexOf",       show s, show s1,          mkThm2 SS.indexOf       indexOf       s s1   ) | s <- ss, s1 <- ss                                             ])+          ++ map mkTest3 (  [("subStr",        show s, show  i, show j,  mkThm3 SS.subStr        subStr        s i  j ) | s <- ss, i  <- range s, j <- range s, i + j <= genericLength s]+                         ++ [("replace",       show s, show s1, show s2, mkThm3 SS.replace       replace       s s1 s2) | s <- ss, s1 <- ss, s2 <- ss                                   ]+                         ++ [("offsetIndexOf", show s, show s1, show i,  mkThm3 SS.offsetIndexOf offsetIndexOf s s1 i ) | s <- ss, s1 <- ss, i <- range s                               ])+  where strLen :: String -> Integer+        strLen = fromIntegral . length++        strToNat :: String -> Integer+        strToNat s+          | all C.isDigit s && not (null s) = read s+          | True                            = -1++        natToStr :: Integer -> String+        natToStr i+          | i >= 0 = show i+          | True   = ""++        range :: String -> [Integer]+        range s = map fromIntegral [0 .. length s - 1]++        indexOf :: String -> String -> Integer+        indexOf s1 s2 = go 0 s1+          where go i x+                 | s2 `isPrefixOf` x = i+                 | True              = case x of+                                          "" -> -1+                                          (_:r) -> go (i+1) r++        strToStrAt :: String -> Integer -> String+        s `strToStrAt` i = [s `strToCharAt` i]++        strToCharAt :: String -> Integer -> Char+        s `strToCharAt` i = s `genericIndex` i++        subStr :: String -> Integer -> Integer -> String+        subStr s i j = genericTake j (genericDrop i s)++        replace :: String -> String -> String -> String+        replace s "" y = y ++ s+        replace s x  y = go s+          where go "" = ""+                go h@(c:rest) | x `isPrefixOf` h = y ++ drop (length x) h+                              | True             = c : go rest++        offsetIndexOf :: String -> String -> Integer -> Integer+        offsetIndexOf x y i = case indexOf (genericDrop i x) y of+                                -1 -> -1+                                r  -> r+i++        mkTest1 (nm, x, t)       = testCase ("genStrings-" ++ nm ++ "." ++ x)                         (assert t)+        mkTest2 (nm, x, y, t)    = testCase ("genStrings-" ++ nm ++ "." ++ x ++ "_" ++ y)             (assert t)+        mkTest3 (nm, x, y, z, t) = testCase ("genStrings-" ++ nm ++ "." ++ x ++ "_" ++ y ++ "_" ++ z) (assert t)++        mkThmI sop s = isTheorem $ do let v c = do sc <- free_+                                                   constrain $ sc .== literal c+                                                   return sc+                                      vs <- mapM v s+                                      return $ literal s .== sop vs++        mkThm1 sop cop arg            = isTheorem $ do a <- free "a"+                                                       constrain $ a .== literal arg+                                                       return $ literal (cop arg) .== sop a+        mkThm2 sop cop arg1 arg2      = isTheorem $ do a <- free "a"+                                                       b <- free "b"+                                                       constrain $ a .== literal arg1+                                                       constrain $ b .== literal arg2+                                                       return $ literal (cop arg1 arg2) .== sop a b+        mkThm3 sop cop arg1 arg2 arg3 = isTheorem $ do a <- free "a"+                                                       b <- free "b"+                                                       c <- free "c"+                                                       constrain $ a .== literal arg1+                                                       constrain $ b .== literal arg2+                                                       constrain $ c .== literal arg3+                                                       return $ literal (cop arg1 arg2 arg3) .== sop a b c+ -- Concrete test data xsSigned, xsUnsigned :: (Num a, Bounded a) => [a] xsUnsigned = [0, 1, maxBound - 1, maxBound]@@ -547,5 +692,18 @@ ds :: [Double] ds = xs ++ map (* (-1)) (filter (not . isNaN) xs) -- -nan is the same as nan   where xs = [nan, infinity, 0, 0.5, 2.516632060108026e-2, 0.8601891300751106, 5.0e-324]++-- Currently we test over all latin-1 characters. But when Unicode comes along, we'll have to be more selective.+-- TODO: Unicode update here.+cs :: String+cs = map C.chr [0..255]++-- For pair char ops, take a subset.+reducedCS :: String+reducedCS = map C.chr $ [0..5] ++ [98..102] ++ [250..255]++-- Ditto for strings, just a few things+ss :: [String]+ss = ["", "palTRY", "teSTing", "SBV", "sTRIngs", "123", "surely", "thIS", "hI", "ly", "0"]  {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
SBVTestSuite/TestSuite/Basics/PseudoBoolean.hs view
@@ -24,6 +24,7 @@     , goldenCapturedIO "pbLe"              $ \rf -> checkWith z3{redirectVerbose=Just rf} propPbLe     , goldenCapturedIO "pbGe"              $ \rf -> checkWith z3{redirectVerbose=Just rf} propPbGe     , goldenCapturedIO "pbEq"              $ \rf -> checkWith z3{redirectVerbose=Just rf} propPbEq+    , goldenCapturedIO "pbEq2"             $ \rf -> checkWith z3{redirectVerbose=Just rf} propPbEq2     , goldenCapturedIO "pbMutexed"         $ \rf -> checkWith z3{redirectVerbose=Just rf} propPbMutexed     , goldenCapturedIO "pbStronglyMutexed" $ \rf -> checkWith z3{redirectVerbose=Just rf} propPbStronglyMutexed     ]@@ -64,6 +65,15 @@ propPbEq bs = pbEq ibs 7 .== (sum (map valIf ibs) .== (7::SInteger))   where ibs = zip [1..] bs         valIf (i, b) = ite b (literal (fromIntegral i)) 0++-- Reported here as a bug <http://github.com/Z3Prover/z3/issues/1571>+-- and SBV didn't catch this. So let's add it as a test case.+propPbEq2 :: [SBool] -> SBool+propPbEq2 bs = (c1 &&& c2) ==> (   ([a, b, c, d, e] .== [false, true, false, true, false])+                               ||| ([a, b, c, d, e] .== [false, true, false, false, true]))+  where ~(a : b : c : d : e : _) = take 5 bs+        c1 = ite a (pbEq [(1, b), (1, c)]         3) (pbEq [(1, b), (1, c)]         1)+        c2 = ite c (pbEq [(1, a), (1, d), (1, e)] 3) (pbEq [(1, a), (1, d), (1, e)] 1)  propPbMutexed :: [SBool] -> SBool propPbMutexed bs = pbMutexed bs .== (sum (map oneIf bs) .<= (1::SWord32))
+ SBVTestSuite/TestSuite/Basics/String.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  TestSuite.Basics.String+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Test the string functions.+-- Most of these tests are adopted from <https://rise4fun.com/z3/tutorialcontent/sequences>+-----------------------------------------------------------------------------++module TestSuite.Basics.String(tests)  where++import Data.SBV.Control+import Utils.SBVTestFramework++import qualified Data.SBV.String as S+import qualified Data.SBV.RegExp as R++import Control.Monad (unless, void)++-- Test suite+tests :: TestTree+tests =+  testGroup "Basics.String" [+      goldenCapturedIO "strConcat"     $ \rf -> checkWith z3{redirectVerbose=Just rf} strConcatSat    Sat+    , goldenCapturedIO "strConcatBad"  $ \rf -> checkWith z3{redirectVerbose=Just rf} strConcatUnsat  Unsat+    , goldenCapturedIO "strIndexOf"    $ \rf -> checkWith z3{redirectVerbose=Just rf} strIndexOfSat   Sat+    , goldenCapturedIO "strIndexOfBad" $ \rf -> checkWith z3{redirectVerbose=Just rf} strIndexOfUnsat Unsat+    , goldenCapturedIO "strExamples1"  $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples1    Sat+    , goldenCapturedIO "strExamples2"  $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples2    Unsat+    , goldenCapturedIO "strExamples3"  $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples3    Sat+    , goldenCapturedIO "strExamples4"  $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples4    Sat+    , goldenCapturedIO "strExamples5"  $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples5    Sat+    , goldenCapturedIO "strExamples6"  $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples6    Unsat+    , goldenCapturedIO "strExamples7"  $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples7    Sat+    , goldenCapturedIO "strExamples8"  $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples8    Unsat+    , goldenCapturedIO "strExamples9"  $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples9    Sat+    , goldenCapturedIO "strExamples10" $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples10   Unsat+    , goldenCapturedIO "strExamples11" $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples11   Unsat+    , goldenCapturedIO "strExamples12" $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples12   Unsat+    , goldenCapturedIO "strExamples13" $ \rf -> checkWith z3{redirectVerbose=Just rf} strExamples13   Unsat+    , goldenCapturedIO "strExamples14" $ \rf -> checkASat z3{redirectVerbose=Just rf} strExamples14+    ]++checkWith :: SMTConfig -> Symbolic () -> CheckSatResult -> IO ()+checkWith cfg props csExpected = runSMTWith cfg{verbose=True} $ do+        _ <- props+        query $ do cs <- checkSat+                   unless (cs == csExpected) $+                     case cs of+                       Unsat -> error "Failed! Expected Sat, got UNSAT"+                       Sat   -> getModel         >>= \r -> error $ "Failed! Expected Unsat, got SAT:\n" ++ show (SatResult (Satisfiable cfg r))+                       Unk   -> getUnknownReason >>= \r -> error $ "Failed! Expected Unsat, got UNK:\n" ++ show r++checkASat :: SMTConfig -> Symbolic SBool -> IO ()+checkASat cfg = void . allSatWith cfg{verbose=True}++strConcatSat :: Symbolic ()+strConcatSat = constrain $ "abc" .++ "def" .== "abcdef"++strConcatUnsat :: Symbolic ()+strConcatUnsat = constrain $ "abc" .++ "def" .== "abcdefg"++strIndexOfSat :: Symbolic ()+strIndexOfSat = constrain $ S.indexOf "abcabc" "a" .== 0++strIndexOfUnsat :: Symbolic ()+strIndexOfUnsat = constrain $ S.indexOf "abcabc" "a" ./= 0++-- Basic string operations+strExamples1 :: Symbolic ()+strExamples1 = constrain $ bAnd+  [ S.charToStr ("abc" .!! 1) .++ S.charToStr ("abc" .!! 0) .== "ba"+  , "abcabc" `S.indexOf` "a"                                .== 0+  , S.offsetIndexOf "abcabc" "a" 1                          .== 3+  , S.subStr "xxabcyy" 2 3                                  .== "abc"+  ]++-- A string cannot overlap with two different characters.+strExamples2 :: Symbolic ()+strExamples2 = do+  a <- sString "a"+  constrain $ a .++ "b" .== "a" .++ a++-- Strings a, b, c can have a non-trivial overlap.+strExamples3 :: Symbolic ()+strExamples3 = do+  [a, b, c] <- sStrings ["a", "b", "c"]+  constrain $ a .++ b .== "abcd"+  constrain $ b .++ c .== "cdef"+  constrain $ bnot $ b .== ""++-- There is a solution to a of length at most 2.+strExamples4 :: Symbolic ()+strExamples4 = do+  [a, b] <- sStrings ["a", "b"]+  constrain $ "abc" .++ a .== b .++ "cef"+  constrain $ S.length a .<= 2++-- There is a solution to a that is not a sequence of "a"'s.+strExamples5 :: Symbolic ()+strExamples5 = do+  [a, b, c] <- sStrings ["a", "b", "c"]+  constrain $ a .++ "ab" .++ b .== b .++ "ba" .++ c+  constrain $ c .== a .++ b+  constrain $ bnot $ a.++ "a" .== "a" .++ a++-- Contains is transitive.+strExamples6 :: Symbolic ()+strExamples6 = do+  [a, b, c] <- sStrings ["a", "b", "c"]+  constrain $ b `S.isInfixOf` a+  constrain $ c `S.isInfixOf` b+  constrain $ bnot $ c `S.isInfixOf` a++-- But containment is not a linear order.+strExamples7 :: Symbolic ()+strExamples7 = do+  [a, b, c] <- sStrings ["a", "b", "c"]+  constrain $ b `S.isInfixOf` a+  constrain $ c `S.isInfixOf` a+  constrain $ bnot $ c `S.isInfixOf` b+  constrain $ bnot $ b `S.isInfixOf` c++-- Any string is equal to the prefix and suffix that add up to a its length.+strExamples8 :: Symbolic ()+strExamples8 = do+  [a, b, c] <- sStrings ["a", "b", "c"]+  constrain $ b `S.isPrefixOf` a+  constrain $ c `S.isSuffixOf` a+  constrain $ S.length a .== S.length b + S.length c+  constrain $ bnot $ a .== b .++ c++-- The maximal length is 6 for a string of length 2 repeated at most 3 times+strExamples9 :: Symbolic ()+strExamples9 = do+   a <- sString "a"+   constrain $ R.match a (R.Loop 1 3 "ab")+   constrain $ S.length a .== 6++-- The maximal length is 6 for a string of length 2 repeated at most 3 times+strExamples10 :: Symbolic ()+strExamples10 = do+   a <- sString "a"+   constrain $ R.match a (R.Loop 1 3 "ab")+   constrain $ S.length a .> 6++-- Conversion from nat to string, only ground terms+strExamples11 :: Symbolic ()+strExamples11 = do+   i <- sInteger "i"+   constrain $ i .== 11+   constrain $ bnot $ S.natToStr i .== "11"++-- Conversion from nat to string, negative values produce empty string+strExamples12 :: Symbolic ()+strExamples12 = do+   i <- sInteger "i"+   constrain $ i .== -2+   constrain $ bnot $ S.natToStr i .== ""++-- Conversion from string to nat, only ground terms+strExamples13 :: Symbolic ()+strExamples13 = do+   s <- sString "s"+   constrain $ s .== "13"+   constrain $ bnot $ S.strToNat s .== 13++-- Generate all length one strings, to enumerate all and making sure we can parse correctly+strExamples14 :: Predicate+strExamples14 = do s <- sString "s"+                   return $ S.length s .== 1
SBVTestSuite/TestSuite/Basics/TOut.hs view
@@ -11,7 +11,7 @@  module TestSuite.Basics.TOut(tests)  where -import Data.SBV.Examples.Puzzles.Euler185+import Documentation.SBV.Examples.Puzzles.Euler185  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/BitPrecise/BitTricks.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.BitPrecise.BitTricks+-- Test suite for Documentation.SBV.Examples.BitPrecise.BitTricks -----------------------------------------------------------------------------  module TestSuite.BitPrecise.BitTricks(tests) where -import Data.SBV.Examples.BitPrecise.BitTricks+import Documentation.SBV.Examples.BitPrecise.BitTricks  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/BitPrecise/Legato.hs view
@@ -6,13 +6,13 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.BitPrecise.Legato+-- Test suite for Documentation.SBV.Examples.BitPrecise.Legato -----------------------------------------------------------------------------  module TestSuite.BitPrecise.Legato(tests) where  import Data.SBV.Internals-import Data.SBV.Examples.BitPrecise.Legato+import Documentation.SBV.Examples.BitPrecise.Legato  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/BitPrecise/MergeSort.hs view
@@ -6,13 +6,13 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.BitPrecise.MergeSort+-- Test suite for Documentation.SBV.Examples.BitPrecise.MergeSort -----------------------------------------------------------------------------  module TestSuite.BitPrecise.MergeSort(tests) where  import Data.SBV.Internals-import Data.SBV.Examples.BitPrecise.MergeSort+import Documentation.SBV.Examples.BitPrecise.MergeSort  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/BitPrecise/PrefixSum.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.PrefixSum.PrefixSum+-- Test suite for Documentation.SBV.Examples.PrefixSum.PrefixSum -----------------------------------------------------------------------------  module TestSuite.BitPrecise.PrefixSum(tests) where -import Data.SBV.Examples.BitPrecise.PrefixSum+import Documentation.SBV.Examples.BitPrecise.PrefixSum  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/CodeGeneration/AddSub.hs view
@@ -6,13 +6,13 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.CodeGeneration.AddSub+-- Test suite for Documentation.SBV.Examples.CodeGeneration.AddSub -----------------------------------------------------------------------------  module TestSuite.CodeGeneration.AddSub(tests) where  import Data.SBV.Internals-import Data.SBV.Examples.CodeGeneration.AddSub+import Documentation.SBV.Examples.CodeGeneration.AddSub  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/CodeGeneration/CRC_USB5.hs view
@@ -6,13 +6,13 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.CodeGeneration.CRC_USB5+-- Test suite for Documentation.SBV.Examples.CodeGeneration.CRC_USB5 -----------------------------------------------------------------------------  module TestSuite.CodeGeneration.CRC_USB5(tests) where  import Data.SBV.Internals-import Data.SBV.Examples.CodeGeneration.CRC_USB5+import Documentation.SBV.Examples.CodeGeneration.CRC_USB5  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/CodeGeneration/Fibonacci.hs view
@@ -6,13 +6,13 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.CodeGeneration.Fibonacci+-- Test suite for Documentation.SBV.Examples.CodeGeneration.Fibonacci -----------------------------------------------------------------------------  module TestSuite.CodeGeneration.Fibonacci(tests) where  import Data.SBV.Internals-import Data.SBV.Examples.CodeGeneration.Fibonacci+import Documentation.SBV.Examples.CodeGeneration.Fibonacci  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/CodeGeneration/GCD.hs view
@@ -6,13 +6,13 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.CodeGeneration.GCD+-- Test suite for Documentation.SBV.Examples.CodeGeneration.GCD -----------------------------------------------------------------------------  module TestSuite.CodeGeneration.GCD(tests) where  import Data.SBV.Internals-import Data.SBV.Examples.CodeGeneration.GCD+import Documentation.SBV.Examples.CodeGeneration.GCD  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/CodeGeneration/PopulationCount.hs view
@@ -6,13 +6,13 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.CodeGeneration.PopulationCount+-- Test suite for Documentation.SBV.Examples.CodeGeneration.PopulationCount -----------------------------------------------------------------------------  module TestSuite.CodeGeneration.PopulationCount(tests) where  import Data.SBV.Internals-import Data.SBV.Examples.CodeGeneration.PopulationCount+import Documentation.SBV.Examples.CodeGeneration.PopulationCount  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/CodeGeneration/Uninterpreted.hs view
@@ -6,13 +6,13 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.CodeGeneration.Uninterpreted+-- Test suite for Documentation.SBV.Examples.CodeGeneration.Uninterpreted -----------------------------------------------------------------------------  module TestSuite.CodeGeneration.Uninterpreted(tests) where  import Data.SBV.Internals-import Data.SBV.Examples.CodeGeneration.Uninterpreted+import Documentation.SBV.Examples.CodeGeneration.Uninterpreted  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Crypto/AES.hs view
@@ -6,13 +6,13 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Crypto.AES+-- Test suite for Documentation.SBV.Examples.Crypto.AES -----------------------------------------------------------------------------  module TestSuite.Crypto.AES(tests) where  import Data.SBV.Internals-import Data.SBV.Examples.Crypto.AES+import Documentation.SBV.Examples.Crypto.AES  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Crypto/RC4.hs view
@@ -6,13 +6,13 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Crypto.RC4+-- Test suite for Documentation.SBV.Examples.Crypto.RC4 -----------------------------------------------------------------------------  module TestSuite.Crypto.RC4(tests) where  import Data.SBV.Tools.STree-import Data.SBV.Examples.Crypto.RC4+import Documentation.SBV.Examples.Crypto.RC4  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Existentials/CRCPolynomial.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Existentials.CRCPolynomial+-- Test suite for Documentation.SBV.Examples.Existentials.CRCPolynomial -----------------------------------------------------------------------------  module TestSuite.Existentials.CRCPolynomial(tests) where -import Data.SBV.Examples.Existentials.CRCPolynomial+import Documentation.SBV.Examples.Existentials.CRCPolynomial  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Polynomials/Polynomials.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Polynomials.Polynomials+-- Test suite for Documentation.SBV.Examples.Polynomials.Polynomials -----------------------------------------------------------------------------  module TestSuite.Polynomials.Polynomials(tests) where -import Data.SBV.Examples.Polynomials.Polynomials+import Documentation.SBV.Examples.Misc.Polynomials  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Puzzles/Coins.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Puzzles.Coins+-- Test suite for Documentation.SBV.Examples.Puzzles.Coins -----------------------------------------------------------------------------  module TestSuite.Puzzles.Coins(tests) where -import Data.SBV.Examples.Puzzles.Coins+import Documentation.SBV.Examples.Puzzles.Coins  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Puzzles/Counts.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Puzzles.Counts+-- Test suite for Documentation.SBV.Examples.Puzzles.Counts -----------------------------------------------------------------------------  module TestSuite.Puzzles.Counts(tests) where -import Data.SBV.Examples.Puzzles.Counts+import Documentation.SBV.Examples.Puzzles.Counts  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Puzzles/DogCatMouse.hs view
@@ -6,7 +6,7 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Puzzles.DogCatMouse+-- Test suite for Documentation.SBV.Examples.Puzzles.DogCatMouse -----------------------------------------------------------------------------  module TestSuite.Puzzles.DogCatMouse(tests) where
SBVTestSuite/TestSuite/Puzzles/Euler185.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Puzzles.Euler185+-- Test suite for Documentation.SBV.Examples.Puzzles.Euler185 -----------------------------------------------------------------------------  module TestSuite.Puzzles.Euler185(tests) where -import Data.SBV.Examples.Puzzles.Euler185+import Documentation.SBV.Examples.Puzzles.Euler185  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Puzzles/MagicSquare.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Puzzles.MagicSquare+-- Test suite for Documentation.SBV.Examples.Puzzles.MagicSquare -----------------------------------------------------------------------------  module TestSuite.Puzzles.MagicSquare(tests) where -import Data.SBV.Examples.Puzzles.MagicSquare+import Documentation.SBV.Examples.Puzzles.MagicSquare  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Puzzles/NQueens.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Puzzles.NQueens+-- Test suite for Documentation.SBV.Examples.Puzzles.NQueens -----------------------------------------------------------------------------  module TestSuite.Puzzles.NQueens(tests) where -import Data.SBV.Examples.Puzzles.NQueens+import Documentation.SBV.Examples.Puzzles.NQueens  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Puzzles/Sudoku.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Puzzles.Sudoku+-- Test suite for Documentation.SBV.Examples.Puzzles.Sudoku -----------------------------------------------------------------------------  module TestSuite.Puzzles.Sudoku(tests) where -import Data.SBV.Examples.Puzzles.Sudoku+import Documentation.SBV.Examples.Puzzles.Sudoku  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Puzzles/U2Bridge.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Puzzles.U2Bridge+-- Test suite for Documentation.SBV.Examples.Puzzles.U2Bridge -----------------------------------------------------------------------------  module TestSuite.Puzzles.U2Bridge(tests) where -import Data.SBV.Examples.Puzzles.U2Bridge+import Documentation.SBV.Examples.Puzzles.U2Bridge  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Queries/Enums.hs view
@@ -6,7 +6,7 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Uninterpreted.AUF+-- Test suite for Documentation.SBV.Examples.Uninterpreted.AUF -----------------------------------------------------------------------------  {-# LANGUAGE TemplateHaskell     #-}
SBVTestSuite/TestSuite/Queries/Interpolants.hs view
@@ -19,7 +19,7 @@ -- Test suite tests :: TestTree tests =-  testGroup "Basics.QueryIndividual"+  testGroup "Basics.QueryInterpolants"     [ goldenCapturedIO "query_Interpolant1" $ testQuery q1     , goldenCapturedIO "query_Interpolant2" $ testQuery q2     , goldenCapturedIO "query_Interpolant3" $ testQuery q3
+ SBVTestSuite/TestSuite/Queries/Strings.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  TestSuite.Queries.Strings+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Testing a few strings+-----------------------------------------------------------------------------++module TestSuite.Queries.Strings (tests)  where++import Data.SBV+import Data.SBV.Control++import qualified Data.SBV.Char   as C+import qualified Data.SBV.RegExp as R++import Utils.SBVTestFramework++-- Test suite+tests :: TestTree+tests =+  testGroup "Basics.QueryStrings"+    [ goldenCapturedIO "query_Strings1" $ testQuery queryString1+    , goldenCapturedIO "query_Chars1"   $ testQuery queryChar1+    ]++testQuery :: Show a => Symbolic a -> FilePath -> IO ()+testQuery t rf = do r <- runSMTWith defaultSMTCfg{verbose=True, redirectVerbose=Just rf} t+                    appendFile rf ("\nFINAL OUTPUT:\n" ++ show r ++ "\n")++queryString1 :: Symbolic [String]+queryString1 = do a <- sString "a"++                  constrain $ a `R.match` R.Loop 5 5 "xyz"++                  query $ do _ <- checkSat+                             s <- getValue a+                             if s == concat (replicate 5 "xyz")+                                then return [s]+                                else error $ "Didn't expect this: " ++ show s++queryChar1 :: Symbolic Char+queryChar1 = do a <- sChar "a"++                constrain $ C.ord a .>= 65+                constrain $ C.ord a .<  66++                query $ do _ <- checkSat+                           s <- getValue a+                           if s == 'A'+                              then return s+                              else error $ "Didn't expect this: " ++ show s
+ SBVTestSuite/TestSuite/QuickCheck/QC.hs view
@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  TestSuite.QuickCheck.QC+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Quick-check based test suite for SBV+-----------------------------------------------------------------------------++{-# LANGUAGE Rank2Types #-}++module TestSuite.QuickCheck.QC (tests) where++import Utils.SBVTestFramework++unaryArith :: String -> (forall a. Num a => a -> a) -> [TestTree]+unaryArith nm op =  qc1 (nm ++ ".SWord8"  ) op (op :: SWord8   -> SWord8)+                 ++ qc1 (nm ++ ".SWord16" ) op (op :: SWord16  -> SWord16)+                 ++ qc1 (nm ++ ".SWord32" ) op (op :: SWord32  -> SWord32)+                 ++ qc1 (nm ++ ".SWord64" ) op (op :: SWord64  -> SWord64)+                 ++ qc1 (nm ++ ".SInt8"   ) op (op :: SInt8    -> SInt8)+                 ++ qc1 (nm ++ ".SInt16"  ) op (op :: SInt16   -> SInt16)+                 ++ qc1 (nm ++ ".SInt32"  ) op (op :: SInt32   -> SInt32)+                 ++ qc1 (nm ++ ".SInt64"  ) op (op :: SInt64   -> SInt64)+                 ++ qc1 (nm ++ ".SInteger") op (op :: SInteger -> SInteger)+                 ++ qc1 (nm ++ ".SReal"   ) op (op :: SReal    -> SReal)+                 ++ qc1 (nm ++ ".SFloat"  ) op (op :: SFloat   -> SFloat)+                 ++ qc1 (nm ++ ".SDouble" ) op (op :: SDouble  -> SDouble)++binaryArith :: String -> (forall a. Num a => a -> a -> a) -> [TestTree]+binaryArith nm op = qc2 (nm ++ ".SWord8"  ) op (op :: SWord8   -> SWord8   -> SWord8)+                 ++ qc2 (nm ++ ".SWord16" ) op (op :: SWord16  -> SWord16  -> SWord16)+                 ++ qc2 (nm ++ ".SWord32" ) op (op :: SWord32  -> SWord32  -> SWord32)+                 ++ qc2 (nm ++ ".SWord64" ) op (op :: SWord64  -> SWord64  -> SWord64)+                 ++ qc2 (nm ++ ".SInt8"   ) op (op :: SInt8    -> SInt8    -> SInt8)+                 ++ qc2 (nm ++ ".SInt16"  ) op (op :: SInt16   -> SInt16   -> SInt16)+                 ++ qc2 (nm ++ ".SInt32"  ) op (op :: SInt32   -> SInt32   -> SInt32)+                 ++ qc2 (nm ++ ".SInt64"  ) op (op :: SInt64   -> SInt64   -> SInt64)+                 ++ qc2 (nm ++ ".SInteger") op (op :: SInteger -> SInteger -> SInteger)+                 ++ qc2 (nm ++ ".SReal"   ) op (op :: SReal    -> SReal    -> SReal)+                 ++ qc2 (nm ++ ".SFloat"  ) op (op :: SFloat   -> SFloat   -> SFloat)+                 ++ qc2 (nm ++ ".SDouble" ) op (op :: SDouble  -> SDouble  -> SDouble)++-- Test suite+tests :: TestTree+tests = testGroup "QuickCheck.QC" [+            testGroup "Arithmetic" [+                 testGroup "Unary"  $    unaryArith "negate" negate+                                      ++ unaryArith "abs"    abs+                                      ++ unaryArith "signum" signum+               , testGroup "Binary" $    binaryArith "+"     (+)+                                      ++ binaryArith "-"     (-)+                                      ++ binaryArith "*"     (*)+               ]+        ]
SBVTestSuite/TestSuite/Uninterpreted/AUF.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Test suite for Data.SBV.Examples.Uninterpreted.AUF+-- Test suite for Documentation.SBV.Examples.Uninterpreted.AUF -----------------------------------------------------------------------------  module TestSuite.Uninterpreted.AUF where -import Data.SBV.Examples.Uninterpreted.AUF+import Documentation.SBV.Examples.Uninterpreted.AUF  import Utils.SBVTestFramework
SBVTestSuite/TestSuite/Uninterpreted/Function.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- Testsuite for Data.SBV.Examples.Uninterpreted.Function+-- Testsuite for Documentation.SBV.Examples.Uninterpreted.Function -----------------------------------------------------------------------------  module TestSuite.Uninterpreted.Function(tests) where -import Data.SBV.Examples.Uninterpreted.Function+import Documentation.SBV.Examples.Uninterpreted.Function  import Utils.SBVTestFramework
SBVTestSuite/Utils/SBVTestFramework.hs view
@@ -20,6 +20,7 @@         , goldenVsStringShow         , goldenCapturedIO         , CIOS(..), TestEnvironment(..), getTestEnvironment+        , qc1, qc2         , pickTests         -- module exports to simplify life         , module Test.Tasty@@ -29,6 +30,8 @@  import qualified Control.Exception as C +import Control.Monad.Trans (liftIO)+ import qualified Data.ByteString.Lazy.Char8 as LBC import qualified Data.ByteString as BS @@ -41,10 +44,14 @@ import Test.Tasty.Golden           (goldenVsString) import Test.Tasty.Golden.Advanced  (goldenTest) +import qualified Test.Tasty.QuickCheck   as QC+import qualified Test.QuickCheck.Monadic as QC+ import Test.Tasty.Runners hiding (Result) import System.Random (randomRIO)  import Data.SBV+import Data.SBV.Control  import Data.Char (chr, ord, isDigit) @@ -52,7 +59,7 @@  import System.FilePath ((</>), (<.>)) -import Data.SBV.Internals (runSymbolic, Symbolic, Result, SBVRunMode(..), IStage(..))+import Data.SBV.Internals (runSymbolic, Symbolic, Result, SBVRunMode(..), IStage(..), SBV(..), SVal(..), showModel, SMTModel(..))  --------------------------------------------------------------------------------------- -- Test environment; continuous integration@@ -159,6 +166,121 @@ assertIsntSat :: Provable a => a -> Assertion assertIsntSat p = assert (fmap not (isSatisfiable p)) +-- | Quick-check a unary function, creating one version for constant folding, and another for solver+qc1 :: (SymWord a, SymWord b, Show a, QC.Arbitrary a, SMTValue b) => String -> (a -> b) -> (SBV a -> SBV b) -> [TestTree]+qc1 nm opC opS = [cf, sm]+   where cf = QC.testProperty (nm ++ ".constantFold") $ do+                        i <- free "i"++                        let extract n = fromMaybe (error $ "qc1." ++ nm ++ ": Cannot extract value for: " ++ n) . unliteral++                            v = extract "i" i++                            expected = literal $ opC v+                            result   = opS i++                        observe "Expected" expected+                        observe "Result"   result++                        case (unliteral expected, unliteral result) of+                           (Just _, Just _) -> return $ expected .== result+                           _                -> return false++         sm = QC.testProperty (nm ++ ".symbolic") $ QC.monadicIO $ do+                        ((i, expected), result) <- QC.run $ runSMT $ do v   <- liftIO $ QC.generate QC.arbitrary+                                                                        i   <- free_+                                                                        res <- free_++                                                                        constrain $ i   .== literal v+                                                                        constrain $ res .== opS i++                                                                        let pre = (v, opC v)++                                                                        query $ do cs <- checkSat+                                                                                   case cs of+                                                                                     Unk   -> return (pre, Left "Unexpected: Solver responded Unknown!")+                                                                                     Unsat -> return (pre, Left "Unexpected: Solver responded Unsatisfiable!")+                                                                                     Sat   -> do r <- getValue res+                                                                                                 return (pre, Right r)++                        let getCW vnm (SBV (SVal _ (Left c))) = (vnm, c)+                            getCW vnm (SBV (SVal k _       )) = error $ "qc2.getCW: Impossible happened, non-CW value while extracting: " ++ show (vnm, k)++                            vals = [ getCW "i"        (literal i)+                                   , getCW "Expected" (literal expected)+                                   ]++                            model = case result of+                                      Right v -> showModel defaultSMTCfg (SMTModel [] (vals ++ [getCW "Result" (literal v)]))+                                      Left  e -> showModel defaultSMTCfg (SMTModel [] vals) ++ "\n" ++ e++                        QC.monitor (QC.counterexample model)++                        case result of+                           Right a -> QC.assert $ expected == a+                           _       -> QC.assert False+++-- | Quick-check a binary function, creating one version for constant folding, and another for solver+qc2 :: (SymWord a, SymWord b, SymWord c, Show a, Show b, QC.Arbitrary a, QC.Arbitrary b, SMTValue c) => String -> (a -> b -> c) -> (SBV a -> SBV b -> SBV c) -> [TestTree]+qc2 nm opC opS = [cf, sm]+   where cf = QC.testProperty (nm ++ ".constantFold") $ do+                        i1 <- free "i1"+                        i2 <- free "i2"++                        let extract n = fromMaybe (error $ "qc2." ++ nm ++ ": Cannot extract value for: " ++ n) . unliteral++                            v1 = extract "i1" i1+                            v2 = extract "i2" i2++                            expected = literal $ opC v1 v2+                            result   = opS i1 i2++                        observe "Expected" expected+                        observe "Result"   result++                        case (unliteral expected, unliteral result) of+                           (Just _, Just _) -> return $ expected .== result+                           _                -> return false++         sm = QC.testProperty (nm ++ ".symbolic") $ QC.monadicIO $ do+                        ((i1, i2, expected), result) <- QC.run $ runSMT $ do v1  <- liftIO $ QC.generate QC.arbitrary+                                                                             v2  <- liftIO $ QC.generate QC.arbitrary+                                                                             i1  <- free_+                                                                             i2  <- free_+                                                                             res <- free_++                                                                             constrain $ i1  .== literal v1+                                                                             constrain $ i2  .== literal v2+                                                                             constrain $ res .== i1 `opS` i2++                                                                             let pre = (v1, v2, v1 `opC` v2)++                                                                             query $ do cs <- checkSat+                                                                                        case cs of+                                                                                          Unk   -> return (pre, Left "Unexpected: Solver responded Unknown!")+                                                                                          Unsat -> return (pre, Left "Unexpected: Solver responded Unsatisfiable!")+                                                                                          Sat   -> do r <- getValue res+                                                                                                      return (pre, Right r)++                        let getCW vnm (SBV (SVal _ (Left c))) = (vnm, c)+                            getCW vnm (SBV (SVal k _       )) = error $ "qc2.getCW: Impossible happened, non-CW value while extracting: " ++ show (vnm, k)++                            vals = [ getCW "i1"       (literal i1)+                                   , getCW "i2"       (literal i2)+                                   , getCW "Expected" (literal expected)+                                   ]++                            model = case result of+                                      Right v -> showModel defaultSMTCfg (SMTModel [] (vals ++ [getCW "Result" (literal v)]))+                                      Left  e -> showModel defaultSMTCfg (SMTModel [] vals) ++ "\n" ++ e++                        QC.monitor (QC.counterexample model)++                        case result of+                           Right a -> QC.assert $ expected == a+                           _       -> QC.assert False+ -- | Picking a certain percent of tests. pickTests :: Int -> TestTree -> IO TestTree pickTests d origTests = fromMaybe noTestsSelected <$> walk origTests@@ -175,3 +297,5 @@                                      case cs of                                        [] -> return Nothing                                        _  -> return $ Just $ TestGroup tn cs++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
sbv.cabal view
@@ -1,5 +1,5 @@ Name:          sbv-Version:       7.6+Version:       7.7 Category:      Formal Methods, Theorem Provers, Bit vectors, Symbolic Computation, Math, SMT Synopsis:      SMT Based Verification: Symbolic Haskell theorem prover using SMT solving. Description:   Express properties about Haskell programs and automatically prove them using SMT@@ -56,60 +56,65 @@                   , Data.SBV.Control                   , Data.SBV.Dynamic                   , Data.SBV.Internals+                  , Data.SBV.String+                  , Data.SBV.Char+                  , Data.SBV.RegExp                   , Data.SBV.Tools.CodeGen                   , 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-                  , Data.SBV.Examples.BitPrecise.MultMask-                  , Data.SBV.Examples.BitPrecise.PrefixSum-                  , Data.SBV.Examples.CodeGeneration.AddSub-                  , Data.SBV.Examples.CodeGeneration.CRC_USB5-                  , Data.SBV.Examples.CodeGeneration.Fibonacci-                  , Data.SBV.Examples.CodeGeneration.GCD-                  , Data.SBV.Examples.CodeGeneration.PopulationCount-                  , Data.SBV.Examples.CodeGeneration.Uninterpreted-                  , Data.SBV.Examples.Crypto.AES-                  , Data.SBV.Examples.Crypto.RC4-                  , Data.SBV.Examples.Existentials.CRCPolynomial-                  , Data.SBV.Examples.Existentials.Diophantine-                  , Data.SBV.Examples.Misc.Enumerate-                  , Data.SBV.Examples.Misc.Floating-                  , Data.SBV.Examples.Misc.ModelExtract-                  , Data.SBV.Examples.Misc.Auxiliary-                  , 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.Optimization.ExtField-                  , Data.SBV.Examples.Puzzles.Birthday-                  , Data.SBV.Examples.Puzzles.Coins-                  , Data.SBV.Examples.Puzzles.Counts-                  , Data.SBV.Examples.Puzzles.DogCatMouse-                  , Data.SBV.Examples.Puzzles.Euler185-                  , Data.SBV.Examples.Puzzles.Fish-                  , Data.SBV.Examples.Puzzles.MagicSquare-                  , Data.SBV.Examples.Puzzles.NQueens-                  , Data.SBV.Examples.Puzzles.SendMoreMoney-                  , Data.SBV.Examples.Puzzles.Sudoku-                  , Data.SBV.Examples.Puzzles.U2Bridge-                  , Data.SBV.Examples.Queries.AllSat-                  , Data.SBV.Examples.Queries.UnsatCore-                  , Data.SBV.Examples.Queries.FourFours-                  , Data.SBV.Examples.Queries.GuessNumber-                  , Data.SBV.Examples.Queries.CaseSplit-                  , Data.SBV.Examples.Queries.Enums-                  , Data.SBV.Examples.Queries.Interpolants-                  , Data.SBV.Examples.Uninterpreted.AUF-                  , Data.SBV.Examples.Uninterpreted.Deduce-                  , Data.SBV.Examples.Uninterpreted.Function-                  , Data.SBV.Examples.Uninterpreted.Shannon-                  , Data.SBV.Examples.Uninterpreted.Sort-                  , Data.SBV.Examples.Uninterpreted.UISortAllSat+                  , Documentation.SBV.Examples.BitPrecise.BitTricks+                  , Documentation.SBV.Examples.BitPrecise.Legato+                  , Documentation.SBV.Examples.BitPrecise.MergeSort+                  , Documentation.SBV.Examples.BitPrecise.MultMask+                  , Documentation.SBV.Examples.BitPrecise.PrefixSum+                  , Documentation.SBV.Examples.CodeGeneration.AddSub+                  , Documentation.SBV.Examples.CodeGeneration.CRC_USB5+                  , Documentation.SBV.Examples.CodeGeneration.Fibonacci+                  , Documentation.SBV.Examples.CodeGeneration.GCD+                  , Documentation.SBV.Examples.CodeGeneration.PopulationCount+                  , Documentation.SBV.Examples.CodeGeneration.Uninterpreted+                  , Documentation.SBV.Examples.Crypto.AES+                  , Documentation.SBV.Examples.Crypto.RC4+                  , Documentation.SBV.Examples.Existentials.CRCPolynomial+                  , Documentation.SBV.Examples.Existentials.Diophantine+                  , Documentation.SBV.Examples.Misc.Enumerate+                  , Documentation.SBV.Examples.Misc.Floating+                  , Documentation.SBV.Examples.Misc.ModelExtract+                  , Documentation.SBV.Examples.Misc.Auxiliary+                  , Documentation.SBV.Examples.Misc.NoDiv0+                  , Documentation.SBV.Examples.Misc.Polynomials+                  , Documentation.SBV.Examples.Misc.Word4+                  , Documentation.SBV.Examples.Optimization.LinearOpt+                  , Documentation.SBV.Examples.Optimization.Production+                  , Documentation.SBV.Examples.Optimization.VM+                  , Documentation.SBV.Examples.Optimization.ExtField+                  , Documentation.SBV.Examples.Puzzles.Birthday+                  , Documentation.SBV.Examples.Puzzles.Coins+                  , Documentation.SBV.Examples.Puzzles.Counts+                  , Documentation.SBV.Examples.Puzzles.DogCatMouse+                  , Documentation.SBV.Examples.Puzzles.Euler185+                  , Documentation.SBV.Examples.Puzzles.Fish+                  , Documentation.SBV.Examples.Puzzles.MagicSquare+                  , Documentation.SBV.Examples.Puzzles.NQueens+                  , Documentation.SBV.Examples.Puzzles.SendMoreMoney+                  , Documentation.SBV.Examples.Puzzles.Sudoku+                  , Documentation.SBV.Examples.Puzzles.U2Bridge+                  , Documentation.SBV.Examples.Queries.AllSat+                  , Documentation.SBV.Examples.Queries.UnsatCore+                  , Documentation.SBV.Examples.Queries.FourFours+                  , Documentation.SBV.Examples.Queries.GuessNumber+                  , Documentation.SBV.Examples.Queries.CaseSplit+                  , Documentation.SBV.Examples.Queries.Enums+                  , Documentation.SBV.Examples.Queries.Interpolants+                  , Documentation.SBV.Examples.Strings.RegexCrossword+                  , Documentation.SBV.Examples.Strings.SQLInjection+                  , Documentation.SBV.Examples.Uninterpreted.AUF+                  , Documentation.SBV.Examples.Uninterpreted.Deduce+                  , Documentation.SBV.Examples.Uninterpreted.Function+                  , Documentation.SBV.Examples.Uninterpreted.Shannon+                  , Documentation.SBV.Examples.Uninterpreted.Sort+                  , Documentation.SBV.Examples.Uninterpreted.UISortAllSat   Other-modules   : Data.SBV.Core.AlgReals                   , Data.SBV.Core.Concrete                   , Data.SBV.Core.Data@@ -153,7 +158,7 @@                   , ScopedTypeVariables   Build-depends : base >= 4.9, data-binary-ieee754, filepath, syb                 , sbv, directory, random, mtl, containers-                , template-haskell, bytestring, tasty, tasty-golden, tasty-hunit+                , template-haskell, bytestring, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, QuickCheck   Hs-Source-Dirs  : SBVTestSuite   main-is         : SBVTest.hs   Other-modules   : Utils.SBVTestFramework@@ -175,6 +180,7 @@                   , TestSuite.Basics.Recursive                   , TestSuite.Basics.SmallShifts                   , TestSuite.Basics.SquashReals+                  , TestSuite.Basics.String                   , TestSuite.Basics.TOut                   , TestSuite.BitPrecise.BitTricks                   , TestSuite.BitPrecise.Legato@@ -225,7 +231,9 @@                   , TestSuite.Queries.Int_Yices                   , TestSuite.Queries.Int_Z3                   , TestSuite.Queries.Interpolants+                  , TestSuite.Queries.Strings                   , TestSuite.Queries.Uninterpreted+                  , TestSuite.QuickCheck.QC                   , TestSuite.Uninterpreted.AUF                   , TestSuite.Uninterpreted.Axioms                   , TestSuite.Uninterpreted.Function@@ -234,7 +242,7 @@  Test-Suite SBVDocTest     Build-Depends:    base, directory, filepath, random-                    , doctest, Glob, bytestring, tasty, tasty-golden, tasty-hunit+                    , doctest, Glob, bytestring, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, mtl, QuickCheck                     , sbv     default-language: Haskell2010     Hs-Source-Dirs  : SBVTestSuite@@ -244,7 +252,7 @@  Test-Suite SBVHLint     build-depends:    base, directory, filepath, random-                    , hlint, bytestring, tasty, tasty-golden, tasty-hunit+                    , hlint, bytestring, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, mtl, QuickCheck                     , sbv     default-language: Haskell2010     hs-source-dirs:   SBVTestSuite