sbv 14.0 → 14.1
raw patch · 197 files changed
+5088/−4683 lines, 197 files
Files
- CHANGES.md +29/−2
- Data/SBV.hs +16/−14
- Data/SBV/Client.hs +5/−15
- Data/SBV/Compilers/C.hs +7/−7
- Data/SBV/Compilers/CodeGen.hs +9/−16
- Data/SBV/Control/BaseIO.hs +6/−4
- Data/SBV/Control/Query.hs +83/−82
- Data/SBV/Control/Utils.hs +182/−193
- Data/SBV/Core/AlgReals.hs +2/−2
- Data/SBV/Core/Concrete.hs +2/−2
- Data/SBV/Core/Data.hs +7/−11
- Data/SBV/Core/Floating.hs +30/−15
- Data/SBV/Core/Kind.hs +30/−36
- Data/SBV/Core/Model.hs +149/−119
- Data/SBV/Core/Operations.hs +12/−12
- Data/SBV/Core/Sized.hs +2/−2
- Data/SBV/Core/Symbolic.hs +151/−204
- Data/SBV/Dynamic.hs +14/−14
- Data/SBV/Either.hs +1/−1
- Data/SBV/Internals.hs +4/−3
- Data/SBV/Lambda.hs +52/−50
- Data/SBV/List.hs +3/−3
- Data/SBV/Maybe.hs +1/−1
- Data/SBV/Provers/CVC4.hs +11/−4
- Data/SBV/Provers/CVC5.hs +11/−4
- Data/SBV/Provers/Prover.hs +50/−48
- Data/SBV/Rational.hs +1/−0
- Data/SBV/SCase.hs +272/−103
- Data/SBV/SMT/SMT.hs +155/−130
- Data/SBV/SMT/SMTLib2.hs +157/−153
- Data/SBV/SMT/Utils.hs +62/−59
- Data/SBV/Set.hs +1/−1
- Data/SBV/TP.hs +4/−1
- Data/SBV/TP/Kernel.hs +45/−35
- Data/SBV/TP/TP.hs +40/−27
- Data/SBV/TP/Utils.hs +78/−39
- Data/SBV/Tools/BMC.hs +7/−7
- Data/SBV/Tools/BVOptimize.hs +1/−1
- Data/SBV/Tools/GenTest.hs +21/−18
- Data/SBV/Tools/Induction.hs +5/−5
- Data/SBV/Tools/Range.hs +11/−11
- Data/SBV/Tools/WeakestPreconditions.hs +29/−29
- Data/SBV/Tuple.hs +1/−1
- Data/SBV/Utils/CrackNum.hs +12/−5
- Data/SBV/Utils/Lib.hs +28/−10
- Data/SBV/Utils/Numeric.hs +5/−3
- Data/SBV/Utils/PrettyNum.hs +124/−153
- Data/SBV/Utils/SExpr.hs +75/−75
- Documentation/SBV/Examples/ADT/Param.hs +2/−2
- Documentation/SBV/Examples/ADT/Types.hs +1/−1
- Documentation/SBV/Examples/BitPrecise/BrokenSearch.hs +1/−1
- Documentation/SBV/Examples/BitPrecise/Legato.hs +1/−1
- Documentation/SBV/Examples/BitPrecise/MergeSort.hs +2/−2
- Documentation/SBV/Examples/BitPrecise/PrefixSum.hs +2/−2
- Documentation/SBV/Examples/CodeGeneration/Fibonacci.hs +2/−2
- Documentation/SBV/Examples/CodeGeneration/GCD.hs +3/−3
- Documentation/SBV/Examples/Crypto/AES.hs +0/−4
- Documentation/SBV/Examples/Crypto/Prince.hs +5/−5
- Documentation/SBV/Examples/Crypto/RC4.hs +1/−1
- Documentation/SBV/Examples/Existentials/Diophantine.hs +3/−3
- Documentation/SBV/Examples/Lists/BoundedMutex.hs +1/−1
- Documentation/SBV/Examples/Misc/Auxiliary.hs +1/−1
- Documentation/SBV/Examples/Misc/Floating.hs +4/−4
- Documentation/SBV/Examples/Misc/ModelExtract.hs +3/−3
- Documentation/SBV/Examples/Misc/Newtypes.hs +1/−1
- Documentation/SBV/Examples/Misc/SoftConstrain.hs +1/−1
- Documentation/SBV/Examples/ProofTools/BMC.hs +1/−1
- Documentation/SBV/Examples/ProofTools/Strengthen.hs +1/−1
- Documentation/SBV/Examples/ProofTools/Sum.hs +1/−1
- Documentation/SBV/Examples/Puzzles/Coins.hs +2/−2
- Documentation/SBV/Examples/Puzzles/Euler185.hs +1/−1
- Documentation/SBV/Examples/Puzzles/Sudoku.hs +0/−3
- Documentation/SBV/Examples/Puzzles/U2Bridge.hs +11/−8
- Documentation/SBV/Examples/Queries/AllSat.hs +1/−1
- Documentation/SBV/Examples/Queries/CaseSplit.hs +2/−2
- Documentation/SBV/Examples/Queries/Concurrency.hs +8/−8
- Documentation/SBV/Examples/Queries/Enums.hs +1/−1
- Documentation/SBV/Examples/Queries/FourFours.hs +16/−16
- Documentation/SBV/Examples/Queries/GuessNumber.hs +1/−1
- Documentation/SBV/Examples/Queries/UnsatCore.hs +1/−1
- Documentation/SBV/Examples/Strings/RegexCrossword.hs +2/−2
- Documentation/SBV/Examples/Strings/SQLInjection.hs +2/−2
- Documentation/SBV/Examples/TP/Ackermann.hs +62/−62
- Documentation/SBV/Examples/TP/Basics.hs +11/−11
- Documentation/SBV/Examples/TP/BinarySearch.hs +36/−36
- Documentation/SBV/Examples/TP/CaseSplit.hs +5/−5
- Documentation/SBV/Examples/TP/Coins.hs +10/−10
- Documentation/SBV/Examples/TP/Collatz.hs +12/−12
- Documentation/SBV/Examples/TP/ConstFold.hs +316/−316
- Documentation/SBV/Examples/TP/Countdown.hs +16/−16
- Documentation/SBV/Examples/TP/Fibonacci.hs +8/−8
- Documentation/SBV/Examples/TP/GCD.hs +199/−199
- Documentation/SBV/Examples/TP/InsertionSort.hs +35/−35
- Documentation/SBV/Examples/TP/Kadane.hs +9/−9
- Documentation/SBV/Examples/TP/Kleene.hs +13/−13
- Documentation/SBV/Examples/TP/Lists.hs +450/−450
- Documentation/SBV/Examples/TP/Majority.hs +16/−16
- Documentation/SBV/Examples/TP/McCarthy91.hs +11/−11
- Documentation/SBV/Examples/TP/MergeSort.hs +58/−58
- Documentation/SBV/Examples/TP/MutualCorecursion.hs +29/−29
- Documentation/SBV/Examples/TP/NatStream.hs +13/−13
- Documentation/SBV/Examples/TP/Numeric.hs +70/−70
- Documentation/SBV/Examples/TP/Peano.hs +159/−159
- Documentation/SBV/Examples/TP/PigeonHole.hs +4/−4
- Documentation/SBV/Examples/TP/PowerMod.hs +162/−162
- Documentation/SBV/Examples/TP/Primes.hs +89/−89
- Documentation/SBV/Examples/TP/QuickSort.hs +184/−187
- Documentation/SBV/Examples/TP/RevAcc.hs +7/−7
- Documentation/SBV/Examples/TP/Reverse.hs +8/−8
- Documentation/SBV/Examples/TP/ShefferStroke.hs +170/−170
- Documentation/SBV/Examples/TP/SortHelpers.hs +50/−50
- Documentation/SBV/Examples/TP/Sqrt2IsIrrational.hs +8/−8
- Documentation/SBV/Examples/TP/StrongInduction.hs +42/−42
- Documentation/SBV/Examples/TP/SumReverse.hs +14/−14
- Documentation/SBV/Examples/TP/Tao.hs +1/−1
- Documentation/SBV/Examples/TP/TautologyChecker.hs +142/−142
- Documentation/SBV/Examples/TP/UpDown.hs +11/−11
- Documentation/SBV/Examples/TP/VM.hs +67/−67
- Documentation/SBV/Examples/Transformers/SymbolicEval.hs +1/−6
- Documentation/SBV/Examples/Uninterpreted/Deduce.hs +2/−2
- Documentation/SBV/Examples/Uninterpreted/EUFLogic.hs +15/−15
- Documentation/SBV/Examples/Uninterpreted/Multiply.hs +4/−3
- Documentation/SBV/Examples/Uninterpreted/Sort.hs +2/−2
- Documentation/SBV/Examples/Uninterpreted/UISortAllSat.hs +1/−1
- Documentation/SBV/Examples/WeakestPreconditions/Append.hs +1/−1
- Documentation/SBV/Examples/WeakestPreconditions/Basics.hs +1/−1
- Documentation/SBV/Examples/WeakestPreconditions/IntDiv.hs +1/−1
- Documentation/SBV/Examples/WeakestPreconditions/IntSqrt.hs +1/−1
- Documentation/SBV/Examples/WeakestPreconditions/Length.hs +1/−1
- Documentation/SBV/Examples/WeakestPreconditions/Sum.hs +5/−5
- SBVBenchSuite/BenchSuite/Bench/Bench.hs +1/−1
- SBVBenchSuite/BenchSuite/Existentials/Diophantine.hs +1/−1
- SBVBenchSuite/BenchSuite/Misc/NoDiv0.hs +1/−1
- SBVBenchSuite/BenchSuite/Optimization/Instances.hs +1/−1
- SBVBenchSuite/BenchSuite/ProofTools/BMC.hs +1/−1
- SBVBenchSuite/BenchSuite/ProofTools/Fibonacci.hs +1/−1
- SBVBenchSuite/BenchSuite/ProofTools/Strengthen.hs +1/−1
- SBVBenchSuite/BenchSuite/ProofTools/Sum.hs +1/−1
- SBVBenchSuite/BenchSuite/Queries/Enums.hs +1/−1
- SBVBenchSuite/BenchSuite/Queries/GuessNumber.hs +1/−1
- SBVBenchSuite/BenchSuite/Transformers/SymbolicEval.hs +1/−1
- SBVBenchSuite/BenchSuite/Uninterpreted/AUF.hs +1/−1
- SBVBenchSuite/BenchSuite/Uninterpreted/Deduce.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Append.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Basics.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Fib.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/GCD.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Instances.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/IntDiv.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/IntSqrt.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Length.hs +1/−1
- SBVBenchSuite/BenchSuite/WeakestPreconditions/Sum.hs +1/−1
- SBVBenchSuite/Utils/SBVBenchFramework.hs +1/−1
- SBVTestSuite/GoldFiles/adt01.gold +1/−1
- SBVTestSuite/GoldFiles/adt05.gold +2/−2
- SBVTestSuite/GoldFiles/freshVars.gold +2/−2
- SBVTestSuite/GoldFiles/pareto1.gold +45/−45
- SBVTestSuite/GoldFiles/pareto2.gold +150/−150
- SBVTestSuite/GoldFiles/query_cvc5.gold +1/−1
- SBVTestSuite/GoldFiles/query_uisatex1.gold +8/−8
- SBVTestSuite/GoldFiles/query_uisatex2.gold +8/−8
- SBVTestSuite/GoldFiles/recursive20_mutualTP.gold +1/−1
- SBVTestSuite/GoldFiles/recursive28_noTermCheck.gold +1/−1
- SBVTestSuite/GoldFiles/recursive6_uselessContract.gold +10/−10
- SBVTestSuite/GoldFiles/tpCache_alias.gold +3/−3
- SBVTestSuite/GoldFiles/tpCache_barFail.gold +4/−0
- SBVTestSuite/GoldFiles/tpCache_calcCollapse.gold +3/−3
- SBVTestSuite/GoldFiles/tpCache_fooFail.gold +4/−0
- SBVTestSuite/GoldFiles/tpCache_hit.gold +2/−2
- SBVTestSuite/GoldFiles/tpCache_miss.gold +1/−1
- SBVTestSuite/GoldFiles/tpCache_nested.gold +3/−3
- SBVTestSuite/GoldFiles/tpCache_recallFail.gold +4/−0
- SBVTestSuite/GoldFiles/tpCache_statsHit.gold +3/−3
- SBVTestSuite/GoldFiles/tpCache_statsMiss.gold +2/−2
- SBVTestSuite/GoldFiles/tpCache_statsNested.gold +4/−4
- SBVTestSuite/TestSuite/Arrays/InitVals.hs +1/−1
- SBVTestSuite/TestSuite/Arrays/Memory.hs +1/−1
- SBVTestSuite/TestSuite/Basics/ArithNoSolver.hs +1/−6
- SBVTestSuite/TestSuite/Basics/ArithNoSolver2.hs +1/−6
- SBVTestSuite/TestSuite/Basics/ArithSolver.hs +1/−6
- SBVTestSuite/TestSuite/Basics/BasicTests.hs +1/−1
- SBVTestSuite/TestSuite/Basics/TPCaching.hs +52/−12
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase17.stderr +2/−2
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase38.stderr +2/−2
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.hs +30/−0
- SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.stderr +24/−0
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase101.stderr +1/−1
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.hs +24/−0
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.stderr +31/−0
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase59.stderr +1/−1
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase66.stderr +1/−1
- SBVTestSuite/TestSuite/CompileTests/SCase/SCase89.stderr +1/−1
- SBVTestSuite/TestSuite/Overflows/Arithmetic.hs +1/−1
- SBVTestSuite/TestSuite/Overflows/Casts.hs +1/−1
- SBVTestSuite/TestSuite/Queries/Tables.hs +1/−1
- SBVTestSuite/TestSuite/QuickCheck/QC.hs +1/−1
- sbv.cabal +4/−7
CHANGES.md view
@@ -1,6 +1,33 @@ * Hackage: <http://hackage.haskell.org/package/sbv> * GitHub: <http://github.com/LeventErkok/sbv> +### Version 14.1, 2026-05-04++ * [BACKWARDS COMPATIBILITY] Removed `tpRibbon`. The ribbon length for TP proof+ output is now auto-computed from the proof structure via a lightweight dry-run+ pass. Users no longer need to manually set it.++ * New TP combinators `whenDryRun` and `unlessDryRun` allow user code to guard+ actions (e.g., proof tree printing) that should only run during the real pass of a TP+ based proof.++ * TP `pCase` now supports nested `case` expressions as proof case-splits,+ mirroring how `sCase` treats nested `case` as symbolic cases.++ * Consolidated internal solver IPC timeouts into named constants.+ Set the environment variable `SBV_COMM_TIMEOUT_FACTOR` to scale them (e.g., `2` to double).++ * Better handling of logic-strings, accommodating solver differences. Thanks to Ryan Scott for the report.++ * Fixed a bug in fpRemH, which calculates the floating point reminder for concrete values. The result+ was rounded twice, which is against the specification. Thanks to Ryan Scott for the report and the fix.++ * Simplify how floating-point literals are printed. The older method worked for Z3/CVC5, but not for Bitwuzla.+ Thanks to Ryan Scott for the report and the fix.++ * Fix the definition of sRealToSIntegerTruncate to do proper truncation. Thanks to Ryan Scott for the+ report and the fix.+ ### Version 14.0, 2026-04-01 * [BACKWARDS COMPATIBILITY] The most important change in this release is how SBV treats@@ -309,7 +336,7 @@ variable or an underscore.) Symbolic-boolean guards allow for concise expressions. This construct makes symbolic programming with ADTs easier. - * Added examples under Documentation.SBV.Examples.ADT, demonstrating the use of basic ADTs and a case study + * Added examples under Documentation.SBV.Examples.ADT, demonstrating the use of basic ADTs and a case study of modeling type-checking constraints. * Added Documentation.SBV.Examples.TP.Peano, modeling peano numbers using an ADT and demonstrating many proofs.@@ -438,7 +465,7 @@ methods/tactics on top of knuckle-dragger provided facilities. ### Version 11.6, 2025-05-10- + * Make SBV compile cleanly with GHC 9.8.4. This is really as far back a GHC you should be using, unless you can't use anything newer.
Data/SBV.hs view
@@ -486,6 +486,8 @@ import Control.Monad (unless) import Control.Monad.Trans (MonadIO) +import qualified Data.Text as T+ import Data.SBV.Core.AlgReals import Data.SBV.Core.Data hiding (free, free_, mkFreeVars, output, symbolic, symbolics, mkSymVal,@@ -905,25 +907,25 @@ allSatPartition "p2" $ y .>= 0 :} Solution #1:- x = 0 :: Integer- y = -1 :: Integer- p1 = True :: Bool- p2 = False :: Bool-Solution #2: x = -1 :: Integer y = 0 :: Integer p1 = False :: Bool p2 = True :: Bool+Solution #2:+ x = 0 :: Integer+ y = 0 :: Integer+ p1 = True :: Bool+ p2 = True :: Bool Solution #3:+ x = 0 :: Integer+ y = -1 :: Integer+ p1 = True :: Bool+ p2 = False :: Bool+Solution #4: x = -1 :: Integer y = -1 :: Integer p1 = False :: Bool p2 = False :: Bool-Solution #4:- x = 0 :: Integer- y = 0 :: Integer- p1 = True :: Bool- p2 = True :: Bool Found 4 different solutions. Without the call to 'allSatPartition' the above example, 'allSat' would return all possible combinations of @x@ and @y@ subject to the constraints. (Since we have none here,@@ -1742,7 +1744,7 @@ sa <- sbvToSV st a sb <- sbvToSV st b - newExpr st KBool $ SBVApp (Uninterpreted nm) [sa, sb]+ newExpr st KBool $ SBVApp (Uninterpreted (T.pack nm)) [sa, sb] -- | Check if the given relation satisfies the required axioms checkSpecialRelation :: forall a. SymVal a => SpecialRelOp -> Relation a -> SBool@@ -1768,8 +1770,8 @@ uop <- newUninterpreted st (UIGiven nm) Nothing (SBVType [ka, ka, KBool]) (UINone True) let nm' = case uop of- Uninterpreted s -> s- _ -> error "Data.SBV: Impossible happened: checkSpecialRelation received: " ++ show op+ Uninterpreted s -> T.unpack s+ _ -> error $ "Data.SBV: Impossible happened: checkSpecialRelation received: " ++ show op -- Add to the end so if we get incremental ones the order doesn't change for old ones! modifyIORef' (rProgInfo st) (\u -> u{progSpecialRels = curSpecialRels ++ [iop]})@@ -1851,6 +1853,6 @@ create = freshVar_ project = getValue- embed = return . literal+ embed = pure . literal {- HLint ignore module "Use import/export shortcut" -}
Data/SBV/Client.hs view
@@ -24,7 +24,7 @@ {-# LANGUAGE FlexibleInstances #-} #endif -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Client ( sbvCheckSolverInstallation@@ -49,9 +49,7 @@ import Data.Ratio import qualified "template-haskell" Language.Haskell.TH as TH-#if MIN_VERSION_template_haskell(2,18,0) import qualified "template-haskell" Language.Haskell.TH.Syntax as TH-#endif import Language.Haskell.TH.ExpandSyns as TH @@ -71,11 +69,11 @@ -- | Check whether the given solver is installed and is ready to go. This call does a -- simple call to the solver to ensure all is well. sbvCheckSolverInstallation :: SMTConfig -> IO Bool-sbvCheckSolverInstallation cfg = check `C.catch` (\(_ :: C.SomeException) -> return False)+sbvCheckSolverInstallation cfg = check `C.catch` (\(_ :: C.SomeException) -> pure False) where check = do ThmResult r <- proveWith cfg $ \x -> sNot (sNot x) .== (x :: SBool) case r of- Unsatisfiable{} -> return True- _ -> return False+ Unsatisfiable{} -> pure True+ _ -> pure False -- | The default configs corresponding to supported SMT solvers defaultSolverConfig :: Solver -> SMTConfig@@ -154,22 +152,14 @@ -- | Add document to a generated declaration for the declaration addDeclDocs :: (TH.Name, String) -> [(TH.Name, String)] -> TH.Q ()-#if MIN_VERSION_template_haskell(2,18,0) addDeclDocs (tnm, ts) cnms = do add True (tnm, ts) mapM_ (add False) cnms where add True (cnm, cs) = TH.addModFinalizer $ TH.putDoc (TH.DeclDoc cnm) $ "Symbolic version of the type t'" ++ cs ++ "'." add False (cnm, cs) = TH.addModFinalizer $ TH.putDoc (TH.DeclDoc cnm) $ "Symbolic version of the constructor v'" ++ cs ++ "'."-#else-addDeclDocs _ _ = pure ()-#endif -- | Add document to a generated function addDoc :: String -> TH.Name -> TH.Q ()-#if MIN_VERSION_template_haskell(2,18,0) addDoc what tnm = TH.addModFinalizer $ TH.putDoc (TH.DeclDoc tnm) what-#else-addDoc _ _ = pure ()-#endif -- | Symbolic version of a type mkSBV :: TH.Type -> TH.Type@@ -290,7 +280,7 @@ concretize (TH.AppT l arg) = TH.AppT (concretize l) (concretize arg) concretize r = r - end <- TH.noBindS [| return () |]+ end <- TH.noBindS [| pure () |] pure $ TH.DoE Nothing $ [TH.NoBindS (TH.AppE (TH.AppE (TH.VarE 'registerKind) (TH.VarE st)) (TH.AppE (TH.VarE 'kindOf) (TH.AppTypeE (TH.ConE 'Proxy) (concretize t))))
Data/SBV/Compilers/C.hs view
@@ -60,11 +60,11 @@ compileToC :: Maybe FilePath -> String -> SBVCodeGen a -> IO a compileToC mbDirName nm f = do (retVal, cfg, bundle) <- compileToC' nm f renderCgPgmBundle mbDirName (cfg, bundle)- return retVal+ pure retVal -- | Lower level version of 'compileToC', producing a t'CgPgmBundle' compileToC' :: String -> SBVCodeGen a -> IO (a, CgConfig, CgPgmBundle)-compileToC' nm f = do rands <- randoms `fmap` newStdGen+compileToC' nm f = do rands <- randoms <$> newStdGen codeGen SBVToC (defaultCgConfig { cgDriverVals = rands }) nm f -- | Create code to generate a library archive (.a) from given symbolic functions. Useful when generating code@@ -80,13 +80,13 @@ compileToCLib :: Maybe FilePath -> String -> [(String, SBVCodeGen a)] -> IO [a] compileToCLib mbDirName libName comps = do (retVal, cfg, pgm) <- compileToCLib' libName comps renderCgPgmBundle mbDirName (cfg, pgm)- return retVal+ pure retVal -- | Lower level version of 'compileToCLib', producing a t'CgPgmBundle' compileToCLib' :: String -> [(String, SBVCodeGen a)] -> IO ([a], CgConfig, CgPgmBundle) compileToCLib' libName comps = do resCfgBundles <- mapM (uncurry compileToC') comps let (finalCfg, finalPgm) = mergeToLib libName [(c, b) | (_, c, b) <- resCfgBundles]- return ([r | (r, _, _) <- resCfgBundles], finalCfg, finalPgm)+ pure ([r | (r, _, _) <- resCfgBundles], finalCfg, finalPgm) --------------------------------------------------------------------------- -- * Implementation@@ -609,7 +609,7 @@ genAssert (msg, cs, sv) = (getNodeId sv, doc) where doc = text "/* ASSERTION:" <+> text msg- $$ maybe empty (vcat . map text) (locInfo (getCallStack `fmap` cs))+ $$ maybe empty (vcat . map text) (locInfo (getCallStack <$> cs)) $$ text " */" $$ text "if" P.<> parens (showSV cfg consts sv) $$ text "{"@@ -764,8 +764,8 @@ p (PseudoBoolean pb) as = handlePB pb as p (OverflowOp o) _ = tbd $ "Overflow operations" ++ show o p (KindCast _ to) [a] = parens (text (show to)) <+> a- p (Uninterpreted s) [] = text "/* Uninterpreted constant */" <+> text s- p (Uninterpreted s) as = text "/* Uninterpreted function */" <+> text s P.<> parens (fsep (punctuate comma as))+ p (Uninterpreted s) [] = text "/* Uninterpreted constant */" <+> text (T.unpack s)+ p (Uninterpreted s) as = text "/* Uninterpreted function */" <+> text (T.unpack s) P.<> parens (fsep (punctuate comma as)) p (Extract i j) [a] = extract i j (hd "Extract" opArgs) a p Join [a, b] = join (let (s1 : s2 : _) = opArgs in (s1, s2, a, b)) p (Rol i) [a] = rotate True i a (hd "Rol" opArgs)
Data/SBV/Compilers/CodeGen.hs view
@@ -9,7 +9,6 @@ -- Code generation utilities ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wall -Werror #-}@@ -58,10 +57,6 @@ import Data.SBV.Provers.Prover(defaultSMTCfg) -#if MIN_VERSION_base(4,11,0)-import Control.Monad.Fail as Fail-#endif- -- | Abstract over code generation for different languages class CgTarget a where targetName :: a -> String@@ -126,9 +121,7 @@ newtype SBVCodeGen a = SBVCodeGen (StateT CgState Symbolic a) deriving ( Applicative, Functor, Monad, MonadIO, MonadState CgState , MonadSymbolic-#if MIN_VERSION_base(4,11,0)- , Fail.MonadFail-#endif+ , MonadFail ) -- | Reach into symbolic monad from code-generation@@ -220,7 +213,7 @@ svCgInput k nm = do r <- symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar (Just ALL)) k Nothing sv <- svToSymSV r modify' (\s -> s { cgInputs = (nm, CgAtomic sv) : cgInputs s })- return r+ pure r -- | Creates an array input in the generated code. svCgInputArr :: Kind -> Int -> String -> SBVCodeGen [SVal]@@ -229,7 +222,7 @@ | True = do rs <- symbolicEnv >>= liftIO . replicateM sz . svMkSymVar (NonQueryVar (Just ALL)) k Nothing sws <- mapM svToSymSV rs modify' (\s -> s { cgInputs = (nm, CgArray sws) : cgInputs s })- return rs+ pure rs -- | Creates an atomic output in the generated code. svCgOutput :: String -> SVal -> SBVCodeGen ()@@ -266,7 +259,7 @@ cgInput nm = do r <- free_ sv <- sbvToSymSV r modify' (\s -> s { cgInputs = (nm, CgAtomic sv) : cgInputs s })- return r+ pure r -- | Creates an array input in the generated code. cgInputArr :: SymVal a => Int -> String -> SBVCodeGen [SBV a]@@ -275,7 +268,7 @@ | True = do rs <- mapM (const free_) [1..sz] sws <- mapM sbvToSymSV rs modify' (\s -> s { cgInputs = (nm, CgArray sws) : cgInputs s })- return rs+ pure rs -- | Creates an atomic output in the generated code. cgOutput :: String -> SBV a -> SBVCodeGen ()@@ -347,7 +340,7 @@ unless (null dupNames) $ error $ "SBV.codeGen: " ++ show nm ++ " has following argument names duplicated: " ++ unwords dupNames - return (retVal, cgFinalConfig st, translate l (cgFinalConfig st) nm st res)+ pure (retVal, cgFinalConfig st, translate l (cgFinalConfig st) nm st res) -- | Render a code-gen bundle to a directory or to stdout renderCgPgmBundle :: Maybe FilePath -> (CgConfig, CgPgmBundle) -> IO ()@@ -361,14 +354,14 @@ dups <- filterM (\fn -> doesFileExist (dirName </> fn)) (map fst files) goOn <- case (overWrite, dups) of- (True, _) -> return True- (_, []) -> return True+ (True, _) -> pure True+ (_, []) -> pure True _ -> do putStrLn $ "Code generation would overwrite the following " ++ (if length dups == 1 then "file:" else "files:") mapM_ (\fn -> putStrLn ('\t' : fn)) dups putStr "Continue? [yn] " hFlush stdout resp <- getLine- return $ map toLower resp `isPrefixOf` "yes"+ pure $ map toLower resp `isPrefixOf` "yes" if goOn then do mapM_ renderFile files unless overWrite $ putStrLn "Done."
Data/SBV/Control/BaseIO.hs view
@@ -21,6 +21,8 @@ import Data.SBV.Core.Data (Symbolic, SymVal, SBool, SBV, SBVType) import Data.SBV.Core.Symbolic (Query, QueryContext, QueryState, State, SMTModel, SMTResult, SV, Name) +import Data.Text (Text)+ import qualified Data.SBV.Control.Query as Trans import qualified Data.SBV.Control.Utils as Trans @@ -401,20 +403,20 @@ -- file redirection is given, the output will go to the file. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.queryDebug'-queryDebug :: [String] -> Query ()+queryDebug :: [Text] -> Query () queryDebug = Trans.queryDebug -- | Send a string to the solver, and return the response -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.ask'-ask :: String -> Query String+ask :: Text -> Query String ask = Trans.ask -- | 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. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.send'-send :: Bool -> String -> Query ()+send :: Bool -> Text -> Query () send = Trans.send -- | Retrieve a responses from the solver until it produces a synchronization tag. We make the tag@@ -506,7 +508,7 @@ -- | Bail out if we don't get what we expected -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.unexpected'-unexpected :: String -> String -> String -> Maybe [String] -> String -> Maybe [String] -> Query a+unexpected :: String -> Text -> String -> Maybe [String] -> String -> Maybe [String] -> Query a unexpected = Trans.unexpected -- | Execute a query.
Data/SBV/Control/Query.hs view
@@ -11,9 +11,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Control.Query ( send, ask, retrieveResponse@@ -54,7 +55,7 @@ import Data.SBV.Control.Types import Data.SBV.Control.Utils -import Data.SBV.Utils.Lib (unBar)+import Data.SBV.Utils.Lib (showText, unBar) import Data.SBV.Utils.PrettyNum (showNegativeNumber) -- | An Assignment of a model binding@@ -79,10 +80,10 @@ serialize :: Bool -> SExpr -> String serialize removeQuotes = go where go (ECon s) = if removeQuotes then unQuote s else s- go (ENum (i, _, _)) = showNegativeNumber i- go (EReal r) = showNegativeNumber r- go (EFloat f) = showNegativeNumber f- go (EDouble d) = showNegativeNumber d+ go (ENum (i, _, _)) = T.unpack (showNegativeNumber i)+ go (EReal r) = T.unpack (showNegativeNumber r)+ go (EFloat f) = T.unpack (showNegativeNumber f)+ go (EDouble d) = T.unpack (showNegativeNumber d) go (EFloatingPoint f) = show f go (EApp [x]) = go x go (EApp ss) = "(" ++ unwords (map go ss) ++ ")"@@ -90,7 +91,7 @@ -- | Generalization of 'Data.SBV.Control.getInfo' getInfo :: (MonadIO m, MonadQuery m) => SMTInfoFlag -> m SMTInfoResponse getInfo flag = do- let cmd = "(get-info " ++ show flag ++ ")"+ let cmd = "(get-info " <> showText flag <> ")" bad = unexpected "getInfo" cmd "a valid get-info response" Nothing isAllStatistics AllStatistics = True@@ -112,17 +113,17 @@ parse r bad $ \pe -> if isAllStat- then return $ Resp_AllStatistics $ grabAllStats pe+ then pure $ Resp_AllStatistics $ grabAllStats pe else case pe of- ECon "unsupported" -> return Resp_Unsupported- EApp [ECon ":assertion-stack-levels", ENum (i, _, _)] -> return $ Resp_AssertionStackLevels i- EApp (ECon ":authors" : ns) -> return $ Resp_Authors (map render ns)- EApp [ECon ":error-behavior", ECon "immediate-exit"] -> return $ Resp_Error ErrorImmediateExit- EApp [ECon ":error-behavior", ECon "continued-execution"] -> return $ Resp_Error ErrorContinuedExecution- EApp (ECon ":name" : o) -> return $ Resp_Name (render (EApp o))- EApp (ECon ":reason-unknown" : o) -> return $ Resp_ReasonUnknown (unk o)- EApp (ECon ":version" : o) -> return $ Resp_Version (render (EApp o))- EApp (ECon s : o) -> return $ Resp_InfoKeyword s (map render o)+ ECon "unsupported" -> pure Resp_Unsupported+ EApp [ECon ":assertion-stack-levels", ENum (i, _, _)] -> pure $ Resp_AssertionStackLevels i+ EApp (ECon ":authors" : ns) -> pure $ Resp_Authors (map render ns)+ EApp [ECon ":error-behavior", ECon "immediate-exit"] -> pure $ Resp_Error ErrorImmediateExit+ EApp [ECon ":error-behavior", ECon "continued-execution"] -> pure $ Resp_Error ErrorContinuedExecution+ EApp (ECon ":name" : o) -> pure $ Resp_Name (render (EApp o))+ EApp (ECon ":reason-unknown" : o) -> pure $ Resp_ReasonUnknown (unk o)+ EApp (ECon ":version" : o) -> pure $ Resp_Version (render (EApp o))+ EApp (ECon s : o) -> pure $ Resp_InfoKeyword s (map render o) _ -> bad r Nothing where render = serialize True@@ -160,33 +161,33 @@ SetInfo{} -> error "Data.SBV.Query: SMTLib does not allow querying value of meta-info!" where askFor sbvName smtLibName continue = do- let cmd = "(get-option " ++ smtLibName ++ ")"+ let cmd = "(get-option " <> T.pack smtLibName <> ")" bad = unexpected ("getOption " ++ sbvName) cmd "a valid option value" Nothing r <- ask cmd - parse r bad $ \case ECon "unsupported" -> return Nothing+ parse r bad $ \case ECon "unsupported" -> pure Nothing e -> continue e (bad r) - string c (ECon s) _ = return $ Just $ c s+ string c (ECon s) _ = pure $ Just $ c s string _ e k = k $ Just ["Expected string, but got: " ++ show (serialize False e)] - bool c (ENum (0, _, True)) _ = return $ Just $ c False- bool c (ENum (1, _, True)) _ = return $ Just $ c True+ bool c (ENum (0, _, True)) _ = pure $ Just $ c False+ bool c (ENum (1, _, True)) _ = pure $ Just $ c True bool _ e k = k $ Just ["Expected boolean, but got: " ++ show (serialize False e)] - integer c (ENum (i, _, _)) _ = return $ Just $ c i+ integer c (ENum (i, _, _)) _ = pure $ Just $ c i integer _ e k = k $ Just ["Expected integer, but got: " ++ show (serialize False e)] -- free format, really- stringList c e _ = return $ Just $ c $ stringsOf e+ stringList c e _ = pure $ Just $ c $ stringsOf e -- | Generalization of 'Data.SBV.Control.getUnknownReason' getUnknownReason :: (MonadIO m, MonadQuery m) => m SMTReasonUnknown getUnknownReason = do ru <- getInfo ReasonUnknown case ru of- Resp_Unsupported -> return $ UnknownOther "Solver responded: Unsupported."- Resp_ReasonUnknown r -> return r+ Resp_Unsupported -> pure $ UnknownOther "Solver responded: Unsupported."+ Resp_ReasonUnknown r -> pure r -- Shouldn't happen, but just in case: _ -> error $ "Unexpected reason value received: " ++ show ru @@ -195,8 +196,8 @@ ensureSat = do cfg <- getConfig cs <- checkSatUsing $ satCmd cfg case cs of- Sat -> return ()- DSat{} -> return ()+ Sat -> pure ()+ DSat{} -> pure () Unk -> do s <- getUnknownReason error $ unlines [ "" , "*** Data.SBV.ensureSat: Solver reported Unknown!"@@ -232,7 +233,7 @@ Unk -> Unknown cfg <$> getUnknownReason where getModelWithObjectives = do objectiveValues <- getObjectiveValues m <- getModel- return m {modelObjectives = objectiveValues}+ pure m {modelObjectives = objectiveValues} -- | Generalization of 'Data.SBV.Control.getIndependentOptResults' getIndependentOptResults :: forall m. (MonadIO m, MonadQuery m) => [String] -> m [(String, SMTResult)]@@ -240,44 +241,44 @@ cs <- checkSat case cs of- Unsat -> getUnsatCoreIfRequested >>= \mbUC -> return [(nm, Unsatisfiable cfg mbUC) | nm <- objNames]+ Unsat -> getUnsatCoreIfRequested >>= \mbUC -> pure [(nm, Unsatisfiable cfg mbUC) | nm <- objNames] Sat -> continue (classifyModel cfg) DSat{} -> continue (classifyModel cfg) Unk -> do ur <- Unknown cfg <$> getUnknownReason- return [(nm, ur) | nm <- objNames]+ pure [(nm, ur) | nm <- objNames] where continue classify = do objectiveValues <- getObjectiveValues nms <- zipWithM getIndependentResult [0..] objNames- return [(n, classify (m {modelObjectives = objectiveValues})) | (n, m) <- nms]+ pure [(n, classify (m {modelObjectives = objectiveValues})) | (n, m) <- nms] getIndependentResult :: Int -> String -> m (String, SMTModel) getIndependentResult i s = do m <- getModelAtIndex (Just i)- return (s, m)+ pure (s, m) -- | Generalization of 'Data.SBV.Control.getParetoOptResults' getParetoOptResults :: (MonadIO m, MonadQuery m) => Maybe Int -> m (Bool, [SMTResult]) getParetoOptResults (Just i)- | i <= 0 = return (True, [])+ | i <= 0 = pure (True, []) getParetoOptResults mbN = do cfg <- getConfig cs <- checkSat case cs of- Unsat -> return (False, [])+ Unsat -> pure (False, []) Sat -> continue (classifyModel cfg) DSat{} -> continue (classifyModel cfg) Unk -> do ur <- getUnknownReason- return (False, [ProofError cfg [show ur] Nothing])+ pure (False, [ProofError cfg [show ur] Nothing]) where continue classify = do m <- getModel (limReached, fronts) <- getParetoFronts (subtract 1 <$> mbN) [m]- return (limReached, reverse (map classify fronts))+ pure (limReached, reverse (map classify fronts)) getParetoFronts :: (MonadIO m, MonadQuery m) => Maybe Int -> [SMTModel] -> m (Bool, [SMTModel])- getParetoFronts (Just i) sofar | i <= 0 = return (True, sofar)+ getParetoFronts (Just i) sofar | i <= 0 = pure (True, sofar) getParetoFronts mbi sofar = do cs <- checkSat let more = getModel >>= \m -> getParetoFronts (subtract 1 <$> mbi) (m : sofar) case cs of- Unsat -> return (False, sofar)+ Unsat -> pure (False, sofar) Sat -> more DSat{} -> more Unk -> more@@ -295,14 +296,14 @@ checkSatAssumingHelper getAssumptions sBools = do -- sigh.. SMT-Lib requires the values to be literals only. So, create proxies. let mkAssumption st = do swsOriginal <- mapM (\sb -> do sv <- sbvToSV st sb- return (sv, sb)) sBools+ pure (sv, sb)) sBools -- drop duplicates and trues let swbs = [p | p@(sv, _) <- nubBy ((==) `on` fst) swsOriginal, sv /= trueSV] -- get a unique proxy name for each uniqueSWBs <- mapM (\(sv, sb) -> do unique <- incrementInternalCounter st- return (sv, (unique, sb))) swbs+ pure (sv, (unique, sb))) swbs let translate (sv, (unique, sb)) = (nm, decls, (proxy, sb)) where nm = show sv@@ -311,13 +312,13 @@ , "(assert (= " ++ proxy ++ " " ++ nm ++ "))" ] - return $ map translate uniqueSWBs+ pure $ map translate uniqueSWBs assumptions <- inNewContext mkAssumption let (origNames, declss, proxyMap) = unzip3 assumptions - let cmd = "(check-sat-assuming (" ++ unwords (map fst proxyMap) ++ "))"+ let cmd = "(check-sat-assuming (" <> T.pack (unwords (map fst proxyMap)) <> "))" bad = unexpected "checkSatAssuming" cmd "one of sat/unsat/unknown" $ Just [ "Make sure you use:" , ""@@ -326,17 +327,17 @@ , "to tell the solver to produce unsat assumptions." ] - mapM_ (send True) $ concat declss+ mapM_ (send True . T.pack) $ concat declss r <- ask cmd let grabUnsat | getAssumptions = do as <- getUnsatAssumptions origNames proxyMap- return (Unsat, Just as)- | True = return (Unsat, Nothing)+ pure (Unsat, Just as)+ | True = pure (Unsat, Nothing) - parse r bad $ \case ECon "sat" -> return (Sat, Nothing)+ parse r bad $ \case ECon "sat" -> pure (Sat, Nothing) ECon "unsat" -> grabUnsat- ECon "unknown" -> return (Unk, Nothing)+ ECon "unknown" -> pure (Unk, Nothing) _ -> bad r Nothing -- | Generalization of 'Data.SBV.Control.getAssertionStackDepth'@@ -352,23 +353,23 @@ let inits = [ "table" ++ show i ++ "_initializer" | i <- [0 .. tCount - 1]] case inits of- [] -> return () -- Nothing to do- [x] -> send True $ "(assert " ++ x ++ ")"- xs -> send True $ "(assert (and " ++ unwords xs ++ "))"+ [] -> pure () -- Nothing to do+ [x] -> send True $ "(assert " <> T.pack x <> ")"+ xs -> send True $ "(assert (and " <> T.pack (unwords xs) <> "))" -- | Generalization of 'Data.SBV.Control.inNewAssertionStack' inNewAssertionStack :: (MonadIO m, MonadQuery m) => m a -> m a inNewAssertionStack q = do push 1 r <- q pop 1- return r+ pure r -- | Generalization of 'Data.SBV.Control.push' push :: (MonadIO m, MonadQuery m) => Int -> m () push i | i <= 0 = error $ "Data.SBV: push requires a strictly positive level argument, received: " ++ show i | True = do depth <- getAssertionStackDepth- send True $ "(push " ++ show i ++ ")"+ send True $ "(push " <> showText i <> ")" modifyQueryState $ \s -> s{queryAssertionStackDepth = depth + i} -- | Generalization of 'Data.SBV.Control.pop'@@ -386,7 +387,7 @@ , "***" , "*** Request this as a feature for the underlying solver!" ]- else do send True $ "(pop " ++ show i ++ ")"+ else do send True $ "(pop " <> showText i <> ")" restoreTablesAndArrays modifyQueryState $ \s -> s{queryAssertionStackDepth = depth - i} where shl 1 = "one level"@@ -398,7 +399,7 @@ go cfg (cases ++ [("Coverage", sNot (sOr (map snd cases)))]) where msg = when printCases . io . putStrLn - go _ [] = return Nothing+ go _ [] = pure Nothing go cfg ((n,c):ncs) = do let notify s = msg $ "Case " ++ n ++ ": " ++ s notify "Starting"@@ -410,15 +411,15 @@ Sat -> do notify "Satisfiable" res <- Satisfiable cfg <$> getModel- return $ Just (n, res)+ pure $ Just (n, res) DSat mbP -> do notify $ "Delta satisfiable" ++ maybe "" (" (precision: " ++) mbP res <- DeltaSat cfg mbP <$> getModel- return $ Just (n, res)+ pure $ Just (n, res) Unk -> do notify "Unknown" res <- Unknown cfg <$> getUnknownReason- return $ Just (n, res)+ pure $ Just (n, res) -- | Generalization of 'Data.SBV.Control.resetAssertions' resetAssertions :: (MonadIO m, MonadQuery m) => m ()@@ -430,7 +431,7 @@ -- | Generalization of 'Data.SBV.Control.echo' echo :: (MonadIO m, MonadQuery m) => String -> m ()-echo s = do let cmd = "(echo \"" ++ concatMap sanitize s ++ "\")"+echo s = do let cmd = "(echo \"" <> T.pack (concatMap sanitize s) <> "\")" -- we send the command, but otherwise ignore the response -- note that 'send True/False' would be incorrect here. 'send True' would@@ -439,7 +440,7 @@ -- and forgets about it immediately. _ <- ask cmd - return ()+ pure () where sanitize '"' = "\"\"" -- quotes need to be duplicated sanitize c = [c] @@ -451,7 +452,7 @@ -- | Generalization of 'Data.SBV.Control.getUnsatCore' getUnsatCore :: (MonadIO m, MonadQuery m) => m [String] getUnsatCore = do- let cmd = "(get-unsat-core)"+ let cmd = "(get-unsat-core)" :: T.Text bad = unexpected "getUnsatCore" cmd "an unsat-core response" $ Just [ "Make sure you use:" , ""@@ -473,7 +474,7 @@ r <- ask cmd parse r bad $ \case- EApp es | Just xs <- mapM fromECon es -> return $ map unBar xs+ EApp es | Just xs <- mapM fromECon es -> pure $ map unBar xs _ -> bad r Nothing -- | Retrieve the unsat core if it was asked for in the configuration@@ -482,12 +483,12 @@ cfg <- getConfig if or [b | ProduceUnsatCores b <- solverSetOptions cfg] then Just <$> getUnsatCore- else return Nothing+ else pure Nothing -- | Generalization of 'Data.SBV.Control.getProof' getProof :: (MonadIO m, MonadQuery m) => m String getProof = do- let cmd = "(get-proof)"+ let cmd = "(get-proof)" :: T.Text bad = unexpected "getProof" cmd "a get-proof response" $ Just [ "Make sure you use:" , ""@@ -502,7 +503,7 @@ -- we only care about the fact that we can parse the output, so the -- result of parsing is ignored.- parse r bad $ \_ -> return r+ parse r bad $ \_ -> pure r -- | Generalization of 'Data.SBV.Control.getInterpolantMathSAT'. Use this version with MathSAT. getInterpolantMathSAT :: (MonadIO m, MonadQuery m) => [String] -> m String@@ -511,7 +512,7 @@ = error "SBV.getInterpolantMathSAT requires at least one marked constraint, received none!" | True = do let bar s = '|' : s ++ "|"- cmd = "(get-interpolant (" ++ unwords (map bar fs) ++ "))"+ cmd = "(get-interpolant (" <> T.pack (unwords (map bar fs)) <> "))" bad = unexpected "getInterpolant" cmd "a get-interpolant response" $ Just [ "Make sure you use:" , ""@@ -524,29 +525,29 @@ r <- ask cmd - parse r bad $ \e -> return $ serialize False e+ parse r bad $ \e -> pure $ serialize False e -- | Generalization of 'Data.SBV.Control.getAbduct'. getAbduct :: (SolverContext m, MonadIO m, MonadQuery m) => Maybe String -> String -> SBool -> m String getAbduct mbGrammar defName b = do s <- inNewContext (`sbvToSV` b)- let cmd = "(get-abduct " ++ defName ++ " " ++ show s ++ fromMaybe "" mbGrammar ++ ")"+ let cmd = "(get-abduct " <> T.pack defName <> " " <> showText s <> T.pack (fromMaybe "" mbGrammar) <> ")" bad = unexpected "getAbduct" cmd "a get-abduct response" Nothing r <- ask cmd - parse r bad $ \e -> return $ serialize False e+ parse r bad $ \e -> pure $ serialize False e -- | Generalization of 'Data.SBV.Control.getAbductNext'. getAbductNext :: (MonadIO m, MonadQuery m) => m String getAbductNext = do- let cmd = "(get-abduct-next)"+ let cmd = "(get-abduct-next)" :: T.Text bad = unexpected "getAbductNext" cmd "a get-abduct-next response" Nothing r <- ask cmd - parse r bad $ \e -> return $ serialize False e+ parse r bad $ \e -> pure $ serialize False e -- | Generalization of 'Data.SBV.Control.getInterpolantZ3'. Use this version with Z3. getInterpolantZ3 :: (MonadIO m, MonadQuery m) => [SBool] -> m String@@ -554,22 +555,22 @@ | length fs < 2 = error $ "SBV.getInterpolantZ3 requires at least two booleans, received: " ++ show fs | True- = do ss <- let fAll [] sofar = return $ reverse sofar+ = do ss <- let fAll [] sofar = pure $ reverse sofar fAll (b:bs) sofar = do sv <- inNewContext (`sbvToSV` b) fAll bs (sv : sofar) in fAll fs [] - let cmd = "(get-interpolant " ++ unwords (map show ss) ++ ")"+ let cmd = "(get-interpolant " <> T.pack (unwords (map show ss)) <> ")" bad = unexpected "getInterpolant" cmd "a get-interpolant response" Nothing r <- ask cmd - parse r bad $ \e -> return $ serialize False e+ parse r bad $ \e -> pure $ serialize False e -- | Generalization of 'Data.SBV.Control.getAssertions' getAssertions :: (MonadIO m, MonadQuery m) => m [String] getAssertions = do- let cmd = "(get-assertions)"+ let cmd = "(get-assertions)" :: T.Text bad = unexpected "getAssertions" cmd "a get-assertions response" $ Just [ "Make sure you use:" , ""@@ -583,13 +584,13 @@ r <- ask cmd parse r bad $ \pe -> case pe of- EApp xs -> return $ map render xs- _ -> return [render pe]+ EApp xs -> pure $ map render xs+ _ -> pure [render pe] -- | Generalization of 'Data.SBV.Control.getAssignment' getAssignment :: (MonadIO m, MonadQuery m) => m [(String, Bool)] getAssignment = do- let cmd = "(get-assignment)"+ let cmd = "(get-assignment)" :: T.Text bad = unexpected "getAssignment" cmd "a get-assignment response" $ Just [ "Make sure you use:" , ""@@ -606,7 +607,7 @@ r <- ask cmd - parse r bad $ \case EApp ps | Just vs <- mapM grab ps -> return vs+ parse r bad $ \case EApp ps | Just vs <- mapM grab ps -> pure vs _ -> bad r Nothing -- | Make an assignment. The type 'Assignment' is abstract, the result is typically passed@@ -636,7 +637,7 @@ QueryState{queryConfig} <- getQueryState inps <- F.toList <$> getTopLevelInputs - let grabValues st = do let extract (Assign s n) = sbvToSV st (SBV s) >>= \sv -> return (sv, n)+ let grabValues st = do let extract (Assign s n) = sbvToSV st (SBV s) >>= \sv -> pure (sv, n) modelAssignment <- mapM extract asgns @@ -687,7 +688,7 @@ , "*** Candidates: " ++ unwords nms ] - return [(findName s, n) | (s, n) <- modelAssignment]+ pure [(findName s, n) | (s, n) <- modelAssignment] assocs <- inNewContext grabValues @@ -697,4 +698,4 @@ , modelUIFuns = [] } - return $ Satisfiable queryConfig m+ pure $ Satisfiable queryConfig m
Data/SBV/Control/Utils.hs view
@@ -16,28 +16,28 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Control.Utils ( io , ask, send, getValue, getFunction , getValueCV, getUICVal, getUIFunCVAssoc, getUnsatAssumptions , SMTFunction(..), getQueryState, modifyQueryState, getConfig, getObjectives, getUIs- , getSBVAssertions, getSBVPgm, getObservables+ , getSBVAssertions, getObservables , checkSat, checkSatUsing, getAllSatResult , inNewContext, freshVar, freshVar_ , getTopLevelInputs, parse, unexpected- , timeout, queryDebug, retrieveResponse, recoverKindedValue, runProofOn, executeQuery+ , timeout, queryDebug, retrieveResponse, runProofOn, executeQuery , startOptimizer, getObjectiveValues, getModel, getModelAtIndex ) where -import Data.List (sortBy, sortOn, partition, groupBy, tails, intercalate, isPrefixOf, isSuffixOf)+import Data.List (sortOn, partition, groupBy, tails, intercalate, isPrefixOf, isSuffixOf) import Data.Char (isPunctuation, isSpace, isDigit) import Data.Function (on)@@ -45,13 +45,13 @@ import Data.Proxy -import qualified Data.Foldable as F (toList)+import qualified Data.Foldable as F (toList, for_) import qualified Data.Map.Strict as Map import qualified Data.Set as Set (empty, fromList, toAscList) import qualified Data.Sequence as S import qualified Data.Text as T -import Control.Monad (join, unless, zipWithM, when, replicateM, forM_)+import Control.Monad (join, unless, zipWithM, when, replicateM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans (lift) import Control.Monad.Reader (runReaderT)@@ -70,7 +70,7 @@ , newExpr, SBVExpr(..), Op(..), FPOp(..), SBV(..) , SolverContext(..), SBool, Objective(..), SolverCapabilities(..), capabilities , Result(..), SMTProblem(..), trueSV, SymVal(..), SBVPgm(..), SMTSolver(..), SBVRunMode(..)- , SBVType(..), forceSVArg, RoundingMode(RoundNearestTiesToEven), (.=>)+ , SBVType(..), forceSVArg, (.=>) , RCSet(..), QuantifiedBool(..), ArrayModel(..), SInfo(..), getSInfo , OptimizeStyle(..), GeneralizedCV(..), ExtCV(..) )@@ -80,9 +80,9 @@ , registerLabel, svMkSymVar, validationRequested , isSafetyCheckingIStage, isSetupIStage, isRunIStage, IStage(..), QueryT(..) , extractSymbolicSimulationState, MonadSymbolic(..)- , UserInputs, getSV, NamedSymVar(..), lookupInput, getUserName'+ , UserInputs, getSV, NamedSymVar(..), lookupInput, getUserName, getUserName' , Name, CnstMap, Inputs(..), ProgInfo(..)- , mustIgnoreVar, newInternalVariable, Penalty(..)+ , mustIgnoreVar, newInternalVariable, Penalty(..), smtLibPgmText ) import Data.SBV.Core.AlgReals (mergeAlgReals, AlgReal(..), RealPoint(..))@@ -98,7 +98,7 @@ ) import Data.SBV.Utils.ExtractIO-import Data.SBV.Utils.Lib (qfsToString, unBar)+import Data.SBV.Utils.Lib (qfsToString, unBar, mapToSortedList, showText) import Data.SBV.Utils.SExpr import Data.SBV.Utils.PrettyNum (cvToSMTLib) @@ -128,7 +128,7 @@ , "*** Hint: Move the call to 'setOption' before the query." ] | True = do State{stCfg} <- contextState- send True $ T.unpack $ setSMTOption stCfg o+ send True $ setSMTOption stCfg o -- | Adding a constraint, possibly with attributes and possibly soft. Only used internally. -- Use 'constrain' and 'namedConstraint' from user programs.@@ -137,7 +137,7 @@ sbvToSV st b) unless (null atts && sv == trueSV) $- send True $ "(" ++ asrt ++ " " ++ T.unpack (addAnnotations atts (T.pack (show sv))) ++ ")"+ send True $ "(" <> T.pack asrt <> " " <> addAnnotations atts (showText sv) <> ")" where asrt | isSoft = "assert-soft" | True = "assert" @@ -150,11 +150,6 @@ getObjectives = do State{rOptGoals} <- queryState io $ reverse <$> readIORef rOptGoals --- | Get the program-getSBVPgm :: (MonadIO m, MonadQuery m) => m SBVPgm-getSBVPgm = do State{spgm} <- queryState- io $ readIORef spgm- -- | Get the assertions put in via 'Data.SBV.sAssert' getSBVAssertions :: (MonadIO m, MonadQuery m) => m [(String, Maybe CallStack, SV)] getSBVAssertions = do State{rAsserts} <- queryState@@ -176,19 +171,17 @@ writeIORef rGlobalConsts allConsts pure (nc, allConsts) - ls <- io $ do let swap (a, b) = (b, a)- cmp (a, _) (b, _) = a `compare` b- arrange (i, (at, rt, es)) = ((i, at, rt), es)+ ls <- io $ do let arrange (i, (at, rt, es)) = ((i, at, rt), es) inps <- reverse <$> readIORef (rNewInps is) ks <- readIORef (rNewKinds is)- tbls <- map arrange . sortBy cmp . map swap . Map.toList <$> readIORef (rNewTbls is)+ tbls <- map arrange . mapToSortedList <$> readIORef (rNewTbls is) uis <- Map.toAscList <$> readIORef (rNewUIs is) as <- readIORef (rNewAsgns is) constraints <- readIORef (rNewConstraints is) - let cnsts = sortBy cmp . map swap . Map.toList $ newConsts+ let cnsts = mapToSortedList newConsts - return $ map T.unpack $ toIncSMTLib cfg progInfo inps ks (allConsts, cnsts) tbls uis as constraints cfg+ pure $ toIncSMTLib cfg progInfo inps ks (allConsts, cnsts) tbls uis as constraints cfg mapM_ (send True) $ mergeSExpr ls @@ -201,7 +194,7 @@ , "*** Data.SBV: Impossible happened: Query context required in a non-query mode." , "Please report this as a bug!" ]- Just qs -> return qs+ Just qs -> pure qs -- | Generalization of 'Data.SBV.Control.modifyQueryState' modifyQueryState :: (MonadIO m, MonadQuery m) => (QueryState -> QueryState) -> m ()@@ -221,7 +214,7 @@ (is, r) <- io $ withNewIncState st act progInfo <- io $ readIORef rProgInfo syncUpSolver progInfo rconstMap is- return r+ pure r -- | Generalization of 'Data.SBV.Control.freshVar_' freshVar_ :: forall a m. (MonadIO m, MonadQuery m, SymVal a) => m (SBV a)@@ -234,31 +227,30 @@ where k = kindOf (Proxy @a) -- | Generalization of 'Data.SBV.Control.queryDebug'-queryDebug :: (MonadIO m, MonadQuery m) => [String] -> m ()+queryDebug :: (MonadIO m, MonadQuery m) => [T.Text] -> m () queryDebug msgs = do QueryState{queryConfig} <- getQueryState io $ do debug queryConfig msgs- -- If we're doing a transcript, record it there too- recordTranscript (transcript queryConfig) (DebugMsg (unlines msgs))+ recordTranscript (transcript queryConfig) (DebugMsg (T.unlines msgs)) -- | We need to track sent asserts/check-sat calls so we can issue an extra check-sat call if needed-trackAsserts :: (MonadIO m, MonadQuery m) => String -> m ()+trackAsserts :: (MonadIO m, MonadQuery m) => T.Text -> m () trackAsserts s | isCheckSat || isAssert = do State{rOutstandingAsserts} <- queryState liftIO $ writeIORef rOutstandingAsserts isAssert | True = pure ()- where trimmedS = dropWhile isSpace s- isCheckSat = "(check-sat" `isPrefixOf` trimmedS- isAssert = "(assert" `isPrefixOf` trimmedS+ where trimmedS = T.dropWhile isSpace s+ isCheckSat = "(check-sat" `T.isPrefixOf` trimmedS+ isAssert = "(assert" `T.isPrefixOf` trimmedS -- | Generalization of 'Data.SBV.Control.ask'-ask :: (MonadIO m, MonadQuery m) => String -> m String+ask :: (MonadIO m, MonadQuery m) => T.Text -> m String ask s = askIgnoring s [] -- | Send a string to the solver, and return the response. Except, if the response -- is one of the "ignore" ones, keep querying.-askIgnoring :: (MonadIO m, MonadQuery m) => String -> [String] -> m String+askIgnoring :: (MonadIO m, MonadQuery m) => T.Text -> [String] -> m String askIgnoring s ignoreList = do trackAsserts s@@ -267,23 +259,23 @@ case queryTimeOutValue of Nothing -> queryDebug ["[SEND] " `alignPlain` s]- Just i -> queryDebug ["[SEND, TimeOut: " ++ showTimeoutValue i ++ "] " `alignPlain` s]+ Just i -> queryDebug ["[SEND, TimeOut: " <> showTimeoutValue i <> "] " `alignPlain` s] r <- io $ queryAsk queryTimeOutValue s- queryDebug ["[RECV] " `alignPlain` r]+ queryDebug ["[RECV] " `alignPlain` T.pack r] let loop currentResponse | currentResponse `notElem` ignoreList- = return currentResponse+ = pure currentResponse | True = do queryDebug ["[WARN] Previous response is explicitly ignored, beware!"] newResponse <- io $ queryRetrieveResponse queryTimeOutValue- queryDebug ["[RECV] " `alignPlain` newResponse]+ queryDebug ["[RECV] " `alignPlain` T.pack newResponse] loop newResponse loop r -- | Generalization of 'Data.SBV.Control.send'-send :: (MonadIO m, MonadQuery m) => Bool -> String -> m ()+send :: (MonadIO m, MonadQuery m) => Bool -> T.Text -> m () send requireSuccess s = do trackAsserts s@@ -297,11 +289,11 @@ ["success"] -> queryDebug ["[GOOD] " `alignPlain` s] _ -> do case queryTimeOutValue of Nothing -> queryDebug ["[FAIL] " `alignPlain` s]- Just i -> queryDebug [("[FAIL, TimeOut: " ++ showTimeoutValue i ++ "] ") `alignPlain` s]+ Just i -> queryDebug ["[FAIL, TimeOut: " <> showTimeoutValue i <> "] " `alignPlain` s] - let cmd = case words (dropWhile (\c -> isSpace c || isPunctuation c) s) of- (c:_) -> c+ let cmd = case T.words (T.dropWhile (\c -> isSpace c || isPunctuation c) s) of+ (c:_) -> T.unpack c _ -> "Command" unexpected cmd s "success" Nothing r Nothing@@ -318,9 +310,9 @@ let synchTag = show $ userTag ++ " (at: " ++ ts ++ ")" cmd = "(echo " ++ synchTag ++ ")" - queryDebug ["[SYNC] Attempting to synchronize with tag: " ++ synchTag]+ queryDebug ["[SYNC] Attempting to synchronize with tag: " <> T.pack synchTag] - send False cmd+ send False (T.pack cmd) QueryState{queryRetrieveResponse} <- getQueryState @@ -331,9 +323,9 @@ -- echo'ed strings, but they don't always do. Accommodate for that -- here, though I wish we didn't have to. if s == synchTag || show s == synchTag- then do queryDebug ["[SYNC] Synchronization achieved using tag: " ++ synchTag]- return $ reverse sofar- else do queryDebug ["[RECV] " `alignPlain` s]+ then do queryDebug ["[SYNC] Synchronization achieved using tag: " <> T.pack synchTag]+ pure $ reverse sofar+ else do queryDebug ["[RECV] " `alignPlain` T.pack s] loop (s : sofar) loop []@@ -386,7 +378,7 @@ ] ++ map (" " ++) (lines (show mdl))) cv <- getValueCV Nothing sv- return $ fromCV cv+ pure $ fromCV cv -- | A class which allows for sexpr-conversion to functions class (HasKind r, SatModel r) => SMTFunction fun a r | fun -> a r where@@ -443,14 +435,14 @@ case S.findIndexR ((== r) . fst) asgns of Nothing -> cantFind uiMap Just i -> case asgns `S.index` i of- (sv, SBVApp (Uninterpreted nm) _) | r == sv -> return nm+ (sv, SBVApp (Uninterpreted nm) _) | r == sv -> pure (T.unpack nm) _ -> cantFind uiMap sexprToFun f (s, e) = do nm <- fst . fst <$> smtFunName f si <- contextState >>= getSInfo mbRes <- case parseSExprFunction e of Just (Left nm') -> case (nm == nm', smtFunDefault f) of- (True, Just v) -> return $ Just ([], v)+ (True, Just v) -> pure $ Just ([], v) _ -> bailOut nm Just (Right v) -> convert si v Nothing -> do mbPVS <- pointWiseExtract nm (smtFunType f)@@ -494,13 +486,13 @@ as = unwords $ map shc args - cmd = "(get-value ((" ++ nm ++ " " ++ as ++ ")))"+ cmd = "(get-value ((" <> T.pack nm <> " " <> T.pack as <> ")))" bad = unexpected "get-value" cmd ("pointwise value of boolean function " ++ nm ++ " on " ++ show as) Nothing r <- ask cmd - parse r bad $ \case EApp [EApp [_, e]] -> return (args, e)+ parse r bad $ \case EApp [EApp [_, e]] -> pure (args, e) _ -> bad r Nothing getBVals :: m [([SExpr], SExpr)]@@ -508,14 +500,14 @@ tryPointWise | not isBoolFunc- = return Nothing+ = pure Nothing | nArgs < 1 = error $ "Data.SBV.pointWiseExtract: Impossible happened, nArgs < 1: " ++ show nArgs ++ " type: " ++ show typ | True = do vs <- getBVals -- Pick the value that will give us the fewer entries let (trues, falses) = partition (\(_, v) -> isTrueSExpr v) vs- return $ Just $ if length trues <= length falses+ pure $ Just $ if length trues <= length falses then (trues, falseSExpr) else (falses, trueSExpr) @@ -844,7 +836,7 @@ => fun -> m (Either (String, (Bool, Maybe [String], SExpr)) ([(a, r)], r)) getFunction f = do ((nm, args), isCurried) <- smtFunName f - let cmd = "(get-value (" ++ nm ++ "))"+ let cmd = "(get-value (" <> T.pack nm <> "))" bad = unexpected "getFunction" cmd "a function value" Nothing r <- ask cmd@@ -854,16 +846,16 @@ parse r bad $ \case EApp [EApp [ECon o, e]] | o == nm -> do mbAssocs <- sexprToFun f (trimFunctionResponse r nm isCurried args, e) case mbAssocs of- Right assocs -> return $ Right assocs+ Right assocs -> pure $ Right assocs Left raw -> do let rawRes = Left (raw, (isCurried, args, e)) mbPVS <- pointWiseExtract nm (smtFunType f) case mbPVS of Just ps -> do rs <- convert si ps case rs of- Just x -> return $ Right x- Nothing -> return rawRes- Nothing -> return rawRes+ Just x -> pure $ Right x+ Nothing -> pure rawRes+ Nothing -> pure rawRes _ -> bad r Nothing where convert si (vs, d) = do ps <- mapM (sexprPoint si) vs pure $ (,) <$> sequenceA ps <*> sexprToVal si d@@ -875,9 +867,9 @@ getValueCVHelper :: (MonadIO m, MonadQuery m) => Maybe Int -> SV -> m CV getValueCVHelper mbi s | s == trueSV- = return trueCV+ = pure trueCV | s == falseSV- = return falseCV+ = pure falseCV | True = extractValue mbi (show s) (kindOf s) @@ -1166,13 +1158,13 @@ else do send True "(set-option :pp.decimal false)" rep1 <- getValueCVHelper mbi s send True "(set-option :pp.decimal true)"- send True $ "(set-option :pp.decimal_precision " ++ show (printRealPrec cfg) ++ ")"+ send True $ "(set-option :pp.decimal_precision " <> showText (printRealPrec cfg) <> ")" rep2 <- getValueCVHelper mbi s let bad = unexpected "getValueCV" "get-value" ("a real-valued binding for " ++ show s) Nothing (show (rep1, rep2)) Nothing case (rep1, rep2) of- (CV KReal (CAlgReal a), CV KReal (CAlgReal b)) -> return $ CV KReal (CAlgReal (mergeAlgReals ("Cannot merge real-values for " ++ show s) a b))+ (CV KReal (CAlgReal a), CV KReal (CAlgReal b)) -> pure $ CV KReal (CAlgReal (mergeAlgReals ("Cannot merge real-values for " ++ show s) a b)) _ -> bad -- | Retrieve value from the solver@@ -1182,7 +1174,7 @@ Nothing -> "" Just i -> " :model_index " ++ show i - cmd = "(get-value (" ++ nm ++ ")" ++ modelIndex ++ ")"+ cmd = "(get-value (" <> T.pack nm <> ")" <> T.pack modelIndex <> ")" bad = unexpected "get-value" cmd ("a value binding for kind: " ++ show k) Nothing @@ -1191,7 +1183,7 @@ si <- queryState >>= getSInfo let recover val = case recoverKindedValue si k val of- Just cv -> return cv+ Just cv -> pure cv Nothing -> bad r Nothing parse r bad $ \case EApp [EApp [ECon v, val]] | v == nm -> recover val@@ -1210,7 +1202,7 @@ Nothing -> "" Just i -> " :model_index " ++ show i - cmd = "(get-value (" ++ nm ++ ")" ++ modelIndex ++ ")"+ cmd = "(get-value (" <> T.pack nm <> ")" <> T.pack modelIndex <> ")" bad = unexpected "get-value" cmd "a function value" Nothing @@ -1241,10 +1233,10 @@ Just sExprs -> pure $ maybe (Left fallBack) Right (convert sExprs) parse r bad $ \case EApp [EApp [ECon o, e]] | o == nm -> case parseSExprFunction e of- Just (Right assocs) | Just res <- convert assocs -> return (Right res)+ Just (Right assocs) | Just res <- convert assocs -> pure (Right res) | True -> tryPointWise - Just (Left nm') | nm == nm', let res = defaultKindedValue rt -> return (Right ([], res))+ Just (Left nm') | nm == nm', let res = defaultKindedValue rt -> pure (Right ([], res)) | True -> bad r Nothing Nothing -> tryPointWise@@ -1258,22 +1250,22 @@ -- | Generalization of 'Data.SBV.Control.checkSatUsing' checkSatUsing :: (MonadIO m, MonadQuery m) => String -> m CheckSatResult-checkSatUsing cmd = do let bad = unexpected "checkSat" cmd "one of sat/unsat/unknown" Nothing+checkSatUsing cmd = do let bad = unexpected "checkSat" (T.pack cmd) "one of sat/unsat/unknown" Nothing -- 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+ r <- askIgnoring (T.pack cmd) ignoreList -- query for the precision if supported let getPrecision = do cfg <- getConfig case supportsDeltaSat (capabilities (solver cfg)) of Nothing -> pure Nothing- Just o -> Just <$> ask o+ Just o -> Just <$> ask (T.pack o) - parse r bad $ \case ECon "sat" -> return Sat- ECon "unsat" -> return Unsat- ECon "unknown" -> return Unk+ parse r bad $ \case ECon "sat" -> pure Sat+ ECon "unsat" -> pure Unsat+ ECon "unknown" -> pure Unk ECon "delta-sat" -> DSat <$> getPrecision _ -> bad r Nothing @@ -1291,7 +1283,7 @@ rObs <- liftIO $ readIORef rObservables -- This intentionally reverses the result; since 'rObs' stores in reversed order- let walk [] !sofar = return sofar+ let walk [] !sofar = pure sofar walk ((n, f, s):os) !sofar = do cv <- getValueCV Nothing s if f cv then walk os ((n, cv) : sofar)@@ -1308,7 +1300,7 @@ prior <- io $ readIORef rUIMap new <- io $ readIORef rIncState >>= readIORef . rNewUIs- return $ Map.toList $ Map.withoutKeys (Map.union prior new) defineSet+ pure $ Map.toList $ Map.withoutKeys (Map.union prior new) defineSet -- | Return all satisfying models. getAllSatResult :: forall m. (MonadIO m, MonadQuery m, SolverContext m) => m AllSatResult@@ -1335,21 +1327,21 @@ -- Functions have at least two kinds in their type and all components must be "interpreted" let allUiFuns = [u | allSatTrackUFs cfg -- config says consider UIFs , u@(nm, (_, _, SBVType as)) <- allUninterpreteds, length as > 1 -- get the function ones- , not (mustIgnoreVar cfg nm) -- make sure they aren't explicitly ignored+ , not (mustIgnoreVar cfg (T.pack nm)) -- make sure they aren't explicitly ignored ] allUiRegs = [u | u@(nm, (_, _, SBVType as)) <- allUninterpreteds, length as == 1 -- non-function ones- , not (mustIgnoreVar cfg nm) -- make sure they aren't explicitly ignored+ , not (mustIgnoreVar cfg (T.pack nm)) -- make sure they aren't explicitly ignored ] -- We can only "allSat" if all component types themselves are interpreted. (Otherwise -- there is no way to reflect back the values to the solver.)- collectAcceptable [] sofar = return sofar+ collectAcceptable [] sofar = pure sofar collectAcceptable ((nm, (_, _, t@(SBVType ats))):rest) sofar | not (any hasUninterpretedSorts ats) = collectAcceptable rest (nm : sofar) | True- = do queryDebug [ "*** SBV.allSat: Uninterpreted function: " ++ nm ++ " :: " ++ show t+ = do queryDebug [ "*** SBV.allSat: Uninterpreted function: " <> T.pack nm <> " :: " <> showText t , "*** Will *not* be used in allSat considerations since its type" , "*** has uninterpreted sorts present." ]@@ -1362,20 +1354,18 @@ -- as cex's tend to get larger unless (null uiFuns) $ let solverCaps = capabilities (solver cfg)- in case supportsFlattenedModels solverCaps of- Nothing -> return ()- Just cmds -> mapM_ (send True) cmds+ in F.for_ (supportsFlattenedModels solverCaps) (mapM_ (send True . T.pack)) let usorts = [s | us@(KADT s _ _) <- Set.toAscList ki, isUninterpreted us] - unless (null usorts) $ queryDebug [ "*** SBV.allSat: Uninterpreted sorts present: " ++ unwords usorts+ unless (null usorts) $ queryDebug [ "*** SBV.allSat: Uninterpreted sorts present: " <> T.pack (unwords usorts) , "*** SBV will use equivalence classes to generate all-satisfying instances." ] -- Drop the things that are not model vars or internal- let mkSVal nm@(getSV -> sv) = (SVal (kindOf sv) (Right (cache (const (return sv)))), nm)+ let mkSVal nm@(getSV -> sv) = (SVal (kindOf sv) (Right (cache (const (pure sv)))), nm) let extractVars :: S.Seq (SVal, NamedSymVar)- extractVars = mkSVal <$> S.filter (not . mustIgnoreVar cfg . getUserName') allModelInputs+ extractVars = mkSVal <$> S.filter (not . mustIgnoreVar cfg . getUserName) allModelInputs vars :: S.Seq (SVal, NamedSymVar) vars = case partitionVars of@@ -1419,7 +1409,7 @@ if isSimple then do let mkVar :: (String, (Bool, Maybe [String], SBVType)) -> IO (SVal, NamedSymVar)- mkVar (nm, (_, _, SBVType [k])) = do sv <- newExpr topState k (SBVApp (Uninterpreted nm) [])+ mkVar (nm, (_, _, SBVType [k])) = do sv <- newExpr topState k (SBVApp (Uninterpreted (T.pack nm)) []) let sval = SVal k $ Right $ cache $ \_ -> pure sv nsv = NamedSymVar sv (T.pack nm) pure (sval, nsv)@@ -1466,7 +1456,7 @@ else case allSatMaxModelCount cfg of Just maxModels | have >= maxModels -> do unless (allSatMaxModelCountReached sofar) $ do- queryDebug ["*** Maximum model count request of " ++ show maxModels ++ " reached, stopping the search."]+ queryDebug ["*** Maximum model count request of " <> showText maxModels <> " reached, stopping the search."] when (allSatPrintAlong cfg) $ io $ putStrLn "Search stopped since model count request was reached." io $ modifyIORef' finalResult $ \(h, s, _, m) -> (h, s{ allSatMaxModelCountReached = True }, True, m) pure Nothing@@ -1475,31 +1465,29 @@ case mbCont of Nothing -> pure () Just cnt -> do- queryDebug ["Fast allSat, Looking for solution " ++ show cnt]+ queryDebug ["Fast allSat, Looking for solution " <> showText cnt] cs <- checkSat case cs of Unsat -> pure () - Unk -> do let m = "Solver returned unknown, terminating query."- queryDebug ["*** " ++ m]- io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedUnknown = True}, True, Just ("[" ++ m ++ "]"))+ Unk -> do queryDebug ["*** Solver returned unknown, terminating query."]+ io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedUnknown = True}, True, Just "[Solver returned unknown, terminating query.]") - DSat _ -> do let m = "Solver returned delta-sat, terminating query."- queryDebug ["*** " ++ m]- io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedDSat = True}, True, Just ("[" ++ m ++ "]"))+ DSat _ -> do queryDebug ["*** Solver returned delta-sat, terminating query."]+ io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedDSat = True}, True, Just "[Solver returned delta-sat, terminating query.]") Sat -> do assocs <- mapM (\(sval, NamedSymVar sv n) -> do !cv <- getValueCV Nothing sv- return (sv, (n, (sval, cv)))) extractVars+ pure (sv, (n, (sval, cv)))) extractVars bindings <- let grab i@(getSV -> sv) = case lookupInput fst sv assocs of- Just (_, (_, (_, cv))) -> return (i, cv)+ Just (_, (_, (_, cv))) -> pure (i, cv) Nothing -> do !cv <- getValueCV Nothing sv- return (i, cv)+ pure (i, cv) in if validationRequested cfg then Just <$> mapM grab allInputs- else return Nothing+ else pure Nothing obsvs <- getObservables @@ -1554,7 +1542,7 @@ send True "(pop 1)" pure r - forM_ [0 .. length terms - 1] $ \i -> do+ F.for_ [0 .. length terms - 1] $ \i -> do sc <- shouldContinue when sc $ do case S.splitAt i terms of (pre, rest@(cur S.:<| _)) -> scope cur pre $ walk False rest@@ -1566,11 +1554,11 @@ where go :: Int -> AllSatResult -> m AllSatResult go !cnt !sofar | Just maxModels <- allSatMaxModelCount cfg, cnt > maxModels- = do queryDebug ["*** Maximum model count request of " ++ show maxModels ++ " reached, stopping the search."]+ = do queryDebug ["*** Maximum model count request of " <> showText maxModels <> " reached, stopping the search."] when (allSatPrintAlong cfg) $ io $ putStrLn "Search stopped since model count request was reached."- return $! sofar { allSatMaxModelCountReached = True }+ pure $! sofar { allSatMaxModelCountReached = True } | True- = do queryDebug ["Looking for solution " ++ show cnt]+ = do queryDebug ["Looking for solution " <> showText cnt] cs <- checkSat @@ -1578,23 +1566,21 @@ case cs of Unsat -> do endMsg Nothing- return sofar+ pure sofar - Unk -> do let m = "Solver returned unknown, terminating query."- queryDebug ["*** " ++ m]- endMsg $ Just $ "[" ++ m ++ "]"- return sofar{ allSatSolverReturnedUnknown = True }+ Unk -> do queryDebug ["*** Solver returned unknown, terminating query."]+ endMsg $ Just "[Solver returned unknown, terminating query.]"+ pure sofar{ allSatSolverReturnedUnknown = True } - DSat _ -> do let m = "Solver returned delta-sat, terminating query."- queryDebug ["*** " ++ m]- endMsg $ Just $ "[" ++ m ++ "]"- return sofar{ allSatSolverReturnedDSat = True }+ DSat _ -> do queryDebug ["*** Solver returned delta-sat, terminating query."]+ endMsg $ Just "[Solver returned delta-sat, terminating query.]"+ pure sofar{ allSatSolverReturnedDSat = True } Sat -> do assocs <- mapM (\(sval, NamedSymVar sv n) -> do !cv <- getValueCV Nothing sv- return (sv, (n, (sval, cv)))) vars+ pure (sv, (n, (sval, cv)))) vars let getUIFun ui@(nm, (isCurried, _, t)) = do cvs <- getUIFunCVAssoc Nothing ui- return (nm, (isCurried, t, cvs))+ pure (nm, (isCurried, t, cvs)) uiFunVals <- mapM getUIFun allUiFuns uiRegVals <- mapM (\ui@(nm, _) -> (nm,) <$> getUICVal Nothing ui) allUiRegs@@ -1602,12 +1588,12 @@ obsvs <- getObservables bindings <- let grab i@(getSV -> sv) = case lookupInput fst sv assocs of- Just (_, (_, (_, cv))) -> return (i, cv)+ Just (_, (_, (_, cv))) -> pure (i, cv) Nothing -> do !cv <- getValueCV Nothing sv- return (i, cv)+ pure (i, cv) in if validationRequested cfg then Just <$> mapM grab allInputs- else return Nothing+ else pure Nothing let model = SMTModel { modelObjectives = [] , modelBindings = F.toList <$> bindings@@ -1618,14 +1604,14 @@ } m = Satisfiable cfg model - (interpreteds, uninterpreteds) = S.partition (not . isUninterpreted . kindOf . fst) (fmap (snd . snd) assocs)+ (interpreteds, uninterpreteds) = S.partition (not . isUninterpreted . kindOf . fst) (snd . snd <$> assocs) interpretedRegUis = filter (not . isUninterpreted . kindOf . snd) uiRegVals interpretedRegUiSVs = [(cvt n (kindOf cv), cv) | (n, cv) <- interpretedRegUis] where cvt :: String -> Kind -> SVal cvt nm k = SVal k $ Right $ cache r- where r st = newExpr st k (SBVApp (Uninterpreted nm) [])+ where r st = newExpr st k (SBVApp (Uninterpreted (T.pack nm)) []) -- For each interpreted variable, figure out the model equivalence -- NB. When the kind is floating, we *have* to be careful, since +/- zero, and NaN's@@ -1657,8 +1643,8 @@ -- For each uninterpreted function, create a disqualifying equation -- We do this rather brute-force, since we need to create a new function -- and do an existential assertion.- uninterpretedReject :: Maybe [String]- uninterpretedFuns :: [String]+ uninterpretedReject :: Maybe [T.Text]+ uninterpretedFuns :: [T.Text] (uninterpretedReject, uninterpretedFuns) = (uiReject, concat defs) where uiReject = case rejects of [] -> Nothing@@ -1690,39 +1676,39 @@ , "*** NB. If this is a use case you'd like SBV to support, please get in touch!" ] mkNotEq (nm, (_, SBVType ts, Right vs)) = (reject, def ++ dif)- where nm' = nm ++ "_model" ++ show cnt+ where nm' = T.pack nm <> "_model" <> showText cnt - reject = nm' ++ "_reject"+ reject = nm' <> "_reject" - -- rounding mode doesn't matter here, just pick one- scv = cvToSMTLib RoundNearestTiesToEven+ -- convert a constant+ scv = cvToSMTLib (ats, rt) = (init ts, last ts) - args = unwords ["(x!" ++ show i ++ " " ++ smtType t ++ ")" | (t, i) <- zip ats [(0::Int)..]]+ args = T.unwords ["(x!" <> showText i <> " " <> smtType t <> ")" | (t, i) <- zip ats [(0::Int)..]] res = smtType rt - params = ["x!" ++ show i | (_, i) <- zip ats [(0::Int)..]]+ params = ["x!" <> showText i | (_, i) <- zip ats [(0::Int)..]] - uparams = unwords params+ uparams = T.unwords params chain (vals, fallThru) = walk vals- where walk [] = [" " ++ scv fallThru ++ replicate (length vals) ')']- walk ((as, r) : rest) = (" (ite " ++ cond as ++ " " ++ scv r) : walk rest+ where walk [] = [" " <> scv fallThru <> T.replicate (length vals) ")"]+ walk ((as, r) : rest) = (" (ite " <> cond as <> " " <> scv r) : walk rest - cond as = "(and " ++ unwords (zipWith eq params as) ++ ")"- eq p a = "(= " ++ p ++ " " ++ scv a ++ ")"+ cond as = "(and " <> T.unwords (zipWith eq params as) <> ")"+ eq p a = "(= " <> p <> " " <> scv a <> ")" - def = ("(define-fun " ++ nm' ++ " (" ++ args ++ ") " ++ res)+ def = ("(define-fun " <> nm' <> " (" <> args <> ") " <> res) : chain vs ++ [")"] - pad = replicate (1 + length nm' - length nm) ' '+ pad = T.replicate (1 + T.length nm' - length nm) " " - dif = [ "(define-fun " ++ reject ++ " () Bool"- , " (exists (" ++ args ++ ")"- , " (distinct (" ++ nm ++ pad ++ uparams ++ ")"- , " (" ++ nm' ++ " " ++ uparams ++ "))))"+ dif = [ "(define-fun " <> reject <> " () Bool"+ , " (exists (" <> args <> ")"+ , " (distinct (" <> T.pack nm <> pad <> uparams <> ")"+ , " (" <> nm' <> " " <> uparams <> "))))" ] eqs = interpretedEqs ++ uninterpretedEqs@@ -1748,36 +1734,37 @@ else do let uiFunRejector = "uiFunRejector_model_" ++ show cnt header = "define-fun " ++ uiFunRejector ++ " () Bool " - defineRejector [] = return ()- defineRejector [x] = send True $ "(" ++ header ++ x ++ ")"- defineRejector (x:xs) = mapM_ (send True) $ mergeSExpr $ ("(" ++ header)- : (" (or " ++ x)- : [" " ++ e | e <- xs]- ++ [" ))"]+ defineRejector [] = pure ()+ defineRejector [x] = send True $ "(" <> T.pack header <> x <> ")"+ defineRejector (x:xs) = mapM_ (send True) $ mergeSExpr+ $ T.pack ("(" ++ header)+ : (" (or " <> x)+ : [" " <> e | e <- xs]+ ++ [" ))"] rejectFuncs <- case uninterpretedReject of- Nothing -> return Nothing+ Nothing -> pure Nothing Just fs -> do mapM_ (send True) $ mergeSExpr uninterpretedFuns defineRejector fs- return $ Just uiFunRejector+ pure $ Just uiFunRejector -- send the disallow clause and the uninterpreted rejector: case (disallow, rejectFuncs) of (Nothing, Nothing) -> pure resultsSoFar (Just d, Nothing) -> do constrain d go (cnt+1) resultsSoFar- (Nothing, Just f) -> do send True $ "(assert " ++ f ++ ")"+ (Nothing, Just f) -> do send True $ "(assert " <> T.pack f <> ")" go (cnt+1) resultsSoFar (Just d, Just f) -> -- This is where it gets ugly. We have an SBV and a string and we need to "or" them. -- But we need a way to force 'd' to be produced. So, go ahead and force it: do constrain $ d .=> d -- NB: Redundant, but it makes sure the corresponding constraint gets shown svd <- io $ svToSV topState (unSBV d)- send True $ "(assert (or " ++ f ++ " " ++ show svd ++ "))"+ send True $ "(assert (or " <> T.pack f <> " " <> showText svd <> "))" go (cnt+1) resultsSoFar -- | Generalization of 'Data.SBV.Control.getUnsatAssumptions' getUnsatAssumptions :: (MonadIO m, MonadQuery m) => [String] -> [(String, a)] -> m [a] getUnsatAssumptions originals proxyMap = do- let cmd = "(get-unsat-assumptions)"+ let cmd = "(get-unsat-assumptions)" :: T.Text bad = unexpected "getUnsatAssumptions" cmd "a list of unsatisfiable assumptions" $ Just [ "Make sure you use:"@@ -1797,13 +1784,13 @@ -- in the original list of assumptions for `check-sat-assuming`. So, we walk over -- and ignore those that weren't in the original list, and put a warning for those -- we couldn't find.- let walk [] sofar = return $ reverse sofar+ let walk [] sofar = pure $ reverse sofar walk (a:as) sofar = case a `lookup` proxyMap of Just v -> walk as (v:sofar) Nothing -> do queryDebug [ "*** In call to 'getUnsatAssumptions'" , "***"- , "*** Unexpected assumption named: " ++ show a- , "*** Was expecting one of : " ++ show originals+ , "*** Unexpected assumption named: " <> showText a+ , "*** Was expecting one of : " <> showText originals , "***" , "*** This can happen if unsat-cores are also enabled. Ignoring." ]@@ -1831,7 +1818,7 @@ timeout n q = do modifyQueryState (\qs -> qs {queryTimeOutValue = Just n}) r <- q modifyQueryState (\qs -> qs {queryTimeOutValue = Nothing})- return r+ pure r -- | Bail out if a parse goes bad parse :: String -> (String -> Maybe [String] -> a) -> (SExpr -> a) -> a@@ -1840,7 +1827,7 @@ Right res -> sCont res -- | Generalization of 'Data.SBV.Control.unexpected'-unexpected :: (MonadIO m, MonadQuery m) => String -> String -> String -> Maybe [String] -> String -> Maybe [String] -> m a+unexpected :: (MonadIO m, MonadQuery m) => String -> T.Text -> String -> Maybe [String] -> String -> Maybe [String] -> m a unexpected ctx sent expected mbHint received mbReason = do -- empty the response channel first extras <- retrieveResponse "terminating upon unexpected response" (Just 5000000)@@ -1848,7 +1835,7 @@ cfg <- getConfig let exc = SBVException { sbvExceptionDescription = "Unexpected response from the solver, context: " ++ ctx- , sbvExceptionSent = Just sent+ , sbvExceptionSent = Just (T.unpack sent) , sbvExceptionExpected = Just expected , sbvExceptionReceived = Just received , sbvExceptionStdOut = Just $ unlines extras@@ -1891,8 +1878,8 @@ -- Make sure the phases match: () <- liftIO $ case (queryContext, rm) of- (QueryInternal, _) -> return () -- no worries, internal- (QueryExternal, SMTMode QueryExternal ISetup _ _) -> return () -- legitimate runSMT call+ (QueryInternal, _) -> pure () -- no worries, internal+ (QueryExternal, SMTMode QueryExternal ISetup _ _) -> pure () -- legitimate runSMT call _ -> invalidQuery rm case rm of@@ -1922,12 +1909,12 @@ checks <- readIORef (rMeasureChecks st) unless (null checks) $ do let nms = map (\(n, _, _) -> n) checks- debug cfg ["[MEASURE] Verifying termination measures for: " ++ intercalate ", " nms]+ debug cfg ["[MEASURE] Verifying termination measures for: " <> T.pack (intercalate ", " nms)] mapM_ (\(nm, isProductive, check) -> do- debug cfg ["[MEASURE] Checking: " ++ nm]+ debug cfg ["[MEASURE] Checking: " <> T.pack nm] check cfg let tag = if isProductive then "productive" else "terminating"- debug cfg ["[MEASURE] Passed (" ++ tag ++ "): " ++ nm]+ debug cfg ["[MEASURE] Passed (" <> tag <> "): " <> T.pack nm] ) checks let SMTProblem{smtLibPgm} = runProofOn rm queryContext [] res@@ -1939,7 +1926,7 @@ let terminateSolver maybeForwardedException = do qs <- readIORef $ rQueryState st case qs of- Nothing -> return ()+ Nothing -> pure () Just QueryState{queryTerminate} -> queryTerminate maybeForwardedException -- If this is an extrnal query and there are objectives, let's add those to the list before we run@@ -1949,14 +1936,14 @@ QueryExternal -> do mbDirs <- startOptimizer cfg Lexicographic case mbDirs of Nothing -> pure ()- Just (_, cmds) -> mapM_ (send True) cmds+ Just (_, cmds) -> mapM_ (send True . T.pack) cmds originalQuery lift $ join $ liftIO $ C.mask $ \restore -> do- r <- restore (extractIO $ join $ liftIO $ backend cfg' st (show pgm) $ extractIO . runReaderT (runQueryT userQuery))+ r <- restore (extractIO $ join $ liftIO $ backend cfg' st (smtLibPgmText pgm) $ extractIO . runReaderT (runQueryT userQuery)) `C.catch` \e -> terminateSolver (Just e) >> C.throwIO (e :: C.SomeException) terminateSolver Nothing- return r+ pure r -- Already in a query, in theory we can just continue, but that causes use-case issues -- so we reject it. TODO: Review if we should actually support this. The issue arises with@@ -2023,7 +2010,7 @@ objectives <- getObjectives if null objectives- then return Nothing+ then pure Nothing else do unless (supportsOptimization (capabilities (solver config))) $ error $ unlines [ "" , "*** Data.SBV: The backend solver " ++ show (name (solver config)) ++ "does not support optimization goals."@@ -2066,7 +2053,7 @@ -- | Just after a check-sat is issued, collect objective values. Used -- internally only, not exposed to the user. getObjectiveValues :: forall m. (MonadIO m, MonadQuery m) => m [(String, GeneralizedCV)]-getObjectiveValues = do let cmd = "(get-objectives)"+getObjectiveValues = do let cmd = "(get-objectives)" :: T.Text bad = unexpected "getObjectiveValues" cmd "a list of objective values" Nothing @@ -2083,13 +2070,13 @@ getObjValue :: SInfo -> (forall a. Maybe [String] -> m a) -> [NamedSymVar] -> SExpr -> m (Maybe (String, GeneralizedCV)) getObjValue si bailOut inputs expr = case expr of- EApp [_] -> return Nothing -- Happens when a soft-assertion has no associated group.+ EApp [_] -> pure Nothing -- Happens when a soft-assertion has no associated group. EApp [ECon nm, v] -> locate nm v -- Regular case _ -> dontUnderstand (show expr) where locate nm v = case listToMaybe [p | p@(NamedSymVar sv _) <- inputs, show sv == nm] of- Nothing -> return Nothing -- Happens when the soft assertion has a group-id that's not one of the input names- Just (NamedSymVar sv actualName) -> grab sv v >>= \val -> return $ Just (T.unpack actualName, val)+ Nothing -> pure Nothing -- Happens when the soft assertion has a group-id that's not one of the input names+ Just (NamedSymVar sv actualName) -> grab sv v >>= \val -> pure $ Just (T.unpack actualName, val) dontUnderstand s = bailOut $ Just [ "Unable to understand solver output." , "While trying to process: " ++ s@@ -2097,19 +2084,19 @@ grab :: SV -> SExpr -> m GeneralizedCV grab s topExpr- | Just v <- recoverKindedValue si k topExpr = return $ RegularCV v+ | Just v <- recoverKindedValue si k topExpr = pure $ RegularCV v | True = ExtendedCV <$> cvt (simplify topExpr) where k = kindOf s -- Convert to an extended expression. Hopefully complete! cvt :: SExpr -> m ExtCV- cvt (ECon "oo") = return $ Infinite k- cvt (ECon "epsilon") = return $ Epsilon k+ cvt (ECon "oo") = pure $ Infinite k+ cvt (ECon "epsilon") = pure $ Epsilon k cvt (EApp [ECon "interval", x, y]) = Interval <$> cvt x <*> cvt y- cvt (ENum (i, _, _)) = return $ BoundedCV $ mkConstCV k i- cvt (EReal r) = return $ BoundedCV $ CV k $ CAlgReal r- cvt (EFloat f) = return $ BoundedCV $ CV k $ CFloat f- cvt (EDouble d) = return $ BoundedCV $ CV k $ CDouble d+ cvt (ENum (i, _, _)) = pure $ BoundedCV $ mkConstCV k i+ cvt (EReal r) = pure $ BoundedCV $ CV k $ CAlgReal r+ cvt (EFloat f) = pure $ BoundedCV $ CV k $ CFloat f+ cvt (EDouble d) = pure $ BoundedCV $ CV k $ CDouble d cvt (EApp [ECon "+", x, y]) = AddExtCV <$> cvt x <*> cvt y cvt (EApp [ECon "*", x, y]) = MulExtCV <$> cvt x <*> cvt y -- Nothing else should show up, hopefully!@@ -2146,39 +2133,37 @@ let name = fst . snd removeSV = snd- prepare = S.unstableSort . S.filter (not . mustIgnoreVar cfg . T.unpack . name)- assocs = fmap removeSV (prepare inputAssocs) <> S.fromList (sortOn fst obsvs)+ prepare = S.unstableSort . S.filter (not . mustIgnoreVar cfg . name)+ assocs = (removeSV <$> prepare inputAssocs) <> S.fromList (sortOn fst obsvs) -- collect UIs, and UI functions if requested- let uiFuns = [ui | ui@(nm, (_, _, SBVType as)) <- uis, length as > 1, allSatTrackUFs cfg, not (mustIgnoreVar cfg nm)] -- functions have at least two things in their type!- uiRegs = [ui | ui@(nm, (_, _, SBVType as)) <- uis, length as == 1, not (mustIgnoreVar cfg nm)]+ let uiFuns = [ui | ui@(nm, (_, _, SBVType as)) <- uis, length as > 1, allSatTrackUFs cfg, not (mustIgnoreVar cfg (T.pack nm))] -- functions have at least two things in their type!+ uiRegs = [ui | ui@(nm, (_, _, SBVType as)) <- uis, length as == 1, not (mustIgnoreVar cfg (T.pack nm))] -- If there are uninterpreted functions, arrange so that z3's pretty-printer flattens things out -- as cex's tend to get larger unless (null uiFuns) $ let solverCaps = capabilities (solver cfg)- in case supportsFlattenedModels solverCaps of- Nothing -> return ()- Just cmds -> mapM_ (send True) cmds+ in F.for_ (supportsFlattenedModels solverCaps) (mapM_ (send True . T.pack)) bindings <- let get i@(getSV -> sv) = case lookupInput fst sv inputAssocs of- Just (_, (_, cv)) -> return (i, cv)+ Just (_, (_, cv)) -> pure (i, cv) Nothing -> do cv <- getValueCV mbi sv- return (i, cv)+ pure (i, cv) in if validationRequested cfg then Just <$> mapM get allModelInputs- else return Nothing+ else pure Nothing uiFunVals <- mapM (\ui@(nm, (c, _, t)) -> (\a -> (nm, (c, t, a))) <$> getUIFunCVAssoc mbi ui) uiFuns uiVals <- mapM (\ui@(nm, (_, _, _)) -> (nm,) <$> getUICVal mbi ui) uiRegs - return $ unBarModel $ SMTModel { modelObjectives = []- , modelBindings = F.toList <$> bindings- , modelAssocs = uiVals ++ F.toList (first T.unpack <$> assocs)- , modelUIFuns = uiFunVals- }+ pure $ unBarModel $ SMTModel { modelObjectives = []+ , modelBindings = F.toList <$> bindings+ , modelAssocs = uiVals ++ F.toList (first T.unpack <$> assocs)+ , modelUIFuns = uiFunVals+ } -- | Remove the bars from model names; these are (mostly!) automatically inserted unBarModel :: SMTModel -> SMTModel@@ -2189,7 +2174,11 @@ , modelUIFuns = ubf <$> modelUIFuns } where ubf (n, a) = (unBar n, a)- ubn (NamedSymVar sv nm, a) = (NamedSymVar sv (T.pack (unBar (T.unpack nm))), a)+ ubn (NamedSymVar sv nm, a) = (NamedSymVar sv (unBarT nm), a)++ unBarT t = case T.uncons t of+ Just ('|', rest) | not (T.null rest) && T.last rest == '|' -> T.init rest+ _ -> t {- HLint ignore module "Reduce duplication" -} {- HLint ignore getAllSatResult "Use forM_" -}
Data/SBV/Core/AlgReals.hs view
@@ -15,7 +15,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.AlgReals ( AlgReal(..)@@ -349,4 +349,4 @@ -- Quickcheck instance instance Arbitrary AlgReal where- arbitrary = AlgRational True `fmap` arbitrary+ arbitrary = AlgRational True <$> arbitrary
Data/SBV/Core/Concrete.hs view
@@ -484,7 +484,7 @@ KSet ek -> do i <- randomIO -- regular or complement l <- randomRIO (0, 100) -- some set upto 100 elements vals <- Set.fromList <$> replicateM l (randomCVal ek)- return $ CSet $ if i then RegularSet vals else ComplementSet vals+ pure $ CSet $ if i then RegularSet vals else ComplementSet vals KTuple ks -> CTuple <$> traverse randomCVal ks @@ -492,7 +492,7 @@ ks <- replicateM l (randomCVal k1) vs <- replicateM l (randomCVal k2) def <- randomCVal k2- return $ CArray $ ArrayModel (zip ks vs) def+ pure $ CArray $ ArrayModel (zip ks vs) def where bounds :: Bool -> Int -> (Integer, Integer) bounds False w = (0, 2^w - 1)
Data/SBV/Core/Data.hs view
@@ -47,11 +47,11 @@ , SBV(..), NodeId(..), mkSymSBV , sbvToSV, sbvToSymSV, forceSVArg , RList(..), RNil, (:>), rlist2list- , SBVs(..), foldlSBVs, mapMSBVs, foldlSymSBVs+ , SBVs(..), mapMSBVs, foldlSymSBVs , SBVExpr(..), newExpr , cache, Cached, uncache, HasKind(..) , Op(..), PBOp(..), FPOp(..), StrOp(..), RegExOp(..), SeqOp(..), RegExp(..), NamedSymVar(..), OvOp(..), getTableIndex- , SBVPgm(..), Symbolic, runSymbolic, State, SInfo(..), getSInfo, getPathCondition, extendPathCondition+ , SBVPgm(..), Symbolic, runSymbolic, State, SInfo(..), getSInfo, getPathCondition , inSMTMode, SBVRunMode(..), Kind(..), Outputtable(..), Result(..) , SolverContext(..), internalConstraint, isCodeGenMode , SBVType(..), newUninterpreted@@ -108,10 +108,6 @@ getPathCondition :: State -> SBool getPathCondition st = SBV (getSValPathCondition st) --- | Extend the path condition with the given test value.-extendPathCondition :: State -> (SBool -> SBool) -> State-extendPathCondition st f = extendSValPathCondition st (unSBV . f . SBV)- -- | The "Symbolic" value. The parameter @a@ is phantom, but is -- extremely important in keeping the user interface strongly typed. newtype SBV a = SBV { unSBV :: SVal }@@ -422,7 +418,7 @@ -- | Map a monadic function over the SBV values in an SBVs sequence in a -- manner similar to 'mapM' for lists mapMSBVs :: Monad m => (forall a. SBV a -> m r) -> SBVs as -> m (RList r)-mapMSBVs f = foldlSBVs (\m arg -> (:>) <$> m <*> f arg) (return RNil)+mapMSBVs f = foldlSBVs (\m arg -> (:>) <$> m <*> f arg) (pure RNil) -- | Fold a function over each SBV value in an SBVs sequence in a manner similar -- to 'foldr' for lists (but backwards because SBVs have cons on the right),@@ -482,7 +478,7 @@ mkQArg :: forall m a. (HasKind a, MonadIO m) => State -> Quantifier -> m (SBV a) mkQArg st q = do let k = kindOf (Proxy @a) sv <- liftIO $ quantVar q st k- pure $ SBV $ SVal k (Right (cache (const (return sv))))+ pure $ SBV $ SVal k (Right (cache (const (pure sv)))) -- | Functions of a single existential instance (SymVal a, Constraint m r) => Constraint m (Exists nm a -> r) where@@ -523,7 +519,7 @@ mkLambda st fn = mkArg >>= mkLambda st . fn where mkArg = do let k = kindOf (Proxy @a) sv <- liftIO $ lambdaVar st k- pure $ SBV $ SVal k (Right (cache (const (return sv))))+ pure $ SBV $ SVal k (Right (cache (const (pure sv)))) -- | A value that can be used as a quantified boolean class QuantifiedBool a where@@ -611,13 +607,13 @@ instance Outputtable (SBV a) where output i = do outputSVal (unSBV i)- return i+ pure i instance Outputtable a => Outputtable [a] where output = mapM output instance Outputtable () where- output = return+ output = pure instance (Outputtable a, Outputtable b) => Outputtable (a, b) where output = mlift2 (,) output output
Data/SBV/Core/Floating.hs view
@@ -18,7 +18,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.Floating ( IEEEFloating(..), IEEEFloatConvertible(..)@@ -382,9 +382,9 @@ -- | Add the converted rounding mode if given as an argument addRM :: State -> Maybe SRoundingMode -> [SV] -> IO [SV]-addRM _ Nothing as = return as+addRM _ Nothing as = pure as addRM st (Just rm) as = do svm <- sbvToSV st rm- return (svm : as)+ pure (svm : as) -- | Lift a 1 arg FP-op lift1 :: SymVal a => FPOp -> Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a@@ -527,12 +527,17 @@ -- and it works as long as you do not have a @NaN@. sFloatAsComparableSWord32 :: SFloat -> SWord32 sFloatAsComparableSWord32 f = ite (fpIsNegativeZero f) (sFloatAsComparableSWord32 0) (fromBitsBE $ sNot sb : ite sb (map sNot rest) rest)- where (sb : rest) = blastBE $ sFloatAsSWord32 f+ where (sb, rest) = case blastBE $ sFloatAsSWord32 f of+ b : bs -> (b, bs)+ [] -> error "sFloatAsComparableSWord32: impossible, blastBE produced empty list" -- | Inverse transformation to 'sFloatAsComparableSWord32'. sComparableSWord32AsSFloat :: SWord32 -> SFloat sComparableSWord32AsSFloat w = sWord32AsSFloat $ ite sb (fromBitsBE $ sFalse : rest) (fromBitsBE $ map sNot allBits)- where allBits@(sb : rest) = blastBE w+ where allBits = blastBE w+ (sb, rest) = case allBits of+ b : bs -> (b, bs)+ [] -> error "sComparableSWord32AsSFloat: impossible, blastBE produced empty list" -- | Convert a double to a comparable 'SWord64'. The trick is to ignore the -- sign of -0, and if it's a negative value flip all the bits, and otherwise@@ -540,13 +545,18 @@ -- and it works as long as you do not have a @NaN@. sDoubleAsComparableSWord64 :: SDouble -> SWord64 sDoubleAsComparableSWord64 d = ite (fpIsNegativeZero d) (sDoubleAsComparableSWord64 0) (fromBitsBE $ sNot sb : ite sb (map sNot rest) rest)- where (sb : rest) = blastBE $ sDoubleAsSWord64 d+ where (sb, rest) = case blastBE $ sDoubleAsSWord64 d of+ b : bs -> (b, bs)+ [] -> error "sDoubleAsComparableSWord64: impossible, blastBE produced empty list" -- | Inverse transformation to 'sDoubleAsComparableSWord64'. Note that this isn't a perfect inverse, since @-0@ maps to @0@ and back to @0@. -- Otherwise, it's faithful: sComparableSWord64AsSDouble :: SWord64 -> SDouble sComparableSWord64AsSDouble w = sWord64AsSDouble $ ite sb (fromBitsBE $ sFalse : rest) (fromBitsBE $ map sNot allBits)- where allBits@(sb : rest) = blastBE w+ where allBits = blastBE w+ (sb, rest) = case allBits of+ b : bs -> (b, bs)+ [] -> error "sComparableSWord64AsSDouble: impossible, blastBE produced empty list" -- | 'Float' instance for 'Metric' goes through the lexicographic ordering on 'Word32'. -- It implicitly makes sure that the value is not @NaN@.@@ -559,12 +569,12 @@ msMinimize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @Float) nm when (nm' /= nm) $ sObserve nm (unSBV o)- addSValOptGoal $ unSBV `fmap` Minimize nm' (toMetricSpace o)+ addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o) msMaximize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @Float) nm when (nm' /= nm) $ sObserve nm (unSBV o)- addSValOptGoal $ unSBV `fmap` Maximize nm' (toMetricSpace o)+ addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o) annotateForMS _ s = "toMetricSpace(" ++ s ++ ")" @@ -579,12 +589,12 @@ msMinimize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @Double) nm when (nm' /= nm) $ sObserve nm (unSBV o)- addSValOptGoal $ unSBV `fmap` Minimize nm' (toMetricSpace o)+ addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o) msMaximize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @Double) nm when (nm' /= nm) $ sObserve nm (unSBV o)- addSValOptGoal $ unSBV `fmap` Maximize nm' (toMetricSpace o)+ addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o) annotateForMS _ s = "toMetricSpace(" ++ s ++ ")" @@ -613,13 +623,18 @@ sFloatingPointAsComparableSWord :: forall eb sb. (ValidFloat eb sb, KnownNat (eb + sb), BVIsNonZero (eb + sb)) => SFloatingPoint eb sb -> SWord (eb + sb) sFloatingPointAsComparableSWord f = ite (fpIsNegativeZero f) posZero (fromBitsBE $ sNot sb : ite sb (map sNot rest) rest) where posZero = sFloatingPointAsComparableSWord (0 :: SFloatingPoint eb sb)- (sb : rest) = blastBE (sFloatingPointAsSWord f :: SWord (eb + sb))+ (sb, rest) = case blastBE (sFloatingPointAsSWord f :: SWord (eb + sb)) of+ b : bs -> (b, bs)+ [] -> error "sFloatingPointAsComparableSWord: impossible, blastBE produced empty list" -- | Inverse transformation to 'sFloatingPointAsComparableSWord'. Note that this isn't a perfect inverse, since @-0@ maps to @0@ and back to @0@. -- Otherwise, it's faithful: sComparableSWordAsSFloatingPoint :: forall eb sb. (KnownNat (eb + sb), BVIsNonZero (eb + sb), ValidFloat eb sb) => SWord (eb + sb) -> SFloatingPoint eb sb sComparableSWordAsSFloatingPoint w = sWordAsSFloatingPoint $ ite signBit (fromBitsBE $ sFalse : rest) (fromBitsBE $ map sNot allBits)- where allBits@(signBit : rest) = blastBE w+ where allBits = blastBE w+ (signBit, rest) = case allBits of+ b : bs -> (b, bs)+ [] -> error "sComparableSWordAsSFloatingPoint: impossible, blastBE produced empty list" -- | Convert a word to an arbitrary float, by reinterpreting the bits of the word as the corresponding bits of the float. sWordAsSFloatingPoint :: forall eb sb. (KnownNat (eb + sb), BVIsNonZero (eb + sb), ValidFloat eb sb) => SWord (eb + sb) -> SFloatingPoint eb sb@@ -653,12 +668,12 @@ msMinimize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @(FloatingPoint eb sb)) nm when (nm' /= nm) $ sObserve nm (unSBV o)- addSValOptGoal $ unSBV `fmap` Minimize nm' (toMetricSpace o)+ addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o) msMaximize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @(FloatingPoint eb sb)) nm when (nm' /= nm) $ sObserve nm (unSBV o)- addSValOptGoal $ unSBV `fmap` Maximize nm' (toMetricSpace o)+ addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o) annotateForMS _ s = "toMetricSpace(" ++ s ++ ")"
Data/SBV/Core/Kind.hs view
@@ -16,6 +16,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}@@ -23,7 +24,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.Kind ( Kind(..), HasKind(..), smtType, hasUninterpretedSorts@@ -57,7 +58,7 @@ import GHC.TypeLits -import Data.SBV.Utils.Lib (isKString)+import Data.SBV.Utils.Lib (isKString, showText) import Data.SBV.Utils.Numeric (RoundingMode) import GHC.Generics@@ -147,23 +148,23 @@ showBaseKind :: Kind -> Text showBaseKind = sh where sh (KVar s) = T.pack s- sh k@KBool = noS (T.pack $ show k)- sh (KBounded False n) = T.pack (pickType n "Word" "WordN ") <> T.pack (show n)- sh (KBounded True n) = T.pack (pickType n "Int" "IntN ") <> T.pack (show n)- sh (KApp s ks) = T.pack $ unwords (s : map (T.unpack . kindParen . sh) ks)- sh k@KUnbounded = noS (T.pack $ show k)- sh k@KReal = noS (T.pack $ show k)- sh k@KADT{} = T.pack $ show k -- Leave user-sorts untouched!- sh k@KFloat = noS (T.pack $ show k)- sh k@KDouble = noS (T.pack $ show k)- sh k@KFP{} = noS (T.pack $ show k)- sh k@KChar = noS (T.pack $ show k)- sh k@KString = noS (T.pack $ show k)- sh KRational = T.pack "Rational"- sh (KList k) = T.pack "[" <> sh k <> T.pack "]"- sh (KSet k) = T.pack "{" <> sh k <> T.pack "}"- sh (KTuple ks) = T.pack "(" <> T.pack (intercalate ", " (map (T.unpack . sh) ks)) <> T.pack ")"- sh (KArray k1 k2) = T.pack "Array " <> kindParen (sh k1) <> T.pack " " <> kindParen (sh k2)+ sh k@KBool = noS (showText k)+ sh (KBounded False n) = T.pack (pickType n "Word" "WordN ") <> showText n+ sh (KBounded True n) = T.pack (pickType n "Int" "IntN ") <> showText n+ sh (KApp s ks) = T.unwords (T.pack s : map (kindParen . sh) ks)+ sh k@KUnbounded = noS (showText k)+ sh k@KReal = noS (showText k)+ sh k@KADT{} = showText k -- Leave user-sorts untouched!+ sh k@KFloat = noS (showText k)+ sh k@KDouble = noS (showText k)+ sh k@KFP{} = noS (showText k)+ sh k@KChar = noS (showText k)+ sh k@KString = noS (showText k)+ sh KRational = "Rational"+ sh (KList k) = "[" <> sh k <> "]"+ sh (KSet k) = "{" <> sh k <> "}"+ sh (KTuple ks) = "(" <> T.intercalate ", " (map sh ks) <> ")"+ sh (KArray k1 k2) = "Array " <> kindParen (sh k1) <> " " <> kindParen (sh k2) -- Drop the initial S if it's there noS s = case T.uncons s of@@ -185,33 +186,26 @@ then T.singleton '(' <> s <> T.singleton ')' else s --- | String version of kindParen for backward compatibility-kindParenStr :: String -> String-kindParenStr s@('[':_) = s-kindParenStr s@('(':_) = s-kindParenStr s | any isSpace s = '(' : s ++ ")"- | True = s- -- | How the type maps to SMT land-smtType :: Kind -> String-smtType (KVar s) = s+smtType :: Kind -> Text+smtType (KVar s) = T.pack s smtType KBool = "Bool"-smtType (KBounded _ sz) = "(_ BitVec " ++ show sz ++ ")"+smtType (KBounded _ sz) = "(_ BitVec " <> showText sz <> ")" smtType KUnbounded = "Int" smtType KReal = "Real" smtType KFloat = "(_ FloatingPoint 8 24)" smtType KDouble = "(_ FloatingPoint 11 53)"-smtType (KFP eb sb) = "(_ FloatingPoint " ++ show eb ++ " " ++ show sb ++ ")"+smtType (KFP eb sb) = "(_ FloatingPoint " <> showText eb <> " " <> showText sb <> ")" smtType KString = "String" smtType KChar = "String"-smtType (KList k) = "(Seq " ++ smtType k ++ ")"-smtType (KSet k) = "(Array " ++ smtType k ++ " Bool)"-smtType (KApp s ks) = kindParenStr $ unwords (s : map smtType ks)-smtType (KADT s pks _) = kindParenStr $ unwords (s : map (smtType . snd) pks)+smtType (KList k) = "(Seq " <> smtType k <> ")"+smtType (KSet k) = "(Array " <> smtType k <> " Bool)"+smtType (KApp s ks) = kindParen $ T.unwords (T.pack s : map smtType ks)+smtType (KADT s pks _) = kindParen $ T.unwords (T.pack s : map (smtType . snd) pks) smtType (KTuple []) = "SBVTuple0"-smtType (KTuple kinds) = "(SBVTuple" ++ show (length kinds) ++ " " ++ unwords (smtType <$> kinds) ++ ")"+smtType (KTuple kinds) = "(SBVTuple" <> showText (length kinds) <> " " <> T.unwords (smtType <$> kinds) <> ")" smtType KRational = "SBVRational"-smtType (KArray k1 k2) = "(Array " ++ smtType k1 ++ " " ++ smtType k2 ++ ")"+smtType (KArray k1 k2) = "(Array " <> smtType k1 <> " " <> smtType k2 <> ")" instance Eq G.DataType where a == b = G.tyconUQname (G.dataTypeName a) == G.tyconUQname (G.dataTypeName b)
Data/SBV/Core/Model.hs view
@@ -20,6 +20,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -27,7 +28,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.Model ( Mergeable(..), Equality(..), EqSymbolic(..), OrdSymbolic(..)@@ -69,7 +70,7 @@ where import Control.Applicative (ZipList(ZipList))-import Control.Monad (when, unless, mplus, replicateM, forM_)+import Control.Monad (when, unless, mplus, replicateM) import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Control.Exception as C@@ -78,10 +79,7 @@ import qualified GHC.Generics as G import GHC.Stack-import GHC.TypeLits-#if MIN_VERSION_base(4,18,0)- hiding(SChar)-#endif+import GHC.TypeLits hiding(SChar) import Data.Array (Array, Ix, elems, bounds, rangeSize) import qualified Data.Array as DA (listArray)@@ -115,9 +113,10 @@ import qualified Test.QuickCheck as QC (quickCheckResult, counterexample) import qualified Test.QuickCheck.Monadic as QC (monadicIO, run, assert, pre, monitor) -import qualified Data.Foldable as F (toList)+import qualified Data.Foldable as F (toList, for_) import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq+import qualified Data.Text as T import Data.SBV.Core.AlgReals import Data.SBV.Core.Sized@@ -434,8 +433,9 @@ instance (SymVal a, SymVal b) => SymVal (a, b) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b))) literal (v1, v2) = mkCVTup 2 (kindOf (Proxy @(a, b))) [toCV v1, toCV v2]- fromCV cv = let ~[v1, v2] = fromCVTup 2 cv- in (fromCV v1, fromCV v2)+ fromCV cv = case fromCVTup 2 cv of+ [v1, v2] -> (fromCV v1, fromCV v2)+ res -> error $ "Data.SBV.SymVal-Tuple2: Unexpected result: " ++ show res minMaxBound = Nothing @@ -443,48 +443,54 @@ instance (SymVal a, SymVal b, SymVal c) => SymVal (a, b, c) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c))) literal (v1, v2, v3) = mkCVTup 3 (kindOf (Proxy @(a, b, c))) [toCV v1, toCV v2, toCV v3]- fromCV cv = let ~[v1, v2, v3] = fromCVTup 3 cv- in (fromCV v1, fromCV v2, fromCV v3)+ fromCV cv = case fromCVTup 3 cv of+ [v1, v2, v3] -> (fromCV v1, fromCV v2, fromCV v3)+ res -> error $ "Data.SBV.SymVal-Tuple3: Unexpected result: " ++ show res minMaxBound = Nothing -- | SymVal for 4-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d) => SymVal (a, b, c, d) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d))) literal (v1, v2, v3, v4) = mkCVTup 4 (kindOf (Proxy @(a, b, c, d))) [toCV v1, toCV v2, toCV v3, toCV v4]- fromCV cv = let ~[v1, v2, v3, v4] = fromCVTup 4 cv- in (fromCV v1, fromCV v2, fromCV v3, fromCV v4)+ fromCV cv = case fromCVTup 4 cv of+ [v1, v2, v3, v4] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4)+ res -> error $ "Data.SBV.SymVal-Tuple4: Unexpected result: " ++ show res minMaxBound = Nothing -- | SymVal for 5-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e) => SymVal (a, b, c, d, e) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e))) literal (v1, v2, v3, v4, v5) = mkCVTup 5 (kindOf (Proxy @(a, b, c, d, e))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5]- fromCV cv = let ~[v1, v2, v3, v4, v5] = fromCVTup 5 cv- in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5)+ fromCV cv = case fromCVTup 5 cv of+ [v1, v2, v3, v4, v5] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5)+ res -> error $ "Data.SBV.SymVal-Tuple5: Unexpected result: " ++ show res minMaxBound = Nothing -- | SymVal for 6-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f) => SymVal (a, b, c, d, e, f) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f))) literal (v1, v2, v3, v4, v5, v6) = mkCVTup 6 (kindOf (Proxy @(a, b, c, d, e, f))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5, toCV v6]- fromCV cv = let ~[v1, v2, v3, v4, v5, v6] = fromCVTup 6 cv- in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6)+ fromCV cv = case fromCVTup 6 cv of+ [v1, v2, v3, v4, v5, v6] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6)+ res -> error $ "Data.SBV.SymVal-Tuple6: Unexpected result: " ++ show res minMaxBound = Nothing -- | SymVal for 7-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g) => SymVal (a, b, c, d, e, f, g) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f, g))) literal (v1, v2, v3, v4, v5, v6, v7) = mkCVTup 7 (kindOf (Proxy @(a, b, c, d, e, f, g))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5, toCV v6, toCV v7]- fromCV cv = let ~[v1, v2, v3, v4, v5, v6, v7] = fromCVTup 7 cv- in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7)+ fromCV cv = case fromCVTup 7 cv of+ [v1, v2, v3, v4, v5, v6, v7] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7)+ res -> error $ "Data.SBV.SymVal-Tuple7: Unexpected result: " ++ show res minMaxBound = Nothing -- | SymVal for 8-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h) => SymVal (a, b, c, d, e, f, g, h) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f, g, h))) literal (v1, v2, v3, v4, v5, v6, v7, v8) = mkCVTup 8 (kindOf (Proxy @(a, b, c, d, e, f, g, h))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5, toCV v6, toCV v7, toCV v8]- fromCV cv = let ~[v1, v2, v3, v4, v5, v6, v7, v8] = fromCVTup 8 cv- in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7, fromCV v8)+ fromCV cv = case fromCVTup 8 cv of+ [v1, v2, v3, v4, v5, v6, v7, v8] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7, fromCV v8)+ res -> error $ "Data.SBV.SymVal-Tuple8: Unexpected result: " ++ show res minMaxBound = Nothing instance IsString SString where@@ -845,7 +851,7 @@ -- | Generalization of 'Data.SBV.solve' solve :: MonadSymbolic m => [SBool] -> m SBool-solve = return . sAnd+solve = pure . sAnd -- | Convert an SReal to an SInteger. That is, it computes the -- largest integer @n@ that satisfies @sIntegerToSReal n <= r@@@ -861,9 +867,10 @@ where y st = do xsv <- sbvToSV st x newExpr st KUnbounded (SBVApp (KindCast KReal KUnbounded) [xsv]) --- | Convert an SReal to an SInteger, truncating version.+-- | Convert an SReal to an SInteger, truncating version. Truncate simply chops of the+-- fractional part, essentially rounding towards zero. sRealToSIntegerTruncate :: SReal -> SInteger-sRealToSIntegerTruncate x = ite (x .< 0) (sRealToSInteger x) (- (sRealToSInteger (- x)))+sRealToSIntegerTruncate x = ite (x .>= 0) (sRealToSInteger x) (- sRealToSInteger (-x)) -- | label: Label the result of an expression. This is essentially a no-op, but useful as it generates a comment in the generated C/SMT-Lib code. -- Note that if the argument is a constant, then the label is dropped completely, per the usual constant folding strategy. Compare this to 'observe'@@ -892,8 +899,8 @@ = SBV $ SVal k $ Right $ cache r where k = kindOf x r st = do xsv <- sbvToSV st (label ("Observing: " ++ m) x)- recordObservable st m (cond . fromCV) xsv- return xsv+ recordObservable st (T.pack m) (cond . fromCV) xsv+ pure xsv -- | Observe the value of an expression, unconditionally. See 'observeIf' for a generalized version. observe :: SymVal a => String -> SBV a -> SBV a@@ -1366,10 +1373,10 @@ let curVerifying = measuresBeingVerified (tpOptions cfg) cfg' = cfg{tpOptions = (tpOptions cfg){measuresBeingVerified = Set.insert funcNm curVerifying}} - debug cfg ["[MEASURE] " ++ funcNm ++ ": verifying with " ++ show (length helpers) ++ " helper(s)"- ++ if Set.null curVerifying then "" else ", already verifying: " ++ show (Set.toList curVerifying)]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": verifying with " <> showText (length helpers) <> " helper(s)"+ <> if Set.null curVerifying then "" else ", already verifying: " <> showText (Set.toList curVerifying)] axioms <- mapM (`runMeasureHelper` cfg') helpers- debug cfg ["[MEASURE] " ++ funcNm ++ ": " ++ show (length axioms) ++ " helper axiom(s) collected, checking measure"]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> showText (length axioms) <> " helper axiom(s) collected, checking measure"] result <- checkMeasure cfg funcNm False info meval axioms let prettyNm = prettyFuncNm funcNm case result of@@ -1417,7 +1424,7 @@ cfgNonNeg = cfgIn{transcript = addSuffix "nonNeg" <$> transcript cfgIn} cfgDecrease = cfgIn{transcript = addSuffix "decrease" <$> transcript cfgIn} barFuncNm = barify funcNm- recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList liAssignments, nm == barFuncNm]+ recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList liAssignments, nm == T.pack barFuncNm] if null recCalls then pure MeasureOK@@ -1494,7 +1501,7 @@ mappedArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs k = kindOf rcSV -- Create the actual function call: f(mapped_args)- actualSV <- newExpr st k (SBVApp (Uninterpreted barFuncNm) mappedArgs)+ actualSV <- newExpr st k (SBVApp (Uninterpreted (T.pack barFuncNm)) mappedArgs) -- Assert fresh_var == f(mapped_args) let freshSVal = SVal k (Right (cache (const (pure freshSV)))) actualSVal = SVal k (Right (cache (const (pure actualSV))))@@ -1542,9 +1549,9 @@ let curVerifying = measuresBeingVerified (tpOptions cfg) cfg' = cfg{tpOptions = (tpOptions cfg){measuresBeingVerified = Set.insert funcNm curVerifying}} - debug cfg ["[MEASURE] " ++ funcNm ++ " (contract): verifying with " ++ show (length helpers) ++ " helper(s)"]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> " (contract): verifying with " <> showText (length helpers) <> " helper(s)"] axioms <- mapM (`runMeasureHelper` cfg') helpers- debug cfg ["[MEASURE] " ++ funcNm ++ " (contract): " ++ show (length axioms) ++ " helper axiom(s) collected, checking measure+contract"]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> " (contract): " <> showText (length axioms) <> " helper axiom(s) collected, checking measure+contract"] result <- checkMeasureWithContract cfg funcNm False info meval ceval axioms let prettyNm = prettyFuncNm funcNm case result of@@ -1587,7 +1594,7 @@ cfgNonNeg = cfgIn{transcript = addSuffix "nonNeg" <$> transcript cfgIn} cfgDecrease = cfgIn{transcript = addSuffix "decrease" <$> transcript cfgIn} barFuncNm = barify funcNm- recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList liAssignments, nm == barFuncNm]+ recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList liAssignments, nm == T.pack barFuncNm] if null recCalls then pure MeasureOK@@ -1658,7 +1665,7 @@ -- with the call's arguments substituted for the formal parameters. -- This gives the solver base-case behavior without assuming totality. let dagList = F.toList liAssignments- liftIO $ forM_ recCalls $ \(rcSV, callArgSVs) -> do+ liftIO $ F.for_ recCalls $ \(rcSV, callArgSVs) -> do let -- Map the call's arguments through svMap to get the fresh session SVs mappedCallArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs -- Build the initial map for the unfolded body: formal params -> call args@@ -1681,11 +1688,11 @@ -- IH contract: for each recursive call, assume the contract holds on its result. -- This is sound because we also prove measure decrease at each call site.- liftIO $ forM_ recCalls $ \(rcSV, callArgSVs) -> do- let mappedArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs- argSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) mappedArgs- freshCallSV = Map.findWithDefault rcSV rcSV svMap- freshResult = SVal (kindOf rcSV) (Right (cache (const (pure freshCallSV))))+ liftIO $ F.for_ recCalls $ \(rcSV, callArgSVs) -> do+ let mappedArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs+ argSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) mappedArgs+ freshCallSV = Map.findWithDefault rcSV rcSV svMap+ freshResult = SVal (kindOf rcSV) (Right (cache (const (pure freshCallSV)))) contractHolds = applyC argSVals freshResult internalConstraint st False [] (unSBV contractHolds) @@ -1734,7 +1741,7 @@ verifyGuardedness :: SMTConfig -> String -> LambdaInfo -> IO () verifyGuardedness cfg funcNm info | isGuardedRecursive (Set.singleton (barify funcNm)) info- = debug cfg ["[MEASURE] " ++ funcNm ++ ": productive (all recursive calls are guarded by constructors)"]+ = debug cfg ["[MEASURE] " <> T.pack funcNm <> ": productive (all recursive calls are guarded by constructors)"] | True = error $ unlines [ ""@@ -1755,7 +1762,7 @@ isGuardedRecursive barFuncNms LambdaInfo{liAssignments} = all isGuarded recCallSVs where dagList = F.toList liAssignments- recCallSVs = [sv | (sv, SBVApp (Uninterpreted nm) _) <- dagList, nm `Set.member` barFuncNms]+ recCallSVs = [sv | (sv, SBVApp (Uninterpreted nm) _) <- dagList, nm `Set.member` Set.map T.pack barFuncNms] -- Build a map from SV to the set of operations that consume it consumers :: Map.Map SV [(SV, Op)]@@ -1823,7 +1830,7 @@ SBV $ SVal KUnbounded $ Right $ cache $ \st -> do ensureADTSizeDefined st sizeName adtKind ctors s <- sbvToSV st (SBV (svs !! i))- newExpr st KUnbounded (SBVApp (Uninterpreted sizeName) [s]), Just i)]+ newExpr st KUnbounded (SBVApp (Uninterpreted (T.pack sizeName)) [s]), Just i)] _ -> [] mkTupleComponent :: Int -> Int -> (Int, Kind) -> [(String, [SVal] -> SInteger, Maybe Int)]@@ -1906,7 +1913,7 @@ defs <- readIORef (rDefns st) unless (Map.member sizeName defs) $ do let argNm = "x"- smtArgType = smtType adtKind+ smtArgType = T.unpack (smtType adtKind) -- Build the SMT-Lib body for the size function body = buildBody ctors@@ -1928,8 +1935,8 @@ smtSum (x:xs) = "(+ " ++ x ++ " " ++ smtSum xs ++ ")" smtSum [] = "0" - paramStr = "((" ++ argNm ++ " " ++ smtArgType ++ "))"- smtDef = SMTDef KUnbounded [sizeName] (Just paramStr) (\n -> replicate n ' ' ++ body)+ paramStr = T.pack $ "((" ++ argNm ++ " " ++ smtArgType ++ "))"+ smtDef = SMTDef KUnbounded [sizeName] (Just paramStr) (\n -> T.pack (replicate n ' ' ++ body)) sbvTy = SBVType [adtKind, KUnbounded] modifyIORef' (rDefns st) (Map.insert sizeName (smtDef, sbvTy))@@ -1955,7 +1962,7 @@ asgns = F.toList liAssignments defMap = Map.fromList asgns - recCalls = [args | (_, SBVApp (Uninterpreted nm) args) <- asgns, nm == barFuncNm]+ recCalls = [args | (_, SBVApp (Uninterpreted nm) args) <- asgns, nm == T.pack barFuncNm] checkCall callArgs | paramIdx < length callArgs = isProperSubTerm (callArgs !! paramIdx)@@ -1974,33 +1981,33 @@ autoGuess :: SMTConfig -> String -> LambdaInfo -> IO (Maybe MeasureEval) autoGuess cfg funcNm info = do let barFuncNm = barify funcNm- recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList (liAssignments info), nm == barFuncNm]+ recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList (liAssignments info), nm == T.pack barFuncNm] allUIs = [(nm, length args) | (_, SBVApp (Uninterpreted nm) args) <- F.toList (liAssignments info)]- debug cfg ["[MEASURE] " ++ funcNm ++ ": barified = " ++ show barFuncNm]- debug cfg ["[MEASURE] " ++ funcNm ++ ": Uninterpreted ops in DAG: " ++ show allUIs]- debug cfg ["[MEASURE] " ++ funcNm ++ ": recursive calls found = " ++ show (length recCalls)]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": barified = " <> showText barFuncNm]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": Uninterpreted ops in DAG: " <> showText allUIs]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": recursive calls found = " <> showText (length recCalls)] go candidates where candidates = guessMeasures (liParams info) go [] = pure Nothing go ((desc, m, mbIdx):ms) = do let skipNonNeg = "sbv.dt.size." `isPrefixOf` desc- debug cfg ["[MEASURE] " ++ funcNm ++ ": trying " ++ desc]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": trying " <> T.pack desc] -- For ADT size measures, try syntactic sub-term check first. -- This avoids calling the solver, which can hang on recursive -- define-fun-rec definitions. result <- case mbIdx of Just idx | isStructurallyDecreasing funcNm info idx -> do- debug cfg ["[MEASURE] " ++ funcNm ++ ": " ++ desc ++ " -> OK (structural recursion)"]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " -> OK (structural recursion)"] pure MeasureOK _ -> checkMeasure cfg funcNm skipNonNeg info m [] case result of- MeasureOK -> do debug cfg ["[MEASURE] " ++ funcNm ++ ": " ++ desc ++ " -> OK"]+ MeasureOK -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " -> OK"] pure (Just m)- MeasureNotNonNeg r -> do debug cfg ["[MEASURE] " ++ funcNm ++ ": " ++ desc ++ " failed non-negativity: " ++ show r]- debug cfg ["[MEASURE] " ++ funcNm ++ ": trying next candidate.."]+ MeasureNotNonNeg r -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " failed non-negativity: " <> showText r]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": trying next candidate.."] go ms- MeasureNotDecreasing r -> do debug cfg ["[MEASURE] " ++ funcNm ++ ": " ++ desc ++ " failed strict decrease: " ++ show r]- debug cfg ["[MEASURE] " ++ funcNm ++ ": trying next candidate.."]+ MeasureNotDecreasing r -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " failed strict decrease: " <> showText r]+ debug cfg ["[MEASURE] " <> T.pack funcNm <> ": trying next candidate.."] go ms -- | Auto-guess a termination measure, or fail with a helpful error message.@@ -2063,9 +2070,9 @@ -- Remove verified members from rFuncLambdaInfos so that subsequent closures -- for the same group (registered by other members) find insufficient infos and skip. modifyIORef' (rFuncLambdaInfos st) (\m -> foldl' (flip Map.delete) m plainMembers)- else do debug cfg ["[MEASURE] " ++ funcNm ++ ": mutual group already verified, skipping"]+ else do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": mutual group already verified, skipping"] modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm)- _ -> do debug cfg ["[MEASURE] " ++ funcNm ++ ": not in a multi-member cycle, skipping mutual check"]+ _ -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": not in a multi-member cycle, skipping mutual check"] modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm) -- | Reject mutual recursion for contract-based functions. Deferred to SCC computation time@@ -2089,7 +2096,7 @@ , "*** Please use smtFunction or smtFunctionWithMeasure for mutual recursion groups." , "" ]- _ -> debug cfg ["[MEASURE] " ++ funcNm ++ ": not in a multi-member cycle, skipping mutual contract check"]+ _ -> debug cfg ["[MEASURE] " <> T.pack funcNm <> ": not in a multi-member cycle, skipping mutual contract check"] -- | Check that all members of a mutual recursion group marked as productive are guarded-recursive, -- considering cross-calls as well as self-calls.@@ -2110,10 +2117,11 @@ if Map.size infos >= 2 then do let barNames = Set.fromList members memberNamesStr = intercalate ", " (map prettyFuncNm plainMembers)- debug cfg ["[MEASURE] Checking mutual productive group: {" ++ memberNamesStr ++ "}"]+ debug cfg ["[MEASURE] Checking mutual productive group: {" <> T.pack memberNamesStr <> "}"] let failed = [(pnm, info) | (pnm, info) <- Map.toList infos, not (isGuardedRecursive barNames info)] case failed of [] -> do debug cfg ["[MEASURE] Mutual productive group: all members are guarded"]+ modifyIORef' (rFuncLambdaInfos st) (\m -> foldl' (flip Map.delete) m plainMembers) _ -> error $ unlines $ [ ""@@ -2127,9 +2135,9 @@ , "*** Every recursive call (self or cross) must be a direct argument to a data constructor." , "" ]- else do debug cfg ["[MEASURE] " ++ funcNm ++ ": mutual productive group already verified, skipping"]+ else do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": mutual productive group already verified, skipping"] modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm)- _ -> do debug cfg ["[MEASURE] " ++ funcNm ++ ": not in a multi-member cycle, skipping mutual productive check"]+ _ -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": not in a multi-member cycle, skipping mutual productive check"] modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm) -- | Check termination for a mutual recursion group. Each function in the group@@ -2141,7 +2149,7 @@ checkMutualGroup cfg members mbMeasure = do let memberNames = Map.keys members memberNamesStr = intercalate ", " (map prettyFuncNm memberNames)- debug cfg ["[MEASURE] Checking mutual recursion group: {" ++ memberNamesStr ++ "}"]+ debug cfg ["[MEASURE] Checking mutual recursion group: {" <> T.pack memberNamesStr <> "}"] -- If a user-provided measure is given, try it first let memberList = Map.toList members@@ -2210,18 +2218,18 @@ where go [] = pure Nothing go ((desc, m, _mbIdx):rest) = do- debug cfg ["[MEASURE] Mutual group: trying measure " ++ desc ++ " for all members"]+ debug cfg ["[MEASURE] Mutual group: trying measure " <> T.pack desc <> " for all members"] -- Try the same measure for all members. Catch exceptions from kind mismatches -- (e.g., applying abs to a list parameter) and treat them as failure. let memberList = [(nm, info) | (nm, info, _) <- memberInfos] result <- C.try $ checkMutualMeasure cfg memberList m case result of- Right True -> do debug cfg ["[MEASURE] Mutual group: measure " ++ desc ++ " works for all members"]+ Right True -> do debug cfg ["[MEASURE] Mutual group: measure " <> T.pack desc <> " works for all members"] pure (Just m)- Right False -> do debug cfg ["[MEASURE] Mutual group: measure " ++ desc ++ " failed, trying next"]+ Right False -> do debug cfg ["[MEASURE] Mutual group: measure " <> T.pack desc <> " failed, trying next"] go rest Left (e :: C.SomeException) -> do- debug cfg ["[MEASURE] Mutual group: measure " ++ desc ++ " incompatible: " ++ show e]+ debug cfg ["[MEASURE] Mutual group: measure " <> T.pack desc <> " incompatible: " <> showText e] go rest -- | Verify that a given measure works for all functions in a mutual recursion group.@@ -2238,7 +2246,7 @@ -- Find all calls to any member of the mutual group let allGroupCalls = [(sv, args) | (sv, SBVApp (Uninterpreted calleeNm) args) <- F.toList liAssignments- , calleeNm `Set.member` groupBarNames+ , calleeNm `Set.member` Set.map T.pack groupBarNames ] if null allGroupCalls@@ -2304,13 +2312,13 @@ pure $ sAnd obligations :: Symbolic SBool) case decResult of ThmResult Unsatisfiable{} -> do- debug cfgIn ["[MEASURE] Mutual group: decrease verified for " ++ funcNm]+ debug cfgIn ["[MEASURE] Mutual group: decrease verified for " <> T.pack funcNm] go rest _ -> do- debug cfgIn ["[MEASURE] Mutual group: decrease failed for " ++ funcNm ++ ": " ++ show decResult]+ debug cfgIn ["[MEASURE] Mutual group: decrease failed for " <> T.pack funcNm <> ": " <> showText decResult] pure False _ -> do- debug cfgIn ["[MEASURE] Mutual group: non-negativity failed for " ++ funcNm]+ debug cfgIn ["[MEASURE] Mutual group: non-negativity failed for " <> T.pack funcNm] pure False -- | Pretty-print a function name: turn @"insert @(SBV Integer -> SBV [Integer])"@ into @"insert :: SBV Integer -> SBV [Integer]"@@@ -2340,7 +2348,7 @@ replayDAG cfg st recFuncNames definedFuncs startMap dag = do let n = length dag let nms = intercalate ", " (map unBar (Set.toList recFuncNames))- debug cfg ["[MEASURE] replayDAG {" ++ nms ++ "}: replaying " ++ show n ++ " node(s)"]+ debug cfg ["[MEASURE] replayDAG {" <> T.pack nms <> "}: replaying " <> showText n <> " node(s)"] go startMap dag where -- Map an SV through the svMap. If it's not found, it's an external captured variable -- (e.g., from a higher-order function's closure). Create a fresh unconstrained variable@@ -2361,9 +2369,9 @@ (mappedArgs, svMap') <- mapArgs svMap args newSV' <- case op of -- For recursive calls (self or mutual), create a fresh uninterpreted value instead of replaying- Uninterpreted nm | nm `Set.member` recFuncNames -> newInternalVariable st (kindOf sv)+ Uninterpreted nm | nm `Set.member` Set.map T.pack recFuncNames -> newInternalVariable st (kindOf sv) -- For calls to other defined functions (e.g., partition), replay properly- Uninterpreted nm | nm `Set.member` definedFuncs -> do+ Uninterpreted nm | nm `Set.member` Set.map T.pack definedFuncs -> do let mappedOp = mapOpSVs (\a -> Map.findWithDefault a a svMap') op newExpr st (kindOf sv) (SBVApp mappedOp mappedArgs) -- For everything else that's Uninterpreted (free functions, sentinels, etc.),@@ -3409,7 +3417,7 @@ -- Quickcheck interface instance (SymVal a, Arbitrary a) => Arbitrary (SBV a) where- arbitrary = literal `fmap` arbitrary+ arbitrary = literal <$> arbitrary -- | Symbolic conditionals are modeled by the 'Mergeable' class, describing -- how to merge the results of an if-then-else call with a symbolic test. SBV@@ -3487,7 +3495,7 @@ | Just mustHold <- unliteral cond = if mustHold then x- else error $ show $ SafeResult ((locInfo . getCallStack) `fmap` cs, msg, Satisfiable defaultSMTCfg (SMTModel [] Nothing [] []))+ else error $ show $ SafeResult (locInfo . getCallStack <$> cs, msg, Satisfiable defaultSMTCfg (SMTModel [] Nothing [] [])) | True = SBV $ SVal k $ Right $ cache r where k = kindOf x@@ -3498,7 +3506,7 @@ mustNeverHappen = pc .&& sNot cond cnd <- sbvToSV st mustNeverHappen addAssertion st cs msg cnd- return xsv+ pure xsv locInfo ps = intercalate ",\n " (map loc ps) where loc (f, sl) = concat [srcLocFile sl, ":", show (srcLocStartLine sl), ":", show (srcLocStartCol sl), ":", f]@@ -3535,7 +3543,7 @@ r st = do sws <- mapM (sbvToSV st) xs swe <- sbvToSV st err if all (== swe) sws -- off-chance that all elts are the same. Note that this also correctly covers the case when list is empty.- then return swe+ then pure swe else do idx <- getTableIndex st kInd kElt sws swi <- sbvToSV st ind let len = length xs@@ -3595,7 +3603,8 @@ symbolicMerge _ _ a b = cannotMerge "'Maybe' values" ("Branches produce different constructors: " ++ show (k a, k b)) "Instead of an option type, try using a valid bit to indicate when a result is valid."- where k Nothing = "Nothing"+ where k :: Maybe a -> String+ k Nothing = "Nothing" k _ = "Just" -- Either@@ -3605,7 +3614,8 @@ symbolicMerge _ _ a b = cannotMerge "'Either' values" ("Branches produce different constructors: " ++ show (k a, k b)) "Consider using a product type by a tag instead."- where k (Left _) = "Left"+ where k :: Either a b -> String+ k (Left _) = "Left" k (Right _) = "Right" -- Arrays@@ -3615,7 +3625,8 @@ | True = cannotMerge "'Array' values" ("Branches produce different ranges: " ++ show (k ba, k bb)) "Consider using SBV's native 'SArray' abstraction."- where [ba, bb] = map bounds [a, b]+ where ba = bounds a+ bb = bounds b k = rangeSize -- Functions@@ -3975,11 +3986,11 @@ sbv2smt a = sbvFun2smt (\(_ :: SBVs RNil) -> a) sbvDefineValue nm mbArgs k =- sbvDefineValueFun nm mbArgs SymValsNil (fmap const k) SBVsNil+ sbvDefineValueFun nm mbArgs SymValsNil (const <$> k) SBVsNil - mkADTConstructor nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTConstructor nm k)) Nothing $ UIFree True in v- mkADTTester nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTTester nm k)) Nothing $ UIFree True in v- mkADTAccessor nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTAccessor nm k)) Nothing $ UIFree True in v+ mkADTConstructor nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTConstructor (T.pack nm) k)) Nothing $ UIFree True in v+ mkADTTester nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTTester (T.pack nm) k)) Nothing $ UIFree True in v+ mkADTAccessor nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTAccessor (T.pack nm) k)) Nothing $ UIFree True in v smtFunctionDef nm msr v = sbvDefineValue (UIGiven (atProxy (Proxy @a) nm)) Nothing $ UIFun (v, \st fk -> do@@ -3988,12 +3999,13 @@ -- Record LambdaInfo for SCC-aware mutual recursion checking modifyIORef' (rFuncLambdaInfos st) (Map.insert funcNm info) let barFuncNm = barify funcNm+ tBarFuncNm = T.pack barFuncNm isSelfRec = any (\(_, SBVApp op _) -> case op of- Uninterpreted n -> n == barFuncNm+ Uninterpreted n -> n == tBarFuncNm _ -> False) (liAssignments info) hasCrossRefs = any (\(_, SBVApp op _) -> case op of- Uninterpreted n -> n /= barFuncNm+ Uninterpreted n -> n /= tBarFuncNm _ -> False) (liAssignments info) case msr of@@ -4005,6 +4017,7 @@ modifyIORef' (rMeasureChecks st) ((funcNm, False, \cfg -> checkMutualFromState cfg funcNm st Nothing) :) pure def+ HasMeasure eval helpers -> do when isSelfRec $ modifyIORef' (rMeasureChecks st)@@ -4013,6 +4026,7 @@ modifyIORef' (rMeasureChecks st) ((funcNm, False, \cfg -> checkMutualFromState cfg funcNm st (Just eval)) :) pure def+ HasContract eval ceval helpers -> do when hasCrossRefs $ modifyIORef' (rMeasureChecks st)@@ -4020,6 +4034,7 @@ modifyIORef' (rMeasureChecks st) ((funcNm, False, \cfg -> verifyMeasureWithContract cfg funcNm info eval ceval helpers) :) pure def+ Productive -> do when isSelfRec $ modifyIORef' (rMeasureChecks st)@@ -4028,8 +4043,9 @@ modifyIORef' (rMeasureChecks st) ((funcNm, True, \cfg -> checkMutualProductiveFromState cfg funcNm st) :) pure def+ Unverified -> do modifyIORef' (rNoTermCheckFunctions st) (Set.insert nm)- debug (stCfg st) ["[MEASURE] " ++ funcNm ++ ": no termination check (smtFunctionNoTermination)"]+ debug (stCfg st) ["[MEASURE] " <> T.pack funcNm <> ": no termination check (smtFunctionNoTermination)"] pure def) @@ -4175,7 +4191,7 @@ = do st <- mkNewState defaultSMTCfg (LambdaGen (Just 0)) s <- lambdaStr st TopLevel (kindOf a) a pure $ intercalate "\n" [ "; Automatically generated by SBV. Do not modify!"- , "; Type: " ++ smtType (kindOf a)+ , "; Type: " ++ T.unpack (smtType (kindOf a)) , show s ] sbvFun2smt fn = defs2smt (\args -> fn args .== fn args)@@ -4207,7 +4223,7 @@ sbvDefineValueFun nm mbArgs insts uiKind args a = sbvDefineValueFun nm mbArgs (SymValsCons insts)- (fmap (\f (SBVsCons xs x) -> f xs x) uiKind) (SBVsCons args a)+ ((\f (SBVsCons xs x) -> f xs x) <$> uiKind) (SBVsCons args a) registerFunction f = do let k = kindOf (Proxy @a) st <- symbolicEnv@@ -4330,7 +4346,7 @@ -- | Generalization of 'Data.SBV.assertWithPenalty' assertWithPenalty :: MonadSymbolic m => String -> SBool -> Penalty -> m ()-assertWithPenalty nm o p = addSValOptGoal $ unSBV `fmap` AssertWithPenalty nm o p+assertWithPenalty nm o p = addSValOptGoal $ unSBV <$> AssertWithPenalty nm o p -- | Class of metrics we can optimize for. Currently, booleans, -- bounded signed/unsigned bit-vectors, unbounded integers,@@ -4366,13 +4382,13 @@ msMinimize :: (MonadSymbolic m, SolverContext m) => String -> SBV a -> m () msMinimize nm o = do let nm' = annotateForMS (Proxy @a) nm when (nm' /= nm) $ sObserve nm (unSBV o)- addSValOptGoal $ unSBV `fmap` Minimize nm' (toMetricSpace o)+ addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o) -- | Maximizing a metric space msMaximize :: (MonadSymbolic m, SolverContext m) => String -> SBV a -> m () msMaximize nm o = do let nm' = annotateForMS (Proxy @a) nm when (nm' /= nm) $ sObserve nm (unSBV o)- addSValOptGoal $ unSBV `fmap` Maximize nm' (toMetricSpace o)+ addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o) -- if MetricSpace is the same, we can give a default definition default toMetricSpace :: (a ~ MetricSpace a) => SBV a -> SBV (MetricSpace a)@@ -4453,7 +4469,7 @@ QC.pre cond unless (r || null modelVals) $ QC.monitor (QC.counterexample (complain modelVals)) QC.assert r- where test = do (r, Result{resTraces=tvals, resObservables=ovals, resConsts=(_, cs), resConstraints=cstrs, resUIConsts=unints}) <- + where test = do (r, Result{resTraces=tvals, resObservables=ovals, resConsts=(_, cs), resConstraints=cstrs, resUIConsts=unints}) <- C.catch (runSymbolic defaultSMTCfg (Concrete Nothing) prop) (\(e :: C.SomeException) -> cantQuickCheck (show e)) @@ -4469,7 +4485,7 @@ case map fst unints of [] -> case unliteral r of Nothing -> cantQuickCheck "The result did not evaluate to a concrete value"- Just b -> return (cond, b, tvals ++ mapMaybe getObservable ovals)+ Just b -> pure (cond, b, tvals ++ mapMaybe getObservable ovals) uis -> cantQuickCheck $ "Uninterpreted constants remain: " ++ unwords uis complain qcInfo = showModel defaultSMTCfg (SMTModel [] Nothing qcInfo [])@@ -4500,14 +4516,14 @@ -- | Quick check an SBV property. Note that a regular @quickCheck@ call will work just as -- well. Use this variant if you want to receive the boolean result. sbvQuickCheck :: Symbolic SBool -> IO Bool-sbvQuickCheck prop = QC.isSuccess `fmap` QC.quickCheckResult prop+sbvQuickCheck prop = QC.isSuccess <$> QC.quickCheckResult prop -- Quickcheck interface on dynamically-typed values. A run-time check -- ensures that the value has boolean type. instance Testable (Symbolic SVal) where property m = property $ do s <- m when (kindOf s /= KBool) $ error "Cannot quickcheck non-boolean value"- return (SBV s :: SBool)+ pure (SBV s :: SBool) -- | Explicit sharing combinator. The SBV library has internal caching/hash-consing mechanisms -- built in, based on Andy Gill's type-safe observable sharing technique (see: <http://ku-fpg.github.io/files/Gill-09-TypeSafeReification.pdf>).@@ -4518,7 +4534,7 @@ slet x f = SBV $ SVal k $ Right $ cache r where k = kindOf (Proxy @b) r st = do xsv <- sbvToSV st x- let xsbv = SBV $ SVal (kindOf x) (Right (cache (const (return xsv))))+ let xsbv = SBV $ SVal (kindOf x) (Right (cache (const (pure xsv)))) res = f xsbv sbvToSV st res @@ -4732,15 +4748,7 @@ -> f -- The higher-order argument. We're very generic here! -> (a -> SBV b) -- The ho-function we're modeling -> a -> SBV b -- The resulting function, that can be used as is, and will be rendered in SMTLib without unfolding-smtHOFunction nm f hof arg = SBV $ SVal (kindOf (Proxy @(SBV b))) $ Right $ cache r- where r st = do SMTLambda lam <- lambdaStr st HigherOrderArg (resKindOf (kindOf (Proxy @f))) f- let uniqLen = firstifyUniqueLen $ stCfg st- uniq = take uniqLen (BC.unpack (B.encode (hash (BC.pack (unwords (words lam))))))- sbvToSV st (smtFunctionDef (atProxy (Proxy @f) nm <> "_" <> uniq) AutoMeasure hof arg)-- -- we get the functions as arrays here, so chase to find the result- resKindOf (KArray _ k) = resKindOf k- resKindOf k = k+smtHOFunction nm f = smtHOFunctionGen nm f AutoMeasure -- | Like 'smtHOFunction', but with an explicit termination measure. Use this when the -- auto-guess measure doesn't work for a higher-order recursive function.@@ -4760,17 +4768,39 @@ -> MeasureOf (a -> SBV b) r -- ^ Termination measure -> (a -> SBV b) -- ^ The ho-function we're modeling -> a -> SBV b -- ^ The resulting function-smtHOFunctionWithMeasure nm f msr hof arg = SBV $ SVal (kindOf (Proxy @(SBV b))) $ Right $ cache r- where r st = do SMTLambda lam <- lambdaStr st HigherOrderArg (resKindOf (kindOf (Proxy @f))) f- let uniqLen = firstifyUniqueLen $ stCfg st- uniq = take uniqLen (BC.unpack (B.encode (hash (BC.pack (unwords (words lam))))))- sbvToSV st (smtFunctionDef (atProxy (Proxy @f) nm <> "_" <> uniq)- (HasMeasure (MeasureEval (applyMeasure @(a -> SBV b) @r msr)) [])- hof arg)+smtHOFunctionWithMeasure nm f msr = smtHOFunctionGen nm f (HasMeasure (MeasureEval (applyMeasure @(a -> SBV b) @r msr)) []) - -- we get the functions as arrays here, so chase to find the result- resKindOf (KArray _ k) = resKindOf k- resKindOf k = k+-- | Common implementation for higher-order SMT function definitions.+smtHOFunctionGen :: forall a b f.+ ( SMTDefinable (a -> SBV b)+ , Lambda Symbolic f+ , Lambda Symbolic (a -> SBV b)+ , HasKind b+ , HasKind f+ , Typeable a+ , Typeable b+ , Typeable f+ ) => String -- ^ prefix to use+ -> f -- ^ The higher-order argument+ -> Measure (a -> SBV b) -- ^ Termination measure+ -> (a -> SBV b) -- ^ The ho-function we're modeling+ -> a -> SBV b -- ^ The resulting function+smtHOFunctionGen nm f measure hof arg = SBV $ SVal (kindOf (Proxy @(SBV b))) $ Right $ cache r+ where r st = do SMTLambda lam <- lambdaStr st HigherOrderArg (arrayResultKind (kindOf (Proxy @f))) f+ let uniq = lambdaFingerprint st (T.unpack lam)+ sbvToSV st (smtFunctionDef (atProxy (Proxy @f) nm <> "_" <> uniq) measure hof arg)++-- | Chase through nested array kinds to find the final result kind. Higher-order+-- arguments are firstified into arrays, so we peel off the array wrappers.+arrayResultKind :: Kind -> Kind+arrayResultKind (KArray _ k) = arrayResultKind k+arrayResultKind k = k++-- | Generate a short fingerprint from a lambda body string, used to give+-- unique names to firstified higher-order function instantiations.+lambdaFingerprint :: State -> String -> String+lambdaFingerprint st lam = take uniqLen (BC.unpack (B.encode (hash (BC.pack (unwords (words lam))))))+ where uniqLen = firstifyUniqueLen $ stCfg st {- HLint ignore module "Reduce duplication" -} {- HLint ignore module "Eta reduce" -}
Data/SBV/Core/Operations.hs view
@@ -932,8 +932,8 @@ -- merge, but simplify for certain boolean cases: case () of- () | swa == swb -> return swa -- if t then a else a ==> a- () | swa == trueSV && swb == falseSV -> return swt -- if t then true else false ==> t+ () | swa == swb -> pure swa -- if t then a else a ==> a+ () | swa == trueSV && swb == falseSV -> pure swt -- if t then true else false ==> t () | swa == falseSV && swb == trueSV -> newExpr st k (SBVApp Not [swt]) -- if t then false else true ==> not t () | swa == trueSV -> newExpr st k (SBVApp Or [swt, swb]) -- if t then true else b ==> t OR b () | swa == falseSV -> do swt' <- newExpr st KBool (SBVApp Not [swt])@@ -969,7 +969,7 @@ r st = do sws <- mapM (svToSV st) xs swe <- svToSV st err if all (== swe) sws -- off-chance that all elts are the same- then return swe+ then pure swe else do idx <- getTableIndex st kInd kElt sws swi <- svToSV st ind let len = length xs@@ -1141,7 +1141,7 @@ | True = Shr adjustedShift <- if kx == ki- then return sw2+ then pure sw2 else newExpr st kx (SBVApp (KindCast ki kx) [sw2]) newExpr st kx (SBVApp op [sw1, adjustedShift])@@ -1369,14 +1369,14 @@ -- | Create a symbolic two argument operation; with shortcut optimizations mkSymOpSC :: (SV -> SV -> Maybe SV) -> Op -> State -> Kind -> SV -> SV -> IO SV-mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) return (shortCut a b)+mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) pure (shortCut a b) -- | Create a symbolic two argument operation; no shortcut optimizations mkSymOp :: Op -> State -> Kind -> SV -> SV -> IO SV mkSymOp = mkSymOpSC (const (const Nothing)) mkSymOp1SC :: (SV -> Maybe SV) -> Op -> State -> Kind -> SV -> IO SV-mkSymOp1SC shortCut op st k a = maybe (newExpr st k (SBVApp op [a])) return (shortCut a)+mkSymOp1SC shortCut op st k a = maybe (newExpr st k (SBVApp op [a])) pure (shortCut a) mkSymOp1 :: Op -> State -> Kind -> SV -> IO SV mkSymOp1 = mkSymOp1SC (const Nothing)@@ -1530,8 +1530,8 @@ newExpr st w32 (SBVApp (IEEEFP (FP_Reinterpret KFloat w32)) [f]) else do n <- newInternalVariable st w32 ysw <- newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret w32 KFloat)) [n])- internalConstraint st False [] $ fVal `svStrongEqual` SVal KFloat (Right (cache (\_ -> return ysw)))- return n+ internalConstraint st False [] $ fVal `svStrongEqual` SVal KFloat (Right (cache (\_ -> pure ysw)))+ pure n svFloatAsSWord32 (SVal k _) = error $ "svFloatAsSWord32: non-float type: " ++ show k -- | Convert an 'Data.SBV.SDouble' to an 'Data.SBV.SWord64', preserving the bit-correspondence. Note that since the@@ -1556,8 +1556,8 @@ newExpr st w64 (SBVApp (IEEEFP (FP_Reinterpret KDouble w64)) [f]) else do n <- newInternalVariable st w64 ysw <- newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret w64 KDouble)) [n])- internalConstraint st False [] $ fVal `svStrongEqual` SVal KDouble (Right (cache (\_ -> return ysw)))- return n+ internalConstraint st False [] $ fVal `svStrongEqual` SVal KDouble (Right (cache (\_ -> pure ysw)))+ pure n svDoubleAsSWord64 (SVal k _) = error $ "svDoubleAsSWord64: non-float type: " ++ show k -- | Convert a float to the word containing the corresponding bit pattern@@ -1575,8 +1575,8 @@ newExpr st kTo (SBVApp (IEEEFP (FP_Reinterpret kFrom kTo)) [f]) else do n <- newInternalVariable st kTo ysw <- newExpr st kFrom (SBVApp (IEEEFP (FP_Reinterpret kTo kFrom)) [n])- internalConstraint st False [] $ fVal `svStrongEqual` SVal kFrom (Right (cache (\_ -> return ysw)))- return n+ internalConstraint st False [] $ fVal `svStrongEqual` SVal kFrom (Right (cache (\_ -> pure ysw)))+ pure n svFloatingPointAsSWord (SVal k _) = error $ "svFloatingPointAsSWord: non-float type: " ++ show k {- HLint ignore svIte "Eta reduce" -}
Data/SBV/Core/Sized.hs view
@@ -217,7 +217,7 @@ -- | Quickcheck instance for WordN instance KnownNat n => Arbitrary (WordN n) where- arbitrary = (WordN . norm . abs) `fmap` arbitrary+ arbitrary = WordN . norm . abs <$> arbitrary where sz = intOfProxy (Proxy @n) norm v | sz == 0 = 0@@ -225,7 +225,7 @@ -- | Quickcheck instance for IntN instance KnownNat n => Arbitrary (IntN n) where- arbitrary = (IntN . norm) `fmap` arbitrary+ arbitrary = IntN . norm <$> arbitrary where sz = intOfProxy (Proxy @n) norm v | sz == 0 = 0
Data/SBV/Core/Symbolic.hs view
@@ -10,7 +10,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -23,29 +22,27 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.Symbolic ( NodeId(..)- , SV(..), swKind, trueSV, falseSV, contextOfSV+ , SV(..), swKind, trueSV, falseSV , Op(..), PBOp(..), OvOp(..), FPOp(..), NROp(..), StrOp(..), RegExOp(..), SeqOp(..), SetOp(..), SpecialRelOp(..), ADTOp(..) , RegExp(..), regExpToSMTString, SMTLambda(..)- , Quantifier(..), needsExistentials, SBVContext(..), globalSBVContext, checkCompatibleContext, VarContext(..)- , SBVType(..), svUninterpreted, svUninterpretedNamedArgs, newUninterpreted, prefixNameToUnique+ , Quantifier(..), needsExistentials, SBVContext(..), globalSBVContext, VarContext(..)+ , SBVType(..), svUninterpreted, svUninterpretedNamedArgs, newUninterpreted , SVal(..) , svMkSymVar, sWordN, sWordN_, sIntN, sIntN_ , svToSV, svToSymSV, forceSVArg , SBVExpr(..), newExpr, isCodeGenMode, isSafetyCheckingIStage, isRunIStage, isSetupIStage , Cached, cache, uncache, modifyState, modifyIncState- , NamedSymVar(..), Name, UserInputs, Inputs(..), getSV, swNodeId, namedNodeId- , addInternInput, addUserInput+ , NamedSymVar(..), Name, UserInputs, Inputs(..), getSV, swNodeId , getUserName', getUserName , lookupInput , getSValPathCondition, extendSValPathCondition , getTableIndex, sObserve@@ -53,12 +50,12 @@ , inSMTMode, SBVRunMode(..), IStage(..), Result(..), ResultInp(..), UICodeKind(..), UIName(..) , registerKind, registerLabel, recordObservable , addAssertion, addNewSMTOption, imposeConstraint, internalConstraint, newInternalVariable, lambdaVar, quantVar- , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension+ , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension, smtLibPgmText , SolverCapabilities(..) , extractSymbolicSimulationState, CnstMap , OptimizeStyle(..), Objective(..), Penalty(..), objectiveName, addSValOptGoal , MonadQuery(..), QueryT(..), Query, QueryState(..), QueryContext(..)- , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), TPOptions(..), SMTEngine, isEmptyModel+ , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), TPOptions(..), SMTEngine , validationRequested, outputSVal, ProgInfo(..), mustIgnoreVar, getRootState , LambdaInfo(..) ) where@@ -73,7 +70,7 @@ import Control.Monad.Trans.Maybe (MaybeT) import Control.Monad.Writer.Strict (MonadWriter) import Data.IORef (IORef, newIORef, readIORef)-import Data.List (intercalate, sortBy, isPrefixOf)+import Data.List (intercalate, isPrefixOf) import Data.Maybe (fromMaybe) import Data.String (IsString(fromString)) @@ -94,7 +91,7 @@ import qualified Data.Generics as G (Data(..)) import qualified Data.Generics.Uniplate.Data as G import qualified Data.IntMap.Strict as IMap (IntMap, empty, lookup, insertWith)-import qualified Data.Map.Strict as Map (Map, empty, toList, lookup, insert, size, notMember, keysSet)+import qualified Data.Map.Strict as Map (Map, empty, toList, lookup, insert, size, keysSet) import qualified Data.Set as Set (Set, empty, toList, insert, member, notMember) import qualified Data.Foldable as F (toList) import qualified Data.Sequence as S (Seq, empty, (|>), lookup, elemIndexL)@@ -108,16 +105,13 @@ import Data.SBV.Core.Concrete import Data.SBV.SMT.SMTLibNames import Data.SBV.Utils.TDiff (Timing)-import Data.SBV.Utils.Lib (stringToQFS, checkObservableName, barify)+import Data.SBV.Utils.Lib (stringToQFS, checkObservableName, barify, mapToSortedList, showText) import Data.SBV.Utils.Numeric (RoundingMode) import Data.Containers.ListUtils (nubOrd) import Data.SBV.Control.Types -#if MIN_VERSION_base(4,11,0)-import Control.Monad.Fail as Fail-#endif -- | Context identifier. 0 is reserved global context newtype SBVContext = SBVContext Int64 deriving (Eq, Ord, G.Data, Show)@@ -155,10 +149,6 @@ data SV = SV !Kind !NodeId deriving G.Data --- | Which context are we using this var at?-contextOfSV :: SV -> SBVContext-contextOfSV (SV _ (NodeId (c, _, _))) = c- -- | For equality, we merely use the lambda-level/node-id instance Eq SV where SV _ n1 == SV _ n2 = n1 == n2@@ -192,7 +182,7 @@ -- to an uninterpreted function are evaluated before called; the semantics of uinterpreted -- functions is necessarily strict; deviating from Haskell's forceSVArg :: SV -> IO ()-forceSVArg (SV k n) = k `seq` n `seq` return ()+forceSVArg (SV k n) = k `seq` n `seq` pure () -- | Constant False as an t'SV'. Note that this value always occupies slot -2 and level 0. falseSV :: SV@@ -233,8 +223,8 @@ | SignExtend Int | LkUp (Int, Kind, Kind, Int) !SV !SV -- (table-index, arg-type, res-type, length of the table) index out-of-bounds-value | KindCast Kind Kind- | Uninterpreted String- | QuantifiedBool String -- When we generate a forall/exists (nested etc.) boolean value. NB. This used to be "QuantifiedBool [Op] String", keeping track of Ops. That turned out to cause memory leaks. So avoid that.+ | Uninterpreted T.Text+ | QuantifiedBool T.Text -- When we generate a forall/exists (nested etc.) boolean value. NB. This used to be "QuantifiedBool [Op] String", keeping track of Ops. That turned out to cause memory leaks. So avoid that. | SpecialRelOp Kind SpecialRelOp -- Generate the equality to the internal operation | Label String -- Essentially no-op; useful for code generation to emit comments. | IEEEFP FPOp -- Floating-point ops, categorized separately@@ -257,9 +247,9 @@ deriving (Eq, Ord, Generic, G.Data, NFData) -- | ADT operations-data ADTOp = ADTConstructor String Kind -- Construct an ADT. Kind is the kind of the resulting ADT- | ADTTester String Kind -- Check if top-level constructor matches. Kind is the kind of the argument- | ADTAccessor String Kind -- Extract a field from an ADT value. Kind is the kind of the argument+data ADTOp = ADTConstructor T.Text Kind -- Construct an ADT. Kind is the kind of the resulting ADT+ | ADTTester T.Text Kind -- Check if top-level constructor matches. Kind is the kind of the argument+ | ADTAccessor T.Text Kind -- Extract a field from an ADT value. Kind is the kind of the argument deriving (Eq, Ord, Generic, G.Data, NFData) -- | Special relations supported by z3@@ -458,37 +448,37 @@ -- | Convert a reg-exp to a Haskell-like string instance Show RegExp where- show = regExpToString show+ show = T.unpack . regExpToText (T.pack . show) -- | Convert a reg-exp to a SMT-lib acceptable representation-regExpToSMTString :: RegExp -> String-regExpToSMTString = regExpToString (\s -> '"' : stringToQFS s ++ "\"")+regExpToSMTString :: RegExp -> Text+regExpToSMTString = regExpToText (\s -> "\"" <> T.pack (stringToQFS s) <> "\"") --- | Convert a RegExp to a string, parameterized by how strings are converted-regExpToString :: (String -> String) -> RegExp -> String-regExpToString fs (Literal s) = "(str.to.re " ++ fs s ++ ")"-regExpToString _ All = "re.all"-regExpToString _ AllChar = "re.allchar"-regExpToString _ None = "re.nostr"-regExpToString fs (Range ch1 ch2) = "(re.range " ++ fs [ch1] ++ " " ++ fs [ch2] ++ ")"-regExpToString _ (Conc []) = show (1 :: Integer)-regExpToString fs (Conc [x]) = regExpToString fs x-regExpToString fs (Conc xs) = "(re.++ " ++ unwords (map (regExpToString fs) xs) ++ ")"-regExpToString fs (KStar r) = "(re.* " ++ regExpToString fs r ++ ")"-regExpToString fs (KPlus r) = "(re.+ " ++ regExpToString fs r ++ ")"-regExpToString fs (Opt r) = "(re.opt " ++ regExpToString fs r ++ ")"-regExpToString fs (Comp r) = "(re.comp " ++ regExpToString fs r ++ ")"-regExpToString fs (Diff r1 r2) = "(re.diff " ++ regExpToString fs r1 ++ " " ++ regExpToString fs r2 ++ ")"-regExpToString fs (Loop lo hi r)- | lo >= 0, hi >= lo = "((_ re.loop " ++ show lo ++ " " ++ show hi ++ ") " ++ regExpToString fs r ++ ")"+-- | Convert a RegExp to text, parameterized by how strings are converted+regExpToText :: (String -> Text) -> RegExp -> Text+regExpToText fs (Literal s) = "(str.to.re " <> fs s <> ")"+regExpToText _ All = "re.all"+regExpToText _ AllChar = "re.allchar"+regExpToText _ None = "re.nostr"+regExpToText fs (Range ch1 ch2) = "(re.range " <> fs [ch1] <> " " <> fs [ch2] <> ")"+regExpToText _ (Conc []) = "1"+regExpToText fs (Conc [x]) = regExpToText fs x+regExpToText fs (Conc xs) = "(re.++ " <> T.unwords (map (regExpToText fs) xs) <> ")"+regExpToText fs (KStar r) = "(re.* " <> regExpToText fs r <> ")"+regExpToText fs (KPlus r) = "(re.+ " <> regExpToText fs r <> ")"+regExpToText fs (Opt r) = "(re.opt " <> regExpToText fs r <> ")"+regExpToText fs (Comp r) = "(re.comp " <> regExpToText fs r <> ")"+regExpToText fs (Diff r1 r2) = "(re.diff " <> regExpToText fs r1 <> " " <> regExpToText fs r2 <> ")"+regExpToText fs (Loop lo hi r)+ | lo >= 0, hi >= lo = "((_ re.loop " <> showText lo <> " " <> showText hi <> ") " <> regExpToText fs r <> ")" | True = error $ "Invalid regular-expression Loop with arguments: " ++ show (lo, hi)-regExpToString fs (Power n r)- | n >= 0 = regExpToString fs (Loop n n r)+regExpToText fs (Power n r)+ | n >= 0 = regExpToText fs (Loop n n r) | True = error $ "Invalid regular-expression Power with arguments: " ++ show n-regExpToString fs (Inter r1 r2) = "(re.inter " ++ regExpToString fs r1 ++ " " ++ regExpToString fs r2 ++ ")"-regExpToString _ (Union []) = "re.nostr"-regExpToString fs (Union [x]) = regExpToString fs x-regExpToString fs (Union xs) = "(re.union " ++ unwords (map (regExpToString fs) xs) ++ ")"+regExpToText fs (Inter r1 r2) = "(re.inter " <> regExpToText fs r1 <> " " <> regExpToText fs r2 <> ")"+regExpToText _ (Union []) = "re.nostr"+regExpToText fs (Union [x]) = regExpToText fs x+regExpToText fs (Union xs) = "(re.union " <> T.unwords (map (regExpToText fs) xs) <> ")" -- | Show instance for @StrOp@. Note that the mapping here is important to match the SMTLib equivalents. instance Show StrOp where@@ -497,22 +487,22 @@ show StrToCode = "str.to_code" show StrFromCode = "str.from_code" -- Note the breakage here with respect to argument order. We fix this explicitly later.- show (StrInRe s) = "str.in_re " ++ regExpToSMTString s+ show (StrInRe s) = "str.in_re " ++ T.unpack (regExpToSMTString s) -- | Show instance for @RegExOp@. instance Show RegExOp where- show (RegExEq r1 r2) = "(= " ++ regExpToSMTString r1 ++ " " ++ regExpToSMTString r2 ++ ")"- show (RegExNEq r1 r2) = "(distinct " ++ regExpToSMTString r1 ++ " " ++ regExpToSMTString r2 ++ ")"+ show (RegExEq r1 r2) = "(= " ++ T.unpack (regExpToSMTString r1) ++ " " ++ T.unpack (regExpToSMTString r2) ++ ")"+ show (RegExNEq r1 r2) = "(distinct " ++ T.unpack (regExpToSMTString r1) ++ " " ++ T.unpack (regExpToSMTString r2) ++ ")" -- | For now, we represent lambda functions in op with their SMTLib equivalent strings. -- This might change in the future.-newtype SMTLambda = SMTLambda String+newtype SMTLambda = SMTLambda T.Text deriving (Eq, Ord, G.Data, Generic) deriving newtype NFData -- | Simple show instance for SMTLambda instance Show SMTLambda where- show (SMTLambda s) = s+ show (SMTLambda s) = T.unpack s -- | Sequence operations. Indexed by the element kind. data SeqOp = SeqLen Kind@@ -586,8 +576,8 @@ where tinfo = "table" ++ show ti ++ "(" ++ show at ++ " -> " ++ show rt ++ ", " ++ show l ++ ")" show (KindCast fr to) = "cast_" ++ show fr ++ "_" ++ show to- show (Uninterpreted i) = "[uninterpreted] " ++ i- show (QuantifiedBool i) = "[quantified boolean] " ++ i+ show (Uninterpreted i) = "[uninterpreted] " ++ T.unpack i+ show (QuantifiedBool i) = "[quantified boolean] " ++ T.unpack i show (Label s) = "[label] " ++ s @@ -706,18 +696,10 @@ instance Ord NamedSymVar where compare (NamedSymVar l _) (NamedSymVar r _) = compare l r --- | Convert to a named symvar, from string-toNamedSV' :: SV -> String -> NamedSymVar-toNamedSV' s = NamedSymVar s . T.pack- -- | Convert to a named symvar, from text toNamedSV :: SV -> Name -> NamedSymVar toNamedSV = NamedSymVar --- | Get the node id from a named sym var-namedNodeId :: NamedSymVar -> NodeId-namedNodeId = swNodeId . getSV- -- | Get the SV from a named sym var getSV :: NamedSymVar -> SV getSV (NamedSymVar s _) = s@@ -761,8 +743,8 @@ objectiveName (AssertWithPenalty s _ _) = s -- | The state we keep track of as we interact with the solver-data QueryState = QueryState { queryAsk :: Maybe Int -> String -> IO String- , querySend :: Maybe Int -> String -> IO ()+data QueryState = QueryState { queryAsk :: Maybe Int -> Text -> IO String+ , querySend :: Maybe Int -> Text -> IO () , queryRetrieveResponse :: Maybe Int -> IO String , queryConfig :: SMTConfig , queryTerminate :: Maybe C.SomeException -> IO ()@@ -910,10 +892,10 @@ shcg (s, ss) = ("Variable: " ++ s) : map (" " ++) ss - shn (NamedSymVar sv nm) = " " <> ni <> " :: " ++ show (swKind sv) ++ alias+ shn (NamedSymVar sv nm) = " " ++ ni ++ " :: " ++ show (swKind sv) ++ alias where ni = show sv - alias | ni == T.unpack nm = ""+ alias | T.pack ni == nm = "" | True = ", aliasing " ++ show nm shq (q, v) = shn v ++ ", " ++ if q == ALL then "universal" else "existential"@@ -928,11 +910,7 @@ soft False = "" shAssert (nm, stk, p) = " -- assertion: " ++ nm ++ " " ++ maybe "[No location]"-#if MIN_VERSION_base(4,9,0) prettyCallStack-#else- showCallStack-#endif stk ++ ": " ++ show p -- | Expression map, used for hash-consing@@ -1005,11 +983,11 @@ -- | Is this a CodeGen run? (i.e., generating code) isCodeGenMode :: State -> IO Bool isCodeGenMode State{runMode} = do rm <- readIORef runMode- return $ case rm of- Concrete{} -> False- SMTMode{} -> False- LambdaGen{} -> False- CodeGen -> True+ pure $ case rm of+ Concrete{} -> False+ SMTMode{} -> False+ LambdaGen{} -> False+ CodeGen -> True -- | The state in query mode, i.e., additional context data IncState = IncState { rNewInps :: IORef [NamedSymVar] -- always existential!@@ -1031,14 +1009,14 @@ ui <- newIORef Map.empty pgm <- newIORef (SBVPgm S.empty) cstrs <- newIORef S.empty- return IncState { rNewInps = is- , rNewKinds = ks- , rNewConsts = nc- , rNewTbls = tm- , rNewUIs = ui- , rNewAsgns = pgm- , rNewConstraints = cstrs- }+ pure IncState { rNewInps = is+ , rNewKinds = ks+ , rNewConsts = nc+ , rNewTbls = tm+ , rNewUIs = ui+ , rNewAsgns = pgm+ , rNewConstraints = cstrs+ } -- | Get a new IncState withNewIncState :: State -> (State -> IO a) -> IO (IncState, a)@@ -1047,7 +1025,7 @@ R.modifyIORef' (rIncState st) (const is) r <- cont st finalIncState <- readIORef (rIncState st)- return (finalIncState, r)+ pure (finalIncState, r) -- | User defined inputs type UserInputs = S.Seq NamedSymVar@@ -1112,7 +1090,7 @@ | True = Nothing -- l != Just 0, a lambda var, whether top-level or in a scope, so we ignore where (_, l, i) = getId (swNodeId sv)- svs = fmap f ns+ svs = f <$> ns res = case S.lookup i ns of -- Nothing on negative Int or Int > length seq Nothing -> secondLookup x@(Just e) -> if sv == f e then x else secondLookup@@ -1123,8 +1101,8 @@ -- | A defined function/value data SMTDef = SMTDef Kind -- ^ Final kind of the definition (resulting kind, not the params) [String] -- ^ other definitions it refers to- (Maybe String) -- ^ parameter string- (Int -> String) -- ^ Body, in SMTLib syntax, given the tab amount+ (Maybe Text) -- ^ parameter string+ (Int -> Text) -- ^ Body, in SMTLib syntax, given the tab amount deriving G.Data -- | For debug purposes@@ -1132,9 +1110,9 @@ show (SMTDef fk frees p body) = unlines [ "-- User defined function:" , "-- Final return type : " ++ show fk , "-- Refers to : " ++ intercalate ", " frees- , "-- Parameters : " ++ fromMaybe "NONE" p+ , "-- Parameters : " ++ maybe "NONE" T.unpack p , "-- Body : "- , body 2+ , T.unpack (body 2) ] -- | NFData instance for SMTDef@@ -1142,7 +1120,7 @@ rnf (SMTDef fk frees params body) = rnf fk `seq` rnf frees `seq` rnf params `seq` rnf body -- | Compare two SMTDef values for semantic equality.--- The body is @(Int -> String)@ where @Int@ is indentation; we compare rendered output at indent 0.+-- The body is @(Int -> Text)@ where @Int@ is indentation; we compare rendered output at indent 0. smtDefEq :: SMTDef -> SMTDef -> Bool smtDefEq (SMTDef k1 refs1 params1 body1) (SMTDef k2 refs2 params2 body2) = k1 == k2 && refs1 == refs2 && params1 == params2 && body1 0 == body2 0@@ -1228,11 +1206,11 @@ -- | Are we running in proof mode? inSMTMode :: State -> IO Bool inSMTMode State{runMode} = do rm <- readIORef runMode- return $ case rm of- CodeGen -> False- LambdaGen{} -> False- Concrete{} -> False- SMTMode{} -> True+ pure $ case rm of+ CodeGen -> False+ LambdaGen{} -> False+ Concrete{} -> False+ SMTMode{} -> True -- | The "Symbolic" value. Either a constant (@Left@) or a symbolic -- value (@Right Cached@). Note that caching is essential for making@@ -1275,7 +1253,7 @@ rm <- readIORef runMode case rm of SMTMode _ IRun _ _ -> interactiveUpdate- _ -> return ()+ _ -> pure () -- | Modify the incremental state modifyIncState :: State -> (IncState -> IORef a) -> (a -> a) -> IO ()@@ -1284,21 +1262,21 @@ R.modifyIORef' (field incState) update -- | Add an observable-recordObservable :: State -> String -> (CV -> Bool) -> SV -> IO ()-recordObservable st (T.pack -> nm) chk sv = modifyState st rObservables (S.|> (nm, chk, sv)) (return ())+recordObservable :: State -> Text -> (CV -> Bool) -> SV -> IO ()+recordObservable st nm chk sv = modifyState st rObservables (S.|> (nm, chk, sv)) (pure ()) -- | Increment the variable counter incrementInternalCounter :: State -> IO Int incrementInternalCounter st = do ctr <- readIORef (rctr st)- modifyState st rctr (+1) (return ())- return ctr+ modifyState st rctr (+1) (pure ())+ pure ctr {-# INLINE incrementInternalCounter #-} -- | Increment the fresh-var counter incrementFreshNameCounter :: State -> IO Int incrementFreshNameCounter st = do ctr <- readIORef (freshNameCtr st)- modifyState st freshNameCtr (+1) (return ())- return ctr+ modifyState st freshNameCtr (+1) (pure ())+ pure ctr {-# INLINE incrementFreshNameCounter #-} -- | Kind of code we have for uninterpretation@@ -1331,18 +1309,6 @@ mapM_ forceSVArg sws newExpr st k $ SBVApp op sws --- | Generate a unique name for the given function based on the object's stable name-prefixNameToUnique :: State -> String -> IO String-prefixNameToUnique st pre = do- uiMap <- readIORef (rUIMap st)-- let suffix 0 = pre- suffix i = pre ++ "_" ++ show i-- case [cand | i <- [0::Int ..], let cand = suffix i, cand `Map.notMember` uiMap] of- (n:_) -> pure n- [] -> error $ "genUniqueName: Can't generate a unique name for prefix: " ++ pre -- can't happen- -- | Create a new value, possibly with user given code. This function might change -- the name given, putting bars around it if needed. That's the name returned. newUninterpreted :: State -> UIName -> Maybe [String] -> SBVType -> UICodeKind -> IO Op@@ -1351,9 +1317,9 @@ let (adtOp, candName) = case uiName of UIGiven n -> (False, n) UIADT o -> case o of- ADTConstructor n _ -> (True, n)- ADTTester n _ -> (True, n)- ADTAccessor n _ -> (True, n)+ ADTConstructor n _ -> (True, T.unpack n)+ ADTTester n _ -> (True, T.unpack n)+ ADTAccessor n _ -> (True, T.unpack n) -- determine the final name. We leave constructors alone. let nm = case () of@@ -1392,7 +1358,7 @@ ] pure True UICgC c -> -- No need to record the code in interactive mode: CodeGen doesn't use interactive- do modifyState st rCgMap (Map.insert nm c) (return ())+ do modifyState st rCgMap (Map.insert nm c) (pure ()) pure True let checkType :: SBVType -> r -> r@@ -1406,18 +1372,19 @@ unless adtOp $ do uiMap <- readIORef (rUIMap st) case nm `Map.lookup` uiMap of- Just (_, _, t') -> checkType t' (return ())+ Just (_, _, t') -> checkType t' (pure ()) Nothing -> modifyState st rUIMap (Map.insert nm (isCurried, mbArgNames, t)) $ modifyIncState st rNewUIs (\newUIs -> case nm `Map.lookup` newUIs of Just (_, _, t') -> checkType t' newUIs Nothing -> Map.insert nm (isCurried, mbArgNames, t) newUIs) - pure $ case uiName of- UIGiven{} -> Uninterpreted nm- UIADT (ADTConstructor _ k) -> ADTOp (ADTConstructor nm k)- UIADT (ADTTester _ k) -> ADTOp (ADTTester nm k)- UIADT (ADTAccessor _ k) -> ADTOp (ADTAccessor nm k)+ pure $ let tnm = T.pack nm+ in case uiName of+ UIGiven{} -> Uninterpreted tnm+ UIADT (ADTConstructor _ k) -> ADTOp (ADTConstructor tnm k)+ UIADT (ADTTester _ k) -> ADTOp (ADTTester tnm k)+ UIADT (ADTAccessor _ k) -> ADTOp (ADTAccessor tnm k) -- | Add a new sAssert based constraint addAssertion :: State -> Maybe CallStack -> String -> SV -> IO ()@@ -1435,14 +1402,14 @@ let n = "__internal_sbv_" <> nm v = NamedSymVar sv n modifyState st rinps (addUserInput sv n) $ modifyIncState st rNewInps (v :)- return sv+ pure sv {-# INLINE newInternalVariable #-} -- | Create a variable to be used in a constraint-expression quantVar :: Quantifier -> State -> Kind -> IO SV quantVar q st k = do v@(NamedSymVar sv _) <- newSV st k- modifyState st rlambdaInps (S.|> (q, v)) (return ())- return sv+ modifyState st rlambdaInps (S.|> (q, v)) (pure ())+ pure sv {-# INLINE quantVar #-} -- | Create a variable to be used in a lambda-expression@@ -1456,7 +1423,7 @@ ll <- readIORef (rLambdaLevel st) let sv = SV k (NodeId (sbvContext st, ll, ctr)) registerKind st k- return $ NamedSymVar sv $ T.pack (show sv)+ pure $ NamedSymVar sv $ showText sv {-# INLINE newSV #-} -- | Register a new kind with the system, used for uninterpreted sorts.@@ -1503,17 +1470,17 @@ -- Don't forget to register subkinds! case k of- KVar {} -> return ()- KBool {} -> return ()- KBounded {} -> return ()- KUnbounded{} -> return ()- KReal {} -> return ()- KFloat {} -> return ()- KDouble {} -> return ()- KFP {} -> return ()- KRational {} -> return ()- KChar {} -> return ()- KString {} -> return ()+ KVar {} -> pure ()+ KBool {} -> pure ()+ KBounded {} -> pure ()+ KUnbounded{} -> pure ()+ KReal {} -> pure ()+ KFloat {} -> pure ()+ KDouble {} -> pure ()+ KFP {} -> pure ()+ KRational {} -> pure ()+ KChar {} -> pure ()+ KString {} -> pure () KApp _ ks -> mapM_ (registerKind st) ks KADT _ pks cks -> mapM_ (registerKind st) (map snd pks ++ concatMap snd cks)@@ -1535,7 +1502,7 @@ = do old <- readIORef $ rUsedLbls st if nm `Set.member` old then err "is used multiple times. Please do not use duplicate names!"- else modifyState st rUsedLbls (Set.insert nm) (return ())+ else modifyState st rUsedLbls (Set.insert nm) (pure ()) where err w = error $ "SBV (" ++ whence ++ "): " ++ show nm ++ " " ++ w @@ -1547,11 +1514,11 @@ -- NB. Unlike in 'newExpr', we don't have to make sure the returned sv -- has the kind we asked for, because the constMap stores the full CV -- which already has a kind field in it.- Just sv -> return sv+ Just sv -> pure sv Nothing -> do (NamedSymVar sv _) <- newSV st (kindOf c) let ins = Map.insert c sv modifyState st rconstMap ins $ modifyIncState st rNewConsts ins- return sv+ pure sv {-# INLINE newConst #-} -- | Create a new table; hash-cons as necessary@@ -1560,11 +1527,11 @@ let key = (at, rt, elts) tblMap <- readIORef (rtblMap st) case key `Map.lookup` tblMap of- Just i -> return i+ Just i -> pure i _ -> do let i = Map.size tblMap upd = Map.insert key i modifyState st rtblMap upd $ modifyIncState st rNewTbls upd- return i+ pure i -- | Create a new expression; hash-cons as necessary newExpr :: State -> Kind -> SBVExpr -> IO SV@@ -1577,13 +1544,13 @@ -- at first, but `svSign` and `svUnsign` rely on this as we can -- get the same expression but at a different type. See -- <http://github.com/GaloisInc/cryptol/issues/566> as an example.- Just sv | kindOf sv == k -> return sv+ Just sv | kindOf sv == k -> pure sv _ -> do (NamedSymVar sv _) <- newSV st k checkConsistent sv e let append (SBVPgm xs) = SBVPgm (xs S.|> (sv, e)) modifyState st spgm append $ modifyIncState st rNewAsgns append- modifyState st rexprMap (Map.insert e sv) (return ())- return sv+ modifyState st rexprMap (Map.insert e sv) (pure ())+ pure sv {-# INLINE newExpr #-} -- | In rare cases, we can get a context mismatch; so make sure the expression is well-formed.@@ -1603,15 +1570,6 @@ compatibleContext c1 c2 = c1 == c2 || c1 == globalSBVContext || c2 == globalSBVContext {-# INLINE compatibleContext #-} --- | Same as checkConsistent above, except in an array context-checkCompatibleContext :: SBVContext -> SBVContext -> IO ()-checkCompatibleContext ctx1 ctx2- | ctx1 `compatibleContext` ctx2- = pure ()- | True- = contextMismatchError ctx1 ctx2-{-# INLINE checkCompatibleContext #-}- -- | Convert a symbolic value to an internal SV svToSV :: State -> SVal -> IO SV svToSV st (SVal _ (Left c)) = newConst st c@@ -1648,9 +1606,7 @@ newtype SymbolicT m a = SymbolicT { runSymbolicT :: ReaderT State m a } deriving newtype ( Applicative, Functor, Monad, MonadIO, MonadTrans , MonadError e, MonadState s, MonadWriter w-#if MIN_VERSION_base(4,11,0)- , Fail.MonadFail-#endif+ , MonadFail ) -- | `MonadSymbolic` instance for `SymbolicT m`@@ -1726,11 +1682,11 @@ QueryVar -> (True, Just EX) mkS q = do (NamedSymVar sv internalName) <- newSV st k- let nm = fromMaybe (T.unpack internalName) mbNm+ let nm = maybe internalName T.pack mbNm introduceUserName st (isQueryVar, isTracker) nm k q sv - mkC cv = do modifyState st rCInfo ((fromMaybe "_" mbNm, cv):) (return ())- return $ SVal k (Left cv)+ mkC cv = do modifyState st rCInfo ((fromMaybe "_" mbNm, cv):) (pure ())+ pure $ SVal k (Left cv) case (mbQ, rm) of (Just q, SMTMode{} ) -> mkS q@@ -1759,8 +1715,8 @@ (NamedSymVar sv internalName) <- newSV st k - let nm = fromMaybe (T.unpack internalName) mbNm- nsv = toNamedSV' sv nm+ let nm = maybe internalName T.pack mbNm+ nsv = NamedSymVar sv nm -- Ignore the context equivalence check here. When validating, we are in a different -- context; so they won't match@@ -1783,11 +1739,11 @@ mkC cv -- | Introduce a new user name. We simply append a suffix if we have seen this variable before.-introduceUserName :: State -> (Bool, Bool) -> String -> Kind -> Quantifier -> SV -> IO SVal+introduceUserName :: State -> (Bool, Bool) -> Text -> Kind -> Quantifier -> SV -> IO SVal introduceUserName st@State{runMode} (isQueryVar, isTracker) nmOrig k q sv = do old <- allInputs <$> readIORef (rinps st) - let nm = mkUnique (T.pack nmOrig) old+ let nm = mkUnique nmOrig old -- If this is not a query variable and we're in a query, reject it. -- See https://github.com/LeventErkok/sbv/issues/554 for the rationale.@@ -1819,13 +1775,13 @@ $ noInteractive ["Adding a new tracker variable in interactive mode: " ++ show nm] else modifyState st rinps (addUserInput sv nm) $ modifyIncState st rNewInps newInp- return $ SVal k $ Right $ cache (const (return sv))+ pure $ SVal k $ Right $ cache (const (pure sv)) where -- The following can be rather slow if we keep reusing the same prefix, but I doubt it'll be a problem in practice -- Also, the following will fail if we span the range of integers without finding a match, but your computer would -- die way ahead of that happening if that's the case! mkUnique :: T.Text -> Set.Set Name -> T.Text- mkUnique prefix names = case dropWhile (`Set.member` names) (prefix : [prefix <> "_" <> T.pack (show i) | i <- [(0::Int)..]]) of+ mkUnique prefix names = case dropWhile (`Set.member` names) (prefix : [prefix <> "_" <> showText i | i <- [(0::Int)..]]) of h:_ -> h _ -> error $ "mkUnique: Impossible happened! Couldn't get a unique name for " ++ show (prefix, names) @@ -1951,7 +1907,7 @@ mapM_ check $ nubOrd $ G.universeBi res - return (r, res)+ pure (r, res) -- | Grab the program from a running symbolic simulation state. extractSymbolicSimulationState :: State -> IO Result@@ -1995,14 +1951,12 @@ outsO <- reverse <$> readIORef outs - let swap (a, b) = (b, a)- cmp (a, _) (b, _) = a `compare` b- arrange (i, (at, rt, es)) = ((i, at, rt), es)+ let arrange (i, (at, rt, es)) = ((i, at, rt), es) constMap <- readIORef (rconstMap st)- let cnsts = sortBy cmp . map swap . Map.toList $ constMap+ let cnsts = mapToSortedList constMap - tbls <- map arrange . sortBy cmp . map swap . Map.toList <$> readIORef tables+ tbls <- map arrange . mapToSortedList <$> readIORef tables defnMap <- readIORef defns let ds = Map.toList defnMap definedSet = Map.keysSet defnMap@@ -2019,12 +1973,12 @@ pinfo <- readIORef progInfo - return $ Result pinfo knds traceVals observables cgMap inpsO (constMap, cnsts) tbls unint ds (SBVPgm rpgm) extraCstrs assertions outsO+ pure $ Result pinfo knds traceVals observables cgMap inpsO (constMap, cnsts) tbls unint ds (SBVPgm rpgm) extraCstrs assertions outsO -- | Generalization of 'Data.SBV.addNewSMTOption' addNewSMTOption :: MonadSymbolic m => SMTOption -> m () addNewSMTOption o = do st <- symbolicEnv- liftIO $ modifyState st rSMTOptions (o:) (return ())+ liftIO $ modifyState st rSMTOptions (o:) (pure ()) -- | Generalization of 'Data.SBV.imposeConstraint' imposeConstraint :: MonadSymbolic m => Bool -> [(String, String)] -> SVal -> m ()@@ -2068,7 +2022,7 @@ let mkGoal nm orig = liftIO $ do origSV <- svToSV st orig track <- svMkTrackerVar (kindOf orig) nm st trackSV <- svToSV st track- return (origSV, trackSV)+ pure (origSV, trackSV) let walk (Minimize nm v) = Minimize nm <$> mkGoal nm v walk (Maximize nm v) = Maximize nm <$> mkGoal nm v@@ -2088,18 +2042,18 @@ | True = do st <- symbolicEnv liftIO $ do xsv <- svToSV st x- recordObservable st m (const True) xsv+ recordObservable st (T.pack m) (const True) xsv -- | Generalization of 'Data.SBV.outputSVal' outputSVal :: MonadSymbolic m => SVal -> m () outputSVal (SVal _ (Left c)) = do st <- symbolicEnv sv <- liftIO $ newConst st c- liftIO $ modifyState st routs (sv:) (return ())+ liftIO $ modifyState st routs (sv:) (pure ()) outputSVal (SVal _ (Right f)) = do st <- symbolicEnv sv <- liftIO $ uncache f st- liftIO $ modifyState st routs (sv:) (return ())+ liftIO $ modifyState st routs (sv:) (pure ()) --------------------------------------------------------------------------------- -- * Cached values@@ -2135,10 +2089,10 @@ sn <- f `seq` makeStableName f let h = hashStableName sn case (h `IMap.lookup` stored) >>= (sn `lookup`) of- Just r -> return r+ Just r -> pure r Nothing -> do r <- f st r `seq` R.modifyIORef' rCache (IMap.insertWith (++) h [(sn, r)])- return r+ pure r -- | Representation of SMTLib Program versions. As of June 2015, we're dropping support -- for SMTLib1, and supporting SMTLib2 only. We keep this data-type around in case@@ -2160,18 +2114,15 @@ instance Show SMTLibPgm where show (SMTLibPgm _ pgm _) = T.unpack pgm +-- | Extract the program text from an SMTLibPgm without converting to String.+smtLibPgmText :: SMTLibPgm -> Text+smtLibPgmText (SMTLibPgm _ pgm _) = pgm+ -- Other Technicalities.. instance NFData GeneralizedCV where rnf (ExtendedCV e) = e `seq` () rnf (RegularCV c) = c `seq` () -#if MIN_VERSION_base(4,9,0)-#else--- Can't really force this, but not a big deal-instance NFData CallStack where- rnf _ = ()-#endif- instance NFData NamedSymVar where rnf (NamedSymVar s n) = rnf s `seq` rnf n @@ -2266,7 +2217,7 @@ , dsatPrecision :: Maybe Double -- ^ Delta-sat precision , solver :: SMTSolver -- ^ The actual SMT solver. , extraArgs :: [String] -- ^ Extra command line arguments to pass to the solver.- , roundingMode :: RoundingMode -- ^ Rounding mode to use for floating-point conversions+ , roundingMode :: RoundingMode -- ^ Rounding mode to use for floating-point calculations. Defaults to RNE. , solverSetOptions :: [SMTOption] -- ^ Options to set as we start the solver , ignoreExitCode :: Bool -- ^ If true, we shall ignore the exit code upon exit. Otherwise we require ExitSuccess. , redirectVerbose :: Maybe FilePath -- ^ Redirect the verbose output to this file if given. If Nothing, stdout is implied.@@ -2285,8 +2236,8 @@ } -- | Ignore internal names and those the user told us to-mustIgnoreVar :: SMTConfig -> String -> Bool-mustIgnoreVar cfg s = "__internal_sbv" `isPrefixOf` s || isNonModelVar cfg s+mustIgnoreVar :: SMTConfig -> T.Text -> Bool+mustIgnoreVar cfg s = "__internal_sbv" `T.isPrefixOf` s || isNonModelVar cfg (T.unpack s) -- | We show the name of the solver for the config. Arguably this is misleading, but better than nothing. instance Show SMTConfig where@@ -2312,10 +2263,6 @@ } deriving Show --- | Is it the case that the model is really uninteresting? This is the case when there are no assocs nor ui's-isEmptyModel :: SMTModel -> Bool-isEmptyModel SMTModel{modelAssocs, modelUIFuns} = null modelAssocs && null modelUIFuns- -- | The result of an SMT solver call. Each constructor is tagged with -- the t'SMTConfig' that created it so that further tools can inspect it -- and build layers of results, if needed. For ordinary uses of the library,@@ -2338,7 +2285,7 @@ type SMTEngine = forall res. SMTConfig -- ^ current configuration -> State -- ^ the state in which to run the engine- -> String -- ^ program+ -> Text -- ^ program -> (State -> IO res) -- ^ continuation -> IO res @@ -2359,7 +2306,7 @@ data SMTSolver = SMTSolver { name :: Solver -- ^ The solver in use , executable :: String -- ^ The path to its executable- , preprocess :: String -> String -- ^ Each line sent to the solver will be passed through this function (typically id)+ , preprocess :: Text -> Text -- ^ Each line sent to the solver will be passed through this function (typically id) , options :: SMTConfig -> [String] -- ^ Options to provide to the solver , engine :: SMTEngine -- ^ The solver engine, responsible for interpreting solver output , capabilities :: SolverCapabilities -- ^ Various capabilities of the solver
Data/SBV/Dynamic.hs view
@@ -166,78 +166,78 @@ -- | Create SMT-Lib benchmark for a sat call generateSMTBenchmarkSat :: Symbolic SVal -> IO String-generateSMTBenchmarkSat s = SBV.generateSMTBenchmarkSat (fmap toSBool s)+generateSMTBenchmarkSat s = SBV.generateSMTBenchmarkSat (toSBool <$> s) -- | Create SMT-Lib benchmark for a proof call generateSMTBenchmarkProof :: Symbolic SVal -> IO String-generateSMTBenchmarkProof s = SBV.generateSMTBenchmarkProof (fmap toSBool s)+generateSMTBenchmarkProof s = SBV.generateSMTBenchmarkProof (toSBool <$> s) -- | Proves the predicate using the given SMT-solver proveWith :: SMTConfig -> Symbolic SVal -> IO ThmResult-proveWith cfg s = SBV.proveWith cfg (fmap toSBool s)+proveWith cfg s = SBV.proveWith cfg (toSBool <$> s) -- | Find a satisfying assignment using the given SMT-solver satWith :: SMTConfig -> Symbolic SVal -> IO SatResult-satWith cfg s = SBV.satWith cfg (fmap toSBool s)+satWith cfg s = SBV.satWith cfg (toSBool <$> s) -- | Check safety using the given SMT-solver safeWith :: SMTConfig -> Symbolic SVal -> IO [SafeResult]-safeWith cfg s = SBV.safeWith cfg (fmap toSBool s)+safeWith cfg s = SBV.safeWith cfg (toSBool <$> s) -- | Find all satisfying assignments using the given SMT-solver allSatWith :: SMTConfig -> Symbolic SVal -> IO AllSatResult-allSatWith cfg s = SBV.allSatWith cfg (fmap toSBool s)+allSatWith cfg s = SBV.allSatWith cfg (toSBool <$> s) -- | Prove a property with multiple solvers, running them in separate threads. The -- results will be returned in the order produced. proveWithAll :: [SMTConfig] -> Symbolic SVal -> IO [(Solver, NominalDiffTime, ThmResult)]-proveWithAll cfgs s = SBV.proveWithAll cfgs (fmap toSBool s)+proveWithAll cfgs s = SBV.proveWithAll cfgs (toSBool <$> s) -- | Prove a property with multiple solvers, running them in separate -- threads. Only the result of the first one to finish will be -- returned, remaining threads will be killed. proveWithAny :: [SMTConfig] -> Symbolic SVal -> IO (Solver, NominalDiffTime, ThmResult)-proveWithAny cfgs s = SBV.proveWithAny cfgs (fmap toSBool s)+proveWithAny cfgs s = SBV.proveWithAny cfgs (toSBool <$> s) -- | Prove a property with query mode using multiple threads. Each query -- computation will spawn a thread and a unique instance of your solver to run -- asynchronously. The 'Symbolic' t'SVal' is duplicated for each thread. This -- function will block until all child threads return. proveConcurrentWithAll :: SMTConfig -> Symbolic SVal -> [Query SVal] -> IO [(Solver, NominalDiffTime, ThmResult)]-proveConcurrentWithAll cfg s queries = SBV.proveConcurrentWithAll cfg queries (fmap toSBool s)+proveConcurrentWithAll cfg s queries = SBV.proveConcurrentWithAll cfg queries (toSBool <$> s) -- | Prove a property with query mode using multiple threads. Each query -- computation will spawn a thread and a unique instance of your solver to run -- asynchronously. The 'Symbolic' t'SVal' is duplicated for each thread. This -- function will return the first query computation that completes, killing the others. proveConcurrentWithAny :: SMTConfig -> Symbolic SVal -> [Query SVal] -> IO (Solver, NominalDiffTime, ThmResult)-proveConcurrentWithAny cfg s queries = SBV.proveConcurrentWithAny cfg queries (fmap toSBool s)+proveConcurrentWithAny cfg s queries = SBV.proveConcurrentWithAny cfg queries (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple solvers, -- running them in separate threads. The results will be returned in -- the order produced. satWithAll :: [SMTConfig] -> Symbolic SVal -> IO [(Solver, NominalDiffTime, SatResult)]-satWithAll cfgs s = SBV.satWithAll cfgs (fmap toSBool s)+satWithAll cfgs s = SBV.satWithAll cfgs (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple solvers, -- running them in separate threads. Only the result of the first one -- to finish will be returned, remaining threads will be killed. satWithAny :: [SMTConfig] -> Symbolic SVal -> IO (Solver, NominalDiffTime, SatResult)-satWithAny cfgs s = SBV.satWithAny cfgs (fmap toSBool s)+satWithAny cfgs s = SBV.satWithAny cfgs (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple threads in query -- mode. The 'Symbolic' t'SVal' represents what is known to all child query threads. -- Each query thread will spawn a unique instance of the solver. Only the first -- one to finish will be returned and the other threads will be killed. satConcurrentWithAny :: SMTConfig -> [Query b] -> Symbolic SVal -> IO (Solver, NominalDiffTime, SatResult)-satConcurrentWithAny cfg qs s = SBV.satConcurrentWithAny cfg qs (fmap toSBool s)+satConcurrentWithAny cfg qs s = SBV.satConcurrentWithAny cfg qs (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple threads in query -- mode. The 'Symbolic' t'SVal' represents what is known to all child query threads. -- Each query thread will spawn a unique instance of the solver. This function -- will block until all child threads have completed. satConcurrentWithAll :: SMTConfig -> [Query b] -> Symbolic SVal -> IO [(Solver, NominalDiffTime, SatResult)]-satConcurrentWithAll cfg qs s = SBV.satConcurrentWithAll cfg qs (fmap toSBool s)+satConcurrentWithAll cfg qs s = SBV.satConcurrentWithAll cfg qs (toSBool <$> s) -- | Extract a model, the result is a tuple where the first argument (if True) -- indicates whether the model was "probable". (i.e., if the solver returned unknown.)
Data/SBV/Either.hs view
@@ -18,7 +18,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Either ( -- * Constructing sums
Data/SBV/Internals.hs view
@@ -19,7 +19,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall -Werror #-}@@ -103,6 +103,7 @@ import GHC.TypeLits import qualified Data.SBV.Control.Utils as Query+import qualified Data.Text as T import Data.SBV.Lambda @@ -118,7 +119,7 @@ -- Note that this is inherently dangerous as it can put the solver in an arbitrary -- state and confuse SBV. If you use this feature, you are on your own! sendStringToSolver :: (MonadIO m, MonadQuery m) => String -> m ()-sendStringToSolver = Query.send False+sendStringToSolver = Query.send False . T.pack -- | Retrieve multiple responses from the solver, until it responds with a user given -- tag that we shall arrange for internally. The optional timeout is in milliseconds.@@ -132,7 +133,7 @@ -- Note that this is inherently dangerous as it can put the solver in an arbitrary -- state and confuse SBV. sendRequestToSolver :: (MonadIO m, MonadQuery m) => String -> m String-sendRequestToSolver = Query.ask+sendRequestToSolver = Query.ask . T.pack {- $coordinateSolverInfo In rare cases it might be necessary to send an arbitrary string down to the solver. Needless to say, this
Data/SBV/Lambda.hs view
@@ -13,10 +13,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Lambda ( lambda, lambdaStr@@ -33,6 +34,7 @@ import Data.SBV.Core.Data import Data.SBV.Core.Kind import Data.SBV.SMT.SMTLib2+import Data.SBV.Utils.Lib (showText) import Data.SBV.Utils.PrettyNum import Data.SBV.Core.Symbolic hiding (mkNewState)@@ -56,8 +58,8 @@ data Defn = Defn [String] -- The uninterpreted names referred to in the body [String] -- Free variables (i.e., not uninterpreted nor bound in the definition itself)- (Maybe [(Quantifier, String)]) -- Param declaration groups, if any- (Int -> String) -- Body, given the tab amount.+ (Maybe [(Quantifier, T.Text)]) -- Param declaration groups, if any+ (Int -> T.Text) -- Body, given the tab amount. -- | Maka a new substate from the incoming state, sharing parts as necessary inSubState :: MonadIO m => LambdaScope -> State -> (State -> m b) -> m b@@ -139,12 +141,12 @@ } -- In this case, we expect just one group of parameters, with universal quantification-extractAllUniversals :: [(Quantifier, String)] -> String+extractAllUniversals :: [(Quantifier, T.Text)] -> T.Text extractAllUniversals [(ALL, s)] = s extractAllUniversals other = error $ unlines [ "" , "*** Data.SBV.Lambda: Impossible happened. Got existential quantifiers." , "***"- , "*** Params: " ++ show other+ , "*** Params: " ++ show (map (\(q, t) -> (q, T.unpack t)) other) , "***" , "*** Please report this as a bug!" ]@@ -188,8 +190,8 @@ , "*** touch for further possible enhancements." ] - sh (Defn _unints _frees Nothing body) = body 0- sh (Defn _unints _frees (Just params) body) = "(lambda " ++ extractAllUniversals params ++ "\n" ++ body 2 ++ ")"+ sh (Defn _unints _frees Nothing body) = T.unpack (body 0)+ sh (Defn _unints _frees (Just params) body) = "(lambda " ++ T.unpack (extractAllUniversals params) ++ "\n" ++ T.unpack (body 2) ++ ")" shift [] = [] shift (x:xs) = intercalate "\n" (x : map tab xs)@@ -236,20 +238,20 @@ lambdaStr :: (MonadIO m, Lambda (SymbolicT m) a) => State -> LambdaScope -> Kind -> a -> m SMTLambda lambdaStr st scope k a = SMTLambda <$> lambdaGen scope mkLam st k a where mkLam (Defn _unints _frees Nothing body) = body 0- mkLam (Defn _unints _frees (Just params) body) = "(lambda " ++ extractAllUniversals params ++ "\n" ++ body 2 ++ ")"+ mkLam (Defn _unints _frees (Just params) body) = "(lambda " <> extractAllUniversals params <> "\n" <> body 2 <> ")" -- | Generic constraint generator.-constraintGen :: (MonadIO m, Constraint (SymbolicT m) a) => LambdaScope -> ([String] -> (Int -> String) -> b) -> State -> a -> m b+constraintGen :: (MonadIO m, Constraint (SymbolicT m) a) => LambdaScope -> ([String] -> (Int -> T.Text) -> b) -> State -> a -> m b constraintGen scope trans inState@State{rProgInfo} f = do -- indicate we have quantifiers liftIO $ modifyIORef' rProgInfo (\u -> u{hasQuants = True}) let mkDef (Defn deps _frees Nothing body) = trans deps body- mkDef (Defn deps _frees (Just params) body) = trans deps $ \i -> unwords (map mkGroup params) ++ "\n"- ++ body (i + 2)- ++ replicate (length params) ')'- mkGroup (ALL, s) = "(forall " ++ s- mkGroup (EX, s) = "(exists " ++ s+ mkDef (Defn deps _frees (Just params) body) = trans deps $ \i -> T.unwords (map mkGroup params) <> "\n"+ <> body (i + 2)+ <> T.replicate (length params) ")"+ mkGroup (ALL, s) = "(forall " <> s+ mkGroup (EX, s) = "(exists " <> s inSubState scope inState $ \st -> mkDef <$> convert st KBool (mkConstraint st f >>= output >> pure ()) @@ -268,9 +270,9 @@ -- We allow free variables here (first arg of constraintGen). This might prove to be not kosher! constraintStr :: (MonadIO m, Constraint (SymbolicT m) a) => State -> a -> m String constraintStr = constraintGen TopLevel toStr- where toStr deps body = intercalate "\n" [ "; user defined axiom: " ++ depInfo deps- , "(assert " ++ body 2 ++ ")"- ]+ where toStr deps body = T.unpack $ T.intercalate "\n" [ "; user defined axiom: " <> T.pack (depInfo deps)+ , "(assert " <> body 2 <> ")"+ ] depInfo [] = "" depInfo ds = "[Refers to: " ++ intercalate ", " ds ++ "]"@@ -344,7 +346,7 @@ ] | True = res- where res = Defn (nub [nm | Uninterpreted nm <- G.universeBi allOps])+ where res = Defn (nub [T.unpack nm | Uninterpreted nm <- G.universeBi allOps]) frees mbParam body@@ -374,29 +376,29 @@ | null params = Nothing | True = Just [(q, paramList (map snd l)) | l@((q, _) : _) <- pGroups] where pGroups = groupBy (\(q1, _) (q2, _) -> q1 == q2) params- paramList ps = '(' : unwords (map (\p -> '(' : show p ++ " " ++ smtType (kindOf p) ++ ")") ps) ++ ")"+ paramList ps = "(" <> T.unwords (map (\p -> "(" <> showText p <> " " <> smtType (kindOf p) <> ")") ps) <> ")" body tabAmnt | null constTables , null nonConstTables , Just e <- simpleBody (map (, Nothing) constBindings ++ svBindings) out- = tab ++ e+ = tab <> e | True- = intercalate "\n" $ map (tab ++) $ [mkLet sv | sv <- constBindings]- ++ [mkTable t | t <- constTables]- ++ walk svBindings nonConstTables- ++ [shift ++ show out ++ replicate totalClose ')']+ = T.intercalate "\n" $ map (tab <>) $ [mkLet sv | sv <- constBindings]+ ++ [mkTable t | t <- constTables]+ ++ walk svBindings nonConstTables+ ++ [shift <> showText out <> T.replicate totalClose ")"] - where tab = replicate tabAmnt ' '+ where tab = T.replicate tabAmnt " " - mkBind l r = shift ++ "(let ((" ++ l ++ " " ++ r ++ "))"- mkLet (s, v) = mkBind (show s) v+ mkBind l r = shift <> "(let ((" <> l <> " " <> r <> "))"+ mkLet (s, v) = mkBind (showText s) v -- Align according to level.- shift = replicate (24 + 16 * (fromMaybe 0 level - 1)) ' '+ shift = T.replicate (24 + 16 * (fromMaybe 0 level - 1)) " " - mkTable (((i, ak, rk), elts), _) = mkBind nm (lambdaTable (map (const ' ') nm) ak rk elts)- where nm = "table" ++ show i+ mkTable (((i, ak, rk), elts), _) = mkBind nm (lambdaTable (T.map (const ' ') nm) ak rk elts)+ where nm = "table" <> showText i totalClose = length constBindings + length svBindings@@ -410,7 +412,7 @@ ++ walk rest notReady where (ready, notReady) = partition (\(need, _) -> need < getLLI nd) remaining mkLocalBind (b, Nothing) = mkLet b- mkLocalBind (b, Just l) = mkLet b ++ " ; " ++ l+ mkLocalBind (b, Just l) = mkLet b <> " ; " <> T.pack l getLLI :: NodeId -> (Int, Int) getLLI (NodeId (_, mbl, i)) = (fromMaybe 0 mbl, i)@@ -420,23 +422,23 @@ -- (see https://github.com/LeventErkok/sbv/issues/733), so only do it if we're being verbose for debugging purposes. mkPretty = verbose cfg - simpleBody :: [((SV, String), Maybe String)] -> SV -> Maybe String- simpleBody [((v, e), Nothing)] o | v == o, not mkPretty || '\n' `notElem` e = Just e- simpleBody _ _ = Nothing+ simpleBody :: [((SV, T.Text), Maybe String)] -> SV -> Maybe T.Text+ simpleBody [((v, e), Nothing)] o | v == o, not mkPretty || not (T.any (== '\n') e) = Just e+ simpleBody _ _ = Nothing assignments = F.toList (pgmAssignments pgm) constants = filter ((`notElem` [falseSV, trueSV]) . fst) consts - constBindings :: [(SV, String)]+ constBindings :: [(SV, T.Text)] constBindings = map mkConst constants- where mkConst :: (SV, CV) -> (SV, String)- mkConst (sv, cv) = (sv, cvToSMTLib (roundingMode cfg) cv)+ where mkConst :: (SV, CV) -> (SV, T.Text)+ mkConst (sv, cv) = (sv, cvToSMTLib cv) - svBindings :: [((SV, String), Maybe String)]+ svBindings :: [((SV, T.Text), Maybe String)] svBindings = map mkAsgn assignments- where mkAsgn (sv, e@(SBVApp (Label l) _)) = ((sv, T.unpack $ converter e), Just l)- mkAsgn (sv, e) = ((sv, T.unpack $ converter e), Nothing)+ where mkAsgn (sv, e@(SBVApp (Label l) _)) = ((sv, converter e), Just l)+ mkAsgn (sv, e) = ((sv, converter e), Nothing) converter = cvtExp cfg curProgInfo (capabilities (solver cfg)) rm tableMap @@ -453,15 +455,15 @@ -- NB. The following is dead-code, since we ensure tbls is empty -- We used to support this, but there are issues, so dropping support -- See, for instance, https://github.com/LeventErkok/sbv/issues/664- (tableMap, constTables, nonConstTablesUnindexed) = constructTables rm consts tbls+ (tableMap, constTables, nonConstTablesUnindexed) = constructTables consts tbls -- Index each non-const table with the largest index of SV it needs nonConstTables = [ (maximum ((0, 0) : [getLLI n | SV _ n <- elts]), nct) | nct@((_, elts), _) <- nonConstTablesUnindexed] - lambdaTable :: String -> Kind -> Kind -> [SV] -> String- lambdaTable extraSpace ak rk elts = "(lambda ((" ++ lv ++ " " ++ smtType ak ++ "))" ++ space ++ chain 0 elts ++ ")"- where cnst k i = T.unpack $ cvtCV rm (mkConstCV k (i::Integer))+ lambdaTable :: T.Text -> Kind -> Kind -> [SV] -> T.Text+ lambdaTable extraSpace ak rk elts = "(lambda ((" <> lv <> " " <> smtType ak <> "))" <> space <> chain 0 elts <> ")"+ where cnst k i = cvtCV (mkConstCV k (i::Integer)) lv = "idx" @@ -469,15 +471,15 @@ long = not (null (drop 5 elts)) space | long- = "\n " ++ extraSpace+ = "\n " <> extraSpace | True = " " chain _ [] = cnst rk 0- chain _ [x] = show x- chain i (x:xs) = "(ite (= " ++ lv ++ " " ++ cnst ak i ++ ") "- ++ show x ++ space- ++ chain (i+1) xs- ++ ")"+ chain _ [x] = showText x+ chain i (x:xs) = "(ite (= " <> lv <> " " <> cnst ak i <> ") "+ <> showText x <> space+ <> chain (i+1) xs+ <> ")" {- HLint ignore module "Use second" -}
Data/SBV/List.hs view
@@ -28,7 +28,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.List ( -- * Length, emptiness@@ -762,7 +762,7 @@ = literal $ P.zip xs' ys' | True = def xs ys- where def = smtFunction "sbv.zip" + where def = smtFunction "sbv.zip" $ \x y -> [sCase| tuple (x, y) of ([], _ ) -> [] (_, [] ) -> []@@ -1348,7 +1348,7 @@ z = zIn + delta / 2 up, down :: SReal -> SReal -> SReal -> SList AlgReal- up = smtFunctionWithMeasure "EnumSymbolic.AlgReal.enumFromThenTo.up" (\start _d end -> 0 `smax` (end - start + 1), [])+ up = smtFunctionWithMeasure "EnumSymbolic.AlgReal.enumFromThenTo.up" (\start _d end -> 0 `smax` (end - start + 1), []) $ \start d end -> ite (start .> end .|| d .<= 0) [] (start .: up (start + d) d end) down = smtFunctionWithMeasure "EnumSymbolic.AlgReal.enumFromThenTo.down" (\start _d end -> 0 `smax` (start - end + 1), []) $ \start d end -> ite (start .< end .|| d .>= 0) [] (start .: down (start + d) d end)
Data/SBV/Maybe.hs view
@@ -18,7 +18,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Maybe ( -- * Constructing optional values
Data/SBV/Provers/CVC4.hs view
@@ -9,12 +9,16 @@ -- The connection to the CVC4 SMT solver ----------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Provers.CVC4(cvc4) where import Data.Char (isSpace) +import qualified Data.Text as T+ import Data.SBV.Core.Data import Data.SBV.SMT.SMT @@ -52,11 +56,14 @@ } } where -- CVC4 wants all input on one line- clean = map simpleSpace . noComment+ clean = T.map simpleSpace . noComment - noComment "" = ""- noComment (';':cs) = noComment $ dropWhile (/= '\n') cs- noComment (c:cs) = c : noComment cs+ noComment t+ | T.null t = T.empty+ | True = case T.break (== ';') t of+ (before, rest)+ | T.null rest -> before+ | True -> before <> noComment (T.dropWhile (/= '\n') (T.tail rest)) simpleSpace c | isSpace c = ' '
Data/SBV/Provers/CVC5.hs view
@@ -9,12 +9,16 @@ -- The connection to the CVC5 SMT solver ----------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-}+ {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Provers.CVC5(cvc5) where import Data.Char (isSpace) +import qualified Data.Text as T+ import Data.SBV.Core.Data import Data.SBV.SMT.SMT @@ -52,11 +56,14 @@ } } where -- CVC5 wants all input on one line- clean = map simpleSpace . noComment+ clean = T.map simpleSpace . noComment - noComment "" = ""- noComment (';':cs) = noComment $ dropWhile (/= '\n') cs- noComment (c:cs) = c : noComment cs+ noComment t+ | T.null t = T.empty+ | True = case T.break (== ';') t of+ (before, rest)+ | T.null rest -> before+ | True -> before <> noComment (T.dropWhile (/= '\n') (T.tail rest)) simpleSpace c | isSpace c = ' '
Data/SBV/Provers/Prover.hs view
@@ -15,6 +15,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -61,6 +62,7 @@ import Data.SBV.SMT.SMT import Data.SBV.SMT.Utils (debug, alignPlain) import Data.SBV.Utils.ExtractIO+import Data.SBV.Utils.Lib (showText) import Data.SBV.Utils.TDiff import Data.SBV.Lambda () -- instances only@@ -209,7 +211,7 @@ satWith cfg a = do r <- runWithQuery satArgReduce True (checkNoOptimizations >> Control.getSMTResult) cfg a SatResult <$> if validationRequested cfg then validate satArgReduce True cfg a r- else return r+ else pure r -- | Generalization of 'Data.SBV.sat' dsat :: a -> m SatResult@@ -220,7 +222,7 @@ dsatWith cfg a = do r <- runWithQuery satArgReduce True (checkNoOptimizations >> Control.getSMTResult) cfg a SatResult <$> if validationRequested cfg then validate satArgReduce True cfg a r- else return r+ else pure r -- | Generalization of 'Data.SBV.allSat' allSat :: a -> m AllSatResult@@ -231,8 +233,8 @@ allSatWith cfg a = do asr <- runWithQuery satArgReduce True (checkNoOptimizations >> Control.getAllSatResult) cfg a if validationRequested cfg then do rs' <- mapM (validate satArgReduce True cfg a) (allSatResults asr)- return asr{allSatResults = rs'}- else return asr+ pure asr{allSatResults = rs'}+ else pure asr -- | Generalization of 'Data.SBV.isSatisfiable' isSatisfiable :: a -> m Bool@@ -242,8 +244,8 @@ isSatisfiableWith :: SMTConfig -> a -> m Bool isSatisfiableWith cfg p = do r <- satWith cfg p case r of- SatResult Satisfiable{} -> return True- SatResult Unsatisfiable{} -> return False+ SatResult Satisfiable{} -> pure True+ SatResult Unsatisfiable{} -> pure False _ -> error $ "SBV.isSatisfiable: Received: " ++ show r -- | Generalization of 'Data.SBV.optimize'@@ -255,12 +257,12 @@ optimizeWith config style optGoal = do res <- runWithQuery satArgReduce True opt config optGoal if not (optimizeValidateConstraints config)- then return res+ then pure res else let v :: SMTResult -> m SMTResult v = validate satArgReduce True config optGoal in case res of LexicographicResult m -> LexicographicResult <$> v m- IndependentResult xs -> let w [] sofar = return (reverse sofar)+ IndependentResult xs -> let w [] sofar = pure (reverse sofar) w ((n, m):rest) sofar = v m >>= \m' -> w rest ((n, m') : sofar) in IndependentResult <$> w xs [] ParetoResult (b, rs) -> ParetoResult . (b, ) <$> mapM v rs@@ -273,7 +275,7 @@ , "*** Use \"sat\" for plain satisfaction" ] Just (objectives, optimizerDirectives) -> do- mapM_ (Control.send True) optimizerDirectives+ mapM_ (Control.send True . T.pack) optimizerDirectives case style of Lexicographic -> LexicographicResult <$> Control.getLexicographicOptResults@@ -302,7 +304,7 @@ -- performance benefit. satConcurrentWithAny :: Satisfiable a => SMTConfig -> [Query b] -> a -> IO (Solver, NominalDiffTime, SatResult) satConcurrentWithAny solver qs a = do (slvr,time,result) <- sbvConcurrentWithAny solver go qs a- return (slvr, time, SatResult result)+ pure (slvr, time, SatResult result) where go cfg a' q = runWithQuery satArgReduce True (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' -- | Find a satisfying assignment to a property using a single solver, but run@@ -310,7 +312,7 @@ -- finish. See 'satConcurrentWithAny' for more details. satConcurrentWithAll :: Satisfiable a => SMTConfig -> [Query b] -> a -> IO [(Solver, NominalDiffTime, SatResult)] satConcurrentWithAll solver qs a = do results <- sbvConcurrentWithAll solver go qs a- return $ (\(a',b,c) -> (a',b,SatResult c)) <$> results+ pure $ (\(a',b,c) -> (a',b,SatResult c)) <$> results where go cfg a' q = runWithQuery satArgReduce True (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' -- | A type @a@ is provable if we can turn it into a predicate, i.e., it has to return a boolean.@@ -328,7 +330,7 @@ proveWith cfg a = do r <- runWithQuery proofArgReduce False (checkNoOptimizations >> Control.getSMTResult) cfg a ThmResult <$> if validationRequested cfg then validate proofArgReduce False cfg a r- else return r+ else pure r -- | Generalization of 'Data.SBV.dprove' dprove :: a -> m ThmResult@@ -339,7 +341,7 @@ dproveWith cfg a = do r <- runWithQuery proofArgReduce False (checkNoOptimizations >> Control.getSMTResult) cfg a ThmResult <$> if validationRequested cfg then validate proofArgReduce False cfg a r- else return r+ else pure r -- | Generalization of 'Data.SBV.isVacuousProof' isVacuousProof :: a -> m Bool@@ -352,9 +354,9 @@ where check = do cs <- Control.checkSat case cs of- Control.Unsat -> return True- Control.Sat -> return False- Control.DSat{} -> return False+ Control.Unsat -> pure True+ Control.Sat -> pure False+ Control.DSat{} -> pure False Control.Unk -> error "SBV: isVacuous: Solver returned unknown!" -- | Generalization of 'Data.SBV.isTheorem'@@ -366,10 +368,10 @@ isTheoremWith cfg p = do r <- proveWith cfg p let bad = error $ "SBV.isTheorem: Received:\n" ++ show r case r of- ThmResult Unsatisfiable{} -> return True- ThmResult Satisfiable{} -> return False- ThmResult DeltaSat{} -> return False- ThmResult SatExtField{} -> return False+ ThmResult Unsatisfiable{} -> pure True+ ThmResult Satisfiable{} -> pure False+ ThmResult DeltaSat{} -> pure False+ ThmResult SatExtField{} -> pure False ThmResult Unknown{} -> bad ThmResult ProofError{} -> bad @@ -390,21 +392,21 @@ -- concurrently and return the first that finishes, killing the others proveConcurrentWithAny :: Provable a => SMTConfig -> [Query b] -> a -> IO (Solver, NominalDiffTime, ThmResult) proveConcurrentWithAny solver qs a = do (slvr,time,result) <- sbvConcurrentWithAny solver go qs a- return (slvr, time, ThmResult result)+ pure (slvr, time, ThmResult result) where go cfg a' q = runWithQuery proofArgReduce False (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' -- | Prove a property by running many queries each isolated to their own thread -- concurrently and wait for each to finish returning all results proveConcurrentWithAll :: Provable a => SMTConfig -> [Query b] -> a -> IO [(Solver, NominalDiffTime, ThmResult)] proveConcurrentWithAll solver qs a = do results <- sbvConcurrentWithAll solver go qs a- return $ (\(a',b,c) -> (a',b,ThmResult c)) <$> results+ pure $ (\(a',b,c) -> (a',b,ThmResult c)) <$> results where go cfg a' q = runWithQuery proofArgReduce False (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' -- | Validate a model obtained from the solver validate :: MonadIO m => (a -> SymbolicT m SBool) -> Bool -> SMTConfig -> a -> SMTResult -> m SMTResult validate reducer isSAT cfg p res = case res of- Unsatisfiable{} -> return res+ Unsatisfiable{} -> pure res Satisfiable _ m -> case modelBindings m of Nothing -> error "Data.SBV.validate: Impossible happened; no bindings generated during model validation." Just env -> check env@@ -419,10 +421,10 @@ , "To turn validation off, use `cfg{optimizeValidateConstraints = False}`" ] - Unknown{} -> return res- ProofError{} -> return res+ Unknown{} -> pure res+ ProofError{} -> pure res - where cant msg = return $ ProofError cfg (msg ++ [ ""+ where cant msg = pure $ ProofError cfg (msg ++ [ "" , "Unable to validate the produced model." ]) (Just res) @@ -430,8 +432,8 @@ where modelBinds = [(T.unpack n, RegularCV v) | (NamedSymVar _ n, v) <- env] notify s- | not (verbose cfg) = return ()- | True = debug cfg ["[VALIDATE] " `alignPlain` s]+ | not (verbose cfg) = pure ()+ | True = debug cfg ["[VALIDATE] " `alignPlain` T.pack s] notify $ "Validating the model. " ++ if null env then "There are no assignments." else "Assignment:" mapM_ notify [" " ++ l | l <- lines envShown]@@ -445,7 +447,7 @@ ++ [ " " ++ l | l <- lines envShown] ++ [ "" ] - wrap tag extras = return $ ProofError cfg (tag : explain ++ extras) (Just res)+ wrap tag extras = pure $ ProofError cfg (tag : explain ++ extras) (Just res) giveUp s = wrap ("Data.SBV: Cannot validate the model: " ++ s) [ "SBV's model validator is incomplete, and cannot handle this particular case."@@ -483,7 +485,7 @@ OverflowOp _ -> Just "Overflow-checking is not done concretely." Uninterpreted v | any isADT as -> Just "Models containing ADTs are currently only partially supported."- | True -> Just $ "The value depends on the uninterpreted constant " ++ show v ++ "."+ | True -> Just $ "The value depends on the uninterpreted constant " ++ T.unpack v ++ "." _ -> listToMaybe $ mapMaybe why as cstrs = S.toList $ resConstraints result@@ -507,7 +509,7 @@ -- SAT: All outputs must be true satLoop [] = do notify "All outputs are satisfied. Validation complete."- return res+ pure res satLoop (sv:svs) | kindOf sv /= KBool = giveUp $ "Output tied to " ++ show sv ++ " is non-boolean."@@ -521,7 +523,7 @@ -- Proof: At least one output must be false proveLoop [] somethingFailed | somethingFailed = do notify "Counterexample is validated."- return res+ pure res | True = do notify "Counterexample violates none of the outputs." badModel "Counter-example violates no constraints." proveLoop (sv:svs) somethingFailed@@ -574,7 +576,7 @@ let SMTProblem{smtLibPgm} = Control.runProofOn (SMTMode QueryInternal IRun isSat cfg) QueryInternal comments res - return $ render (smtLibPgm cfg)+ pure $ render (smtLibPgm cfg) checkNoOptimizations :: MonadIO m => QueryT m () checkNoOptimizations = do objectives <- Control.getObjectives@@ -591,8 +593,8 @@ instance ExtractIO m => SatisfiableM m (SymbolicT m SBool) where satArgReduce = id instance ExtractIO m => ProvableM m (SymbolicT m SBool) where proofArgReduce = id -instance ExtractIO m => SatisfiableM m SBool where satArgReduce = return-instance ExtractIO m => ProvableM m SBool where proofArgReduce = return+instance ExtractIO m => SatisfiableM m SBool where satArgReduce = pure+instance ExtractIO m => ProvableM m SBool where proofArgReduce = pure instance {-# OVERLAPPABLE #-} (ExtractIO m, SatisfiableM m a) => SatisfiableM m (SymbolicT m a) where satArgReduce a = a >>= satArgReduce instance {-# OVERLAPPABLE #-} (ExtractIO m, ProvableM m a) => ProvableM m (SymbolicT m a) where proofArgReduce a = a >>= proofArgReduce@@ -652,7 +654,7 @@ -- | Create an 'SBVs' sequence of arguments mkArgs :: MonadSymbolic m => SymValInsts as -> m (SBVs as)-mkArgs SymValsNil = return SBVsNil+mkArgs SymValsNil = pure SBVsNil mkArgs (SymValsCons insts) = SBVsCons <$> mkArgs insts <*> mkArg -- Multi-arity Functions@@ -768,14 +770,14 @@ runInThread beginTime action config = async $ do result <- action config endTime <- rnf result `seq` getCurrentTime- return (name (solver config), endTime `diffUTCTime` beginTime, result)+ pure (name (solver config), endTime `diffUTCTime` beginTime, result) -- | Perform action for all given configs, return the first one that wins. Note that we do -- not wait for the other asyncs to terminate; hopefully they'll do so quickly. sbvWithAny :: NFData b => [SMTConfig] -> (SMTConfig -> a -> IO b) -> a -> IO (Solver, NominalDiffTime, b) sbvWithAny [] _ _ = error "SBV.withAny: No solvers given!" sbvWithAny solvers what a = do beginTime <- getCurrentTime- snd `fmap` (mapM (runInThread beginTime (`what` a)) solvers >>= waitAnyFastCancel)+ snd <$> (mapM (runInThread beginTime (`what` a)) solvers >>= waitAnyFastCancel) where -- Async's `waitAnyCancel` nicely blocks; so we use this variant to ignore the -- wait part for killed threads. waitAnyFastCancel asyncs = waitAny asyncs `finally` mapM_ cancelFast asyncs@@ -783,7 +785,7 @@ sbvConcurrentWithAny :: NFData c => SMTConfig -> (SMTConfig -> a -> QueryT m b -> IO c) -> [QueryT m b] -> a -> IO (Solver, NominalDiffTime, c)-sbvConcurrentWithAny solver what queries a = snd `fmap` (mapM runQueryInThread queries >>= waitAnyFastCancel)+sbvConcurrentWithAny solver what queries a = snd <$> (mapM runQueryInThread queries >>= waitAnyFastCancel) where -- Async's `waitAnyCancel` nicely blocks; so we use this variant to ignore the -- wait part for killed threads. waitAnyFastCancel asyncs = waitAny asyncs `finally` mapM_ cancelFast asyncs@@ -797,7 +799,7 @@ where runQueryInThread q = do beginTime <- getCurrentTime runInThread beginTime (\cfg -> what cfg a q) solver - go [] = return []+ go [] = pure [] go as = do (d, r) <- waitAny as -- The following filter works because the Eq instance on Async -- checks the thread-id; so we know that we're removing the@@ -805,13 +807,13 @@ -- running the same-solver (with different options), since -- they will get different thread-ids. rs <- unsafeInterleaveIO $ go (filter (/= d) as)- return (r : rs)+ pure (r : rs) -- | Perform action for all given configs, return all the results. sbvWithAll :: NFData b => [SMTConfig] -> (SMTConfig -> a -> IO b) -> a -> IO [(Solver, NominalDiffTime, b)] sbvWithAll solvers what a = do beginTime <- getCurrentTime mapM (runInThread beginTime (`what` a)) solvers >>= (unsafeInterleaveIO . go)- where go [] = return []+ where go [] = pure [] go as = do (d, r) <- waitAny as -- The following filter works because the Eq instance on Async -- checks the thread-id; so we know that we're removing the@@ -819,7 +821,7 @@ -- running the same-solver (with different options), since -- they will get different thread-ids. rs <- unsafeInterleaveIO $ go (filter (/= d) as)- return (r : rs)+ pure (r : rs) -- | Symbolically executable program fragments. This class is mainly used for 'safe' calls, and is sufficiently populated internally to cover most use -- cases. Users can extend it as they wish to allow 'safe' checks for SBV programs that return/take types that are user-defined.@@ -847,18 +849,18 @@ verify mkRelative (msg, cs, cond) = do let locInfo ps = let loc (f, sl) = concat [mkRelative (srcLocFile sl), ":", show (srcLocStartLine sl), ":", show (srcLocStartCol sl), ":", f] in intercalate ",\n " (map loc ps)- location = (locInfo . getCallStack) `fmap` cs+ location = locInfo . getCallStack <$> cs result <- do Control.push 1- Control.send True $ "(assert " ++ show cond ++ ")"+ Control.send True $ "(assert " <> showText cond <> ")" r <- Control.getSMTResult Control.pop 1- return r+ pure r - return $ SafeResult (location, msg, result)+ pure $ SafeResult (location, msg, result) instance (ExtractIO m, NFData a) => SExecutable m (SymbolicT m a) where- sName a = a >>= \r -> rnf r `seq` return ()+ sName a = a >>= \r -> rnf r `seq` pure () instance ExtractIO m => SExecutable m (SBV a) where sName v = sName (output v :: SymbolicT m (SBV a))
Data/SBV/Rational.hs view
@@ -10,6 +10,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}
Data/SBV/SCase.hs view
@@ -14,7 +14,9 @@ -- @sCase@ are automatically treated as symbolic case-splits, enabling -- nested symbolic pattern matching. ----- Also provides `[pCase| expr of ... |]` for proof case-splits.+-- Also provides `[pCase| expr of ... |]` for proof case-splits. Plain+-- @case@ expressions inside @pCase@ are automatically treated as nested+-- proof case-splits (generating @cases [...]@ calls). ----------------------------------------------------------------------------- {-# LANGUAGE LambdaCase #-}@@ -44,9 +46,8 @@ import Prelude hiding (fail) import qualified Prelude as P(fail) -import Data.Generics+import Data.Generics (everywhereM, mkM) import qualified Data.Map.Strict as Map-import Data.Map (Map) import qualified Data.Set as Set import Data.Set (Set) @@ -485,15 +486,15 @@ -- Variable pattern at top level: binds the scrutinee (only when used) VarP v -> let bindScrut e | v `Set.member` freeVars e = LetE [ValD (VarP v) (NormalB scrut) []] e | True = e- in pure [CWild off (fmap bindScrut mbG) (bindScrut rhs) | (mbG, rhs) <- rhss]+ in pure [CWild off (bindScrut <$> mbG) (bindScrut rhs) | (mbG, rhs) <- rhss] -- As-pattern at top level: name@subpat — bind name to scrutinee, then process inner pattern AsP name subpat -> do cases <- matchToPair scrut off (Match subpat grhs locals) let bindAs e | name `Set.member` freeVars e = LetE [ValD (VarP name) (NormalB scrut) []] e | True = e- addBind (CMatch o cn ps mbG' rhs' used) = CMatch o cn ps (fmap bindAs mbG') (bindAs rhs') used- addBind (CWild o mbG' rhs') = CWild o (fmap bindAs mbG') (bindAs rhs')+ addBind (CMatch o cn ps mbG' rhs' used) = CMatch o cn ps (bindAs <$> mbG') (bindAs rhs') used+ addBind (CWild o mbG' rhs') = CWild o (bindAs <$> mbG') (bindAs rhs') pure (map addBind cases) _ -> fail Unknown $ unlines [ "sCase/pCase: Unsupported pattern:"@@ -565,6 +566,12 @@ (pat', guards, decs) <- flattenPat off arg subpat let asDec = ValD (VarP name) (NormalB arg) [] pure (pat', guards, asDec : decs)+-- Nested empty record pattern: Cstr{} — equivalent to Cstr with all wildcards+flattenPat off arg (RecP conName []) = do+ con <- getReference off conName+ DataConI _ conType _ <- reify con+ let arity = countArgs conType+ flattenPat off arg (ConP con [] (replicate arity WildP)) flattenPat o _ p = fail o $ unlines [ "sCase/pCase: Unsupported complex pattern match." , " Saw: " <> pprint p , ""@@ -575,7 +582,7 @@ -- We include a destructuring equality (arg .=== head arg .: tail arg) because lists use -- SMT Seq, not declare-datatypes, so the solver doesn't automatically know this relationship. -- This is critical for pCase proof progress; harmless for sCase (redundant guard in ite-chain).--- NB. For top-level list cons patterns in pCase, the same equality is added by processCases.+-- NB. For top-level list cons patterns in pCase, the same equality is added by processProofCases. flattenCons :: Offset -> Exp -> Pat -> Pat -> Q (Pat, [Exp], [Dec]) flattenCons off arg p1 p2 = do let headExpr = mkAccessorFor (Just BTList) (mkName ":") 1 arg@@ -968,26 +975,45 @@ go (CaseE s ms) = processCaseExp (repeat Unknown) s ms go e = pure e +-- | Transform nested @case@ expressions inside a TH 'Exp' into proof case-splits.+-- Like 'transformNestedCases', but generates @cases [cond ==> rhs, ...]@ instead of+-- @ite@ chains. This is what enables @case@ expressions inside @[pCase| ... |]@ to work+-- as nested proof case-splits.+transformNestedCasesProof :: Exp -> Q Exp+transformNestedCasesProof = everywhereM (mkM go)+ where go :: Exp -> Q Exp+ go (CaseE s ms) = processProofCaseExp s ms+ go e = pure e+ -- | Transform the matches of an outer sCase expression, resolving any nested -- @case@ expressions in the RHS and guards before the outer case processes them. transformMatches :: [Match] -> Q [Match]-transformMatches = mapM transformMatch+transformMatches = transformMatchesWith transformNestedCases++-- | Transform the matches of an outer pCase expression, resolving any nested+-- @case@ expressions in the RHS and guards as proof case-splits.+transformMatchesProof :: [Match] -> Q [Match]+transformMatchesProof = transformMatchesWith transformNestedCasesProof++-- | Generic match transformer parameterized by the nested-case handler.+transformMatchesWith :: (Exp -> Q Exp) -> [Match] -> Q [Match]+transformMatchesWith xform = mapM transformMatch where transformMatch (Match pat body locals) = do body' <- transformBody body locals' <- mapM transformDec locals pure (Match pat body' locals') - transformBody (NormalB e) = NormalB <$> transformNestedCases e+ transformBody (NormalB e) = NormalB <$> xform e transformBody (GuardedB gs) = GuardedB <$> mapM transformGuarded gs transformGuarded (g, e) = do g' <- transformGuard g- e' <- transformNestedCases e+ e' <- xform e pure (g', e') - transformGuard (NormalG e) = NormalG <$> transformNestedCases e+ transformGuard (NormalG e) = NormalG <$> xform e transformGuard (PatG ss) = PatG <$> mapM transformStmt ss - transformStmt (NoBindS e) = NoBindS <$> transformNestedCases e+ transformStmt (NoBindS e) = NoBindS <$> xform e transformStmt s = pure s transformDec (ValD p b ls) = do b' <- transformBody b@@ -1000,6 +1026,44 @@ ls' <- mapM transformDec ls pure (Clause ps b' ls') +-- | Core proof-case pipeline: given a scrutinee and matches (in TH AST form),+-- generate @cases [cond ==> rhs, ...]@. This is the proof-level counterpart of+-- 'processCaseExp', used by 'transformNestedCasesProof' to handle inner @case@+-- expressions inside @[pCase| ... |]@.+processProofCaseExp :: Exp -> [Match] -> Q Exp+processProofCaseExp scrut0 matches0 = do+ -- Recursively transform any nested case expressions as proof case-splits.+ matches <- transformMatchesProof matches0+ scrut <- transformNestedCasesProof scrut0+ mbTypeInfo <- inferType "pCase" matches+ let offsets = repeat Unknown+ case mbTypeInfo of+ Nothing -> do+ allCases <- concat <$> zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches+ loc <- location+ checkWildcard "pCase" loc allCases+ allPairs <- processProofCases scrut [] Nothing Map.empty [] allCases+ let casesName = mkName "cases"+ impliesName = mkName "==>"+ mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r)+ pure $ AppE (VarE casesName) (ListE (map mkPair allPairs))+ Just (typ, mbt) -> do+ cs <- zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches+ let cases = concat cs+ loc <- location+ cstrs <- getCstrs mbt typ+ checkWildcard "pCase" loc cases+ checkArities "pCase" typ cstrs cases+ let allGrdVars :: Map.Map Name (Set Name)+ allGrdVars = Map.fromListWith Set.union+ [ (nm, maybe Set.empty freeVars mbG)+ | CMatch _ nm _ mbG _ _ <- cases ]+ allPairs <- processProofCases scrut cstrs mbt allGrdVars [] cases+ let casesName = mkName "cases"+ impliesName = mkName "==>"+ mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r)+ pure $ AppE (VarE casesName) (ListE (map mkPair allPairs))+ -- * pCase -- | Quasi-quoter for proof case-splits.@@ -1029,9 +1093,10 @@ case metaParse fullCase of Right (CaseE scrut0 matches0) -> do -- Transform any nested case expressions in the RHS/guards of each match.- -- This ensures inner cases become symbolic before the outer case processes them.- matches <- transformMatches matches0- scrut <- transformNestedCases scrut0+ -- Inner case expressions become proof case-splits (cases [...]),+ -- just like inner cases in sCase become symbolic ite-chains.+ matches <- transformMatchesProof matches0+ scrut <- transformNestedCasesProof scrut0 mbTypeInfo <- inferType "pCase" matches case mbTypeInfo of Nothing -> do@@ -1039,7 +1104,7 @@ allCases <- concat <$> zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches loc <- location checkWildcard "pCase" loc allCases- allPairs <- processCases scrut [] Nothing Map.empty [] allCases+ allPairs <- processProofCases scrut [] Nothing Map.empty [] allCases let casesName = mkName "cases" impliesName = mkName "==>" mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r)@@ -1105,116 +1170,220 @@ cstrs <- getCstrs mbt typ -- Collect guard variables for each constructor across all arms -- (needed to suppress false "unused binding" warnings for guard-only variables)- let allGrdVars :: Map Name (Set Name)+ let allGrdVars :: Map.Map Name (Set Name) allGrdVars = Map.fromListWith Set.union [ (nm, maybe Set.empty freeVars mbG) | CMatch _ nm _ mbG _ _ <- cases ]- allPairs <- processCases scrut cstrs mbt allGrdVars [] cases+ allPairs <- processProofCases scrut cstrs mbt allGrdVars [] cases let casesName = mkName "cases" impliesName = mkName "==>" mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r) pure $ AppE (VarE casesName) (ListE (map mkPair allPairs)) - -- | Process all cases linearly, accumulating prior guards.- -- Prior guards are tagged with their constructor name (Nothing for wildcards).- -- Each entry stores (constructor, fullGuard, userGuardOnly):- -- fullGuard = the complete guard expression (used for wildcard De Morgan negation)- -- userGuardOnly = Just the user guard part (used for same-constructor negation)- -- Nothing if unguarded (same-constructor arms don't negate unguarded matches)- processCases :: Exp -> [(Name, [Type])] -> Maybe BuiltinType -> Map Name (Set Name) -> [(Maybe Name, Exp, Maybe Exp)] -> [Case] -> Q [(Exp, Exp)]- processCases _ _ _ _ _ [] = pure []- processCases scrut cstrs mbt allGrdVars priorGuards (c:rest) = case c of- CWild _ mbG rhs -> do- -- Wildcard: negate the disjunction of ALL prior full guards (De Morgan)- let allGuards = [g | (_, g, _) <- priorGuards]- baseGuard = negateAll allGuards- finalGuard = case mbG of- Nothing -> baseGuard- Just g -> sAndAll [baseGuard, g]- rest' <- processCases scrut cstrs mbt allGrdVars (priorGuards ++ [(Nothing, finalGuard, Nothing)]) rest- pure $ (finalGuard, rhs) : rest'+-- * Proof case processing - CMatch _o nm mbp mbG rhs _allUsed -> do- let ts = case lookupBase nm cstrs of- Just t -> t- Nothing -> error $ "pCase: impossible: unknown constructor " ++ nameBase nm- pats = fromMaybe (map (const WildP) ts) mbp+-- | Process all proof cases linearly, accumulating prior guards.+-- Shared between the top-level @pCase@ quasi-quoter and 'processProofCaseExp'+-- (which handles nested @case@ expressions inside @[pCase| ... |]@).+--+-- Prior guards are tagged with their constructor name (Nothing for wildcards).+-- Each entry stores (constructor, fullGuard, userGuardOnly):+--+-- * fullGuard = the complete guard expression (used for wildcard De Morgan negation)+-- * userGuardOnly = Just the user guard part (used for same-constructor negation),+-- Nothing if unguarded (same-constructor arms don't negate unguarded matches)+processProofCases :: Exp -> [(Name, [Type])] -> Maybe BuiltinType -> Map.Map Name (Set Name) -> [(Maybe Name, Exp, Maybe Exp)] -> [Case] -> Q [(Exp, Exp)]+processProofCases _ _ _ _ _ [] = pure []+processProofCases scrut cstrs mbt allGrdVars priorGuards (c:rest) = case c of+ CWild _ mbG rhs -> do+ -- Wildcard: negate the disjunction of ALL prior full guards (De Morgan)+ let allGuards = [g | (_, g, _) <- priorGuards]+ baseGuard = negateAllGuards allGuards+ finalGuard = case mbG of+ Nothing -> baseGuard+ Just g -> sAndAll [baseGuard, g]+ rest' <- processProofCases scrut cstrs mbt allGrdVars (priorGuards ++ [(Nothing, finalGuard, Nothing)]) rest+ pure $ (finalGuard, rhs) : rest' - -- Build let-bindings for pattern variables- args = [(i, mkAccessorFor mbt nm i scrut) | (i, _) <- zip [(1 :: Int) ..] ts]- bindings = [ ValD (VarP v) (NormalB acc) []- | (i, acc) <- args, VarP v <- [pats !! (i - 1)] ]+ CMatch _o nm mbp mbG rhs _allUsed -> do+ let ts = case lookupBase nm cstrs of+ Just t -> t+ Nothing -> error $ "pCase: impossible: unknown constructor " ++ nameBase nm+ pats = fromMaybe (map (const WildP) ts) mbp - testerGuard = mkTesterFor mbt nm scrut+ -- Build let-bindings for pattern variables+ args = [(i, mkAccessorFor mbt nm i scrut) | (i, _) <- zip [(1 :: Int) ..] ts]+ bindings = [ ValD (VarP v) (NormalB acc) []+ | (i, acc) <- args, VarP v <- [pats !! (i - 1)] ] - -- For list cons patterns in pCase, add a destructuring equality:- -- scrut .=== head scrut .: tail scrut- -- Lists use SMT Seq (not declare-datatypes), so the solver doesn't automatically- -- know that xs = head xs .: tail xs from sNot (null xs). We must add an explicit- -- equality to give the solver this information, mirroring what 'split' does.- -- All other types (ADTs, Maybe, Either, Tuple) use declare-datatypes and get- -- these axioms for free.- -- NB. For nested list cons patterns, the same equality is added by 'flattenCons'.- destructEq- | Just BTList <- mbt, nameBase nm == ":"- = let hd = AppE (VarE (sbvName "Data.SBV.List" "head")) scrut- tl = AppE (VarE (sbvName "Data.SBV.List" "tail")) scrut- in [foldl1 AppE [VarE '(.===), scrut, InfixE (Just hd) (VarE '(.:)) (Just tl)]]- | True- = []+ testerGuard = mkTesterFor mbt nm scrut - -- Only negate prior USER guards for the SAME constructor (others are mutually exclusive)- sameUserGuards = [ ug | (Just cn, _, Just ug) <- priorGuards, sameBase cn nm ]- negPriors = map (AppE (VarE 'sNot)) sameUserGuards+ -- For list cons patterns in pCase, add a destructuring equality:+ -- scrut .=== head scrut .: tail scrut+ -- Lists use SMT Seq (not declare-datatypes), so the solver doesn't automatically+ -- know that xs = head xs .: tail xs from sNot (null xs). We must add an explicit+ -- equality to give the solver this information, mirroring what 'split' does.+ -- All other types (ADTs, Maybe, Either, Tuple) use declare-datatypes and get+ -- these axioms for free.+ -- NB. For nested list cons patterns, the same equality is added by 'flattenCons'.+ destructEq+ | Just BTList <- mbt, nameBase nm == ":"+ = let hd = AppE (VarE (sbvName "Data.SBV.List" "head")) scrut+ tl = AppE (VarE (sbvName "Data.SBV.List" "tail")) scrut+ in [foldl1 AppE [VarE '(.===), scrut, InfixE (Just hd) (VarE '(.:)) (Just tl)]]+ | True+ = [] - -- Build the final guard (wrap user guard in bindings so pattern vars are in scope)- grdVars = maybe Set.empty freeVars mbG- grdBindings = filter (\case- ValD (VarP v) _ _ -> v `Set.member` grdVars- _ -> True) bindings- guardParts = [testerGuard] ++ destructEq ++ negPriors ++ maybe [] (pure . addLocals grdBindings) mbG- finalGuard = sAndAll guardParts+ -- Only negate prior USER guards for the SAME constructor (others are mutually exclusive)+ sameUserGuards = [ ug | (Just cn, _, Just ug) <- priorGuards, sameBase cn nm ]+ negPriors = map (AppE (VarE 'sNot)) sameUserGuards - -- Wrap RHS with let-bindings; include all bindings except those- -- used in any guard of the same constructor but not in this RHS- -- (to avoid false "unused" warnings from GHC for guard-only variables)- cstrGrdVars = Map.findWithDefault Set.empty nm allGrdVars- rhsVars = freeVars rhs- rhs' = addLocals (filter (\case- ValD (VarP v) _ _ -> not (v `Set.member` cstrGrdVars) || v `Set.member` rhsVars- _ -> True) bindings) rhs+ -- Build the final guard (wrap user guard in bindings so pattern vars are in scope)+ grdVars = maybe Set.empty freeVars mbG+ grdBindings = filter (\case+ ValD (VarP v) _ _ -> v `Set.member` grdVars+ _ -> True) bindings+ guardParts = [testerGuard] ++ destructEq ++ negPriors ++ maybe [] (pure . addLocals grdBindings) mbG+ finalGuard = sAndAll guardParts - -- Track: full guard for wildcard negation, user guard for same-constructor negation- userGuardOnly = case mbG of- Just g -> Just (addLocals grdBindings g)- Nothing -> Nothing- priorGuards' = priorGuards ++ [(Just nm, finalGuard, userGuardOnly)]+ -- Wrap RHS with let-bindings; include all bindings except those+ -- used in any guard of the same constructor but not in this RHS+ -- (to avoid false "unused" warnings from GHC for guard-only variables)+ cstrGrdVars = Map.findWithDefault Set.empty nm allGrdVars+ rhsVars = freeVars rhs+ rhs' = addLocals (filter (\case+ ValD (VarP v) _ _ -> not (v `Set.member` cstrGrdVars) || v `Set.member` rhsVars+ _ -> True) bindings) rhs - rest' <- processCases scrut cstrs mbt allGrdVars priorGuards' rest- pure $ (finalGuard, rhs') : rest'+ -- Track: full guard for wildcard negation, user guard for same-constructor negation+ userGuardOnly = case mbG of+ Just g -> Just (addLocals grdBindings g)+ Nothing -> Nothing+ priorGuards' = priorGuards ++ [(Just nm, finalGuard, userGuardOnly)] - -- | Negate the disjunction of all given guards using De Morgan: sNot (g1 .|| g2 .|| ...)- negateAll :: [Exp] -> Exp- negateAll [] = VarE 'sTrue- negateAll gs = AppE (VarE 'sNot) (foldl1 (\a b -> foldl1 AppE [VarE '(.||), a, b]) gs)+ rest' <- processProofCases scrut cstrs mbt allGrdVars priorGuards' rest+ pure $ (finalGuard, rhs') : rest' +-- | Negate the disjunction of all given guards using De Morgan: sNot (g1 .|| g2 .|| ...)+negateAllGuards :: [Exp] -> Exp+negateAllGuards [] = VarE 'sTrue+negateAllGuards gs = AppE (VarE 'sNot) (foldl1 (\a b -> foldl1 AppE [VarE '(.||), a, b]) gs)+ -- * Standalone helpers --- | Free variables = used – bound+-- | Free variables of an expression, respecting lexical scope.+-- A variable is free if it is used (VarE) and not bound by any enclosing+-- LetE, LamE, or CaseE at its use site. freeVars :: Exp -> Set Name-freeVars e = usedVars e Set.\\ boundVars e- where boundVars :: Exp -> Set Name- boundVars = everything Set.union (mkQ Set.empty f)- where f :: Pat -> Set Name- f (VarP n) = Set.singleton n- f (AsP n _) = Set.singleton n- f _ = Set.empty+freeVars = go Set.empty+ where+ go :: Set Name -> Exp -> Set Name+ go bound = \case+ VarE n -> if n `Set.member` bound then Set.empty else Set.singleton n+ ConE {} -> Set.empty+ LitE {} -> Set.empty+ AppE f x -> go bound f <> go bound x+ AppTypeE e _ -> go bound e+ InfixE ml o mr -> maybe Set.empty (go bound) ml <> go bound o <> maybe Set.empty (go bound) mr+ UInfixE l o r -> go bound l <> go bound o <> go bound r+ ParensE e -> go bound e+ CondE c t f -> go bound c <> go bound t <> go bound f+ TupE mes -> foldMap (maybe Set.empty (go bound)) mes+ UnboxedTupE mes -> foldMap (maybe Set.empty (go bound)) mes+ ListE es -> foldMap (go bound) es+ SigE e _ -> go bound e+ RecConE _ fes -> foldMap (go bound . snd) fes+ RecUpdE e fes -> go bound e <> foldMap (go bound . snd) fes+ -- Binding forms: extend the bound set in the appropriate scope+ LamE ps body -> go (bound <> patsNames ps) body+ LetE ds body -> let bound' = bound <> decsNames ds+ in foldMap (goDec bound') ds <> go bound' body+ CaseE scr ms -> go bound scr <> foldMap (goMatch bound) ms+ -- Fallback for other expression forms: conservatively report all+ -- VarE names minus known bound (may over-report, never under-report)+ other -> allVarE other Set.\\ bound - usedVars :: Exp -> Set Name- usedVars = everything Set.union (mkQ Set.empty f)- where f :: Exp -> Set Name- f (VarE n) = Set.singleton n- f _ = Set.empty+ goMatch :: Set Name -> Match -> Set Name+ goMatch bound (Match pat body ds) =+ let bound' = bound <> patNames pat <> decsNames ds+ in goBody bound' body <> foldMap (goDec bound') ds++ goBody :: Set Name -> Body -> Set Name+ goBody bound (NormalB e) = go bound e+ goBody bound (GuardedB gs) = foldMap (\(g, e) -> goGuard bound g <> go bound e) gs++ goGuard :: Set Name -> Guard -> Set Name+ goGuard bound (NormalG e) = go bound e+ goGuard _ _ = Set.empty++ goDec :: Set Name -> Dec -> Set Name+ goDec bound (ValD _ body ds) = goBody bound body <> foldMap (goDec bound) ds+ goDec bound (FunD _ cs) = foldMap (goClause bound) cs+ goDec _ _ = Set.empty++ goClause :: Set Name -> Clause -> Set Name+ goClause bound (Clause ps body ds) =+ let bound' = bound <> patsNames ps <> decsNames ds+ in goBody bound' body <> foldMap (goDec bound') ds++ -- Extract bound names from patterns+ patNames :: Pat -> Set Name+ patNames (VarP n) = Set.singleton n+ patNames (AsP n p) = Set.singleton n <> patNames p+ patNames (ConP _ _ ps) = patsNames ps+ patNames (InfixP p1 _ p2) = patNames p1 <> patNames p2+ patNames (UInfixP p1 _ p2) = patNames p1 <> patNames p2+ patNames (TupP ps) = patsNames ps+ patNames (UnboxedTupP ps) = patsNames ps+ patNames (ListP ps) = patsNames ps+ patNames (SigP p _) = patNames p+ patNames (ParensP p) = patNames p+ patNames (TildeP p) = patNames p+ patNames (BangP p) = patNames p+ patNames (ViewP _ p) = patNames p+ patNames WildP = Set.empty+ patNames (LitP _) = Set.empty+ patNames _ = Set.empty++ patsNames :: [Pat] -> Set Name+ patsNames = foldMap patNames++ -- Extract bound names from declarations+ decsNames :: [Dec] -> Set Name+ decsNames ds = Set.fromList $ [n | ValD (VarP n) _ _ <- ds] ++ [n | FunD n _ <- ds]++ -- Collect all VarE names in an expression (scope-unaware, for fallback only)+ allVarE :: Exp -> Set Name+ allVarE = \case+ VarE n -> Set.singleton n+ AppE f x -> allVarE f <> allVarE x+ AppTypeE e _ -> allVarE e+ InfixE ml o mr -> maybe Set.empty allVarE ml <> allVarE o <> maybe Set.empty allVarE mr+ UInfixE l o r -> allVarE l <> allVarE o <> allVarE r+ ParensE e -> allVarE e+ CondE c t f -> allVarE c <> allVarE t <> allVarE f+ TupE mes -> foldMap (maybe Set.empty allVarE) mes+ UnboxedTupE mes -> foldMap (maybe Set.empty allVarE) mes+ ListE es -> foldMap allVarE es+ SigE e _ -> allVarE e+ RecConE _ fes -> foldMap (allVarE . snd) fes+ RecUpdE e fes -> allVarE e <> foldMap (allVarE . snd) fes+ LamE _ body -> allVarE body+ LetE ds body -> foldMap allVarEDec ds <> allVarE body+ CaseE scr ms -> allVarE scr <> foldMap allVarEMatch ms+ _ -> Set.empty++ allVarEMatch :: Match -> Set Name+ allVarEMatch (Match _ body ds) = allVarEBody body <> foldMap allVarEDec ds++ allVarEBody :: Body -> Set Name+ allVarEBody (NormalB e) = allVarE e+ allVarEBody (GuardedB gs) = foldMap (\(_, e) -> allVarE e) gs++ allVarEDec :: Dec -> Set Name+ allVarEDec (ValD _ body ds) = allVarEBody body <> foldMap allVarEDec ds+ allVarEDec (FunD _ cs) = foldMap (\(Clause _ body ds) -> allVarEBody body <> foldMap allVarEDec ds) cs+ allVarEDec _ = Set.empty -- | Count the number of arguments in a constructor type by counting arrows. -- e.g., @Integer -> String -> Bool@ has 2 arguments.
Data/SBV/SMT/SMT.hs view
@@ -13,7 +13,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-}@@ -60,13 +62,14 @@ import Data.Either (rights) import System.Directory (findExecutable)-import System.Environment (getEnv)+import System.Environment (getEnv, lookupEnv) import System.Exit (ExitCode(..))-import System.IO (hClose, hFlush, hPutStrLn, hGetContents, hGetLine, hReady, hGetChar)+import System.IO (hClose, hFlush, hGetContents, hGetLine, hReady, hGetChar) import System.Process (runInteractiveProcess, waitForProcess, terminateProcess) import qualified Data.Map.Strict as M import qualified Data.Text as T+import qualified Data.Text.IO as TIO import Text.Read (readMaybe) import Data.SBV.Core.AlgReals@@ -82,7 +85,7 @@ ) import Data.SBV.Utils.PrettyNum-import Data.SBV.Utils.Lib (joinArgs, splitArgs, needsBars)+import Data.SBV.Utils.Lib (joinArgs, splitArgs, needsBars, showText) import Data.SBV.Utils.SExpr (parenDeficit, nameSupply) import qualified System.Timeout as Timeout (timeout)@@ -237,7 +240,7 @@ -- | Given a parsed model instance, transform it using @f@, and return the result. -- The default definition for this method should be sufficient in most use cases. cvtModel :: (a -> Maybe b) -> Maybe (a, [CV]) -> Maybe (b, [CV])- cvtModel f x = x >>= \(a, r) -> f a >>= \b -> return (b, r)+ cvtModel f x = x >>= \(a, r) -> f a >>= \b -> pure (b, r) {-# MINIMAL parseCVs #-} @@ -248,12 +251,12 @@ -- | Base case for 'SatModel' at unit type. Comes in handy if there are no real variables. instance SatModel () where- parseCVs xs = return ((), xs)+ parseCVs xs = pure ((), xs) -- | 'Bool' as extracted from a model instance SatModel Bool where parseCVs xs = do (x, r) <- genParse KBool xs- return ((x :: Integer) /= 0, r)+ pure ((x :: Integer) /= 0, r) -- | 'Word8' as extracted from a model instance SatModel Word8 where@@ -370,37 +373,37 @@ instance (SatModel a, SatModel b) => SatModel (a, b) where parseCVs as = do (a, bs) <- parseCVs as (b, cs) <- parseCVs bs- return ((a, b), cs)+ pure ((a, b), cs) -- | 3-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c) => SatModel (a, b, c) where parseCVs as = do (a, bs) <- parseCVs as ((b, c), ds) <- parseCVs bs- return ((a, b, c), ds)+ pure ((a, b, c), ds) -- | 4-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d) => SatModel (a, b, c, d) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d), es) <- parseCVs bs- return ((a, b, c, d), es)+ pure ((a, b, c, d), es) -- | 5-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e) => SatModel (a, b, c, d, e) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d, e), fs) <- parseCVs bs- return ((a, b, c, d, e), fs)+ pure ((a, b, c, d, e), fs) -- | 6-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e, SatModel f) => SatModel (a, b, c, d, e, f) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d, e, f), gs) <- parseCVs bs- return ((a, b, c, d, e, f), gs)+ pure ((a, b, c, d, e, f), gs) -- | 7-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e, SatModel f, SatModel g) => SatModel (a, b, c, d, e, f, g) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d, e, f, g), hs) <- parseCVs bs- return ((a, b, c, d, e, f, g), hs)+ pure ((a, b, c, d, e, f, g), hs) -- | Various SMT results that we can extract models out of. class Modelable a where@@ -417,7 +420,7 @@ -- | Extract a model value for a given element. Also see `getModelValues`. getModelValue :: SymVal b => String -> a -> Maybe b- getModelValue v r = fromCV `fmap` (v `M.lookup` getModelDictionary r)+ getModelValue v r = fromCV <$> (v `M.lookup` getModelDictionary r) -- | A simpler variant of 'getModelAssignment' to get a model out without the fuss. extractModel :: SatModel b => a -> Maybe b@@ -518,8 +521,8 @@ displayModels arrange disp AllSatResult{allSatResults = ms} = do let models = rights (map (getModelAssignment . SatResult) ms) inds <- zipWithM display (arrange models) [(1::Int)..]- return $ last (0:inds)- where display r i = disp i r >> return i+ pure $ last (0:inds)+ where display r i = disp i r >> pure i -- | Show an SMTResult; generic version showSMTResult :: String -> String -> String -> String -> (Maybe String -> String) -> String -> SMTResult -> String@@ -529,7 +532,7 @@ Satisfiable _ m -> satMsgModel ++ showModel cfg m DeltaSat _ p m -> dSatMsgModel p ++ showModel cfg m SatExtField _ (SMTModel b _ _ _) -> satExtMsg ++ showModelDictionary True False cfg b- Unknown _ r -> unkMsg ++ ".\n" ++ " Reason: " `alignPlain` show r+ Unknown _ r -> unkMsg ++ ".\n" ++ T.unpack (" Reason: " `alignPlain` showText r) ProofError _ [] Nothing -> "*** An error occurred. No additional information available. Try running in verbose mode." ProofError _ ls Nothing -> "*** An error occurred.\n" ++ intercalate "\n" (map ("*** " ++) ls) ProofError _ ls (Just r) -> intercalate "\n" $ [ "*** " ++ l | l <- ls]@@ -570,7 +573,7 @@ relevantVars = filter (not . ignore) allVars ignore (T.pack -> s, _) | includeEverything = False- | True = mustIgnoreVar cfg (T.unpack s)+ | True = mustIgnoreVar cfg s shM (s, RegularCV v) = let vs = shCV cfg s v in ((length s, s), (vlength vs, vs)) shM (s, other) = let vs = show other in ((length s, s), (vlength vs, vs))@@ -673,7 +676,7 @@ Just cs -> def ++ "\n" ++ cs -- | Helper function to spin off to an SMT solver.-pipeProcess :: SMTConfig -> State -> String -> [String] -> String -> (State -> IO a) -> IO a+pipeProcess :: SMTConfig -> State -> String -> [String] -> T.Text -> (State -> IO a) -> IO a pipeProcess cfg ctx execName opts pgm continuation = do mbExecPath <- findExecutable execName case mbExecPath of@@ -691,14 +694,42 @@ ]) ] +-- Communication-level timeouts (microseconds). These are NOT solver timeouts+-- (i.e., how long check-sat takes); they govern how long SBV waits for the+-- solver process to respond to individual IPC commands.+--+-- Adjust via the @SBV_COMM_TIMEOUT_FACTOR@ environment variable (default: 1).+-- For instance, setting it to 2 doubles all communication timeouts.++-- | Timeout for @set-option@ commands (expected to be fast).+setCommandTimeOut :: Int+setCommandTimeOut = 2_000_000 -- 2 seconds++-- | Timeout for subsequent response lines once the solver starts responding,+-- and for heartbeat\/sync-point reads.+defaultLineTimeOut :: Int+defaultLineTimeOut = 5_000_000 -- 5 seconds++-- | Read @SBV_COMM_TIMEOUT_FACTOR@ and return a function that scales timeout values.+-- If the variable is unset, the identity function is returned. If set to an invalid+-- value (not a positive number), an error is raised.+commTimeOutScaler :: IO (Int -> Int)+commTimeOutScaler = do+ mbFactor <- lookupEnv "SBV_COMM_TIMEOUT_FACTOR"+ case mbFactor of+ Nothing -> pure id+ Just s -> case reads s of+ [(f, "")] | f > (0 :: Double) -> pure (round . (f *) . fromIntegral)+ _ -> error $ "SBV_COMM_TIMEOUT_FACTOR: invalid value " ++ show s ++ ". Must be a positive number."+ -- | A standard engine interface. Most solvers follow-suit here in how we "chat" to them.. standardEngine :: String -> String -> SMTEngine standardEngine envName envOptName cfg ctx pgm continuation = do - execName <- getEnv envName `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (executable (solver cfg))))- execOpts <- (splitArgs `fmap` getEnv envOptName) `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (options (solver cfg) cfg)))+ execName <- getEnv envName `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (executable (solver cfg))))+ execOpts <- (splitArgs <$> getEnv envOptName) `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (options (solver cfg) cfg))) let cfg' = cfg {solver = (solver cfg) {executable = execName, options = const execOpts}} @@ -708,15 +739,15 @@ -- communicating with it. standardSolver :: SMTConfig -- ^ The current configuration -> State -- ^ Context in which we are running- -> String -- ^ The program+ -> T.Text -- ^ The program -> (State -> IO a) -- ^ The continuation -> IO a standardSolver config ctx pgm continuation = do- let msg s = debug config ["** " ++ s]+ let msg s = debug config ["** " <> s] smtSolver= solver config exec = executable smtSolver opts = options smtSolver config ++ extraArgs config- msg $ "Calling: " ++ (exec ++ (if null opts then "" else " ") ++ joinArgs opts)+ msg $ "Calling: " <> T.pack (exec ++ (if null opts then "" else " ") ++ joinArgs opts) rnf pgm `seq` pipeProcess config ctx exec opts pgm continuation -- | An internal type to track of solver interactions@@ -725,21 +756,40 @@ | SolverException String -- ^ Something else went wrong -- | A variant of @readProcessWithExitCode@; except it deals with SBV continuations-runSolver :: SMTConfig -> State -> FilePath -> [String] -> String -> (State -> IO a) -> IO a+runSolver :: SMTConfig -> State -> FilePath -> [String] -> T.Text -> (State -> IO a) -> IO a runSolver cfg ctx execPath opts pgm continuation- = do let nm = show (name (solver cfg))- msg = debug cfg . map ("*** " ++)+ = do scaler <- commTimeOutScaler + let nm = show (name (solver cfg))+ msg = debug cfg . map ("*** " <>)+ clean = preprocess (solver cfg) -- the very first command we send heartbeat = "(set-option :print-success true)" + -- Scaled communication timeouts+ setCommandTO = Just (scaler setCommandTimeOut)+ defaultLineTO = Just (scaler defaultLineTimeOut)++ -- Default SBVException with solver config baked in; callers override fields as needed+ solverException desc = SBVException { sbvExceptionDescription = desc+ , sbvExceptionSent = Nothing+ , sbvExceptionExpected = Nothing+ , sbvExceptionReceived = Nothing+ , sbvExceptionStdOut = Nothing+ , sbvExceptionStdErr = Nothing+ , sbvExceptionExitCode = Nothing+ , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } }+ , sbvExceptionReason = Nothing+ , sbvExceptionHint = Nothing+ }+ (send, ask, getResponseFromSolver, terminateSolver, cleanUp, pid) <- do (inh, outh, errh, pid) <- runInteractiveProcess execPath opts Nothing Nothing - let send :: Maybe Int -> String -> IO ()- send mbTimeOut command = do hPutStrLn inh (clean command)+ let send :: Maybe Int -> T.Text -> IO ()+ send mbTimeOut command = do TIO.hPutStrLn inh (clean command) hFlush inh recordTranscript (transcript cfg) $ SentMsg command mbTimeOut @@ -748,40 +798,34 @@ where chk cmd = cmd /= heartbeat && "(set-option :" `isPrefixOf` cmd -- Send a line, get a whole s-expr. We ignore the pathetic case that there might be a string with an unbalanced parentheses in it in a response.- ask :: Maybe Int -> String -> IO String- ask mbTimeOutGiven command =- let -- If the command is a set-option call, make sure there's a timeout on it- -- This ensures that if we try to set an option before diagnostic-output- -- is redirected to stdout and the solver chokes, then we can catch it- mbTimeOut | isSetCommand (Just command) = Just 1000000- | True = mbTimeOutGiven-- -- solvers don't respond to empty lines or comments; we just pass back+ ask :: Maybe Int -> T.Text -> IO String+ ask mbTimeOut command =+ let -- solvers don't respond to empty lines or comments; we just pass back -- success in these cases to keep the illusion of everything has a response- cmd = dropWhile isSpace command+ cmd = T.dropWhile isSpace command - in if null cmd || ";" `isPrefixOf` cmd- then return "success"+ in if T.null cmd || ";" `T.isPrefixOf` cmd+ then pure "success" else do send mbTimeOut command- getResponseFromSolver (Just command) mbTimeOut+ getResponseFromSolver (Just (T.unpack command)) mbTimeOut -- Get a response from the solver, with an optional time-out on how long- -- to wait. Note that there's *always* a time-out of 5 seconds once we get the- -- first line of response, as while the solver might take it's time to respond,+ -- to wait. Note that there's *always* a time-out once we get the+ -- first line of response, as while the solver might take its time to respond, -- once it starts responding successive lines should come quickly. getResponseFromSolver :: Maybe String -> Maybe Int -> IO String getResponseFromSolver mbCommand mbTimeOut = do response <- go True 0 [] let collated = intercalate "\n" $ reverse response recordTranscript (transcript cfg) $ RecvMsg collated- return collated+ pure collated where safeGetLine isFirst h =- let timeOutToUse | isSetCommand mbCommand = Just 2000000+ let timeOutToUse | isSetCommand mbCommand = setCommandTO | isFirst = mbTimeOut- | True = Just 5000000- timeOutMsg t | isFirst = "User specified timeout of " ++ showTimeoutValue t ++ " exceeded"- | True = "A multiline complete response wasn't received before " ++ showTimeoutValue t ++ " exceeded"+ | True = defaultLineTO+ timeOutMsg t | isFirst = "User specified timeout of " ++ T.unpack (showTimeoutValue t) ++ " exceeded"+ | True = "A multiline complete response wasn't received before " ++ T.unpack (showTimeoutValue t) ++ " exceeded" -- Like hGetLine, except it keeps getting lines if inside a string. getFullLine :: IO String@@ -798,7 +842,7 @@ if stillInside then collect True sofar'- else return sofar'+ else pure sofar' -- Carefully grab things as they are ready. But don't block! collectH handle = reverse <$> coll ""@@ -815,7 +859,7 @@ Nothing -> SolverRegular <$> getFullLine Just t -> do r <- Timeout.timeout t getFullLine case r of- Just l -> return $ SolverRegular l+ Just l -> pure $ SolverRegular l Nothing -> do out <- grab outh err <- grab errh -- in this case, if we have something on out/err pass that back as regular@@ -824,7 +868,7 @@ _ -> pure $ SolverTimeout (timeOutMsg t) go isFirst i sofar = do- errln <- safeGetLine isFirst outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (SolverException (show e))))+ errln <- safeGetLine isFirst outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (SolverException (show e)))) case errln of SolverRegular ln -> let !need = i + parenDeficit ln -- make sure we get *something*@@ -833,95 +877,78 @@ (';':_) -> True -- yes this does happen! I've seen z3 print out comments on stderr. _ -> False in case (empty, need <= 0) of- (True, _) -> do debug cfg ["[SKIP] " `alignPlain` ln]+ (True, _) -> do debug cfg ["[SKIP] " `alignPlain` T.pack ln] go isFirst need sofar (False, False) -> go False need (ln:sofar)- (False, True) -> return (ln:sofar)+ (False, True) -> pure (ln:sofar) SolverException e -> do terminateProcess pid- C.throwIO SBVException { sbvExceptionDescription = e- , sbvExceptionSent = mbCommand- , sbvExceptionExpected = Nothing- , sbvExceptionReceived = Just $ unlines (reverse sofar)- , sbvExceptionStdOut = Nothing- , sbvExceptionStdErr = Nothing- , sbvExceptionExitCode = Nothing- , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } }- , sbvExceptionReason = Nothing- , sbvExceptionHint = if "hGetLine: end of file" `isInfixOf` e- then Just [ "Solver process prematurely ended communication."- , ""- , "It is likely it was terminated because of a seg-fault."- , "Run with 'transcript=Just \"bad.smt2\"' option, and feed"- , "the generated \"bad.smt2\" file directly to the solver"- , "outside of SBV for further information."- ]- else Nothing- }+ C.throwIO (solverException e)+ { sbvExceptionSent = mbCommand+ , sbvExceptionReceived = Just $ unlines (reverse sofar)+ , sbvExceptionHint = if "hGetLine: end of file" `isInfixOf` e+ then Just [ "Solver process prematurely ended communication."+ , ""+ , "It is likely it was terminated because of a seg-fault."+ , "Run with 'transcript=Just \"bad.smt2\"' option, and feed"+ , "the generated \"bad.smt2\" file directly to the solver"+ , "outside of SBV for further information."+ ]+ else Nothing+ } SolverTimeout e -> do terminateProcess pid -- NB. Do not *wait* for the process, just quit. - C.throwIO SBVException { sbvExceptionDescription = "Timeout! " ++ e- , sbvExceptionSent = mbCommand- , sbvExceptionExpected = Nothing- , sbvExceptionReceived = Just $ unlines (reverse sofar)- , sbvExceptionStdOut = Nothing- , sbvExceptionStdErr = Nothing- , sbvExceptionExitCode = Nothing- , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } }- , sbvExceptionReason = Nothing- , sbvExceptionHint = if not (verbose cfg)- then Just ["Run with 'verbose=True' for further information"]- else Nothing- }+ C.throwIO (solverException ("Timeout! " ++ e))+ { sbvExceptionSent = mbCommand+ , sbvExceptionReceived = Just $ unlines (reverse sofar)+ , sbvExceptionHint = if not (verbose cfg)+ then Just ["Run with 'verbose=True' for further information"]+ else Nothing+ } terminateSolver = do hClose inh outMVar <- newEmptyMVar- out <- hGetContents outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (show e)))+ out <- hGetContents outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (show e))) _ <- forkIO $ C.evaluate (length out) >> putMVar outMVar ()- err <- hGetContents errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (show e)))+ err <- hGetContents errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (show e))) _ <- forkIO $ C.evaluate (length err) >> putMVar outMVar () takeMVar outMVar takeMVar outMVar- hClose outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return ()))- hClose errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return ()))- ex <- waitForProcess pid `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (ExitFailure (-999))))- return (out, err, ex)+ hClose outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure ()))+ hClose errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure ()))+ ex <- waitForProcess pid `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (ExitFailure (-999))))+ pure (out, err, ex) cleanUp maybeForwardedException = do (out, err, ex) <- terminateSolver - msg $ [ "Solver : " ++ nm- , "Exit code: " ++ show ex+ msg $ [ "Solver : " <> T.pack nm+ , "Exit code: " <> showText ex ]- ++ [ "Std-out : " ++ intercalate "\n " (lines out) | not (null out)]- ++ [ "Std-err : " ++ intercalate "\n " (lines err) | not (null err)]+ <> [ "Std-out : " <> T.pack (intercalate "\n " (lines out)) | not (null out)]+ <> [ "Std-err : " <> T.pack (intercalate "\n " (lines err)) | not (null err)] finalizeTranscript (transcript cfg) ex recordEndTime cfg ctx case (ex, maybeForwardedException) of (_, Just forwardedException) -> C.throwIO forwardedException- (ExitSuccess, _) -> return ()+ (ExitSuccess, _) -> pure () _ -> if ignoreExitCode cfg- then msg ["Ignoring non-zero exit code of " ++ show ex ++ " per user request!"]- else C.throwIO SBVException { sbvExceptionDescription = "Failed to complete the call to " ++ nm- , sbvExceptionSent = Nothing- , sbvExceptionExpected = Nothing- , sbvExceptionReceived = Nothing- , sbvExceptionStdOut = Just out- , sbvExceptionStdErr = Just err- , sbvExceptionExitCode = Just ex- , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } }- , sbvExceptionReason = Nothing- , sbvExceptionHint = if not (verbose cfg)- then Just ["Run with 'verbose=True' for further information"]- else Nothing+ then msg ["Ignoring non-zero exit code of " <> showText ex <> " per user request!"]+ else C.throwIO (solverException ("Failed to complete the call to " ++ nm))+ { sbvExceptionStdOut = Just out+ , sbvExceptionStdErr = Just err+ , sbvExceptionExitCode = Just ex+ , sbvExceptionHint = if not (verbose cfg)+ then Just ["Run with 'verbose=True' for further information"]+ else Nothing } - return (send, ask, getResponseFromSolver, terminateSolver, cleanUp, pid)+ pure (send, ask, getResponseFromSolver, terminateSolver, cleanUp, pid) - let executeSolver = do let sendAndGetSuccess :: Maybe Int -> String -> IO ()+ let executeSolver = do let sendAndGetSuccess :: Maybe Int -> T.Text -> IO () sendAndGetSuccess mbTimeOut l -- The pathetic case when the solver doesn't support queries, so we pretend it responded "success" -- Currently ABC is the only such solver.@@ -934,7 +961,7 @@ ["success"] -> debug cfg ["[GOOD] " `alignPlain` l] _ -> do debug cfg ["[FAIL] " `alignPlain` l] - let isOption = "(set-option" `isPrefixOf` dropWhile isSpace l+ let isOption = T.isPrefixOf "(set-option" (T.dropWhile isSpace l) reason | isOption = [ "Backend solver reports it does not support this option." , "Check the spelling, and if correct please report this as a"@@ -945,8 +972,8 @@ ] -- put a sync point here before we die so we consume everything- mbExtras <- (Right <$> getResponseFromSolver Nothing (Just 5000000))- `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (Left (show e))))+ mbExtras <- (Right <$> getResponseFromSolver Nothing defaultLineTO)+ `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (Left (show e)))) -- Ignore any exceptions from last sync, pointless. let extras = case mbExtras of@@ -957,16 +984,14 @@ let out = intercalate "\n" . lines $ outOrig err = intercalate "\n" . lines $ errOrig - exc = SBVException { sbvExceptionDescription = "Unexpected non-success response from " ++ nm- , sbvExceptionSent = Just l- , sbvExceptionExpected = Just "success"- , sbvExceptionReceived = Just $ r ++ "\n" ++ extras- , sbvExceptionStdOut = Just out- , sbvExceptionStdErr = Just err- , sbvExceptionExitCode = Just ex- , sbvExceptionConfig = cfg { solver = (solver cfg) {executable = execPath } }- , sbvExceptionReason = Just reason- , sbvExceptionHint = Nothing+ exc = (solverException ("Unexpected non-success response from " ++ nm))+ { sbvExceptionSent = Just (T.unpack l)+ , sbvExceptionExpected = Just "success"+ , sbvExceptionReceived = Just $ r ++ "\n" ++ extras+ , sbvExceptionStdOut = Just out+ , sbvExceptionStdErr = Just err+ , sbvExceptionExitCode = Just ex+ , sbvExceptionReason = Just reason } C.throwIO exc@@ -977,10 +1002,10 @@ -- First check that the solver supports :print-success let backend = name $ solver cfg if not (supportsCustomQueries (capabilities (solver cfg)))- then debug cfg ["** Skipping heart-beat for the solver " ++ show backend]- else do r <- ask (Just 5000000) heartbeat -- Give the solver 5s to respond, this should be plenty enough!+ then debug cfg ["** Skipping heart-beat for the solver " <> showText backend]+ else do r <- ask defaultLineTO (T.pack heartbeat) case words r of- ["success"] -> debug cfg ["[GOOD] " ++ heartbeat]+ ["success"] -> debug cfg ["[GOOD] " <> T.pack heartbeat] ["unsupported"] -> error $ unlines [ "" , "*** Backend solver (" ++ show backend ++ ") does not support the command:" , "***"@@ -1002,13 +1027,13 @@ -- For push/pop support, we require :global-declarations to be true. But not all solvers -- support this. Issue it if supported. (If not, we'll reject pop calls.) if not (supportsGlobalDecls (capabilities (solver cfg)))- then debug cfg [ "** Backend solver " ++ show backend ++ " does not support global decls."+ then debug cfg [ "** Backend solver " <> showText backend <> " does not support global decls." , "** Some incremental calls, such as pop, will be limited." ] else sendAndGetSuccess Nothing "(set-option :global-declarations true)" -- Now dump the program!- mapM_ (sendAndGetSuccess Nothing) (mergeSExpr (lines pgm))+ mapM_ (sendAndGetSuccess Nothing) (mergeSExpr (T.lines pgm)) -- Prepare the query context and ship it off let qs = QueryState { queryAsk = ask
Data/SBV/SMT/SMTLib2.hs view
@@ -35,11 +35,12 @@ import Data.SBV.SMT.Utils -import Data.SBV.Core.Symbolic ( QueryContext(..), SetOp(..), getUserName', getSV, regExpToSMTString, NROp(..)- , SMTDef(..), ResultInp(..), ProgInfo(..), SpecialRelOp(..), ADTOp(..)+import Data.SBV.Core.Symbolic ( QueryContext(..), SetOp(..), getUserName, getUserName', getSV, regExpToSMTString, NROp(..)+ , SMTDef(..), SMTLambda(..), ResultInp(..), ProgInfo(..), SpecialRelOp(..), ADTOp(..) ) import Data.SBV.Utils.PrettyNum (smtRoundingMode, cvToSMTLib)+import Data.SBV.Utils.Lib (showText) import qualified Data.Generics.Uniplate.Data as G @@ -125,7 +126,6 @@ hasTuples = not . null $ tupleArities hasRational = any isRational kindInfo hasADTs = not . null $ adtsNoRM- rm = roundingMode cfg solverCaps = capabilities (solver cfg) (needsQuantifiers, needsSpecialRels) = case curProgInfo of@@ -146,19 +146,11 @@ ] nope w = [ "*** Given problem requires support for " <> T.pack w- , "*** But the chosen solver (" <> T.pack (show (name (solver cfg))) <> ") doesn't support this feature."+ , "*** But the chosen solver (" <> showText (name (solver cfg)) <> ") doesn't support this feature." ] -- Some cases require all, some require none.- setAll reason = ["(set-logic " <> T.pack (showLogic Logic_ALL) <> ") ; " <> T.pack reason <> ", using catch-all."]-- isCVC5 = case name (solver cfg) of- CVC5 -> True- _ -> False-- -- If ALL is selected, use HO_ALL for CVC5 to get support for higher-order features. Yet another discrepancy.- showLogic Logic_ALL | isCVC5 = "HO_ALL"- showLogic l = show l+ setAll reason = [logicString cfg Logic_ALL <> " ; " <> T.pack reason <> ", using catch-all."] -- Determining the logic is surprisingly tricky! logic :: [Text]@@ -167,14 +159,13 @@ | Just l <- case [l | SetLogic l <- solverSetOptions cfg] of [] -> Nothing [l] -> Just l- ls -> let msg = T.unlines [ ""- , "*** Only one setOption call to 'setLogic' is allowed, found: " <> T.pack (show (length ls))- , "*** " <> T.unwords (map (T.pack . show) ls)- ]- in error $ T.unpack msg+ ls -> error $ T.unpack $ T.unlines [ ""+ , "*** Only one setOption call to 'setLogic' is allowed, found: " <> showText (length ls)+ , "*** " <> T.unwords (map showText ls)+ ] = case l of Logic_NONE -> ["; NB. Not setting the logic per user request of Logic_NONE"]- _ -> ["(set-logic " <> T.pack (showLogic l) <> ") ; NB. User specified."]+ _ -> [logicString cfg l <> " ; NB. User specified."] -- There's a reason why we can't handle this problem: | Just cantDo <- doesntHandle@@ -212,26 +203,25 @@ | hasFP || hasRounding = if needsQuantifiers- then ["(set-logic ALL)"]- else if hasBVs- then ["(set-logic QF_FPBV)"]- else ["(set-logic QF_FP)"]+ then [logicString cfg Logic_ALL]+ else [logicString cfg (if hasBVs then QF_FPBV else QF_FP)] -- If we're in a user query context, we'll pick ALL, otherwise -- we'll stick to some bit-vector logic based on what we see in the problem. -- This is controversial, but seems to work well in practice. | True = case ctx of- QueryExternal -> ["(set-logic ALL) ; external query, using all logics."]+ QueryExternal -> [logicString cfg Logic_ALL <> " ; external query, using all logics."] QueryInternal -> if supportsBitVectors solverCaps- then ["(set-logic " <> qs <> as <> ufs <> "BV)"]- else ["(set-logic ALL)"] -- fall-thru- where qs | not needsQuantifiers = "QF_"- | True = ""- as | not hasArrays = ""- | True = "A"- ufs | null uis && null tbls = "" -- we represent tables as UFs- | True = "UF"+ then [logicString cfg picked]+ else [logicString cfg Logic_ALL] -- fall-thru+ where picked + | needsQuantifiers = Logic_ALL+ | True = case (hasArrays, null uis && null tbls) of+ (False, False) -> QF_UFBV+ (False, True) -> QF_BV+ (True, False) -> QF_AUFBV+ (True, True) -> QF_ABV -- SBV always requires the production of models! getModels :: [Text]@@ -279,7 +269,7 @@ <> [ "; --- top level inputs ---"] <> concat [declareFun s (SBVType [kindOf s]) (userName s) | var <- inputs, let s = getSV var] <> [ "; --- optimization tracker variables ---" | not (null trackerVars) ]- <> concat [declareFun s (SBVType [kindOf s]) (Just ("tracks " <> T.pack nm)) | var <- trackerVars, let s = getSV var, let nm = getUserName' var]+ <> concat [declareFun s (SBVType [kindOf s]) (Just ("tracks " <> getUserName var)) | var <- trackerVars, let s = getSV var] <> [ "; --- constant tables ---" ] <> concatMap (uncurry (:) . mkTable) constTables <> [ "; --- non-constant tables ---" ]@@ -303,7 +293,7 @@ = "; Automatically generated by SBV. Do not modify!" : userDefs - (tableMap, constTables, nonConstTables) = constructTables rm consts tbls+ (tableMap, constTables, nonConstTables) = constructTables consts tbls delayedEqualities = concatMap snd nonConstTables @@ -346,7 +336,7 @@ userNameMap = M.fromList $ map (\nSymVar -> (getSV nSymVar, getUserName' nSymVar)) inputs userName s = case M.lookup s userNameMap of- Just u | show s /= u -> Just $ "tracks user variable " <> T.pack (show u)+ Just u | show s /= u -> Just $ "tracks user variable " <> showText u _ -> Nothing -- | Declare ADTs@@ -367,7 +357,7 @@ mkC (nm, []) = T.pack nm mkC (nm, ts) = T.pack nm <> " " <> T.unwords ['(' `T.cons` mkF (nm <> "_" <> show i) t <> ")" | (i, t) <- zip [(1::Int)..] ts]- where mkF a t = "get" <> T.pack a <> " " <> T.pack (smtType t)+ where mkF a t = "get" <> T.pack a <> " " <> smtType t singleADT :: (String, [(String, Kind)], [(String, [Kind])]) -> [Text] singleADT (tName, [], []) = ["(declare-sort " <> T.pack tName <> " 0) ; N.B. Uninterpreted sort."]@@ -384,7 +374,7 @@ : concatMap adtBody adts <> ["))"] - typeDecls = T.unwords ['(' `T.cons` T.pack name <> " " <> T.pack (show (length pks)) <> ")" | (name, pks, _) <- adts]+ typeDecls = T.unwords ['(' `T.cons` T.pack name <> " " <> showText (length pks) <> ")" | (name, pks, _) <- adts] adtBody (_, pks, cstrs) = body where (parOpen, parClose) = parParens pks@@ -407,18 +397,18 @@ | arity == 1 = error "Data.SBV.declTuple: Unexpected one-tuple" | True = (l1 <> "(par (" <> T.unwords [param i | i <- [1..arity]] <> ")") : [pre i <> proj i <> post i | i <- [1..arity]]- where l1 = "(declare-datatypes ((SBVTuple" <> T.pack (show arity) <> " " <> T.pack (show arity) <> ")) ("- l2 = T.replicate (T.length l1) " " <> "((mkSBVTuple" <> T.pack (show arity) <> " "+ where l1 = "(declare-datatypes ((SBVTuple" <> showText arity <> " " <> showText arity <> ")) ("+ l2 = T.replicate (T.length l1) " " <> "((mkSBVTuple" <> showText arity <> " " tab = T.replicate (T.length l2) " " pre 1 = l2 pre _ = tab - proj i = "(proj_" <> T.pack (show i) <> "_SBVTuple" <> T.pack (show arity) <> " " <> param i <> ")"+ proj i = "(proj_" <> showText i <> "_SBVTuple" <> showText arity <> " " <> param i <> ")" post i = if i == arity then ")))))" else "" - param i = "T" <> T.pack (show i)+ param i = "T" <> showText i -- | Find the set of tuple sizes to declare, eg (2-tuple, 5-tuple). -- NB. We do *not* need to recursively go into list/tuple kinds here,@@ -475,14 +465,12 @@ <> concat tableAssigns -- extra constraints <> map (\(isSoft, attr, v) -> "(assert" <> (if isSoft then "-soft " else " ") <> addAnnotations attr (cvtSV v) <> ")") (F.toList cstrs)- where rm = roundingMode cfg-- newKinds = Set.toList newKs+ where newKinds = Set.toList newKs declInp (getSV -> s) = declareFun s (SBVType [kindOf s]) Nothing (tableMap, allTables) = (tm, ct <> nct)- where (tm, ct, nct) = constructTables rm consts tbls+ where (tm, ct, nct) = constructTables consts tbls (tableDecls, tableAssigns) = unzip $ map mkTable allTables @@ -508,7 +496,7 @@ | True = [ "(declare-fun " <> varT <> ")" <> cmnt , "(assert (= " <> var <> " " <> def <> "))" ]- where var = T.pack $ show s+ where var = showText s varT = var <> " " <> svFunType [] s cmnt = maybe "" (" ; " <>) mbComment @@ -520,14 +508,14 @@ | s == falseSV || s == trueSV = [] | True- = defineFun cfg (s, cvtCV (roundingMode cfg) c) Nothing+ = defineFun cfg (s, cvtCV c) Nothing -- Make a function equality of nm against the internal function fun mkRelEq :: Text -> (Text, Text) -> Kind -> Text mkRelEq nm (fun, order) ak = res where lhs = "(" <> nm <> " x y)" rhs = "((_ " <> fun <> " " <> order <> ") x y)"- tk = T.pack $ smtType ak+ tk = smtType ak res = "(forall ((x " <> tk <> ") (y " <> tk <> ")) (= " <> lhs <> " " <> rhs <> "))" declUI :: ProgInfo -> (String, (Bool, Maybe [String], SBVType)) -> [Text]@@ -550,7 +538,7 @@ getDeps (_, (SMTDef _ d _ _, _)) = d mkDecl Nothing rt = "() " <> rt- mkDecl (Just p) rt = T.pack p <> " " <> rt+ mkDecl (Just p) rt = p <> " " <> rt sorted = DG.stronglyConnComp (map mkNode ds) @@ -561,7 +549,7 @@ xs -> declUserDefMulti xs declUserDef isRec (nm, (SMTDef fk deps param body, ty)) =- "; " <> T.pack nm <> " :: " <> T.pack (show ty) <> recursive <> frees <> "\n" <> s+ "; " <> T.pack nm <> " :: " <> showText ty <> recursive <> frees <> "\n" <> s where (recursive, definer) | isRec = (" [Recursive]", "define-fun-rec") | True = ("", "define-fun") @@ -569,17 +557,17 @@ frees | null otherDeps = "" | True = " [Refers to: " <> T.intercalate ", " (map T.pack otherDeps) <> "]" - decl = mkDecl param (T.pack $ smtType fk)+ decl = mkDecl param (smtType fk) - s = "(" <> definer <> " " <> T.pack nm <> " " <> decl <> "\n" <> T.pack (body 2) <> ")"+ s = "(" <> definer <> " " <> T.pack nm <> " " <> decl <> "\n" <> body 2 <> ")" -- declare a bunch of mutually-recursive functions declUserDefMulti bs = render $ map collect bs where collect (nm, (SMTDef fk deps param body, ty)) = (deps, nm, ty, "(" <> T.pack nm <> " " <> decl <> ")", body 3)- where decl = mkDecl param (T.pack $ smtType fk)+ where decl = mkDecl param (smtType fk) render defs = T.intercalate "\n" $- [ "; " <> T.intercalate ", " [T.pack n <> " :: " <> T.pack (show ty) | (_, n, ty, _, _) <- defs]+ [ "; " <> T.intercalate ", " [T.pack n <> " :: " <> showText ty | (_, n, ty, _, _) <- defs] , "(define-funs-rec" ] <> [ open i <> param d <> close1 i | (i, d) <- zip [1..] defs]@@ -589,8 +577,8 @@ param (_deps, _nm, _ty, p, _body) = p - dump (deps, nm, ty, _, body) = "; Definition of: " <> T.pack nm <> " :: " <> T.pack (show ty) <> ". [Refers to: " <> T.intercalate ", " (map T.pack deps) <> "]"- <> "\n" <> T.pack body+ dump (deps, nm, ty, _, body) = "; Definition of: " <> T.pack nm <> " :: " <> showText ty <> ". [Refers to: " <> T.intercalate ", " (map T.pack deps) <> "]"+ <> "\n" <> body ld = length defs @@ -599,12 +587,12 @@ mkTable :: (((Int, Kind, Kind), [SV]), [Text]) -> (Text, [Text]) mkTable (((i, ak, rk), _elts), is) = (decl, zipWith wrap [(0::Int)..] is <> setup)- where t = "table" <> T.pack (show i)- decl = "(declare-fun " <> t <> " (" <> T.pack (smtType ak) <> ") " <> T.pack (smtType rk) <> ")"+ where t = "table" <> showText i+ decl = "(declare-fun " <> t <> " (" <> smtType ak <> ") " <> smtType rk <> ")" -- Arrange for initializers- mkInit idx = "table" <> T.pack (show i) <> "_initializer_" <> T.pack (show (idx :: Int))- initializer = "table" <> T.pack (show i) <> "_initializer"+ mkInit idx = "table" <> showText i <> "_initializer_" <> showText (idx :: Int)+ initializer = "table" <> showText i <> "_initializer" wrap index s = "(define-fun " <> mkInit index <> " () Bool " <> s <> ")" @@ -621,32 +609,32 @@ ] nonConstTable :: (((Int, Kind, Kind), [SV]), [Text]) -> Text nonConstTable (((i, ak, rk), _elts), _) = decl- where t = "table" <> T.pack (show i)- decl = "(declare-fun " <> t <> " (" <> T.pack (smtType ak) <> ") " <> T.pack (smtType rk) <> ")"+ where t = "table" <> showText i+ decl = "(declare-fun " <> t <> " (" <> smtType ak <> ") " <> smtType rk <> ")" -constructTables :: RoundingMode -> [(SV, CV)] -> [((Int, Kind, Kind), [SV])]+constructTables :: [(SV, CV)] -> [((Int, Kind, Kind), [SV])] -> ( IM.IntMap Text -- table enumeration , [(((Int, Kind, Kind), [SV]), [Text])] -- constant tables , [(((Int, Kind, Kind), [SV]), [Text])] -- non-constant tables )-constructTables rm consts tbls = (tableMap, constTables, nonConstTables)- where allTables = [(t, genTableData rm (map fst consts) t) | t <- tbls]+constructTables consts tbls = (tableMap, constTables, nonConstTables)+ where allTables = [(t, genTableData (map fst consts) t) | t <- tbls] constTables = [(t, d) | (t, Left d) <- allTables] nonConstTables = [(t, d) | (t, Right d) <- allTables] tableMap = IM.fromList $ map grab allTables - grab (((t, _, _), _), _) = (t, "table" <> T.pack (show t))+ grab (((t, _, _), _), _) = (t, "table" <> showText t) -- Left if all constants, Right if otherwise-genTableData :: RoundingMode -> [SV] -> ((Int, Kind, Kind), [SV]) -> Either [Text] [Text]-genTableData rm consts ((i, aknd, _), elts)+genTableData :: [SV] -> ((Int, Kind, Kind), [SV]) -> Either [Text] [Text]+genTableData consts ((i, aknd, _), elts) | null post = Left (map (mkEntry . snd) pre) | True = Right (map (mkEntry . snd) (pre ++ post)) where (pre, post) = partition fst (zipWith mkElt elts [(0::Int)..])- t = "table" <> T.pack (show i)+ t = "table" <> showText i mkElt x k = (isReady, (idx, cvtSV x))- where idx = cvtCV rm (mkConstCV aknd k)+ where idx = cvtCV (mkConstCV aknd k) isReady = x `Set.member` constsSet mkEntry (idx, v) = "(= (" <> t <> " " <> idx <> ") " <> v <> ")"@@ -654,30 +642,29 @@ constsSet = Set.fromList consts svType :: SV -> Text-svType s = T.pack $ smtType (kindOf s)+svType s = smtType (kindOf s) svFunType :: [SV] -> SV -> Text svFunType ss s = "(" <> T.unwords (map svType ss) <> ") " <> svType s cvtType :: SBVType -> Text cvtType (SBVType []) = error "SBV.SMT.SMTLib2.cvtType: internal: received an empty type!"-cvtType (SBVType xs) = "(" <> T.unwords (map (T.pack . smtType) body) <> ") " <> T.pack (smtType ret)+cvtType (SBVType xs) = "(" <> T.unwords (map smtType body) <> ") " <> smtType ret where (body, ret) = (init xs, last xs) type TableMap = IM.IntMap Text -- Present an SV, simply show cvtSV :: SV -> Text-cvtSV = T.pack . show+cvtSV = showText -cvtCV :: RoundingMode -> CV -> Text-cvtCV = T.pack .* cvToSMTLib- where (.*) = (.) . (.)+cvtCV :: CV -> Text+cvtCV = cvToSMTLib getTable :: TableMap -> Int -> Text getTable m i | Just tn <- i `IM.lookup` m = tn- | True = "table" <> T.pack (show i)+ | True = "table" <> showText i cvtExp :: SMTConfig -> ProgInfo -> SolverCapabilities -> RoundingMode -> TableMap -> SBVExpr -> Text cvtExp cfg curProgInfo caps rm tableMap expr@(SBVApp _ arguments) = sh expr@@ -701,7 +688,7 @@ ensureBVOrBool = bvOp || boolOp || bad ensureBV = bvOp || bad - addRM s = s <> " " <> T.pack (smtRoundingMode rm)+ addRM s = s <> " " <> smtRoundingMode rm isZ3 = case name (solver cfg) of Z3 -> True@@ -737,7 +724,7 @@ mkAbs x cmp neg = "(ite " <> ltz <> " " <> nx <> " " <> x <> ")" where ltz = "(" <> cmp <> " " <> x <> " " <> z <> ")" nx = "(" <> neg <> " " <> x <> ")"- z = cvtCV rm (mkConstCV (kindOf (hd "liftAbs.arguments" arguments)) (0::Integer))+ z = cvtCV (mkConstCV (kindOf (hd "liftAbs.arguments" arguments)) (0::Integer)) lift2B bOp vOp | boolOp = lift2 bOp@@ -842,24 +829,24 @@ KTuple k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected tuple valued index: " ++ show k KArray k1 k2 -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected array valued index: " ++ show (k1, k2) - mkCnst = cvtCV rm . mkConstCV (kindOf i)+ mkCnst = cvtCV . mkConstCV (kindOf i) le0 = "(" <> less <> " " <> cvtSV i <> " " <> mkCnst 0 <> ")" gtl = "(" <> leq <> " " <> mkCnst l <> " " <> cvtSV i <> ")" sh (SBVApp (KindCast f t) [a]) = handleKindCast f t (cvtSV a) - sh (SBVApp (ArrayInit (Left (f, t))) [a]) = "((as const (Array " <> T.pack (smtType f) <> " " <> T.pack (smtType t) <> ")) " <> cvtSV a <> ")"- sh (SBVApp (ArrayInit (Right s)) []) = T.pack $ show s- sh (SBVApp ReadArray [a, i]) = "(select " <> cvtSV a <> " " <> cvtSV i <> ")"- sh (SBVApp WriteArray [a, i, e]) = "(store " <> cvtSV a <> " " <> cvtSV i <> " " <> cvtSV e <> ")"+ sh (SBVApp (ArrayInit (Left (f, t))) [a]) = "((as const (Array " <> smtType f <> " " <> smtType t <> ")) " <> cvtSV a <> ")"+ sh (SBVApp (ArrayInit (Right (SMTLambda s))) []) = s+ sh (SBVApp ReadArray [a, i]) = "(select " <> cvtSV a <> " " <> cvtSV i <> ")"+ sh (SBVApp WriteArray [a, i, e]) = "(store " <> cvtSV a <> " " <> cvtSV i <> " " <> cvtSV e <> ")" - sh (SBVApp (Uninterpreted nm) []) = T.pack nm- sh (SBVApp (Uninterpreted nm) args) = "(" <> T.pack nm <> " " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (Uninterpreted nm) []) = nm+ sh (SBVApp (Uninterpreted nm) args) = "(" <> nm <> " " <> T.unwords (map cvtSV args) <> ")" sh (SBVApp (ADTOp aop) args) = handleADT caps aop args - sh (SBVApp (QuantifiedBool i) []) = T.pack i- sh (SBVApp (QuantifiedBool i) args) = error $ "SBV.SMT.SMTLib2.cvtExp: unexpected arguments to quantified boolean: " ++ show (i, args)+ sh (SBVApp (QuantifiedBool i) []) = i+ sh (SBVApp (QuantifiedBool i) args) = error $ "SBV.SMT.SMTLib2.cvtExp: unexpected arguments to quantified boolean: " ++ show (T.unpack i, args) sh a@(SBVApp (SpecialRelOp k o) args) | not (null args)@@ -870,16 +857,16 @@ Nothing -> error $ unlines [ "SBV.SMT.SMTLib2.cvtExp: Cannot find " ++ show o ++ " in the special-relations list." , "Known relations: " ++ intercalate ", " (map show specialRels) ]- asrt nm fun = mkRelEq (T.pack nm) (T.pack fun, T.pack $ show order) k+ asrt nm fun = mkRelEq (T.pack nm) (T.pack fun, showText order) k in case o of IsPartialOrder nm -> asrt nm "partial-order" IsLinearOrder nm -> asrt nm "linear-order" IsTreeOrder nm -> asrt nm "tree-order" IsPiecewiseLinearOrder nm -> asrt nm "piecewise-linear-order" - sh (SBVApp (Divides n) [a]) = "((_ divisible " <> T.pack (show n) <> ") " <> cvtSV a <> ")"+ sh (SBVApp (Divides n) [a]) = "((_ divisible " <> showText n <> ") " <> cvtSV a <> ")" - sh (SBVApp (Extract i j) [a]) | ensureBV = "((_ extract " <> T.pack (show i) <> " " <> T.pack (show j) <> ") " <> cvtSV a <> ")"+ sh (SBVApp (Extract i j) [a]) | ensureBV = "((_ extract " <> showText i <> " " <> showText j <> ") " <> cvtSV a <> ")" sh (SBVApp (Rol i) [a]) | bvOp = rot "rotate_left" i a@@ -898,11 +885,11 @@ | True = bad sh (SBVApp (ZeroExtend i) [a])- | bvOp = "((_ zero_extend " <> T.pack (show i) <> ") " <> cvtSV a <> ")"+ | bvOp = "((_ zero_extend " <> showText i <> ") " <> cvtSV a <> ")" | True = bad sh (SBVApp (SignExtend i) [a])- | bvOp = "((_ sign_extend " <> T.pack (show i) <> ") " <> cvtSV a <> ")"+ | bvOp = "((_ sign_extend " <> showText i <> ") " <> cvtSV a <> ")" | True = bad sh (SBVApp op args)@@ -921,7 +908,7 @@ sh (SBVApp (Label _) [a]) = cvtSV a -- This won't be reached; but just in case! sh (SBVApp (IEEEFP (FP_Cast kFrom kTo m)) args) = handleFPCast kFrom kTo (cvtSV m) (T.unwords (map cvtSV args))- sh (SBVApp (IEEEFP w ) args) = "(" <> T.pack (show w) <> " " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (IEEEFP w ) args) = "(" <> showText w <> " " <> T.unwords (map cvtSV args) <> ")" -- Some non-linear operators are supported by z3/CVC5 specifically, so do the custom translation Otherwise -- we pass them along.@@ -930,26 +917,26 @@ sh (SBVApp (NonLinear NR_Pow) [a, b]) | isZ3 || isCVC5 = "(^ " <> cvtSV a <> " " <> cvtSV b <> ")" - sh (SBVApp (NonLinear w) args) = "(" <> T.pack (show w) <> " " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (NonLinear w) args) = "(" <> showText w <> " " <> T.unwords (map cvtSV args) <> ")" sh (SBVApp (PseudoBoolean pb) args) | hasPB = handlePB pb args' | True = reducePB pb args' where args' = map cvtSV args - sh (SBVApp (OverflowOp op) args) = "(" <> T.pack (show op) <> " " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (OverflowOp op) args) = "(" <> showText op <> " " <> T.unwords (map cvtSV args) <> ")" -- Note the unfortunate reversal in StrInRe..- sh (SBVApp (StrOp (StrInRe r)) args) = "(str.in_re " <> T.unwords (map cvtSV args) <> " " <> T.pack (regExpToSMTString r) <> ")"- sh (SBVApp (StrOp op) args) = "(" <> T.pack (show op) <> " " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (StrOp (StrInRe r)) args) = "(str.in_re " <> T.unwords (map cvtSV args) <> " " <> regExpToSMTString r <> ")"+ sh (SBVApp (StrOp op) args) = "(" <> showText op <> " " <> T.unwords (map cvtSV args) <> ")" - sh (SBVApp (RegExOp o@RegExEq{}) []) = T.pack (show o)- sh (SBVApp (RegExOp o@RegExNEq{}) []) = T.pack (show o)+ sh (SBVApp (RegExOp o@RegExEq{}) []) = showText o+ sh (SBVApp (RegExOp o@RegExNEq{}) []) = showText o -- Sequences. The only interesting thing here is that unit over KChar is a no-op since SMTLib doesn't distinguish -- Strings and Characters, but SBV does. sh (SBVApp (SeqOp (SeqUnit KChar)) [a]) = cvtSV a- sh (SBVApp (SeqOp op) args) = "(" <> T.pack (show op) <> " " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (SeqOp op) args) = "(" <> showText op <> " " <> T.unwords (map cvtSV args) <> ")" sh (SBVApp (SetOp SetEqual) args) = "(= " <> T.unwords (map cvtSV args) <> ")" sh (SBVApp (SetOp SetMember) [e, s]) = "(select " <> cvtSV s <> " " <> cvtSV e <> ")"@@ -962,8 +949,8 @@ sh (SBVApp (SetOp SetComplement) args) = "(complement " <> T.unwords (map cvtSV args) <> ")" sh (SBVApp (TupleConstructor 0) []) = "mkSBVTuple0"- sh (SBVApp (TupleConstructor n) args) = "((as mkSBVTuple" <> T.pack (show n) <> " " <> T.pack (smtType (KTuple (map kindOf args))) <> ") " <> T.unwords (map cvtSV args) <> ")"- sh (SBVApp (TupleAccess i n) [tup]) = "(proj_" <> T.pack (show i) <> "_SBVTuple" <> T.pack (show n) <> " " <> cvtSV tup <> ")"+ sh (SBVApp (TupleConstructor n) args) = "((as mkSBVTuple" <> showText n <> " " <> smtType (KTuple (map kindOf args)) <> ") " <> T.unwords (map cvtSV args) <> ")"+ sh (SBVApp (TupleAccess i n) [tup]) = "(proj_" <> showText i <> "_SBVTuple" <> showText n <> " " <> cvtSV tup <> ")" sh (SBVApp RationalConstructor [t, b]) = "(SBV.Rational " <> cvtSV t <> " " <> cvtSV b <> ")" @@ -1088,7 +1075,7 @@ ] declareFun :: SV -> SBVType -> Maybe Text -> [Text]-declareFun sv = declareName (T.pack $ show sv)+declareFun sv = declareName (showText sv) -- If we have a char, we have to make sure it's and SMTLib string of length exactly one -- If we have a rational, we have to make sure the denominator is > 0@@ -1113,8 +1100,8 @@ resultVar | needsQuant = "result" | True = s - argList = ["a" <> T.pack (show i) | (i, _) <- zip [1::Int ..] args]- argTList = ["(" <> a <> " " <> T.pack (smtType k) <> ")" | (a, k) <- zip argList args]+ argList = ["a" <> showText i | (i, _) <- zip [1::Int ..] args]+ argTList = ["(" <> a <> " " <> smtType k <> ")" | (a, k) <- zip argList args] resultExp = "(" <> s <> " " <> T.unwords argList <> ")" restrict | noCharOrRat = []@@ -1159,25 +1146,25 @@ walk _d nm f k@KString {} = f k nm walk d nm f (KList k) | charRatFree k = []- | True = let fnm = "seq" <> T.pack (show d)+ | True = let fnm = "seq" <> showText d cstrs = walk (d+1) ("(seq.nth " <> nm <> " " <> fnm <> ")") f k- in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> T.pack (smtType KUnbounded) <> ")) (=> (and (>= " <> fnm <> " 0) (< " <> fnm <> " (seq.len " <> nm <> "))) " <> hole <> "))"]+ in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> smtType KUnbounded <> ")) (=> (and (>= " <> fnm <> " 0) (< " <> fnm <> " (seq.len " <> nm <> "))) " <> hole <> "))"] walk d nm f (KSet k) | charRatFree k = []- | True = let fnm = "set" <> T.pack (show d)+ | True = let fnm = "set" <> showText d cstrs = walk (d+1) nm (\sk snm -> ["(=> (select " <> snm <> " " <> fnm <> ") " <> c <> ")" | c <- f sk fnm]) k- in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> T.pack (smtType k) <> ")) " <> hole <> ")"]- walk d nm f (KTuple ks) = let tt = "SBVTuple" <> T.pack (show (length ks))- project i = "(proj_" <> T.pack (show i) <> "_" <> tt <> " " <> nm <> ")"+ in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> smtType k <> ")) " <> hole <> ")"]+ walk d nm f (KTuple ks) = let tt = "SBVTuple" <> showText (length ks)+ project i = "(proj_" <> showText i <> "_" <> tt <> " " <> nm <> ")" nmks = [(project i, k) | (i, k) <- zip [1::Int ..] ks] in concatMap (\(n, k) -> walk (d+1) n f k) nmks walk d nm f (KArray k1 k2) | all charRatFree [k1, k2] = []- | True = let fnm = "array" <> T.pack (show d)+ | True = let fnm = "array" <> showText d cstrs = walk (d+1) ("(select " <> nm <> " " <> fnm <> ")") f k2- in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> T.pack (smtType k1) <> ")) " <> hole <> ")"]+ in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> smtType k1 <> ")) " <> hole <> ")"] walk d nm f (KADT ty dict pureFS) = let fs = [(c, map (substituteADTVars ty dict) ks) | (c, ks) <- pureFS]- nmks = [("(get" <> T.pack c <> "_" <> T.pack (show i) <> " " <> nm <> ")", k) | (c, ks) <- fs, (i, k) <- zip [(1::Int)..] ks]+ nmks = [("(get" <> T.pack c <> "_" <> showText i <> " " <> nm <> ")", k) | (c, ks) <- fs, (i, k) <- zip [(1::Int)..] ks] in concatMap (\(n, k) -> walk (d+1) n f k) nmks -----------------------------------------------------------------------------------------------@@ -1219,7 +1206,7 @@ simplify KDouble = KFP 11 53 simplify k = k - size (eb, sb) = T.pack (show eb) <> " " <> T.pack (show sb)+ size (eb, sb) = showText eb <> " " <> showText sb -- To go and back from Ints, we detour through reals cast KUnbounded (KFP eb sb) a = "(_ to_fp " <> size (eb, sb) <> ") " <> rm <> " (to_real " <> a <> ")"@@ -1232,8 +1219,8 @@ cast KFP{} (KFP eb sb) a = addRM a $ "(_ to_fp " <> size (eb, sb) <> ")" -- From float/double- cast KFP{} (KBounded False m) a = addRM a $ "(_ fp.to_ubv " <> T.pack (show m) <> ")"- cast KFP{} (KBounded True m) a = addRM a $ "(_ fp.to_sbv " <> T.pack (show m) <> ")"+ cast KFP{} (KBounded False m) a = addRM a $ "(_ fp.to_ubv " <> showText m <> ")"+ cast KFP{} (KBounded True m) a = addRM a $ "(_ fp.to_sbv " <> showText m <> ")" -- To real cast KFP{} KReal a = "fp.to_real" <> " " <> a@@ -1242,7 +1229,7 @@ cast f d _ = error $ "SBV.SMTLib2: Unexpected FPCast from: " ++ show f ++ " to " ++ show d rot :: Text -> Int -> SV -> Text-rot o c x = "((_ " <> o <> " " <> T.pack (show c) <> ") " <> cvtSV x <> ")"+rot o c x = "((_ " <> o <> " " <> showText c <> ") " <> cvtSV x <> ")" shft :: Text -> Text -> SV -> SV -> Text shft oW oS x c = "(" <> o <> " " <> cvtSV x <> " " <> cvtSV c <> ")"@@ -1254,13 +1241,13 @@ [] -> f _ -> "(" <> f <> " " <> T.unwords (map cvtSV args) <> ")" where f = case op of- ADTConstructor nm k -> ascribe (T.pack nm) k+ ADTConstructor nm k -> ascribe nm k ADTTester nm k -> if supportsDirectTesters caps- then T.pack nm- else ascribe (T.pack nm) k- ADTAccessor nm _ -> T.pack nm+ then nm+ else ascribe nm k+ ADTAccessor nm _ -> nm - ascribe nm k = "(as " <> nm <> " " <> T.pack (smtType k) <> ")"+ ascribe nm k = "(as " <> nm <> " " <> smtType k <> ")" -- Various casts handleKindCast :: Kind -> Kind -> Text -> Text@@ -1277,7 +1264,7 @@ KUnbounded -> case kTo of KReal -> "(to_real " <> a <> ")"- KBounded _ n -> "((_ int_to_bv " <> T.pack (show n) <> ") " <> a <> ")"+ KBounded _ n -> "((_ int_to_bv " <> showText n <> ") " <> a <> ")" _ -> tryFPCast KReal -> case kTo of@@ -1290,7 +1277,7 @@ -- Otherwise complain tryFPCast | any (\k -> isFloat k || isDouble k) [kFrom, kTo]- = handleFPCast kFrom kTo (T.pack $ smtRoundingMode RoundNearestTiesToEven) a+ = handleFPCast kFrom kTo (smtRoundingMode RoundNearestTiesToEven) a | True = error $ "SBV.SMTLib2: Unexpected cast from: " ++ show kFrom ++ " to " ++ show kTo @@ -1299,36 +1286,36 @@ | m == n = a | True = extract (n - 1) - signExtend i = "((_ sign_extend " <> T.pack (show i) <> ") " <> a <> ")"- zeroExtend i = "((_ zero_extend " <> T.pack (show i) <> ") " <> a <> ")"- extract i = "((_ extract " <> T.pack (show i) <> " 0) " <> a <> ")"+ signExtend i = "((_ sign_extend " <> showText i <> ") " <> a <> ")"+ zeroExtend i = "((_ zero_extend " <> showText i <> ") " <> a <> ")"+ extract i = "((_ extract " <> showText i <> " 0) " <> a <> ")" -- Translation of pseudo-booleans, in case the solver supports them handlePB :: PBOp -> [Text] -> Text-handlePB (PB_AtMost k) args = "((_ at-most " <> T.pack (show k) <> ") " <> T.unwords args <> ")"-handlePB (PB_AtLeast k) args = "((_ at-least " <> T.pack (show k) <> ") " <> T.unwords args <> ")"-handlePB (PB_Exactly k) args = "((_ pbeq " <> T.unwords (map (T.pack . show) (k : replicate (length args) 1)) <> ") " <> T.unwords args <> ")"-handlePB (PB_Eq cs k) args = "((_ pbeq " <> T.unwords (map (T.pack . show) (k : cs)) <> ") " <> T.unwords args <> ")"-handlePB (PB_Le cs k) args = "((_ pble " <> T.unwords (map (T.pack . show) (k : cs)) <> ") " <> T.unwords args <> ")"-handlePB (PB_Ge cs k) args = "((_ pbge " <> T.unwords (map (T.pack . show) (k : cs)) <> ") " <> T.unwords args <> ")"+handlePB (PB_AtMost k) args = "((_ at-most " <> showText k <> ") " <> T.unwords args <> ")"+handlePB (PB_AtLeast k) args = "((_ at-least " <> showText k <> ") " <> T.unwords args <> ")"+handlePB (PB_Exactly k) args = "((_ pbeq " <> T.unwords (map showText (k : replicate (length args) 1)) <> ") " <> T.unwords args <> ")"+handlePB (PB_Eq cs k) args = "((_ pbeq " <> T.unwords (map showText (k : cs)) <> ") " <> T.unwords args <> ")"+handlePB (PB_Le cs k) args = "((_ pble " <> T.unwords (map showText (k : cs)) <> ") " <> T.unwords args <> ")"+handlePB (PB_Ge cs k) args = "((_ pbge " <> T.unwords (map showText (k : cs)) <> ") " <> T.unwords args <> ")" -- Translation of pseudo-booleans, in case the solver does *not* support them reducePB :: PBOp -> [Text] -> Text reducePB op args = case op of- PB_AtMost k -> "(<= " <> addIf (repeat 1) <> " " <> T.pack (show k) <> ")"- PB_AtLeast k -> "(>= " <> addIf (repeat 1) <> " " <> T.pack (show k) <> ")"- PB_Exactly k -> "(= " <> addIf (repeat 1) <> " " <> T.pack (show k) <> ")"- PB_Le cs k -> "(<= " <> addIf cs <> " " <> T.pack (show k) <> ")"- PB_Ge cs k -> "(>= " <> addIf cs <> " " <> T.pack (show k) <> ")"- PB_Eq cs k -> "(= " <> addIf cs <> " " <> T.pack (show k) <> ")"+ PB_AtMost k -> "(<= " <> addIf (repeat 1) <> " " <> showText k <> ")"+ PB_AtLeast k -> "(>= " <> addIf (repeat 1) <> " " <> showText k <> ")"+ PB_Exactly k -> "(= " <> addIf (repeat 1) <> " " <> showText k <> ")"+ PB_Le cs k -> "(<= " <> addIf cs <> " " <> showText k <> ")"+ PB_Ge cs k -> "(>= " <> addIf cs <> " " <> showText k <> ")"+ PB_Eq cs k -> "(= " <> addIf cs <> " " <> showText k <> ")" where addIf :: [Int] -> Text- addIf cs = "(+ " <> T.unwords ["(ite " <> a <> " " <> T.pack (show c) <> " 0)" | (a, c) <- zip args cs] <> ")"+ addIf cs = "(+ " <> T.unwords ["(ite " <> a <> " " <> showText c <> " 0)" | (a, c) <- zip args cs] <> ")" -- | Translate an option setting to SMTLib. Note the SetLogic/SetInfo discrepancy. setSMTOption :: SMTConfig -> SMTOption -> Text setSMTOption cfg = set- where set (DiagnosticOutputChannel f) = opt [":diagnostic-output-channel", T.pack $ show f]+ where set (DiagnosticOutputChannel f) = opt [":diagnostic-output-channel", showText f] set (ProduceAssertions b) = opt [":produce-assertions", smtBool b] set (ProduceAssignments b) = opt [":produce-assignments", smtBool b] set (ProduceProofs b) = opt [":produce-proofs", smtBool b]@@ -1336,30 +1323,47 @@ set (ProduceUnsatAssumptions b) = opt [":produce-unsat-assumptions", smtBool b] set (ProduceUnsatCores b) = opt [":produce-unsat-cores", smtBool b] set (ProduceAbducts b) = opt [":produce-abducts", smtBool b]- set (RandomSeed i) = opt [":random-seed", T.pack $ show i]- set (ReproducibleResourceLimit i) = opt [":reproducible-resource-limit", T.pack $ show i]- set (SMTVerbosity i) = opt [":verbosity", T.pack $ show i]+ set (RandomSeed i) = opt [":random-seed", showText i]+ set (ReproducibleResourceLimit i) = opt [":reproducible-resource-limit", showText i]+ set (SMTVerbosity i) = opt [":verbosity", showText i] set (OptionKeyword k as) = opt (T.pack k : map T.pack as)- set (SetLogic l) = logic l+ set (SetLogic l) = logicString cfg l set (SetInfo k as) = info (T.pack k : map T.pack as) set (SetTimeOut i) = opt $ timeOut i opt xs = "(set-option " <> T.unwords xs <> ")" info xs = "(set-info " <> T.unwords xs <> ")" - logic Logic_NONE = "; NB. not setting the logic per user request of Logic_NONE"- logic l = "(set-logic " <> T.pack (show l) <> ")"- -- timeout is not standard. We distinguish between CVC/Z3. All else follows z3 -- The value is in milliseconds, which is how z3/CVC interpret it timeOut i = case name (solver cfg) of- CVC4 -> [":tlimit-per", T.pack $ show i]- CVC5 -> [":tlimit-per", T.pack $ show i]- _ -> [":timeout", T.pack $ show i]+ CVC4 -> [":tlimit-per", showText i]+ CVC5 -> [":tlimit-per", showText i]+ _ -> [":timeout", showText i] -- SMTLib's True/False is spelled differently than Haskell's. smtBool :: Bool -> Text smtBool True = "true" smtBool False = "false"++-- | Set the logic, accounting for solver inconsistencies.+logicString :: SMTConfig -> Logic -> Text+logicString cfg = pick+ where+ slvr = name (solver cfg)++ -- This is more or less showText, but with exceptions:+ --+ -- Logic_ALL : HO_ALL for CVC5 to get support for higher-order features.+ -- QF_FPBV : Bitwuzla calls it QF_BVFP. See: https://github.com/LeventErkok/sbv/issues/774+ -- Logic_NONE: Sets nothing, just sets a comment+ pick Logic_ALL | CVC5 <- slvr = wrap "HO_ALL"+ pick QF_FPBV | Bitwuzla <- slvr = wrap "QF_BVFP"+ pick Logic_NONE = "; NB. not setting the logic per user request of Logic_NONE"++ -- Fall thru+ pick l = wrap (showText l)++ wrap l = "(set-logic " <> l <> ")" {- HLint ignore module "Use record patterns" -}
Data/SBV/SMT/Utils.hs view
@@ -19,7 +19,6 @@ , SMTLibIncConverter , addAnnotations , showTimeoutValue- , alignDiagnostic , alignPlain , debug , mergeSExpr@@ -40,7 +39,7 @@ import Data.SBV.Core.Data import Data.SBV.Core.Symbolic (QueryContext, CnstMap, SMTDef, ResultInp(..), ProgInfo(..), startTime) -import Data.SBV.Utils.Lib (joinArgs)+import Data.SBV.Utils.Lib (joinArgs, showText) import Data.SBV.Utils.TDiff (Timing(..), showTDiff) import Data.IORef (writeIORef)@@ -48,12 +47,12 @@ import Data.Char (isSpace) import Data.Maybe (fromMaybe)-import Data.List (intercalate) import qualified Data.Set as Set (Set) import qualified Data.Sequence as S (Seq) -import qualified Data.Text as T+import qualified Data.Text as T+import qualified Data.Text.IO as TIO import Data.Text (Text) import System.Directory (findExecutable)@@ -98,63 +97,67 @@ sanitize c = [c] -- | Show a millisecond time-out value somewhat nicely-showTimeoutValue :: Int -> String+showTimeoutValue :: Int -> Text showTimeoutValue i = case (i `quotRem` 1000000, i `quotRem` 500000) of- ((s, 0), _) -> shows s "s"- (_, (hs, 0)) -> shows (fromIntegral hs / (2::Float)) "s"- _ -> shows i "ms"+ ((s, 0), _) -> showText s <> "s"+ (_, (hs, 0)) -> showText (fromIntegral hs / (2::Float)) <> "s"+ _ -> showText i <> "ms" -- | Nicely align a potentially multi-line message with some tag, but prefix with three stars-alignDiagnostic :: String -> String -> String+alignDiagnostic :: Text -> Text -> Text alignDiagnostic = alignWithPrefix "*** " -- | Nicely align a potentially multi-line message with some tag, no prefix.-alignPlain :: String -> String -> String+alignPlain :: Text -> Text -> Text alignPlain = alignWithPrefix "" -- | Align with some given prefix-alignWithPrefix :: String -> String -> String -> String-alignWithPrefix pre tag multi = intercalate "\n" $ zipWith (++) (tag : repeat (pre ++ replicate (length tag - length pre) ' ')) (filter (not . null) (lines multi))+alignWithPrefix :: Text -> Text -> Text -> Text+alignWithPrefix pre tag multi = T.intercalate "\n" $ zipWith (<>) (tag : repeat (pre <> T.replicate (T.length tag - T.length pre) " ")) (filter (not . T.null) (T.lines multi)) -- | Diagnostic message when verbose-debug :: MonadIO m => SMTConfig -> [String] -> m ()+debug :: MonadIO m => SMTConfig -> [Text] -> m () debug cfg- | not (verbose cfg) = const (return ())- | Just f <- redirectVerbose cfg = liftIO . mapM_ (appendFile f . (++ "\n"))- | True = liftIO . mapM_ putStrLn+ | not (verbose cfg) = const (pure ())+ | Just f <- redirectVerbose cfg = liftIO . mapM_ (\t -> TIO.appendFile f (t <> "\n"))+ | True = liftIO . mapM_ TIO.putStrLn -- | In case the SMT-Lib solver returns a response over multiple lines, compress them so we have -- each S-Expression spanning only a single line.-mergeSExpr :: [String] -> [String]+mergeSExpr :: [Text] -> [Text] mergeSExpr [] = [] mergeSExpr (x:xs) | d == 0 = x : mergeSExpr xs- | True = let (f, r) = grab d xs in unlines (x:f) : mergeSExpr r+ | True = let (f, r) = grab d xs in T.unlines (x:f) : mergeSExpr r where d = parenDiff x - parenDiff :: String -> Int+ parenDiff :: Text -> Int parenDiff = go 0- where go i "" = i- go i ('(':cs) = let i'= i+1 in i' `seq` go i' cs- go i (')':cs) = let i'= i-1 in i' `seq` go i' cs- go i ('"':cs) = go i (skipString cs)- go i ('|':cs) = go i (skipBar cs)- go i (';':cs) = go i (drop 1 (dropWhile (/= '\n') cs))- go i (_ :cs) = go i cs+ where go i t = case T.uncons t of+ Nothing -> i+ Just ('(', r) -> let i' = i+1 in i' `seq` go i' r+ Just (')', r) -> let i' = i-1 in i' `seq` go i' r+ Just ('"', r) -> go i (skipString r)+ Just ('|', r) -> go i (skipBar r)+ Just (';', r) -> go i (T.drop 1 (T.dropWhile (/= '\n') r))+ Just (_, r) -> go i r grab i ls | i <= 0 = ([], ls) grab _ [] = ([], []) grab i (l:ls) = let (a, b) = grab (i+parenDiff l) ls in (l:a, b) - 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 t = case T.uncons t of+ Nothing -> T.empty -- Oh dear, line finished, but the string didn't. We're in trouble. Ignore!+ Just ('"', r) -> case T.uncons r of+ Just ('"', r') -> skipString r' -- escaped quote+ _ -> r -- end of string+ Just (_, r) -> skipString r - skipBar ('|':cs) = cs- skipBar (_:cs) = skipBar cs- skipBar [] = [] -- Oh dear, line finished, but the string didn't. We're in trouble. Ignore!+ skipBar t = case T.uncons t of+ Nothing -> T.empty -- Oh dear, line finished, but the bar didn't. We're in trouble. Ignore!+ Just ('|', r) -> r+ Just (_, r) -> skipBar r -- | An exception thrown from SBV. If the solver ever responds with a non-success value for a command, -- SBV will throw an t'SBVException', it so the user can process it as required. The provided 'Show' instance@@ -192,42 +195,42 @@ } = let grp1 = [ ""- , "*** Data.SBV: " ++ sbvExceptionDescription ++ ":"+ , "*** Data.SBV: " <> T.pack sbvExceptionDescription <> ":" ] - grp2 = ["*** Sent : " `alignDiagnostic` snt | Just snt <- [sbvExceptionSent], not $ null snt ]- ++ ["*** Expected : " `alignDiagnostic` excp | Just excp <- [sbvExceptionExpected], not $ null excp]- ++ ["*** Received : " `alignDiagnostic` rcvd | Just rcvd <- [sbvExceptionReceived], not $ null rcvd]+ grp2 = ["*** Sent : " `alignDiagnostic` T.pack snt | Just snt <- [sbvExceptionSent], not $ null snt ]+ <> ["*** Expected : " `alignDiagnostic` T.pack excp | Just excp <- [sbvExceptionExpected], not $ null excp]+ <> ["*** Received : " `alignDiagnostic` T.pack rcvd | Just rcvd <- [sbvExceptionReceived], not $ null rcvd] - grp3 = ["*** Stdout : " `alignDiagnostic` out | Just out <- [sbvExceptionStdOut], not $ null out ]- ++ ["*** Stderr : " `alignDiagnostic` err | Just err <- [sbvExceptionStdErr], not $ null err ]- ++ ["*** Exit code : " `alignDiagnostic` show ec | Just ec <- [sbvExceptionExitCode] ]- ++ ["*** Executable: " `alignDiagnostic` executable (solver sbvExceptionConfig) ]- ++ ["*** Options : " `alignDiagnostic` joinArgs (options (solver sbvExceptionConfig) sbvExceptionConfig) ]+ grp3 = ["*** Stdout : " `alignDiagnostic` T.pack out | Just out <- [sbvExceptionStdOut], not $ null out ]+ <> ["*** Stderr : " `alignDiagnostic` T.pack err | Just err <- [sbvExceptionStdErr], not $ null err ]+ <> ["*** Exit code : " `alignDiagnostic` showText ec | Just ec <- [sbvExceptionExitCode] ]+ <> ["*** Executable: " `alignDiagnostic` T.pack (executable (solver sbvExceptionConfig)) ]+ <> ["*** Options : " `alignDiagnostic` T.pack (joinArgs (options (solver sbvExceptionConfig) sbvExceptionConfig))] - grp4 = ["*** Reason : " `alignDiagnostic` unlines rsn | Just rsn <- [sbvExceptionReason]]- ++ ["*** Hint : " `alignDiagnostic` unlines hnt | Just hnt <- [sbvExceptionHint ]]+ grp4 = ["*** Reason : " `alignDiagnostic` T.pack (unlines rsn) | Just rsn <- [sbvExceptionReason]]+ <> ["*** Hint : " `alignDiagnostic` T.pack (unlines hnt) | Just hnt <- [sbvExceptionHint ]] join [] = [] join [x] = x join (g:gs) = case join gs of [] -> g- rest -> g ++ ["***"] ++ rest+ rest -> g <> ["***"] <> rest - in unlines $ join [grp1, grp2, grp3, grp4]+ in T.unpack $ T.unlines $ join [grp1, grp2, grp3, grp4] -- | Compute and report the end time recordEndTime :: SMTConfig -> State -> IO () recordEndTime SMTConfig{timing} state = case timing of- NoTiming -> return ()+ NoTiming -> pure () PrintTiming -> do e <- elapsed putStrLn $ "*** SBV: Elapsed time: " ++ showTDiff e SaveTiming here -> writeIORef here =<< elapsed- where elapsed = getCurrentTime >>= \end -> return $ diffUTCTime end (startTime state)+ where elapsed = getCurrentTime >>= \end -> pure $ diffUTCTime end (startTime state) -- | Start a transcript file, if requested. startTranscript :: Maybe FilePath -> SMTConfig -> IO ()-startTranscript Nothing _ = return ()+startTranscript Nothing _ = pure () startTranscript (Just f) cfg = do ts <- show <$> getZonedTime mbExecPath <- findExecutable (executable (solver cfg)) writeFile f $ start ts mbExecPath@@ -246,7 +249,7 @@ -- | Finish up the transcript file. finalizeTranscript :: Maybe FilePath -> ExitCode -> IO ()-finalizeTranscript Nothing _ = return ()+finalizeTranscript Nothing _ = pure () finalizeTranscript (Just f) ec = do ts <- show <$> getZonedTime appendFile f $ end ts where end ts = unlines [ ""@@ -260,31 +263,31 @@ ] -- Kind of things we can record-data TranscriptMsg = SentMsg String (Maybe Int) -- ^ Message sent, and time-out if any+data TranscriptMsg = SentMsg Text (Maybe Int) -- ^ Message sent, and time-out if any | RecvMsg String -- ^ Message received- | DebugMsg String -- ^ A debug message; neither sent nor received+ | DebugMsg Text -- ^ A debug message; neither sent nor received -- If requested, record in the transcript file recordTranscript :: Maybe FilePath -> TranscriptMsg -> IO ()-recordTranscript Nothing _ = return ()+recordTranscript Nothing _ = pure () recordTranscript (Just f) m = do tsPre <- formatTime defaultTimeLocale "; [%T%Q" <$> getZonedTime let ts = take 15 $ tsPre ++ repeat '0' case m of- SentMsg sent mbTimeOut -> appendFile f $ unlines $ (ts ++ "] " ++ to mbTimeOut ++ "Sending:") : lines sent+ SentMsg sent mbTimeOut -> TIO.appendFile f $ T.unlines $ (T.pack ts <> "] " <> to mbTimeOut <> "Sending:") : T.lines sent RecvMsg recv -> appendFile f $ unlines $ case lines (dropWhile isSpace recv) of [] -> [ts ++ "] Received: <NO RESPONSE>"] -- can't really happen. [x] -> [ts ++ "] Received: " ++ x] xs -> (ts ++ "] Received: ") : map ("; " ++) xs- DebugMsg msg -> let tag = ts ++ "] "- emp = ';' : drop 1 (map (const ' ') tag)- in appendFile f $ unlines $ zipWith (++) (tag : repeat emp) (lines msg)+ DebugMsg msg -> let tag = T.pack ts <> "] "+ emp = T.cons ';' (T.replicate (T.length tag - 1) " ")+ in TIO.appendFile f $ T.unlines $ zipWith (<>) (tag : repeat emp) (T.lines msg) where to Nothing = ""- to (Just i) = "[Timeout: " ++ showTimeoutValue i ++ "] "+ to (Just i) = "[Timeout: " <> showTimeoutValue i <> "] " {-# INLINE recordTranscript #-} -- Record the exception recordException :: Maybe FilePath -> String -> IO ()-recordException Nothing _ = return ()+recordException Nothing _ = pure () recordException (Just f) m = do ts <- show <$> getZonedTime appendFile f $ exc ts where exc ts = unlines $ [ ""
Data/SBV/Set.hs view
@@ -22,7 +22,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}
Data/SBV/TP.hs view
@@ -48,7 +48,10 @@ , sorry -- * Running TP proofs- , TP, runTP, runTPWith, tpQuiet, tpRibbon, tpStats, tpAsms+ , TP, runTP, runTPWith, tpQuiet, tpStats, tpAsms++ -- * Dry run guards+ , whenDryRun, unlessDryRun -- * Measure helpers for smtFunctionWithMeasure , measureLemma, measureLemmaWith
Data/SBV/TP/Kernel.hs view
@@ -14,6 +14,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -42,6 +43,7 @@ import Data.SBV.SMT.SMT import Data.SBV.Core.Model import Data.SBV.Provers.Prover+import Data.SBV.Utils.Lib (showText) import Data.SBV.TP.Utils @@ -259,34 +261,36 @@ -- measureLemma proof uses the function whose measure is currently being checked. checkNewMeasures :: SMTConfig -> State -> TPState -> IO () checkNewMeasures cfg@SMTConfig{tpOptions = TPOptions{measuresBeingVerified}} st tpSt = do- checks <- readIORef (rMeasureChecks st)- verified <- readIORef (measuresVerified tpSt)- productive <- readIORef (productiveVerified tpSt)- let allVerified = verified `Set.union` productive- allNames = Set.fromList (map (\(n, _, _) -> n) checks)- new = [(n, p, c) | (n, p, c) <- checks, n `Set.notMember` allVerified, n `Set.notMember` measuresBeingVerified]- skipped = [n | (n, _, _) <- checks, n `Set.notMember` allVerified, n `Set.member` measuresBeingVerified]+ isDry <- readIORef (dryRun tpSt)+ unless isDry $ do+ checks <- readIORef (rMeasureChecks st)+ verified <- readIORef (measuresVerified tpSt)+ productive <- readIORef (productiveVerified tpSt)+ let allVerified = verified `Set.union` productive+ allNames = Set.fromList (map (\(n, _, _) -> n) checks)+ new = [(n, p, c) | (n, p, c) <- checks, n `Set.notMember` allVerified, n `Set.notMember` measuresBeingVerified]+ skipped = [n | (n, _, _) <- checks, n `Set.notMember` allVerified, n `Set.member` measuresBeingVerified] - msg s | not (verbose cfg)- = pure ()- | Just f <- redirectVerbose cfg- = appendFile f (s ++ "\n")- | True- = putStrLn s+ msg s | not (verbose cfg)+ = pure ()+ | Just f <- redirectVerbose cfg+ = appendFile f (s ++ "\n")+ | True+ = putStrLn s - unless (null new && null skipped) $- msg $ "[MEASURE] checkNewMeasures: " ++ show (length new) ++ " to verify"- ++ (if null skipped then "" else ", " ++ show (length skipped) ++ " skipped (being verified): " ++ show skipped)+ unless (null new && null skipped) $+ msg $ "[MEASURE] checkNewMeasures: " ++ show (length new) ++ " to verify"+ ++ (if null skipped then "" else ", " ++ show (length skipped) ++ " skipped (being verified): " ++ show skipped) - modifyIORef' (measuresEncountered tpSt) (Set.union allNames)- let verify (n, isProductive, c) = do- msg $ "[MEASURE] checkNewMeasures: verifying " ++ n- () <- c cfg- msg $ "[MEASURE] checkNewMeasures: " ++ n ++ " verified"- if isProductive- then modifyIORef' (productiveVerified tpSt) (Set.insert n)- else modifyIORef' (measuresVerified tpSt) (Set.insert n)- mapM_ verify new+ modifyIORef' (measuresEncountered tpSt) (Set.union allNames)+ let verify (n, isProductive, c) = do+ msg $ "[MEASURE] checkNewMeasures: verifying " ++ n+ () <- c cfg+ msg $ "[MEASURE] checkNewMeasures: " ++ n ++ " verified"+ if isProductive+ then modifyIORef' (productiveVerified tpSt) (Set.insert n)+ else modifyIORef' (measuresVerified tpSt) (Set.insert n)+ mapM_ verify new -- | Capture the general flow of a proof-step. Note that this is the only point where we call the backend solver -- in a TP proof.@@ -303,12 +307,18 @@ -> m r smtProofStep cfg@SMTConfig{verbose, tpOptions = TPOptions{printStats}} tpState tag level ctx mbAssumptions prop disps unsat = do - case mbAssumptions of- Nothing -> do queryDebug ["; smtProofStep: No context value to push."]- check- Just asm -> do queryDebug ["; smtProofStep: Pushing in the context: " ++ show asm]- inNewAssertionStack $ do constrain asm- check+ isDry <- liftIO $ readIORef (dryRun tpState)+ if isDry+ then do -- Dry run: record width, skip solver, report success+ tab <- liftIO $ startTP cfg verbose tag level ctx+ liftIO $ modifyIORef' (maxRibbon tpState) (max tab)+ liftIO $ unsat (tab, Nothing)+ else case mbAssumptions of+ Nothing -> do queryDebug ["; smtProofStep: No context value to push."]+ check+ Just asm -> do queryDebug ["; smtProofStep: Pushing in the context: " <> showText asm]+ inNewAssertionStack $ do constrain asm+ check where check = do tab <- liftIO $ startTP cfg verbose tag level ctx@@ -339,13 +349,13 @@ TPProofStep False s _ ss -> intercalate "." (s : ss) unknown = do r <- getUnknownReason- liftIO $ do putStrLn $ "\n*** Failed to prove " ++ fullNm ++ "."- putStrLn $ "\n*** Solver reported: " ++ show r+ liftIO $ do message cfg $ "\n*** Failed to prove " ++ fullNm ++ ".\n"+ message cfg $ "\n*** Solver reported: " ++ show r ++ "\n" die -- What to do if the proof fails cex = do- liftIO $ putStrLn $ "\n*** Failed to prove " ++ fullNm ++ "."+ liftIO $ message cfg $ "\n*** Failed to prove " ++ fullNm ++ ".\n" res <- case ctx of TPProofStep{} -> do mapM_ (uncurry sObserve) disps@@ -364,6 +374,6 @@ pure $ skolemize (qNot prop) pure res - liftIO $ print $ ThmResult res+ liftIO $ message cfg $ show (ThmResult res) ++ "\n" die
Data/SBV/TP/TP.hs view
@@ -13,6 +13,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-}@@ -31,7 +32,8 @@ , induct, inductWith , sInduct, sInductWith , sorry- , TP, runTP, runTPWith, tpQuiet, tpRibbon, tpStats, tpAsms+ , TP, runTP, runTPWith, tpQuiet, tpStats, tpAsms+ , whenDryRun, unlessDryRun , measureLemma, measureLemmaWith , (|-), (|->), (⊢), (=:), (≡), (??), (∵), split, split2, cases, (==>), (⟹), qed, trivial, contradiction , qc, qcWith@@ -44,6 +46,8 @@ import Data.SBV.Core.Data (SBV(..), SVal(..)) import qualified Data.SBV.Core.Symbolic as S (sObserve) +import qualified Data.Text as T+ import Data.SBV.Core.Symbolic (rSkipMeasureChecks, rNoTermCheckFunctions) import Data.SBV.Core.Operations (svEqual) import Data.SBV.Control hiding (getProof, (|->))@@ -53,6 +57,7 @@ import qualified Data.SBV.List as SL +import Control.Exception (SomeException) import Control.Monad (when) import Control.Monad.Trans (liftIO) import Data.IORef (readIORef, writeIORef, modifyIORef')@@ -161,11 +166,11 @@ {-# MINIMAL calcSteps #-} calcSteps :: (SymVal t, EqSymbolic (SBV t)) => a -> StepArgs a t -> Symbolic (SBool, CalcStrategy) - calc nm p steps = getTPConfig >>= \cfg -> calcWith cfg nm p steps- calcWith cfg nm p steps = getTPConfig >>= \cfg' -> calcGeneric False (tpMergeCfg cfg cfg') nm p steps+ calc nm p steps = getTPConfig >>= \cfg -> calcWith cfg nm p steps+ calcWith cfg nm p steps = getTPConfig >>= \cfg' -> calcGeneric (tpMergeCfg cfg cfg') nm p steps - calcGeneric :: (SymVal t, EqSymbolic (SBV t), Proposition a) => Bool -> SMTConfig -> String -> a -> StepArgs a t -> TP (Proof a)- calcGeneric tagTheorem cfg nm result steps = do+ calcGeneric :: (SymVal t, EqSymbolic (SBV t), Proposition a) => SMTConfig -> String -> a -> StepArgs a t -> TP (Proof a)+ calcGeneric cfg nm result steps = do cached <- lookupProofCache result case cached of Just prf -> returnCachedProof cfg nm prf@@ -179,7 +184,10 @@ qSaturateSavingObservables result -- make sure we saturate the result, i.e., get all it's UI's, types etc. pop out - message cfg $ (if tagTheorem then "Theorem" else "Lemma") ++ ": " ++ nm ++ "\n"+ let header = "Lemma: " ++ nm+ message cfg $ header ++ "\n"+ liftIO $ do isDry <- readIORef (dryRun tpSt)+ when isDry $ modifyIORef' (maxRibbon tpSt) (max (length header)) (calcGoal, strategy@CalcStrategy {calcIntros, calcProofTree}) <- calcSteps result steps @@ -234,7 +242,7 @@ proveProofTree cfg tpSt nm (result, resultBool) initialHypotheses calcProofTree uniq quickCheckInstance = do results <- walk initialHypotheses 1 ([1], calcProofTree) - queryDebug [nm ++ ": Proof end: proving the result:"]+ queryDebug [T.pack nm <> ": Proof end: proving the result:"] mbStartTime <- getTimeStampIf printStats st <- symbolicEnv@@ -370,6 +378,8 @@ liftIO $ do tab <- startTP cfg (verbose cfg) "Step" level (TPProofStep False nm (getHelperText hs') stepName)+ isDry <- readIORef (dryRun tpSt)+ when isDry $ modifyIORef' (maxRibbon tpSt) (max tab) (mbT, r) <- timeIf printStats $ quickCheckWithResult qcArg{QC.chatty = verbose cfg} $ quickCheckInstance bn @@ -559,8 +569,8 @@ -- partial correctness is guaranteed if non-terminating functions are involved. inductWith :: (Proposition a, SymVal t, EqSymbolic (SBV t)) => SMTConfig -> String -> a -> (Proof (IHType a) -> IHArg a -> IStepArgs a t) -> TP (Proof a) - induct nm p steps = getTPConfig >>= \cfg -> inductWith cfg nm p steps- inductWith cfg nm p steps = getTPConfig >>= \cfg' -> inductionEngine RegularInduction False (tpMergeCfg cfg cfg') nm p (inductionStrategy p steps)+ induct nm p steps = getTPConfig >>= \cfg -> inductWith cfg nm p steps+ inductWith cfg nm p steps = getTPConfig >>= \cfg' -> inductionEngine RegularInduction (tpMergeCfg cfg cfg') nm p (inductionStrategy p steps) -- | Internal, shouldn't be needed outside the library {-# MINIMAL inductionStrategy #-}@@ -578,16 +588,16 @@ -- partial correctness is guaranteed if non-terminating functions are involved. sInductWith :: (Proposition a, Zero m, SymVal t, EqSymbolic (SBV t)) => SMTConfig -> String -> a -> (MeasureArgs a m, [ProofObj]) -> (Proof a -> StepArgs a t) -> TP (Proof a) - sInduct nm p mhs steps = getTPConfig >>= \cfg -> sInductWith cfg nm p mhs steps- sInductWith cfg nm p mhs steps = getTPConfig >>= \cfg' -> inductionEngine GeneralInduction False (tpMergeCfg cfg cfg') nm p (sInductionStrategy p mhs steps)+ sInduct nm p mhs steps = getTPConfig >>= \cfg -> sInductWith cfg nm p mhs steps+ sInductWith cfg nm p mhs steps = getTPConfig >>= \cfg' -> inductionEngine GeneralInduction (tpMergeCfg cfg cfg') nm p (sInductionStrategy p mhs steps) -- | Internal, shouldn't be needed outside the library {-# MINIMAL sInductionStrategy #-} sInductionStrategy :: (Proposition a, Zero m, SymVal t, EqSymbolic (SBV t)) => a -> (MeasureArgs a m, [ProofObj]) -> (Proof a -> StepArgs a t) -> Symbolic InductionStrategy -- | Do an inductive proof, based on the given strategy-inductionEngine :: Proposition a => InductionStyle -> Bool -> SMTConfig -> String -> a -> Symbolic InductionStrategy -> TP (Proof a)-inductionEngine style tagTheorem cfg nm result getStrategy = do+inductionEngine :: Proposition a => InductionStyle -> SMTConfig -> String -> a -> Symbolic InductionStrategy -> TP (Proof a)+inductionEngine style cfg nm result getStrategy = do cached <- lookupProofCache result case cached of Just prf -> returnCachedProof cfg nm prf@@ -603,7 +613,10 @@ RegularInduction -> "" GeneralInduction -> " (strong)" - message cfg $ "Inductive " ++ (if tagTheorem then "theorem" else "lemma") ++ qual ++ ": " ++ nm ++ "\n"+ let header = "Inductive lemma" ++ qual ++ ": " ++ nm+ message cfg $ header ++ "\n"+ liftIO $ do isDry <- readIORef (dryRun tpSt)+ when isDry $ modifyIORef' (maxRibbon tpSt) (max (length header)) strategy@InductionStrategy { inductionIntros , inductionMeasure@@ -623,8 +636,8 @@ query $ do case inductionMeasure of- Nothing -> queryDebug [nm ++ ": Induction" ++ qual ++ ", there is no custom measure to show non-negativeness."]- Just (m, hs) -> do queryDebug [nm ++ ": Induction, proving measure is always non-negative:"]+ Nothing -> queryDebug [T.pack nm <> ": Induction" <> T.pack qual <> ", there is no custom measure to show non-negativeness."]+ Just (m, hs) -> do queryDebug [T.pack nm <> ": Induction, proving measure is always non-negative:"] smtProofStep cfg tpSt "Step" 1 (TPProofStep False nm [] ["Measure is non-negative"]) (Just (sAnd (inductionIntros : map getObjProof hs)))@@ -632,8 +645,8 @@ [] (\d -> finishTP cfg "Q.E.D." d []) case inductionBaseCase of- Nothing -> queryDebug [nm ++ ": Induction" ++ qual ++ ", there is no base case to prove."]- Just bc -> do queryDebug [nm ++ ": Induction, proving base case:"]+ Nothing -> queryDebug [T.pack nm <> ": Induction" <> T.pack qual <> ", there is no base case to prove."]+ Just bc -> do queryDebug [T.pack nm <> ": Induction, proving base case:"] smtProofStep cfg tpSt "Step" 1 (TPProofStep False nm [] ["Base"]) (Just inductionIntros)@@ -1551,16 +1564,16 @@ pure r else do let new = cfg{tpOptions = (tpOptions cfg) {quiet = True}} restoring new topCfg $ do- r@Proof{proofOf = po@ProofObj{dependencies, aliases = aka, wasCached = cached}} <- prf+ res <- tryTP prf cleanup- let nm = proofName po- akaStr | null aka = ""- | True = " (a.k.a. " ++ intercalate ", " aka ++ ")"- what | cached = "Cached"- | True = "Lemma"- tab <- liftIO $ startTP cfg (verbose cfg) what 0 (TPProofOneShot nm [])- liftIO $ finishTP cfg ("Q.E.D." ++ concludeModulo dependencies ++ akaStr) (tab, Nothing) []- pure r+ case res of+ Left (_ :: SomeException) ->+ -- Re-run with original config so failure details are visible+ restoring cfg topCfg prf >> pure (error "unreachable")+ Right r@Proof{proofOf = po@ProofObj{dependencies, aliases = aka, wasCached = cached}} -> do+ let nm = proofName po+ liftIO $ printLemmaResult cfg (verbose cfg) nm dependencies cached aka+ pure r where restoring new old act = do setTPConfig new res <- act setTPConfig old
Data/SBV/TP/Utils.hs view
@@ -23,17 +23,18 @@ {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.TP.Utils (- TP, runTP, runTPWith, Proof(..), ProofObj(..), assumptionFromProof, sorry, quickCheckProof, noTermCheckProof+ TP, runTP, runTPWith, tryTP, whenDryRun, unlessDryRun, Proof(..), ProofObj(..), assumptionFromProof, sorry, quickCheckProof, noTermCheckProof , startTP, finishTP, getTPState, getTPConfig, setTPConfig, tpGetNextUnique, TPState(..), TPStats(..), RootOfTrust(..)- , TPProofContext(..), message, updStats, rootOfTrust, concludeModulo+ , TPProofContext(..), message, updStats, rootOfTrust, concludeModulo, printLemmaResult , ProofTree(..), TPUnique(..), showProofTree, showProofTreeHTML , addToProofCache, lookupProofCache, returnCachedProof- , tpQuiet, tpRibbon, tpAsms, tpStats+ , tpQuiet, tpAsms, tpStats , measureLemma, measureLemmaWith ) where -import Control.Monad (unless)-import Control.Monad.Reader (ReaderT, runReaderT, MonadReader, ask, liftIO)+import Control.Exception (Exception, try)+import Control.Monad (unless, when)+import Control.Monad.Reader (ReaderT(..), runReaderT, MonadReader, ask, liftIO) import Control.Monad.Trans (MonadIO) import Data.Generics (everywhere, mkT)@@ -70,7 +71,6 @@ import Data.Dynamic import qualified Data.Map.Strict as Map-import Data.Map (Map) import qualified Data.Set as Set import Data.Set (Set)@@ -83,18 +83,37 @@ -- | Extra state we carry in a TP context data TPState = TPState { stats :: IORef TPStats- , proofCache :: IORef (Map (PropFingerprint, TypeRep) [ProofObj])+ , proofCache :: IORef (Map.Map (PropFingerprint, TypeRep) [ProofObj]) , config :: IORef SMTConfig , inRecallContext :: IORef Int , measuresVerified :: IORef (Set String) , productiveVerified :: IORef (Set String) , measuresEncountered :: IORef (Set String)+ , dryRun :: IORef Bool -- ^ If True, collecting ribbon widths (no proving)+ , maxRibbon :: IORef Int -- ^ Session-wide maximum ribbon length } -- | Monad for running TP proofs in. newtype TP a = TP (ReaderT TPState IO a) deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader TPState, MonadFail) +-- | Run a TP action, catching exceptions.+tryTP :: Exception e => TP a -> TP (Either e a)+tryTP (TP act) = TP $ ReaderT $ \st -> try (runReaderT act st)++-- | Run an action only during the dry-run pass.+whenDryRun :: TP () -> TP ()+whenDryRun act = do st <- ask+ isDry <- liftIO $ readIORef (dryRun st)+ when isDry act++-- | Run an action only during the real (non-dry-run) pass. Useful for guarding user-facing output+-- (e.g., proof tree printing) that should be suppressed during ribbon calculation.+unlessDryRun :: TP () -> TP ()+unlessDryRun act = do st <- ask+ isDry <- liftIO $ readIORef (dryRun st)+ unless isDry act+ -- | Extract the integer node ID from an SV. svIntId :: SV -> Int svIntId (SV _ (NodeId (_, _, i))) = i@@ -163,12 +182,9 @@ -- | Return a cached proof, printing a brief "Q.E.D." line with optional "a.k.a." annotation. returnCachedProof :: SMTConfig -> String -> ProofObj -> TP (Proof a) returnCachedProof cfg nm prf = do- let aka = filter (/= nm) $ nub $ proofName prf : aliases prf- prf' = prf { proofName = nm, wasCached = True, aliases = aka }- akaStr | null aka = ""- | True = " (a.k.a. " ++ intercalate ", " aka ++ ")"- tab <- liftIO $ startTP cfg False "Cached" 0 (TPProofOneShot nm [])- liftIO $ finishTP cfg ("Q.E.D." ++ concludeModulo (dependencies prf) ++ akaStr) (tab, Nothing) []+ let aka = filter (/= nm) $ nub $ proofName prf : aliases prf+ prf' = prf { proofName = nm, wasCached = True, aliases = aka }+ liftIO $ printLemmaResult cfg False nm (dependencies prf) True aka pure $ Proof prf' -- | The context in which we make a check-sat call@@ -186,29 +202,48 @@ -- | Run a TP proof, using the given configuration. runTPWith :: SMTConfig -> TP a -> IO a runTPWith cfg@SMTConfig{tpOptions = TPOptions{printStats}} (TP f) = do- rStats <- newIORef $ TPStats { noOfCheckSats = 0, solverElapsed = 0, qcElapsed = 0 }- rCache <- newIORef Map.empty- rCfg <- newIORef cfg- rRecall <- newIORef (0 :: Int)- rMeasures <- newIORef Set.empty- rProductive <- newIORef Set.empty- rEncountered <- newIORef Set.empty- (mbT, r) <- timeIf printStats $ runReaderT f TPState { config = rCfg- , stats = rStats- , proofCache = rCache- , inRecallContext = rRecall- , measuresVerified = rMeasures- , productiveVerified = rProductive- , measuresEncountered = rEncountered- }+ rDryRun <- newIORef True+ rMaxRibbon <- newIORef 0 + let runPass c = do+ rStats <- newIORef $ TPStats { noOfCheckSats = 0, solverElapsed = 0, qcElapsed = 0 }+ rCache <- newIORef Map.empty+ rCfg <- newIORef c+ rRecall <- newIORef (0 :: Int)+ rMeasures <- newIORef Set.empty+ rProductive <- newIORef Set.empty+ rEncountered <- newIORef Set.empty+ let st = TPState { config = rCfg+ , stats = rStats+ , proofCache = rCache+ , inRecallContext = rRecall+ , measuresVerified = rMeasures+ , productiveVerified = rProductive+ , measuresEncountered = rEncountered+ , dryRun = rDryRun+ , maxRibbon = rMaxRibbon+ }+ a <- runReaderT f st+ pure (a, st)++ -- Pass 1: Dry run to collect ribbon widths+ _ <- runPass ((tpQuiet True cfg){verbose = False})++ -- Pass 2: Real run with computed ribbon+ writeIORef rDryRun False+ ribbon <- readIORef rMaxRibbon+ let cfg' = cfg{tpOptions = (tpOptions cfg) { ribbonLength = max 20 (ribbon + 4) }}++ (mbT, (r, TPState{stats = rStats, measuresVerified = rMeasures, productiveVerified = rProductive, measuresEncountered = rEncountered}))+ <- timeIf printStats $ runPass cfg'+ -- Print verified measures and productive functions verified <- readIORef rMeasures productive <- readIORef rProductive encountered <- readIORef rEncountered - unless (Set.null verified) $ printMeasures cfg (Set.toAscList verified)- unless (Set.null productive) $ printProductive cfg (Set.toAscList productive)+ unless (Set.null verified) $ printMeasures cfg' (Set.toAscList verified)+ unless (Set.null productive) $ printProductive cfg' (Set.toAscList productive) -- Belt-and-suspenders: make sure all encountered measures have been verified. -- Exclude functions in measuresBeingVerified: those are being verified by an outer caller@@ -231,7 +266,7 @@ , ("Decisions", show noOfCheckSats) ] - message cfg $ '[' : intercalate ", " [k ++ ": " ++ v | (k, v) <- stats] ++ "]\n"+ message cfg' $ '[' : intercalate ", " [k ++ ": " ++ v | (k, v) <- stats] ++ "]\n" pure r -- | get the state@@ -264,7 +299,7 @@ | Just f <- redirectVerbose = liftIO $ appendFile f s | True- = liftIO $ putStr s+ = liftIO $ putStr s >> hFlush stdout -- | Print the list of functions whose termination measures have been verified. printMeasures :: SMTConfig -> [String] -> IO ()@@ -303,7 +338,7 @@ startTP :: SMTConfig -> Bool -> String -> Int -> TPProofContext -> IO Int startTP cfg newLine what level ctx = do message cfg $ line ++ if newLine then "\n" else "" hFlush stdout- return (length line)+ pure (length line) where nm = case ctx of TPProofOneShot n _ -> n TPProofStep _ _ hs ss -> intercalate "." ss ++ userHints hs@@ -596,6 +631,16 @@ | any (\o -> uniqId o == TPSorry) ps = [sorry] | True = ps +-- | Print a one-line lemma result: @Lemma: name Q.E.D. [Modulo: ...] [Cached] (a.k.a. ...)@+printLemmaResult :: SMTConfig -> Bool -> String -> [ProofObj] -> Bool -> [String] -> IO ()+printLemmaResult cfg verboseFlag nm deps cached aka = do+ tab <- startTP cfg verboseFlag "Lemma" 0 (TPProofOneShot nm [])+ finishTP cfg ("Q.E.D." ++ concludeModulo deps ++ cacheStr ++ akaStr) (tab, Nothing) []+ where cacheStr | cached = " [Cached]"+ | True = ""+ akaStr | null aka = ""+ | True = " (a.k.a. " ++ intercalate ", " aka ++ ")"+ -- | Calculate the modulo string for dependencies concludeModulo :: [ProofObj] -> String concludeModulo by = case foldMap (rootOfTrust . Proof) by of@@ -607,12 +652,6 @@ -- will inherit the quiet settings from the surrounding environment. tpQuiet :: Bool -> SMTConfig -> SMTConfig tpQuiet b cfg = cfg{tpOptions = (tpOptions cfg) { quiet = b }}---- | Change the size of the ribbon for TP proofs. Note that this setting will be effective with the--- call to 'runTP'\/'runTPWith', i.e., if you change the solver in a call to 'Data.SBV.TP.lemmaWith'\/'Data.SBV.TP.theoremWith', we--- will inherit the ribbon settings from the surrounding environment.-tpRibbon :: Int -> SMTConfig -> SMTConfig-tpRibbon i cfg = cfg{tpOptions = (tpOptions cfg) { ribbonLength = i }} -- | Make TP proofs produce statistics. Note that this setting will be effective with the -- call to 'runTP'\/'runTPWith', i.e., if you change the solver in a call to 'Data.SBV.TP.lemmaWith'\/'Data.SBV.TP.theoremWith', we
Data/SBV/Tools/BMC.hs view
@@ -34,7 +34,7 @@ bmcRefute :: (Queriable IO st, res ~ QueryResult st) => Maybe Int -- ^ Optional bound -> Bool -- ^ Verbose: prints iteration count- -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.)+ -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition -> (st -> st -> SBool) -- ^ Transition relation -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate.@@ -46,7 +46,7 @@ => SMTConfig -- ^ Solver to use -> Maybe Int -- ^ Optional bound -> Bool -- ^ Verbose: prints iteration count- -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.)+ -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition -> (st -> st -> SBool) -- ^ Transition relation -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate.@@ -59,7 +59,7 @@ bmcCover :: (Queriable IO st, res ~ QueryResult st) => Maybe Int -- ^ Optional bound -> Bool -- ^ Verbose: prints iteration count- -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.)+ -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition -> (st -> st -> SBool) -- ^ Transition relation -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate.@@ -71,7 +71,7 @@ => SMTConfig -- ^ Solver to use -> Maybe Int -- ^ Optional bound -> Bool -- ^ Verbose: prints iteration count- -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.)+ -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition -> (st -> st -> SBool) -- ^ Transition relation -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate.@@ -93,7 +93,7 @@ go i _ _ | Just l <- mbLimit, i >= l- = return $ Left $ what ++ " limit of " ++ show l ++ " reached. " ++ badResult+ = pure $ Left $ what ++ " limit of " ++ show l ++ " reached. " ++ badResult go i curState sofar = do when chatty $ io $ putStrLn $ what ++ ": Iteration: " ++ show i @@ -110,9 +110,9 @@ DSat{} -> error $ what ++ ": Solver returned an unexpected delta-sat result." Sat -> do when chatty $ io $ putStrLn $ what ++ ": " ++ goodResult ++ " state found at iteration " ++ show i ms <- mapM project (curState : sofar)- return $ Right (i, reverse ms)+ pure $ Right (i, reverse ms) Unk -> do when chatty $ io $ putStrLn $ what ++ ": Backend solver said unknown at iteration " ++ show i- return $ Left $ what ++ ": Solver said unknown in iteration " ++ show i+ pure $ Left $ what ++ ": Solver said unknown in iteration " ++ show i Unsat -> do pop 1 nextState <- create constrain $ curState `trans` nextState
Data/SBV/Tools/BVOptimize.hs view
@@ -120,7 +120,7 @@ else constrain $ sNot b r <- checkSat case r of- Sat -> go bs >>= \res -> pop 1 >> return res+ Sat -> go bs >>= \res -> pop 1 >> pure res Unsat -> pop 1 >> go bs Unk -> pop 1 >> rUnk DSat{} -> error "minMaxBV: Unexpected DSat result"
Data/SBV/Tools/GenTest.hs view
@@ -9,7 +9,7 @@ -- Test generation from symbolic programs ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Tools.GenTest ( -- * Test case generation@@ -49,7 +49,7 @@ genTest :: Outputtable a => Int -> Symbolic a -> IO TestVectors genTest n m = gen 0 [] where gen i sofar- | i == n = return $ TV $ reverse sofar+ | i == n = pure $ TV $ reverse sofar | True = do t <- tc gen (i+1) (t:sofar) tc = do (_, Result {resTraces=tvals, resConsts=(_, cs), resDefinitions=definitions, resConstraints=cstrs, resOutputs=os}) <- runSymbolic defaultSMTCfg (Concrete Nothing) (m >>= output)@@ -57,7 +57,7 @@ cond = and [cvToBool (cval v) | (False, _, v) <- F.toList cstrs] -- Only pick-up "hard" constraints, as indicated by False in the fist component unless (null definitions) $ error "Cannot generate tests in the presence of 'smtFunction' calls!" if cond- then return (map snd tvals, map cval os)+ then pure (map snd tvals, map cval os) else tc -- try again, with the same set of constraints -- | Test output style@@ -95,8 +95,7 @@ | needsWord = ["import Data.Word", ""] | needsRatio = ["import Data.Ratio"] | True = []- where ((is, os):_) = vs- params = is ++ os+ where params = case vs of { (is, os):_ -> is ++ os; _ -> error "SBV.renderTest: impossible, empty test vectors" } needsInt = any isSW params needsWord = any isUW params needsRatio = any isR params@@ -109,7 +108,9 @@ isUW cv = case kindOf cv of KBounded False sz -> sz > 1 _ -> False- modName = let (f:r) = n in toUpper f : r+ modName = case n of+ f:r -> toUpper f : r+ _ -> error "SBV.renderTest: impossible, empty module name" pad = replicate (length n + 3) ' ' getType [] = "[a]" getType ((i, o):_) = "[(" ++ mapType typeOf i ++ ", " ++ mapType typeOf o ++ ")]"@@ -147,21 +148,22 @@ s cv = case kindOf cv of KVar{} -> error $ "SBV.renderTest: Unexpected: " ++ show (kindOf cv) KBool -> take 5 (show (cvToBool cv) ++ repeat ' ')- KBounded sgn sz -> let CInteger w = cvVal cv in T.unpack $ shex False True (sgn, sz) w- KUnbounded -> let CInteger w = cvVal cv in T.unpack $ shexI False True w- KFloat -> let CFloat w = cvVal cv in showHFloat w- KDouble -> let CDouble w = cvVal cv in showHDouble w+ KBounded sgn sz -> case cvVal cv of { CInteger w -> T.unpack $ shex False True (sgn, sz) w; r -> bad r }+ KUnbounded -> case cvVal cv of { CInteger w -> T.unpack $ shexI False True w; r -> bad r }+ KFloat -> case cvVal cv of { CFloat w -> showHFloat w; r -> bad r }+ KDouble -> case cvVal cv of { CDouble w -> showHDouble w; r -> bad r } KRational -> error "SBV.renderTest: Unsupported rational number" KFP{} -> error "SBV.renderTest: Unsupported arbitrary float" KChar -> error "SBV.renderTest: Unsupported char" KString -> error "SBV.renderTest: Unsupported string"- KReal -> let CAlgReal w = cvVal cv in algRealToHaskell w+ KReal -> case cvVal cv of { CAlgReal w -> algRealToHaskell w; r -> bad r } KList es -> error $ "SBV.renderTest: Unsupported list valued sort: [" ++ show es ++ "]" KSet es -> error $ "SBV.renderTest: Unsupported set valued sort: {" ++ show es ++ "}" k@KApp{} -> error $ "SBV.renderTest: Unsupported adt app: " ++ show k k@KADT{} -> error $ "SBV.renderTest: Unsupported adt: " ++ show k k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple: " ++ show k k@KArray{} -> error $ "SBV.renderTest: Unsupported array: " ++ show k+ where bad _ = error $ "SBV.renderTest: Unexpected CVal for kind: " ++ show (kindOf cv) c :: String -> [([CV], [CV])] -> String c n vs = intercalate "\n" $@@ -262,10 +264,10 @@ v cv = case kindOf cv of KVar{} -> error $ "SBV.renderTest: Unexpected: " ++ show (kindOf cv) KBool -> if cvToBool cv then "true " else "false"- KBounded sgn sz -> let CInteger w = cvVal cv in T.unpack $ chex False True (sgn, sz) w- KUnbounded -> let CInteger w = cvVal cv in T.unpack $ shexI False True w- KFloat -> let CFloat w = cvVal cv in showCFloat w- KDouble -> let CDouble w = cvVal cv in showCDouble w+ KBounded sgn sz -> case cvVal cv of { CInteger w -> T.unpack $ chex False True (sgn, sz) w; r -> bad r }+ KUnbounded -> case cvVal cv of { CInteger w -> T.unpack $ shexI False True w; r -> bad r }+ KFloat -> case cvVal cv of { CFloat w -> showCFloat w; r -> bad r }+ KDouble -> case cvVal cv of { CDouble w -> showCDouble w; r -> bad r } KRational -> error "SBV.renderTest: Unsupported rational number" KFP{} -> error "SBV.renderTest: Unsupported arbitrary float" KChar -> error "SBV.renderTest: Unsupported char"@@ -277,6 +279,7 @@ k@KADT{} -> error $ "SBV.renderTest: Unsupported adt: " ++ show k k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple sort: " ++ show k k@KArray{} -> error $ "SBV.renderTest: Unsupported sum sort: " ++ show k+ where bad _ = error $ "SBV.renderTest: Unexpected CVal for kind: " ++ show (kindOf cv) outLine | null vs = "printf(\"\");"@@ -375,9 +378,9 @@ form [] bs = error $ "SBV.renderTest: Mismatched index in stream, extra " ++ show (length bs) ++ " bit(s) remain." form (i:is) bs | length bs < i = error $ "SBV.renderTest: Mismatched index in stream, was looking for " ++ show i ++ " bit(s), but only " ++ show bs ++ " remains."- | i == 1 = let b:r = bs- v = if b == '1' then "T" else "F"- in v : form is r+ | i == 1 = case bs of+ b:r -> (if b == '1' then "T" else "F") : form is r+ _ -> error "SBV.renderTest: impossible, empty bit stream" | True = let (f, r) = splitAt i bs v = "c \"" ++ show i ++ "'b" ++ f ++ "\"" in v : form is r
Data/SBV/Tools/Induction.hs view
@@ -84,7 +84,7 @@ -- and "Documentation.SBV.Examples.ProofTools.Sum" for examples. induct :: (Show res, Queriable IO st, res ~ QueryResult st) => Bool -- ^ Verbose mode- -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.)+ -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition -> (st -> st -> SBool) -- ^ Transition relation -> [(String, st -> SBool)] -- ^ Strengthenings, if any. The @String@ is a simple tag.@@ -115,14 +115,14 @@ $ try "Proving partial correctness" (\s _ -> let (term, result) = goal s in inv s .&& term .=> result) (Failed PartialCorrectness)- (msg "Done" >> return Proven)+ (msg "Done" >> pure Proven) where msg = when chatty . putStrLn try m p wrap cont = do msg m res <- check p case res of- Just ex -> return $ wrap ex+ Just ex -> pure $ wrap ex Nothing -> cont check p = runSMTWith cfg $ do@@ -135,14 +135,14 @@ case cs of Unk -> error "Solver said unknown" DSat{} -> error "Solver returned a delta-sat result"- Unsat -> return Nothing+ Unsat -> pure Nothing Sat -> do io $ msg "Failed in state:" exS <- project s io $ msg $ show exS io $ msg "Transitioning to:" exS' <- project s' io $ msg $ show exS'- return $ Just (exS, exS')+ pure $ Just (exS, exS') strengthen [] cont = cont strengthen ((nm, st):sts) cont = try ("Proving strengthening initiation : " ++ nm)
Data/SBV/Tools/Range.hs view
@@ -108,7 +108,7 @@ rangesWith :: forall a. (OrdSymbolic (SBV a), Num a, SymVal a, SatModel a, Metric a, SymVal (MetricSpace a), SatModel (MetricSpace a)) => SMTConfig -> (SBV a -> SBool) -> IO [Range a] rangesWith cfg prop = do mbBounds <- getInitialBounds case mbBounds of- Nothing -> return []+ Nothing -> pure [] Just r -> search [r] [] where getInitialBounds :: IO (Maybe (Range a))@@ -155,16 +155,16 @@ constrain $ prop x cstr objName x case m of- Unsatisfiable{} -> return Nothing+ Unsatisfiable{} -> pure Nothing Unknown{} -> error "Solver said Unknown!" ProofError{} -> error (show res)- _ -> return $ getModelObjectiveValue (annotateForMS (Proxy @a) objName) m+ _ -> pure $ getModelObjectiveValue (annotateForMS (Proxy @a) objName) m mi <- getBound minimize ma <- getBound maximize case (mi, ma) of- (Just minV, Just maxV) -> return $ Just $ Range (getGenVal minV) (getGenVal maxV)- _ -> return Nothing+ (Just minV, Just maxV) -> pure $ Just $ Range (getGenVal minV) (getGenVal maxV)+ _ -> pure Nothing -- Is this range satisfiable? Returns a witness to it. witness :: Range a -> Symbolic (SBV a)@@ -180,17 +180,17 @@ constrain $ lower .&& upper - return x+ pure x isFeasible :: Range a -> IO Bool isFeasible r = runSMTWith cfg $ do _ <- witness r query $ do cs <- checkSat case cs of- Unsat -> return False+ Unsat -> pure False DSat{} -> error "Data.SBV.interval.isFeasible: Solver returned a delta-satisfiable result!" Unk -> error "Data.SBV.interval.isFeasible: Solver said unknown!"- Sat -> return True+ Sat -> pure True bisect :: Range a -> IO (Maybe [Range a]) bisect r@(Range lo hi) = runSMTWith cfg $ do x <- witness r@@ -199,14 +199,14 @@ query $ do cs <- checkSat case cs of- Unsat -> return Nothing+ Unsat -> pure Nothing DSat{} -> error "Data.SBV.interval.bisect: Solver returned a delta-satisfiable result!" Unk -> error "Data.SBV.interval.bisect: Solver said unknown!" Sat -> do midV <- Open <$> getValue x- return $ Just [Range lo midV, Range midV hi]+ pure $ Just [Range lo midV, Range midV hi] search :: [Range a] -> [Range a] -> IO [Range a]- search [] sofar = return $ reverse sofar+ search [] sofar = pure $ reverse sofar search (c:cs) sofar = do feasible <- isFeasible c if feasible then do mbCS <- bisect c
Data/SBV/Tools/WeakestPreconditions.hs view
@@ -73,7 +73,7 @@ -- -- The 'setup' field is reserved for any symbolic code you might -- want to run before the proof takes place, typically for calls--- to 'Data.SBV.setOption'. If not needed, simply pass @return ()@.+-- to 'Data.SBV.setOption'. If not needed, simply pass @pure ()@. -- For an interesting use case where we use setup to axiomatize -- the spec, see "Documentation.SBV.Examples.WeakestPreconditions.Fib" -- and "Documentation.SBV.Examples.WeakestPreconditions.GCD".@@ -234,7 +234,7 @@ Sat -> do let checkVC :: (SBool, VC st SInteger) -> Query [VC res Integer] checkVC (cond, vc) = do c <- getValue cond if c- then return [] -- The VC was OK+ then pure [] -- The VC was OK else do vc' <- case vc of BadPrecondition s -> BadPrecondition <$> project s BadPostcondition s1 s2 -> BadPostcondition <$> project s1 <*> project s2@@ -244,13 +244,13 @@ InvariantMaintain l s1 s2 -> InvariantMaintain l <$> project s1 <*> project s2 MeasureBound l (s, m) -> do r <- project s v <- mapM getValue m- return $ MeasureBound l (r, v)+ pure $ MeasureBound l (r, v) MeasureDecrease l (s1, i1) (s2, i2) -> do r1 <- project s1 v1 <- mapM getValue i1 r2 <- project s2 v2 <- mapM getValue i2- return $ MeasureDecrease l (r1, v1) (r2, v2)- return [vc']+ pure $ MeasureDecrease l (r1, v1) (r2, v2)+ pure [vc'] badVCs <- concat <$> mapM checkVC vcs @@ -267,7 +267,7 @@ let disp c = mapM_ msg [" " ++ l | l <- lines (show c)] mapM_ disp badVCs - return $ Failed badVCs+ pure $ Failed badVCs msg = io . when wpVerbose . putStrLn @@ -275,28 +275,28 @@ wp :: st -> Stmt st -> (st -> [(SBool, VC st SInteger)]) -> Query (st -> [(SBool, VC st SInteger)]) -- Skip simply keeps the conditions- wp _ Skip post = return post+ wp _ Skip post = pure post -- Abort is never satisfiable. The only way to have Abort's VC to pass is -- to run it in a precondition (either via program or in an if branch) that -- evaluates to false, i.e., it must not be reachable.- wp start (Abort nm) _ = return $ \st -> [(sFalse, AbortReachable nm start st)]+ wp start (Abort nm) _ = pure $ \st -> [(sFalse, AbortReachable nm start st)] -- Assign simply transforms the state and passes on. It also checks that the -- stability constraints are not violated.- wp _ (Assign f) post = return $ \st -> let st' = f st- vcs = map (\s -> let (nm, b) = s st st' in (b, Unstable nm st st')) stability- in vcs ++ post st'+ wp _ (Assign f) post = pure $ \st -> let st' = f st+ vcs = map (\s -> let (nm, b) = s st st' in (b, Unstable nm st st')) stability+ in vcs ++ post st' -- Conditional: We separately collect the VCs, and predicate with the proper branch condition wp start (If c tb fb) post = do tWP <- wp start tb post fWP <- wp start fb post- return $ \st -> let cond = c st- in [( cond .=> b, v) | (b, v) <- tWP st]- ++ [(sNot cond .=> b, v) | (b, v) <- fWP st]+ pure $ \st -> let cond = c st+ in [( cond .=> b, v) | (b, v) <- tWP st]+ ++ [(sNot cond .=> b, v) | (b, v) <- fWP st] -- Sequencing: Simply run through the statements- wp _ (Seq []) post = return post+ wp _ (Seq []) post = pure post wp start (Seq (s:ss)) post = wp start s =<< wp start (Seq ss) post -- While loop, where all the WP magic happens!@@ -323,20 +323,20 @@ -- Condition 4: If we iterate, measure must always be non-negative measureNonNegative <- if noMeasure- then return (const [])+ then pure (const []) else wp st' Skip (const [(iterates .=> curM .>= zeroM, MeasureBound nm (st', curM))]) -- Condition 5: If we iterate, the measure must decrease measureDecreases <- if noMeasure- then return (const [])+ then pure (const []) else wp st' body (\st -> let prevM = m st in [(iterates .=> prevM .< curM, MeasureDecrease nm (st', curM) (st, prevM))]) -- Simply concatenate the VCs from all our conditions:- return $ \st -> invHoldsPrior st- ++ invMaintained st'- ++ invEstablish st'- ++ measureNonNegative st'- ++ measureDecreases st'+ pure $ \st -> invHoldsPrior st+ ++ invMaintained st'+ ++ invEstablish st'+ ++ measureNonNegative st'+ ++ measureDecreases st' -- | Check correctness using the default solver. Equivalent to @'wpProveWith' 'defaultWPCfg'@. wpProve :: (Show res, Mergeable st, Queriable IO st, res ~ QueryResult st) => Program st -> IO (ProofResult res)@@ -388,7 +388,7 @@ else giveUp start (BadPrecondition start) "*** Initial state does not satisfy the precondition:" case status of- s@Stuck{} -> return s+ s@Stuck{} -> pure s Good end -> if unwrap [] "checking postcondition" (postcondition end) then step [] end "*** Program successfully terminated, post condition holds of the final state:" else giveUp end (BadPostcondition start end) "*** Failed, final state does not satisfy the postcondition:"@@ -403,16 +403,16 @@ step :: Loc -> st -> String -> IO (Status st) step l st m = do putStrLn $ sLoc l m printST st- return $ Good st+ pure $ Good st stop :: Loc -> VC st Integer -> String -> IO (Status st) stop l vc m = do putStrLn $ sLoc l m- return $ Stuck vc+ pure $ Stuck vc giveUp :: st -> VC st Integer -> String -> IO (Status st) giveUp st vc m = do r <- stop [] vc m printST st- return r+ pure r dispST :: st -> String dispST st = intercalate "\n" [" " ++ l | l <- lines (show st)]@@ -434,7 +434,7 @@ ] go :: Loc -> Stmt st -> Status st -> IO (Status st)- go _ _ s@Stuck{} = return s+ go _ _ s@Stuck{} = pure s go loc p (Good st) = analyze p where analyze Skip = step loc st "Skip" @@ -453,7 +453,7 @@ where branchTrue = unwrap loc "evaluating the test condition" (c st) analyze (Seq stmts) = walk stmts 1 (Good st)- where walk [] _ is = return is+ where walk [] _ is = pure is walk (s:ss) c is = walk ss (c+1) =<< go (Line c : loc) s is analyze (While loopName invariant mbMeasure condition body)@@ -470,7 +470,7 @@ currentMeasure = map (unwrap loc (tag "evaluating the measure")) . measure currentInvariant = unwrap loc (tag "evaluating the invariant") . invariant - while _ _ _ s@Stuck{} = return s+ while _ _ _ s@Stuck{} = pure s while c prevST mbPrev (Good is) | not (currentCondition is) = step loc is $ tag "condition fails, terminating"
Data/SBV/Tuple.hs view
@@ -18,7 +18,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Tuple ( -- * Symbolic field access
Data/SBV/Utils/CrackNum.hs view
@@ -11,7 +11,7 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Utils.CrackNum ( crackNum@@ -57,10 +57,17 @@ KArray {} -> Nothing -- Actual crackables- KFloat{} -> Just $ let CFloat f = cvVal cv in float verbose mbIV f- KDouble{} -> Just $ let CDouble d = cvVal cv in float verbose mbIV d- KFP{} -> Just $ let CFP f = cvVal cv in float verbose mbIV f- KBounded sg sz -> Just $ let CInteger i = cvVal cv in int sg sz i+ KFloat{} | CFloat f <- cvVal cv -> Just $ float verbose mbIV f+ | True -> Nothing -- Can't really happen; but don't die++ KDouble{} | CDouble d <- cvVal cv -> Just $ float verbose mbIV d+ | True -> Nothing -- Can't really happen; but don't die++ KFP{} | CFP f <- cvVal cv -> Just $ float verbose mbIV f+ | True -> Nothing -- Can't really happen; but don't die++ KBounded sg sz | CInteger i <- cvVal cv -> Just $ int sg sz i+ | True -> Nothing -- Can't really happen; but don't die -- How far off the screen we want displayed? Somewhat experimentally found. tab :: String
Data/SBV/Utils/Lib.hs view
@@ -17,22 +17,30 @@ module Data.SBV.Utils.Lib ( mlift2, mlift3, mlift4, mlift5, mlift6, mlift7, mlift8 , joinArgs, splitArgs , stringToQFS, qfsToString+ , showText , isKString , checkObservableName- , needsBars, barify, isEnclosedInBars- , noSurrounding, unQuote, unBar, nameSupply+ , needsBars, barify+ , unQuote, unBar, nameSupply , atProxy+ , mapToSortedList , curry2, curry3, curry4, curry5, curry6, curry7, curry8, curry9, curry10, curry11, curry12 , uncurry2, uncurry3, uncurry4, uncurry5, uncurry6, uncurry7, uncurry8, uncurry9, uncurry10, uncurry11, uncurry12 ) where import Data.Char (isSpace, chr, ord, isDigit, isAscii, isAlphaNum)-import Data.List (isPrefixOf, isSuffixOf)+import Data.List (isPrefixOf, isSuffixOf, sortBy)+import Data.Ord (comparing) import Data.Dynamic (fromDynamic, toDyn, Typeable) import Data.Maybe (fromJust, isJust, isNothing) import Data.Proxy+import Data.Text (Text) +import qualified Data.Text as T++import qualified Data.Map.Strict as Map+ import Type.Reflection (typeRep) import Numeric (readHex, showHex)@@ -46,31 +54,31 @@ -- | 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'+mlift2 k f g (a, b) = f a >>= \a' -> g b >>= \b' -> pure $ k a' b' -- | Monadic lift over 3-tuples mlift3 :: Monad m => (a' -> b' -> c' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (a, b, c) -> m r-mlift3 k f g h (a, b, c) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> return $ k a' b' c'+mlift3 k f g h (a, b, c) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> pure $ k a' b' c' -- | Monadic lift over 4-tuples mlift4 :: Monad m => (a' -> b' -> c' -> d' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (a, b, c, d) -> m r-mlift4 k f g h i (a, b, c, d) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> return $ k a' b' c' d'+mlift4 k f g h i (a, b, c, d) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> pure $ k a' b' c' d' -- | Monadic lift over 5-tuples mlift5 :: Monad m => (a' -> b' -> c' -> d' -> e' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (a, b, c, d, e) -> m r-mlift5 k f g h i j (a, b, c, d, e) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> return $ k a' b' c' d' e'+mlift5 k f g h i j (a, b, c, d, e) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> pure $ k a' b' c' d' e' -- | Monadic lift over 6-tuples mlift6 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (a, b, c, d, e, f) -> m r-mlift6 k f g h i j l (a, b, c, d, e, y) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> return $ k a' b' c' d' e' y'+mlift6 k f g h i j l (a, b, c, d, e, y) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> pure $ k a' b' c' d' e' y' -- | Monadic lift over 7-tuples mlift7 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> g' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (g -> m g') -> (a, b, c, d, e, f, g) -> m r-mlift7 k f g h i j l m (a, b, c, d, e, y, z) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> return $ k a' b' c' d' e' y' z'+mlift7 k f g h i j l m (a, b, c, d, e, y, z) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> pure $ k a' b' c' d' e' y' z' -- | Monadic lift over 8-tuples mlift8 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> g' -> h' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (g -> m g') -> (h -> m h') -> (a, b, c, d, e, f, g, h) -> m r-mlift8 k f g h i j l m n (a, b, c, d, e, y, z, w) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> n w >>= \w' -> return $ k a' b' c' d' e' y' z' w'+mlift8 k f g h i j l m n (a, b, c, d, e, y, z, w) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> n w >>= \w' -> pure $ k a' b' c' d' e' y' z' w' -- Command line argument parsing code courtesy of Neil Mitchell's cmdargs package: see -- <http://github.com/ndmitchell/cmdargs/blob/master/System/Console/CmdArgs/Explicit/SplitJoin.hs>@@ -134,6 +142,10 @@ -- Otherwise, just proceed; hopefully we covered everything above go (c : rest) = c : go rest +-- | Show a value as 'Text'.+showText :: Show a => a -> Text+showText = T.pack . show+ -- | Given a Haskell string, convert it to SMTLib. if ord is 0x00020 to 0x0007E, then we print it as is -- to cover the printable ASCII range. stringToQFS :: String -> String@@ -272,3 +284,9 @@ uncurry12 :: (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> z) -> (a, b, c, d, e, f, g, h, i, j, k, l) -> z uncurry12 fn (a, b, c, d, e, f, g, h, i, j, k, l) = fn a b c d e f g h i j k l++-- | Convert a map to a list of @(value, key)@ pairs, sorted by value.+-- Useful when the map is keyed by a descriptor but indexed by an integer+-- that determines output order.+mapToSortedList :: Ord v => Map.Map k v -> [(v, k)]+mapToSortedList = sortBy (comparing fst) . map (\(a, b) -> (b, a)) . Map.toList
Data/SBV/Utils/Numeric.hs view
@@ -9,7 +9,8 @@ -- Various number related utilities ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -20,6 +21,7 @@ ) where import Data.Word+import Data.Text (Text) import Data.Array.ST (newArray, readArray, MArray, STUArray) import Data.Array.Unsafe (castSTUArray) import GHC.ST (runST, ST)@@ -72,7 +74,7 @@ | isInfinite x || isNaN x = 0 / 0 | y == 0 || isNaN y = 0 / 0 | isInfinite y = x- | True = pSign (x - fromRational (fromInteger d * ry))+ | True = pSign (fromRational (rx - fromInteger d * ry)) where rx, ry, rd :: Rational rx = toRational x ry = toRational y@@ -176,7 +178,7 @@ arbitrary = elements [minBound .. maxBound] -- | Convert a rounding mode to the format SMT-Lib2 understands.-smtRoundingMode :: RoundingMode -> String+smtRoundingMode :: RoundingMode -> Text smtRoundingMode RoundNearestTiesToEven = "roundNearestTiesToEven" smtRoundingMode RoundNearestTiesToAway = "roundNearestTiesToAway" smtRoundingMode RoundTowardPositive = "roundTowardPositive"
Data/SBV/Utils/PrettyNum.hs view
@@ -10,9 +10,10 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Utils.PrettyNum ( PrettyNum(..), readBin, shex, chex, shexI, sbin, sbinI@@ -21,7 +22,7 @@ , showNegativeNumber ) where -import Data.Bits ((.&.), countTrailingZeros)+import Data.Bits ((.&.), countTrailingZeros, testBit) import Data.Char (intToDigit, ord, chr) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (isPrefixOf)@@ -42,8 +43,8 @@ import Data.SBV.Core.AlgReals (algRealToSMTLib2) import Data.SBV.Core.SizedFloats (fprToSMTLib2, bfToString) -import Data.SBV.Utils.Lib (stringToQFS)-import Data.SBV.Utils.Numeric (smtRoundingMode)+import Data.SBV.Utils.Lib (stringToQFS, showText)+import Data.SBV.Utils.Numeric (smtRoundingMode, floatToWord, doubleToWord) -- | PrettyNum class captures printing of numbers in hex and binary formats; also supporting negative numbers. class PrettyNum a where@@ -62,20 +63,20 @@ -- Why not default methods? Because defaults need "Integral a" but Bool is not.. instance PrettyNum Bool where- hexS = T.pack . show- binS = T.pack . show- hexP = T.pack . show- binP = T.pack . show- hex = T.pack . show- bin = T.pack . show+ hexS = showText+ binS = showText+ hexP = showText+ binP = showText+ hex = showText+ bin = showText instance PrettyNum String where- hexS = T.pack . show- binS = T.pack . show- hexP = T.pack . show- binP = T.pack . show- hex = T.pack . show- bin = T.pack . show+ hexS = showText+ binS = showText+ hexP = showText+ binP = showText+ hex = showText+ bin = showText instance PrettyNum Word8 where hexS = shex True True (False, 8)@@ -168,78 +169,49 @@ bin = sbinI False False shBKind :: HasKind a => a -> Text-shBKind a = T.pack " :: " <> showBaseKind (kindOf a)+shBKind a = " :: " <> showBaseKind (kindOf a) instance PrettyNum CV where- hexS cv | isADT cv = T.pack (show cv) <> shBKind cv- | isBoolean cv = hexS (cvToBool cv) <> shBKind cv- | isFloat cv = let CFloat f = cvVal cv in T.pack (N.showHFloat f "") <> shBKind cv- | isDouble cv = let CDouble d = cvVal cv in T.pack (N.showHFloat d "") <> shBKind cv- | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 16 True True f) <> shBKind cv- | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r) <> shBKind cv- | isString cv = let CString s = cvVal cv in T.pack (show s) <> shBKind cv- | not (isBounded cv) = let CInteger i = cvVal cv in shexI True True i- | True = let CInteger i = cvVal cv in shex True True (hasSign cv, intSizeOf cv) i-- binS cv | isADT cv = T.pack (show cv) <> shBKind cv- | isBoolean cv = binS (cvToBool cv) <> shBKind cv- | isFloat cv = let CFloat f = cvVal cv in T.pack (showBFloat f "") <> shBKind cv- | isDouble cv = let CDouble d = cvVal cv in T.pack (showBFloat d "") <> shBKind cv- | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 2 True True f) <> shBKind cv- | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r) <> shBKind cv- | isString cv = let CString s = cvVal cv in T.pack (show s) <> shBKind cv- | not (isBounded cv) = let CInteger i = cvVal cv in sbinI True True i- | True = let CInteger i = cvVal cv in sbin True True (hasSign cv, intSizeOf cv) i-- hexP cv | isADT cv = T.pack (show cv)- | isBoolean cv = hexS (cvToBool cv)- | isFloat cv = let CFloat f = cvVal cv in T.pack (show f)- | isDouble cv = let CDouble d = cvVal cv in T.pack (show d)- | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 16 True True f)- | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r)- | isString cv = let CString s = cvVal cv in T.pack (show s)- | not (isBounded cv) = let CInteger i = cvVal cv in shexI False True i- | True = let CInteger i = cvVal cv in shex False True (hasSign cv, intSizeOf cv) i-- binP cv | isADT cv = T.pack (show cv)- | isBoolean cv = binS (cvToBool cv)- | isFloat cv = let CFloat f = cvVal cv in T.pack (show f)- | isDouble cv = let CDouble d = cvVal cv in T.pack (show d)- | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 2 True True f)- | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r)- | isString cv = let CString s = cvVal cv in T.pack (show s)- | not (isBounded cv) = let CInteger i = cvVal cv in sbinI False True i- | True = let CInteger i = cvVal cv in sbin False True (hasSign cv, intSizeOf cv) i-- hex cv | isADT cv = T.pack (show cv)- | isBoolean cv = hexS (cvToBool cv)- | isFloat cv = let CFloat f = cvVal cv in T.pack (show f)- | isDouble cv = let CDouble d = cvVal cv in T.pack (show d)- | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 16 False True f)- | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r)- | isString cv = let CString s = cvVal cv in T.pack (show s)- | not (isBounded cv) = let CInteger i = cvVal cv in shexI False False i- | True = let CInteger i = cvVal cv in shex False False (hasSign cv, intSizeOf cv) i+ hexS = cvPretty True True True True (\f -> T.pack (N.showHFloat f "")) (\d -> T.pack (N.showHFloat d ""))+ binS = cvPretty False True True True (\f -> T.pack (showBFloat f "")) (\d -> T.pack (showBFloat d ""))+ hexP = cvPretty True False True False showText showText+ binP = cvPretty False False True False showText showText+ hex = cvPretty True False False False showText showText+ bin = cvPretty False False False False showText showText - bin cv | isADT cv = T.pack (show cv)- | isBoolean cv = binS (cvToBool cv)- | isFloat cv = let CFloat f = cvVal cv in T.pack (show f)- | isDouble cv = let CDouble d = cvVal cv in T.pack (show d)- | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 2 False True f)- | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r)- | isString cv = let CString s = cvVal cv in T.pack (show s)- | not (isBounded cv) = let CInteger i = cvVal cv in sbinI False False i- | True = let CInteger i = cvVal cv in sbin False False (hasSign cv, intSizeOf cv) i+-- | Factor out the common structure of PrettyNum CV methods+cvPretty :: Bool -- ^ isHex (True) or isBin (False)+ -> Bool -- ^ Show type suffix on integers+ -> Bool -- ^ Show prefix (0x/0b) on integers+ -> Bool -- ^ Show kind suffix on non-integer cases+ -> (Float -> Text) -- ^ Float formatter+ -> (Double -> Text) -- ^ Double formatter+ -> CV -> Text+cvPretty isHex shType shPre shKind fmtF fmtD cv+ | isADT cv = showText cv <> knd+ | isBoolean cv = (if isHex then hexS else binS) (cvToBool cv) <> knd+ | isFloat cv, CFloat f <- cvVal cv = fmtF f <> knd+ | isDouble cv, CDouble d <- cvVal cv = fmtD d <> knd+ | isFP cv, CFP f <- cvVal cv = T.pack (bfToString base shPre True f) <> knd+ | isReal cv, CAlgReal r <- cvVal cv = showText r <> knd+ | isString cv, CString s <- cvVal cv = showText s <> knd+ | not (isBounded cv), CInteger i <- cvVal cv = intI i+ | CInteger i <- cvVal cv = intB (hasSign cv, intSizeOf cv) i+ | True = error $ "PrettyNum: Received CV that can't be displayed: " ++ show cv+ where knd = if shKind then shBKind cv else ""+ base = if isHex then 16 else 2+ intI = (if isHex then shexI else sbinI) shType shPre+ intB = (if isHex then shex else sbin) shType shPre instance (SymVal a, PrettyNum a) => PrettyNum (SBV a) where- hexS s = maybe (T.pack $ show s) (hexS :: a -> Text) $ unliteral s- binS s = maybe (T.pack $ show s) (binS :: a -> Text) $ unliteral s+ hexS s = maybe (showText s) (hexS :: a -> Text) $ unliteral s+ binS s = maybe (showText s) (binS :: a -> Text) $ unliteral s - hexP s = maybe (T.pack $ show s) (hexP :: a -> Text) $ unliteral s- binP s = maybe (T.pack $ show s) (binP :: a -> Text) $ unliteral s+ hexP s = maybe (showText s) (hexP :: a -> Text) $ unliteral s+ binP s = maybe (showText s) (binP :: a -> Text) $ unliteral s - hex s = maybe (T.pack $ show s) (hex :: a -> Text) $ unliteral s- bin s = maybe (T.pack $ show s) (bin :: a -> Text) $ unliteral s+ hex s = maybe (showText s) (hex :: a -> Text) $ unliteral s+ bin s = maybe (showText s) (bin :: a -> Text) $ unliteral s -- | Show as a hexadecimal value. First bool controls whether type info is printed -- while the second boolean controls whether 0x prefix is printed. The tuple is@@ -248,12 +220,12 @@ shex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> Text shex shType shPre (signed, size) a | a < 0- = T.pack "-" <> pre <> T.pack (pad l (s16 (abs (fromIntegral a :: Integer)))) <> t+ = "-" <> pre <> T.pack (pad l (s16 (abs (fromIntegral a :: Integer)))) <> t | True = pre <> T.pack (pad l (s16 a)) <> t- where t | shType = T.pack " :: " <> T.pack (if signed then "Int" else "Word") <> T.pack (show size)+ where t | shType = " :: " <> (if signed then "Int" else "Word") <> showText size | True = T.empty- pre | shPre = T.pack "0x"+ pre | shPre = "0x" | True = T.empty l = (size + 3) `div` 4 @@ -290,36 +262,36 @@ shexI :: Bool -> Bool -> Integer -> Text shexI shType shPre a | a < 0- = T.pack "-" <> pre <> T.pack (s16 (abs a)) <> t+ = "-" <> pre <> T.pack (s16 (abs a)) <> t | True = pre <> T.pack (s16 a) <> t- where t | shType = T.pack " :: Integer"+ where t | shType = " :: Integer" | True = T.empty- pre | shPre = T.pack "0x"+ pre | shPre = "0x" | True = T.empty -- | Similar to 'shex'; except in binary. sbin :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> Text sbin shType shPre (signed,size) a | a < 0- = T.pack "-" <> pre <> T.pack (pad size (s2 (abs (fromIntegral a :: Integer)))) <> t+ = "-" <> pre <> T.pack (pad size (s2 (abs (fromIntegral a :: Integer)))) <> t | True = pre <> T.pack (pad size (s2 a)) <> t- where t | shType = T.pack " :: " <> T.pack (if signed then "Int" else "Word") <> T.pack (show size)+ where t | shType = " :: " <> (if signed then "Int" else "Word") <> showText size | True = T.empty- pre | shPre = T.pack "0b"+ pre | shPre = "0b" | True = T.empty -- | Similar to 'shexI'; except in binary. sbinI :: Bool -> Bool -> Integer -> Text sbinI shType shPre a | a < 0- = T.pack "-" <> pre <> T.pack (s2 (abs a)) <> t+ = "-" <> pre <> T.pack (s2 (abs a)) <> t | True = pre <> T.pack (s2 a) <> t- where t | shType = T.pack " :: Integer"+ where t | shType = " :: Integer" | True = T.empty- pre | shPre = T.pack "0b"+ pre | shPre = "0b" | True = T.empty -- | Pad a string to a given length. If the string is longer, then we don't drop anything.@@ -341,7 +313,7 @@ [(a, "")] -> a _ -> error $ "SBV.readBin: Cannot read a binary number from: " ++ show s where cvt c = ord c - ord '0'- isDigit = (`elem` "01")+ isDigit = (`elem` ("01" :: String)) s' | "0b" `isPrefixOf` s = drop 2 s | True = s @@ -378,53 +350,52 @@ | True = show d -- | A version of show for floats that generates correct SMTLib literals using the rounding mode-showSMTFloat :: RoundingMode -> Float -> String-showSMTFloat rm f+showSMTFloat :: Float -> Text+showSMTFloat f | isNaN f = as "NaN" | isInfinite f, f < 0 = as "-oo" | isInfinite f = as "+oo" | isNegativeZero f = as "-zero" | f == 0 = as "+zero"- | True = "((_ to_fp 8 24) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational f) ++ ")"- where as s = "(_ " ++ s ++ " 8 24)"-+ | True = let w = floatToWord f+ b i = if w `testBit` i then '1' else '0'+ s = T.pack [b 31]+ e = T.pack [b i | i <- [30, 29 .. 23]]+ m = T.pack [b i | i <- [22, 21 .. 0]]+ in "(fp #b" <> s <> " #b" <> e <> " #b" <> m <> ")"+ where as s = "(_ " <> s <> " 8 24)" -- | A version of show for doubles that generates correct SMTLib literals using the rounding mode-showSMTDouble :: RoundingMode -> Double -> String-showSMTDouble rm d+showSMTDouble :: Double -> Text+showSMTDouble d | isNaN d = as "NaN" | isInfinite d, d < 0 = as "-oo" | isInfinite d = as "+oo" | isNegativeZero d = as "-zero" | d == 0 = as "+zero"- | True = "((_ to_fp 11 53) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational d) ++ ")"- where as s = "(_ " ++ s ++ " 11 53)"+ | True = let w = doubleToWord d+ b i = if w `testBit` i then '1' else '0'+ s = T.pack [b 63]+ e = T.pack [b i | i <- [62, 61 .. 52]]+ m = T.pack [b i | i <- [51, 50 .. 0]]+ in "(fp #b" <> s <> " #b" <> e <> " #b" <> m <> ")"+ where as s = "(_ " <> s <> " 11 53)" -- | Show an SBV rational as an SMTLib value. This is used for faithful rationals.-showSMTRational :: Rational -> String-showSMTRational r = "(SBV.Rational " ++ showNegativeNumber (numerator r) ++ " " ++ showNegativeNumber (denominator r) ++ ")"---- | Show a rational in SMTLib format. This is used for conversions from regular rationals.-toSMTLibRational :: Rational -> String-toSMTLibRational r- | n < 0- = "(- (/ " ++ show (abs n) ++ ".0 " ++ show d ++ ".0))"- | True- = "(/ " ++ show n ++ ".0 " ++ show d ++ ".0)"- where n = numerator r- d = denominator r+showSMTRational :: Rational -> Text+showSMTRational r = "(SBV.Rational " <> showNegativeNumber (numerator r) <> " " <> showNegativeNumber (denominator r) <> ")" -- | Convert a CV to an SMTLib2 compliant value-cvToSMTLib :: RoundingMode -> CV -> String-cvToSMTLib rm x+cvToSMTLib :: CV -> Text+cvToSMTLib x | isBoolean x, CInteger w <- cvVal x = if w == 0 then "false" else "true" | isRoundingMode x, CADT (s, []) <- cvVal x = roundModeConvert s- | isReal x, CAlgReal r <- cvVal x = algRealToSMTLib2 r- | isFloat x, CFloat f <- cvVal x = showSMTFloat rm f- | isDouble x, CDouble d <- cvVal x = showSMTDouble rm d+ | isReal x, CAlgReal r <- cvVal x = T.pack (algRealToSMTLib2 r) | isRational x, CRational r <- cvVal x = showSMTRational r- | isFP x, CFP f <- cvVal x = fprToSMTLib2 f- | not (isBounded x), CInteger w <- cvVal x = if w >= 0 then show w else "(- " ++ show (abs w) ++ ")"+ | isFloat x, CFloat f <- cvVal x = showSMTFloat f+ | isDouble x, CDouble d <- cvVal x = showSMTDouble d+ | isFP x, CFP f <- cvVal x = T.pack (fprToSMTLib2 f)+ | not (isBounded x), CInteger w <- cvVal x = if w >= 0 then showText w else "(- " <> showText (abs w) <> ")" | not (hasSign x) , CInteger w <- cvVal x = smtLibHex (intSizeOf x) w -- signed numbers (with 2's complement representation) is problematic -- since there's no way to put a bvneg over a positive number to get minBound..@@ -432,8 +403,8 @@ | hasSign x , CInteger w <- cvVal x = if w == negate (2 ^ intSizeOf x) then mkMinBound (intSizeOf x) else negIf (w < 0) $ smtLibHex (intSizeOf x) (abs w)- | isChar x , CChar c <- cvVal x = "(_ char " ++ smtLibHex 8 (fromIntegral (ord c)) ++ ")"- | isString x , CString s <- cvVal x = '\"' : stringToQFS s ++ "\""+ | isChar x , CChar c <- cvVal x = "(_ char " <> smtLibHex 8 (fromIntegral (ord c)) <> ")"+ | isString x , CString s <- cvVal x = "\"" <> T.pack (stringToQFS s) <> "\"" | isList x , CList xs <- cvVal x = smtLibSeq (kindOf x) xs | isSet x , CSet s <- cvVal x = smtLibSet (kindOf x) s | isTuple x , CTuple xs <- cvVal x = smtLibTup (kindOf x) xs@@ -445,29 +416,29 @@ | isADT x , CADT c <- cvVal x = smtLibADT (cvKind x) c | True = error $ "SBV.cvtCV: 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])+ where roundModeConvert s = fromMaybe (T.pack s) (listToMaybe [smtRoundingMode m | m <- [minBound .. maxBound] :: [RoundingMode], show m == s]) -- Carefully code hex numbers, SMTLib is picky about lengths of hex constants. For the time -- being, SBV only supports sizes that are multiples of 4, but the below code is more robust -- in case of future extensions to support arbitrary sizes.- smtLibHex :: Int -> Integer -> String- smtLibHex 1 v = "#b" ++ show v+ smtLibHex :: Int -> Integer -> Text+ smtLibHex 1 v = "#b" <> showText v smtLibHex sz v- | sz `mod` 4 == 0 = "#x" ++ pad (sz `div` 4) (showHex v "")- | True = "#b" ++ pad sz (showBin v "")+ | sz `mod` 4 == 0 = "#x" <> T.pack (pad (sz `div` 4) (showHex v ""))+ | True = "#b" <> T.pack (pad sz (showBin v "")) where showBin = showIntAtBase 2 intToDigit- negIf :: Bool -> String -> String- negIf True a = "(bvneg " ++ a ++ ")"+ negIf :: Bool -> Text -> Text+ negIf True a = "(bvneg " <> a <> ")" negIf False a = a - smtLibSeq :: Kind -> [CVal] -> String- smtLibSeq k [] = "(as seq.empty " ++ smtType k ++ ")"+ smtLibSeq :: Kind -> [CVal] -> Text+ smtLibSeq k [] = "(as seq.empty " <> smtType k <> ")" smtLibSeq (KList ek) xs = let mkSeq [e] = e- mkSeq es = "(seq.++ " ++ unwords es ++ ")"- mkUnit inner = "(seq.unit " ++ inner ++ ")"- in mkSeq (mkUnit . cvToSMTLib rm . CV ek <$> xs)- smtLibSeq k _ = error "SBV.cvToSMTLib: Impossible case (smtLibSeq), received kind: " ++ show k+ mkSeq es = "(seq.++ " <> T.unwords es <> ")"+ mkUnit inner = "(seq.unit " <> inner <> ")"+ in mkSeq (mkUnit . cvToSMTLib . CV ek <$> xs)+ smtLibSeq k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibSeq), received kind: " ++ show k - smtLibSet :: Kind -> RCSet CVal -> String+ smtLibSet :: Kind -> RCSet CVal -> Text smtLibSet k set = case set of RegularSet rs -> Set.foldr' (modify "true") (start "false") rs ComplementSet rs -> Set.foldr' (modify "false") (start "true") rs@@ -475,38 +446,38 @@ KSet ek -> ek _ -> error $ "SBV.cvToSMTLib: Impossible case (smtLibSet), received kind: " ++ show k - start def = "((as const " ++ smtType k ++ ") " ++ def ++ ")"+ start def = "((as const " <> smtType k <> ") " <> def <> ")" - modify how e s = "(store " ++ s ++ " " ++ cvToSMTLib rm (CV ke e) ++ " " ++ how ++ ")"+ modify how e s = "(store " <> s <> " " <> cvToSMTLib (CV ke e) <> " " <> how <> ")" - smtLibTup :: Kind -> [CVal] -> String+ smtLibTup :: Kind -> [CVal] -> Text smtLibTup (KTuple []) _ = "mkSBVTuple0"- smtLibTup (KTuple ks) xs = "(mkSBVTuple" ++ show (length ks) ++ " " ++ unwords (zipWith (\ek e -> cvToSMTLib rm (CV ek e)) ks xs) ++ ")"+ smtLibTup (KTuple ks) xs = "(mkSBVTuple" <> showText (length ks) <> " " <> T.unwords (zipWith (\ek e -> cvToSMTLib (CV ek e)) ks xs) <> ")" smtLibTup k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibTup), received kind: " ++ show k -- Remember that in an ArrayModel we keep a history; i.e., the earlier elements are written later. So, we reverse the assocs- smtLibArray :: Kind -> ArrayModel CVal CVal -> String+ smtLibArray :: Kind -> ArrayModel CVal CVal -> Text smtLibArray k@(KArray k1 k2) (ArrayModel assocs def) = mkStoreChain k k1 k2 (reverse assocs) def smtLibArray k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibArray), received non-matching kind: " ++ show k mkStoreChain k k1 k2 writes def = walk writes base- where base = "((as const " ++ smtType k ++ ") " ++ cvToSMTLib rm (CV k2 def) ++ ")"+ where base = "((as const " <> smtType k <> ") " <> cvToSMTLib (CV k2 def) <> ")" walk [] sofar = sofar walk ((key, val) : rest) sofar = walk rest (store key val sofar) - store key val sofar = "(store " ++ sofar ++ " " ++ cvToSMTLib rm (CV k1 key) ++ " " ++ cvToSMTLib rm (CV k2 val) ++ ")"+ store key val sofar = "(store " <> sofar <> " " <> cvToSMTLib (CV k1 key) <> " " <> cvToSMTLib (CV k2 val) <> ")" -- anomaly at the 2's complement min value! Have to use binary notation here -- as there is no positive value we can provide to make the bvneg work.. (see above)- mkMinBound :: Int -> String- mkMinBound i = "#b1" ++ replicate (i-1) '0'+ mkMinBound :: Int -> Text+ mkMinBound i = "#b1" <> T.replicate (i-1) "0" -- ADTs- smtLibADT :: Kind -> (String, [(Kind, CVal)]) -> String+ smtLibADT :: Kind -> (String, [(Kind, CVal)]) -> Text smtLibADT knd (c, []) = ascribe c knd- smtLibADT knd (c, kvs) = '(' : ascribe c knd ++ " " ++ unwords (map (\(k, v) -> cvToSMTLib rm (CV k v)) kvs) ++ ")"- ascribe nm k = "(as " ++ nm ++ " " ++ smtType k ++ ")"+ smtLibADT knd (c, kvs) = "(" <> ascribe c knd <> " " <> T.unwords (map (\(k, v) -> cvToSMTLib (CV k v)) kvs) <> ")"+ ascribe nm k = "(as " <> T.pack nm <> " " <> smtType k <> ")" -- | Show a float as a binary showBFloat :: (Show a, RealFloat a) => a -> ShowS@@ -570,7 +541,7 @@ | True = '<' : show v ++ ">" -- | When we show a negative number in SMTLib, we must properly parenthesize.-showNegativeNumber :: (Show a, Num a, Ord a) => a -> String+showNegativeNumber :: (Show a, Num a, Ord a) => a -> Text showNegativeNumber i- | i < 0 = "(- " ++ show (-i) ++ ")"- | True = show i+ | i < 0 = "(- " <> showText (-i) <> ")"+ | True = showText i
Data/SBV/Utils/SExpr.hs view
@@ -104,7 +104,7 @@ if null extras then case sexp of EApp [ECon "error", ECon er] -> Left $ "Solver returned an error: " ++ er- _ -> return sexp+ _ -> pure sexp else die "Extra tokens after valid input" where inpToks = tokenize inp@@ -115,21 +115,21 @@ parse [] = die "ran out of tokens" parse ("(":toks) = do (f, r) <- parseApp toks [] f' <- cvt (EApp f)- return (f', r)+ pure (f', r) parse (")":_) = die "extra tokens after close paren" parse [tok] = do t <- pTok tok- return (t, [])+ pure (t, []) parse _ = die "ill-formed s-expr" parseApp [] _ = die "failed to grab s-expr application"- parseApp (")":toks) sofar = return (reverse sofar, toks)+ parseApp (")":toks) sofar = pure (reverse sofar, toks) parseApp ("(":toks) sofar = do (f, r) <- parse ("(":toks) parseApp r (f : sofar) parseApp (tok:toks) sofar = do t <- pTok tok parseApp toks (t : sofar) - pTok "false" = return $ ENum (0, Nothing, True)- pTok "true" = return $ ENum (1, Nothing, True)+ pTok "false" = pure $ ENum (0, Nothing, True)+ pTok "true" = pure $ ENum (1, Nothing, True) pTok ('0':'b':r) = mkNum (Just (length r)) $ readInt 2 (`elem` "01") (\c -> ord c - ord '0') r pTok ('b':'v':r) | not (null r) && all isDigit r = mkNum Nothing $ readDec (takeWhile (/= '[') r)@@ -137,7 +137,7 @@ pTok ('#':'x':r) = mkNum (Just (4 * length r)) $ readHex r pTok n | possiblyNum n = if all intChar n then mkNum Nothing $ readSigned readDec n else getReal n- pTok n = return $ ECon (constantMap n)+ pTok n = pure $ ECon (constantMap n) -- crude, but effective! possiblyNum s = case s of@@ -147,10 +147,10 @@ intChar c = c == '-' || isDigit c - mkNum l [(n, "")] = return $ ENum (n, l, False)+ mkNum l [(n, "")] = pure $ ENum (n, l, False) mkNum _ _ = die "cannot read number" - getReal n = return $ EReal $ mkPolyReal (Left (exact, n'))+ getReal n = pure $ EReal $ mkPolyReal (Left (exact, n')) where exact = not ("?" `isPrefixOf` reverse n) n' | exact = n | True = init n@@ -160,19 +160,19 @@ thd3 (_, _, c) = c -- simplify numbers and root-obj values- cvt (EApp [ECon "to_int", EReal a]) = return $ EReal a -- ignore the "casting"- cvt (EApp [ECon "to_real", EReal a]) = return $ EReal a -- ignore the "casting"- cvt (EApp [ECon "/", EReal a, EReal b]) = return $ EReal (a / b)- cvt (EApp [ECon "/", EReal a, ENum b]) = return $ EReal (a / fromInteger (fst3 b))- cvt (EApp [ECon "/", ENum a, EReal b]) = return $ EReal (fromInteger (fst3 a) / b )- cvt (EApp [ECon "/", ENum a, ENum b]) = return $ EReal (fromInteger (fst3 a) / fromInteger (fst3 b))- cvt (EApp [ECon "-", EReal a]) = return $ EReal (-a)- cvt (EApp [ECon "-", ENum a]) = return $ ENum (-(fst3 a), snd3 a, thd3 a)+ cvt (EApp [ECon "to_int", EReal a]) = pure $ EReal a -- ignore the "casting"+ cvt (EApp [ECon "to_real", EReal a]) = pure $ EReal a -- ignore the "casting"+ cvt (EApp [ECon "/", EReal a, EReal b]) = pure $ EReal (a / b)+ cvt (EApp [ECon "/", EReal a, ENum b]) = pure $ EReal (a / fromInteger (fst3 b))+ cvt (EApp [ECon "/", ENum a, EReal b]) = pure $ EReal (fromInteger (fst3 a) / b )+ cvt (EApp [ECon "/", ENum a, ENum b]) = pure $ EReal (fromInteger (fst3 a) / fromInteger (fst3 b))+ cvt (EApp [ECon "-", EReal a]) = pure $ EReal (-a)+ cvt (EApp [ECon "-", ENum a]) = pure $ ENum (-(fst3 a), snd3 a, thd3 a) -- bit-vector value as CVC4 prints: (_ bv0 16) for instance- cvt (EApp [ECon "_", ENum a, ENum _b]) = return $ ENum a+ cvt (EApp [ECon "_", ENum a, ENum _b]) = pure $ ENum a cvt (EApp [ECon "root-obj", EApp (ECon "+":trms), ENum k]) = do ts <- mapM getCoeff trms- return $ EReal $ mkPolyReal (Right (fst3 k, ts))+ pure $ EReal $ mkPolyReal (Right (fst3 k, ts)) cvt (EApp [ECon "as", n, EApp [ECon "_", ECon "FloatingPoint", ENum (11, _, _), ENum (53, _, _)]]) = getDouble n cvt (EApp [ECon "as", n, EApp [ECon "_", ECon "FloatingPoint", ENum ( 8, _, _), ENum (24, _, _)]]) = getFloat n cvt (EApp [ECon "as", n, ECon "Float64"]) = getDouble n@@ -183,10 +183,10 @@ , EApp [ECon "or", EApp [ECon "=", ECon v', val], _]]) | v == v' = do approx <- cvt val case approx of- ENum (s, _, _) -> return $ EReal $ mkPolyReal (Left (False, show s))+ ENum (s, _, _) -> pure $ EReal $ mkPolyReal (Left (False, show s)) EReal aval -> case aval of- AlgRational _ r -> return $ EReal $ AlgRational False r- _ -> return $ EReal aval+ AlgRational _ r -> pure $ EReal $ AlgRational False r+ _ -> pure $ EReal aval _ -> die $ "Cannot parse a CVC4 approximate value from: " ++ show x -- Deal with CVC5's algebraic reals. This is very crude!@@ -194,83 +194,83 @@ let isComma (ECon ",") = True isComma _ = False - get (ENum (n, _, _)) = return $ fromIntegral n- get (EReal (AlgRational True r)) = return r- get (EFloat f) = return $ toRational f- get (EDouble d) = return $ toRational d+ get (ENum (n, _, _)) = pure $ fromIntegral n+ get (EReal (AlgRational True r)) = pure r+ get (EFloat f) = pure $ toRational f+ get (EDouble d) = pure $ toRational d get t = die $ "Cannot get a CVC5 real-algebraic bound from: " ++ show t in case drop 1 (dropWhile (not . isComma) rest) of [EApp [n1, n2], _] -> do low <- get n1 high <- get n2- return $ EReal $ AlgInterval (OpenPoint low) (OpenPoint high)+ pure $ EReal $ AlgInterval (OpenPoint low) (OpenPoint high) _ -> die $ "Cannot parse a CVC5 real-algebraic number from: " ++ show x -- NB. Note the lengths on the mantissa for the following two are 23/52; not 24/53!- cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just 8, _), ENum (m, Just 23, _)]) = return $ EFloat $ getTripleFloat s e m- cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just 11, _), ENum (m, Just 52, _)]) = return $ EDouble $ getTripleDouble s e m- cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just eb, _), ENum (m, Just sb, _)]) = return $ EFloatingPoint $ fpFromRawRep (s == 1) (e, eb) (m, sb+1)+ cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just 8, _), ENum (m, Just 23, _)]) = pure $ EFloat $ getTripleFloat s e m+ cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just 11, _), ENum (m, Just 52, _)]) = pure $ EDouble $ getTripleDouble s e m+ cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just eb, _), ENum (m, Just sb, _)]) = pure $ EFloatingPoint $ fpFromRawRep (s == 1) (e, eb) (m, sb+1) - cvt (EApp [ECon "_", ECon "NaN", ENum ( 8, _, _), ENum (24, _, _)]) = return $ EFloat nan- cvt (EApp [ECon "_", ECon "NaN", ENum (11, _, _), ENum (53, _, _)]) = return $ EDouble nan- cvt (EApp [ECon "_", ECon "NaN", ENum (eb, _, _), ENum (sb, _, _)]) = return $ EFloatingPoint $ fpNaN (fromIntegral eb) (fromIntegral sb)+ cvt (EApp [ECon "_", ECon "NaN", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat nan+ cvt (EApp [ECon "_", ECon "NaN", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble nan+ cvt (EApp [ECon "_", ECon "NaN", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpNaN (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "+oo", ENum ( 8, _, _), ENum (24, _, _)]) = return $ EFloat infinity- cvt (EApp [ECon "_", ECon "+oo", ENum (11, _, _), ENum (53, _, _)]) = return $ EDouble infinity- cvt (EApp [ECon "_", ECon "+oo", ENum (eb, _, _), ENum (sb, _, _)]) = return $ EFloatingPoint $ fpInf False (fromIntegral eb) (fromIntegral sb)+ cvt (EApp [ECon "_", ECon "+oo", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat infinity+ cvt (EApp [ECon "_", ECon "+oo", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble infinity+ cvt (EApp [ECon "_", ECon "+oo", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpInf False (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "-oo", ENum ( 8, _, _), ENum (24, _, _)]) = return $ EFloat $ -infinity- cvt (EApp [ECon "_", ECon "-oo", ENum (11, _, _), ENum (53, _, _)]) = return $ EDouble $ -infinity- cvt (EApp [ECon "_", ECon "-oo", ENum (eb, _, _), ENum (sb, _, _)]) = return $ EFloatingPoint $ fpInf True (fromIntegral eb) (fromIntegral sb)+ cvt (EApp [ECon "_", ECon "-oo", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat $ -infinity+ cvt (EApp [ECon "_", ECon "-oo", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble $ -infinity+ cvt (EApp [ECon "_", ECon "-oo", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpInf True (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "+zero", ENum ( 8, _, _), ENum (24, _, _)]) = return $ EFloat 0- cvt (EApp [ECon "_", ECon "+zero", ENum (11, _, _), ENum (53, _, _)]) = return $ EDouble 0- cvt (EApp [ECon "_", ECon "+zero", ENum (eb, _, _), ENum (sb, _, _)]) = return $ EFloatingPoint $ fpZero False (fromIntegral eb) (fromIntegral sb)+ cvt (EApp [ECon "_", ECon "+zero", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat 0+ cvt (EApp [ECon "_", ECon "+zero", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble 0+ cvt (EApp [ECon "_", ECon "+zero", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpZero False (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "-zero", ENum ( 8, _, _), ENum (24, _, _)]) = return $ EFloat $ -0- cvt (EApp [ECon "_", ECon "-zero", ENum (11, _, _), ENum (53, _, _)]) = return $ EDouble $ -0- cvt (EApp [ECon "_", ECon "-zero", ENum (eb, _, _), ENum (sb, _, _)]) = return $ EFloatingPoint $ fpZero True (fromIntegral eb) (fromIntegral sb)+ cvt (EApp [ECon "_", ECon "-zero", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat $ -0+ cvt (EApp [ECon "_", ECon "-zero", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble $ -0+ cvt (EApp [ECon "_", ECon "-zero", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpZero True (fromIntegral eb) (fromIntegral sb) - cvt x = return x+ cvt x = pure x - getCoeff (EApp [ECon "*", ENum k, EApp [ECon "^", ECon "x", ENum p]]) = return (fst3 k, fst3 p) -- kx^p- getCoeff (EApp [ECon "*", ENum k, ECon "x" ] ) = return (fst3 k, 1) -- kx- getCoeff ( EApp [ECon "^", ECon "x", ENum p] ) = return ( 1, fst3 p) -- x^p- getCoeff ( ECon "x" ) = return ( 1, 1) -- x- getCoeff ( ENum k ) = return (fst3 k, 0) -- k+ getCoeff (EApp [ECon "*", ENum k, EApp [ECon "^", ECon "x", ENum p]]) = pure (fst3 k, fst3 p) -- kx^p+ getCoeff (EApp [ECon "*", ENum k, ECon "x" ] ) = pure (fst3 k, 1) -- kx+ getCoeff ( EApp [ECon "^", ECon "x", ENum p] ) = pure ( 1, fst3 p) -- x^p+ getCoeff ( ECon "x" ) = pure ( 1, 1) -- x+ getCoeff ( ENum k ) = pure (fst3 k, 0) -- k getCoeff x = die $ "Cannot parse a root-obj,\nProcessing term: " ++ show x getDouble (ECon s) = case (s, rdFP (dropWhile (== '+') s)) of- ("plusInfinity", _ ) -> return $ EDouble infinity- ("minusInfinity", _ ) -> return $ EDouble (-infinity)- ("oo", _ ) -> return $ EDouble infinity- ("-oo", _ ) -> return $ EDouble (-infinity)- ("zero", _ ) -> return $ EDouble 0- ("-zero", _ ) -> return $ EDouble (-0)- ("NaN", _ ) -> return $ EDouble nan- (_, Just v) -> return $ EDouble v+ ("plusInfinity", _ ) -> pure $ EDouble infinity+ ("minusInfinity", _ ) -> pure $ EDouble (-infinity)+ ("oo", _ ) -> pure $ EDouble infinity+ ("-oo", _ ) -> pure $ EDouble (-infinity)+ ("zero", _ ) -> pure $ EDouble 0+ ("-zero", _ ) -> pure $ EDouble (-0)+ ("NaN", _ ) -> pure $ EDouble nan+ (_, Just v) -> pure $ EDouble v _ -> die $ "Cannot parse a double value from: " ++ s getDouble (EApp [_, s, _, _]) = getDouble s- getDouble (EReal r) = return $ EDouble $ fromRat $ toRational r+ getDouble (EReal r) = pure $ EDouble $ fromRat $ toRational r getDouble x = die $ "Cannot parse a double value from: " ++ show x getFloat (ECon s) = case (s, rdFP (dropWhile (== '+') s)) of- ("plusInfinity", _ ) -> return $ EFloat infinity- ("minusInfinity", _ ) -> return $ EFloat (-infinity)- ("oo", _ ) -> return $ EFloat infinity- ("-oo", _ ) -> return $ EFloat (-infinity)- ("zero", _ ) -> return $ EFloat 0- ("-zero", _ ) -> return $ EFloat (-0)- ("NaN", _ ) -> return $ EFloat nan- (_, Just v) -> return $ EFloat v+ ("plusInfinity", _ ) -> pure $ EFloat infinity+ ("minusInfinity", _ ) -> pure $ EFloat (-infinity)+ ("oo", _ ) -> pure $ EFloat infinity+ ("-oo", _ ) -> pure $ EFloat (-infinity)+ ("zero", _ ) -> pure $ EFloat 0+ ("-zero", _ ) -> pure $ EFloat (-0)+ ("NaN", _ ) -> pure $ EFloat nan+ (_, Just v) -> pure $ EFloat v _ -> die $ "Cannot parse a float value from: " ++ s- getFloat (EReal r) = return $ EFloat $ fromRat $ toRational r+ getFloat (EReal r) = pure $ EFloat $ fromRat $ toRational r getFloat (EApp [_, s, _, _]) = getFloat s getFloat x = die $ "Cannot parse a float value from: " ++ show x -- | Parses the Z3 floating point formatted numbers like so: 1.321p5/1.2123e9 etc. rdFP :: (Read a, RealFloat a) => String -> Maybe a rdFP s = case break (`elem` "pe") s of- (m, 'p':e) -> rd m >>= \m' -> rd e >>= \e' -> return $ m' * ( 2 ** e')- (m, 'e':e) -> rd m >>= \m' -> rd e >>= \e' -> return $ m' * (10 ** e')+ (m, 'p':e) -> rd m >>= \m' -> rd e >>= \e' -> pure $ m' * ( 2 ** e')+ (m, 'e':e) -> rd m >>= \m' -> rd e >>= \e' -> pure $ m' * (10 ** e') (m, "") -> rd m _ -> Nothing where rd v = case reads v of@@ -504,10 +504,10 @@ parseStoreAssociations (EApp [ECon "_", ECon "as-array", ECon nm]) = Just $ Left nm parseStoreAssociations e = Right <$> (chainAssigns =<< vals e) where vals :: SExpr -> Maybe [Either ([SExpr], SExpr) SExpr]- vals (EApp [EApp [ECon "as", ECon "const", ECon "Array"], defVal]) = return [Right defVal]- vals (EApp [EApp [ECon "as", ECon "const", EApp (ECon "Array" : _)], defVal]) = return [Right defVal]+ vals (EApp [EApp [ECon "as", ECon "const", ECon "Array"], defVal]) = pure [Right defVal]+ vals (EApp [EApp [ECon "as", ECon "const", EApp (ECon "Array" : _)], defVal]) = pure [Right defVal] vals (EApp (ECon "store" : prev : argsVal)) | length argsVal >= 2 = do rest <- vals prev- return $ Left (init argsVal, last argsVal) : rest+ pure $ Left (init argsVal, last argsVal) : rest vals _ = Nothing -- | Turn a sequence of left-right chain assignments (condition + free) into a single chain@@ -576,7 +576,7 @@ Right (EApp [EApp [ECon o, e]]) | o == nm -> do (args, bd) <- lambda e let params | isCurried = unwords args | True = '(' : intercalate ", " args ++ ")"- return $ unBar nm ++ " " ++ params ++ " = " ++ bd+ pure $ unBar nm ++ " " ++ params ++ " = " ++ bd _ -> Nothing where -- infinite supply of names; starting with the ones we're given
Documentation/SBV/Examples/ADT/Param.hs view
@@ -155,9 +155,9 @@ -- | Query mode example. -- -- >>> queryE--- e1: (let p = (-3 * 1) in (-1 * p))+-- e1: (let h = (-3 * -1) in (1 * h)) -- e2: -2--- e3: (let p = 314 % 315 in p)+-- e3: (let d = 368 % 369 in d) queryE :: IO () queryE = runSMT $ do e1 :: SExpr String Integer <- free "e1"
Documentation/SBV/Examples/ADT/Types.hs view
@@ -42,7 +42,7 @@ -- types, we'll simply use an uninterpreted function. Note that -- this also implies we consider all terms to be given so that variables -- do not shadow each other; i.e., all variables are unique. This is--- a simplification, but it is not without justification: One can +-- a simplification, but it is not without justification: One can -- always alpha-rename bound variables so all bound variables are unique. env :: SString -> ST env = uninterpret "env"
Documentation/SBV/Examples/BitPrecise/BrokenSearch.hs view
@@ -110,6 +110,6 @@ mid = f low high - return $ sFromIntegral mid .== mid'+ pure $ sFromIntegral mid .== mid' {- HLint ignore module "Reduce duplication" -}
Documentation/SBV/Examples/BitPrecise/Legato.hs view
@@ -294,7 +294,7 @@ flagC <- sBool "flagC" flagZ <- sBool "flagZ" - return $ legatoIsCorrect (x, y, lo, regX, regA, flagC, flagZ)+ pure $ legatoIsCorrect (x, y, lo, regX, regA, flagC, flagZ) ------------------------------------------------------------------ -- * C Code generation
Documentation/SBV/Examples/BitPrecise/MergeSort.hs view
@@ -53,7 +53,7 @@ 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 -} @@ -88,7 +88,7 @@ correctness :: Int -> IO ThmResult correctness n = prove $ do xs <- mkFreeVars n let ys = mergeSort xs- return $ nonDecreasing ys .&& isPermutationOf xs ys+ pure $ nonDecreasing ys .&& isPermutationOf xs ys ----------------------------------------------------------------------------- -- * Generating C code
Documentation/SBV/Examples/BitPrecise/PrefixSum.hs view
@@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -Werror #-}@@ -85,7 +85,7 @@ flIsCorrect :: Int -> (forall a. (OrdSymbolic a, Num a, Bits a) => (a, a -> a -> a)) -> Symbolic SBool flIsCorrect n zf = do args :: PowerList SWord32 <- mkFreeVars n- return $ ps zf args .== lf zf args+ pure $ 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:
Documentation/SBV/Examples/CodeGeneration/Fibonacci.hs view
@@ -107,7 +107,7 @@ -- > const SWord64 s32 = s6 ? 0x0000000000000001ULL : s31; -- > const SWord64 s33 = s4 ? 0x0000000000000001ULL : s32; -- > const SWord64 s34 = s2 ? 0x0000000000000000ULL : s33;--- > +-- > -- > return s34; -- > } genFib1 :: SWord64 -> IO ()@@ -176,7 +176,7 @@ -- > 0x000003af9a19bbd9ULL, 0x000005f6c7b064e2ULL, 0x000009a661ca20bbULL -- > }; -- > const SWord64 s65 = s0 >= 65 ? 0x0000000000000000ULL : table0[s0];--- > +-- > -- > return s65; -- > } genFib2 :: Word64 -> IO ()
Documentation/SBV/Examples/CodeGeneration/GCD.hs view
@@ -88,14 +88,14 @@ -- 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;@@ -146,7 +146,7 @@ -- > const SWord8 s46 = s9 ? s5 : s45; -- > const SWord8 s47 = s6 ? s1 : s46; -- > const SWord8 s48 = s3 ? s0 : s47;--- > +-- > -- > return s48; -- > } genGCDInC :: IO ()
Documentation/SBV/Examples/Crypto/AES.hs view
@@ -29,11 +29,7 @@ {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE TypeApplications #-} -#if MIN_VERSION_base(4,19,0) {-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns -Wno-x-partial #-}-#else-{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}-#endif module Documentation.SBV.Examples.Crypto.AES where
Documentation/SBV/Examples/Crypto/Prince.hs view
@@ -14,7 +14,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ParallelListComp #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} module Documentation.SBV.Examples.Crypto.Prince where @@ -131,8 +131,8 @@ -- Q.E.D. prop_sr :: Predicate prop_sr = do b <- free "block"- return $ b .== sr (srInv b)- .&& b .== srInv (sr b)+ pure $ b .== sr (srInv b)+ .&& b .== srInv (sr b) -- | M' transformation m' :: Block -> Block@@ -189,8 +189,8 @@ -- Q.E.D. prop_SBox :: Predicate prop_SBox = do b <- free "block"- return $ b .== sBoxInv (sBox b)- .&& b .== sBox (sBoxInv b)+ pure $ b .== sBoxInv (sBox b)+ .&& b .== sBox (sBoxInv b) -- * Round constants
Documentation/SBV/Examples/Crypto/RC4.hs view
@@ -144,7 +144,7 @@ let ks = keySchedule key ct = zipWith xor ks pt pt' = zipWith xor ks ct- return $ pt .== pt'+ pure $ pt .== pt' -------------------------------------------------------------------------------------------- -- | For doctest purposes only
Documentation/SBV/Examples/Existentials/Diophantine.hs view
@@ -70,10 +70,10 @@ ldn :: forall proxy n. KnownNat n => proxy n -> Maybe Int -> [([Integer], Integer)] -> IO Solution ldn pn mbLim problem = do solution <- basis pn mbLim (map (map literal) m) if homogeneous- then return $ Homogeneous solution+ then pure $ Homogeneous solution else do let ones = [xs | (1:xs) <- solution] zeros = [xs | (0:xs) <- solution]- return $ NonHomogeneous ones zeros+ pure $ NonHomogeneous ones zeros where rhs = map snd problem lhs = map fst problem homogeneous = all (== 0) rhs@@ -170,5 +170,5 @@ , ([0, 0, 0, 0, 0, 4, -5], 1) ] case soln of- NonHomogeneous (xs:_) _ -> return xs+ NonHomogeneous (xs:_) _ -> pure xs _ -> search (i+1)
Documentation/SBV/Examples/Lists/BoundedMutex.hs view
@@ -110,7 +110,7 @@ -- -- >>> notFair 10 -- Fairness is violated at bound: 10--- P1: [Idle,Idle,Idle,Idle,Ready,Critical,Critical,Critical,Idle,Ready]+-- P1: [Idle,Idle,Idle,Idle,Ready,Critical,Idle,Ready,Critical,Critical] -- P2: [Idle,Ready,Ready,Ready,Ready,Ready,Ready,Ready,Ready,Ready] -- Ts: [1,1,1,1,1,1,1,1,1,1] --
Documentation/SBV/Examples/Misc/Auxiliary.hs view
@@ -28,7 +28,7 @@ y <- free "y" constrain $ x .>= 0 constrain $ x .<= 1- return $ x - abs y .== (0 :: SInteger)+ pure $ x - abs y .== (0 :: SInteger) -- | Generate all satisfying assignments for our problem. We have: --
Documentation/SBV/Examples/Misc/Floating.hs view
@@ -90,7 +90,7 @@ -- make sure we do not overflow at the intermediate points constrain $ fpIsPoint lhs constrain $ fpIsPoint rhs- return $ lhs .== rhs+ pure $ lhs .== rhs ----------------------------------------------------------------------------- -- * FP addition by non-zero can result in no change@@ -118,7 +118,7 @@ constrain $ fpIsPoint a constrain $ fpIsPoint b constrain $ a + b .== a- return $ b .== 0+ pure $ b .== 0 ----------------------------------------------------------------------------- -- * FP multiplicative inverses may not exist@@ -142,7 +142,7 @@ multInverse = prove $ do a <- sFloat "a" constrain $ fpIsPoint a constrain $ fpIsPoint (1/a)- return $ a * (1/a) .== 1+ pure $ a * (1/a) .== 1 ----------------------------------------------------------------------------- -- * Effect of rounding modes@@ -189,7 +189,7 @@ let rhs = x + y constrain $ fpIsPoint lhs constrain $ fpIsPoint rhs- return $ lhs ./= rhs+ pure $ lhs ./= rhs -- | Arbitrary precision floating-point numbers. SBV can talk about floating point numbers with arbitrary -- exponent and significand sizes as well. Here is a simple example demonstrating the minimum non-zero positive
Documentation/SBV/Examples/Misc/ModelExtract.hs view
@@ -25,7 +25,7 @@ outside disallow = sat $ do x <- sInteger "x" let notEq i = constrain $ x ./= literal i mapM_ notEq disallow- return $ x .>= 0+ pure $ 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@@ -37,7 +37,7 @@ genVals :: IO [Integer] genVals = go [] [] where go _ model- | length model >= 10 = return model+ | length model >= 10 = pure model go disallow model = do res <- outside disallow -- Look up the value of "x" in the generated model@@ -45,4 +45,4 @@ -- SBV known type would be OK as well. case "x" `getModelValue` res of Just c -> go ([c-4 .. c+4] ++ disallow) (c : model)- _ -> return model+ _ -> pure model
Documentation/SBV/Examples/Misc/Newtypes.hs view
@@ -94,4 +94,4 @@ humanHeight :: SHumanHeightInCm <- free "humanheight" constrain $ humanHeight .== tallestHumanEver - return $ ceilingHighEnoughForHuman ceiling humanHeight+ pure $ ceilingHighEnoughForHuman ceiling humanHeight
Documentation/SBV/Examples/Misc/SoftConstrain.hs view
@@ -44,4 +44,4 @@ softConstrain $ x .== "default-x-value" softConstrain $ y .== "default-y-value" - return sTrue+ pure sTrue
Documentation/SBV/Examples/ProofTools/BMC.hs view
@@ -59,7 +59,7 @@ -- calls to 'Data.SBV.setOption'. We do not need any for this problem, -- so we simply do nothing. setup :: Symbolic ()- setup = return ()+ setup = pure () -- Transition relation: At each step we either -- get to increase @x@ by 2, or decrement @y@ by 4:
Documentation/SBV/Examples/ProofTools/Strengthen.hs view
@@ -68,7 +68,7 @@ -- calls to 'Data.SBV.setOption'. We do not need any for this problem, -- so we simply do nothing. setup :: Symbolic ()- setup = return ()+ setup = pure () -- Initially, @x@ and @y@ are both @1@ initial :: S SInteger -> SBool
Documentation/SBV/Examples/ProofTools/Sum.hs view
@@ -60,7 +60,7 @@ -- calls to 'Data.SBV.setOption'. We do not need any for this problem, -- so we simply do nothing. setup :: Symbolic ()- setup = return ()+ setup = pure () -- Initially, @s@ and @i@ are both @0@. We also require @n@ to be at least @0@. initial :: S SInteger -> SBool
Documentation/SBV/Examples/Puzzles/Coins.hs view
@@ -44,7 +44,7 @@ mkCoin :: Int -> Symbolic Coin mkCoin i = do c <- free $ 'c' : show i constrain $ sAny (.== c) [1, 5, 10, 25, 50, 100]- return c+ pure c -- | Return all combinations of a sequence of values. combinations :: [a] -> [[a]]@@ -105,4 +105,4 @@ constrain $ sAnd $ zipWith (.>=) cs (drop 1 cs) -- assert that the sum must be 115 cents.- return $ sum cs .== 115+ pure $ sum cs .== 115
Documentation/SBV/Examples/Puzzles/Euler185.hs view
@@ -34,7 +34,7 @@ -- number of matching digits match what's given in the problem statement. euler185 :: Symbolic SBool euler185 = do soln <- mkFreeVars 16- return $ sAll digit soln .&& sAnd (map (genConstr soln) guesses)+ pure $ sAll digit soln .&& sAnd (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
Documentation/SBV/Examples/Puzzles/Sudoku.hs view
@@ -9,16 +9,13 @@ -- The Sudoku solver, quintessential SMT solver example! ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Puzzles.Sudoku where -#if MIN_VERSION_base(4,18,0) import Control.Monad (when, zipWithM_)-#endif import Control.Monad.State.Lazy
Documentation/SBV/Examples/Puzzles/U2Bridge.hs view
@@ -15,7 +15,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Puzzles.U2Bridge where @@ -114,7 +114,7 @@ let (ar, s1) = runState a s (br, s2) = runState b s put $ symbolicMerge f t s1 s2- return $ symbolicMerge f t ar br+ pure $ symbolicMerge f t ar br -- | Read the state via an accessor function peek :: (Status -> a) -> Move a@@ -133,7 +133,10 @@ -- | Transferring a person to the other side xferPerson :: SU2Member -> Move ()-xferPerson p = do ~[lb, le, la, ll] <- mapM peek [lBono, lEdge, lAdam, lLarry]+xferPerson p = do lb <- peek lBono+ le <- peek lEdge+ la <- peek lAdam+ ll <- peek lLarry let move l = ite (l .== sHere) sThere sHere lb' = ite (p .== sBono) (move lb) lb le' = ite (p .== sEdge) (move le) le@@ -151,7 +154,7 @@ -- | Symbolic version of 'Control.Monad.when' whenS :: SBool -> Move () -> Move ()-whenS t a = ite t a (return ())+whenS t a = ite t a (pure ()) -- | Move one member, remembering to take the flash move1 :: SU2Member -> Move ()@@ -215,19 +218,19 @@ let genAct = do b <- free_ p1 <- free_ p2 <- free_- return (b, p1, p2)+ pure (b, p1, p2) res <- allSat $ isValid `fmap` mapM (const genAct) [1..n] cnt <- displayModels (sortOn show) disp res- if cnt == 0 then return False+ if cnt == 0 then pure False else do putStrLn $ "Found: " ++ show cnt ++ " solution" ++ plu cnt ++ " with " ++ show n ++ " move" ++ plu n ++ "."- return True+ pure 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 ()+ pure () 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
Documentation/SBV/Examples/Queries/AllSat.hs view
@@ -45,7 +45,7 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!"- return $ reverse sofar+ pure $ reverse sofar Sat -> do xv <- getValue x yv <- getValue y
Documentation/SBV/Examples/Queries/CaseSplit.hs view
@@ -54,7 +54,7 @@ case mbR of Nothing -> error "Cannot find a FP number x such that x /= x" -- Won't happen! Just (s, _) -> do xv <- getValue x- return (s, xv)+ pure (s, xv) -- | Demonstrates the "coverage" case. --@@ -82,4 +82,4 @@ case mbR of Nothing -> error "Cannot find a solution!" -- Won't happen! Just (s, _) -> do xv <- getValue x- return (s, xv)+ pure (s, xv)
Documentation/SBV/Examples/Queries/Concurrency.hs view
@@ -61,12 +61,12 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ pure Nothing Sat -> do xv <- getValue x yv <- getValue y io $ putStrLn $ "[One]: Current solution is: " ++ show (xv, yv)- return $ Just (xv + yv)+ pure $ Just (xv + yv) -- | In the second query we constrain for an answer where y is smaller than x, -- and then return the product of the found values.@@ -81,12 +81,12 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ pure Nothing Sat -> do yv <- getValue y xv <- getValue x io $ putStrLn $ "[Two]: Current solution is: " ++ show (xv, yv)- return $ Just (xv * yv)+ pure $ Just (xv * yv) -- | Run the demo several times to see that the children threads will change ordering. demo :: IO ()@@ -125,14 +125,14 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ pure Nothing Sat -> do xv <- getValue x yv <- getValue y io $ putStrLn $ "[One]: Current solution is: " ++ show (xv, yv) io $ putStrLn "[One]: Place vars for [Two]" liftIO $ putMVar v2 (literal (xv + yv), literal (xv * yv))- return $ Just (xv + yv)+ pure $ Just (xv + yv) -- | In the second query we create a new variable z, and then a symbolic query -- using information from the first query and return a solution that uses the@@ -153,13 +153,13 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!"- return Nothing+ pure Nothing Sat -> do yv <- getValue y xv <- getValue x zv <- getValue z io $ putStrLn $ "[Two]: My solution is: " ++ show (zv + xv, zv + yv)- return $ Just (zv * xv * yv)+ pure $ Just (zv * xv * yv) -- | In our second demonstration we show how through the use of concurrency -- constructs the user can have children queries communicate with one another.
Documentation/SBV/Examples/Queries/Enums.hs view
@@ -60,6 +60,6 @@ Sat -> do a <- getValue d1 b <- getValue d2 c <- getValue d3- return [a, b, c]+ pure [a, b, c] _ -> error "Impossible, can't find days!"
Documentation/SBV/Examples/Queries/FourFours.hs view
@@ -91,7 +91,7 @@ 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+fill F = pure F -- | Minor helper for writing "symbolic" case statements. Simply walks down a list -- of values to match against a symbolic version of the key.@@ -109,27 +109,27 @@ 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+ F -> pure 4 where binOp :: SBinOp -> SInteger -> SInteger -> Symbolic SInteger binOp o l r = do constrain $ o .== sDivide .=> r .== 4 .|| r .== 2 constrain $ o .== sExpt .=> r .== 0- return $ cases 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- ]+ pure $ cases 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 .== sSqrt .=> v .== 4 constrain $ o .== sFactorial .=> v .== 4- return $ cases 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- ]+ pure $ cases 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 evaluates to the -- requested number /i/. Note that we return back a concrete tree.@@ -140,10 +140,10 @@ query $ do cs <- checkSat case cs of Sat -> Just <$> construct symT- _ -> return Nothing+ _ -> pure Nothing where -- Walk through the tree, ask the solver for -- the assignment to symbolic operators and fill back.- construct F = return F+ construct F = pure F construct (U o s') = do uo <- getValue o U uo <$> construct s' construct (B b l' r') = do bo <- getValue b
Documentation/SBV/Examples/Queries/GuessNumber.hs view
@@ -50,7 +50,7 @@ Sat -> do gv <- getValue g case gv `compare` input of EQ -> -- Got it, return:- return (reverse (gv : sofar))+ pure (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:
Documentation/SBV/Examples/Queries/UnsatCore.hs view
@@ -36,7 +36,7 @@ query $ do cs <- checkSat case cs of Unsat -> Just <$> getUnsatCore- _ -> return Nothing+ _ -> pure Nothing -- | Extract the unsat-core of 'p'. We have:
Documentation/SBV/Examples/Strings/RegexCrossword.hs view
@@ -34,7 +34,7 @@ let mkRow rowRegExp = do row :: SString <- free_ constrain $ row `R.match` rowRegExp constrain $ L.length row .== literal numCols- return row+ pure row rows <- mapM mkRow rowRegExps @@ -42,7 +42,7 @@ let mkCol colRegExp = do col :: SString <- free_ constrain $ col `R.match` colRegExp constrain $ L.length col .== literal numRows- return col+ pure col cols <- mapM mkCol colRegExps
Documentation/SBV/Examples/Strings/SQLInjection.hs view
@@ -49,11 +49,11 @@ eval (Query q) = do q' <- eval q tell [q'] lift $ lift free_-eval (Const str) = return $ literal str+eval (Const str) = pure $ literal str eval (Concat e1 e2) = (++) <$> eval e1 <*> eval e2 eval (ReadVar nm) = do n <- eval nm arr <- get- return $ readArray arr n+ pure $ readArray arr n -- | A simple program to query all messages with a given topic id. In SQL like notation: --
Documentation/SBV/Examples/TP/Ackermann.hs view
@@ -75,15 +75,15 @@ -- -- >>> runTP ack_2_2_4 -- Inductive lemma (strong): ack_2_2_4--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: ack -- [Proven] ack_2_2_4 :: Ɐm ∷ Integer → Bool ack_2_2_4 :: TP (Proof (Forall "m" Integer -> SBool))@@ -106,16 +106,16 @@ -- -- >>> runTP ack_psd -- Inductive lemma (strong): ack_psd--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3 Q.E.D.--- Step: 1.4.1 Q.E.D.--- Step: 1.4.2 Q.E.D.--- Step: 1.4.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.4.1 Q.E.D.+-- Step: 1.4.2 Q.E.D.+-- Step: 1.4.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: ack -- [Proven] ack_psd :: Ɐm ∷ Integer → Ɐn ∷ Integer → Ɐa ∷ Integer → Bool ack_psd :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> Forall "a" Integer -> SBool))@@ -142,17 +142,17 @@ -- -- >>> runTPWith cvc5 pet_psd -- Inductive lemma (strong): pet_psd--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.3.1 Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: pet -- [Proven] pet_psd :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool pet_psd :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool))@@ -182,46 +182,46 @@ -- -- >>> runTPWith cvc5 petAck -- Inductive lemma (strong): ack_2_2_4--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): pet_psd--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.3.1 Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): petAck--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.3.1 Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.3.4 Q.E.D.--- Step: 1.3.5 Q.E.D.--- Step: 1.4.1 Q.E.D.--- Step: 1.4.2 Q.E.D.--- Step: 1.4.3 Q.E.D.--- Step: 1.4.4 Q.E.D.--- Step: 1.4.5 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.4.1 Q.E.D.+-- Step: 1.4.2 Q.E.D.+-- Step: 1.4.3 Q.E.D.+-- Step: 1.4.4 Q.E.D.+-- Step: 1.4.5 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: ack, pet -- [Proven] petAck :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool petAck :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool))
Documentation/SBV/Examples/TP/Basics.hs view
@@ -44,7 +44,7 @@ -- We have: -- -- >>> trueIsProvable--- Lemma: true Q.E.D.+-- Lemma: true Q.E.D. -- [Proven] true :: Bool trueIsProvable :: IO (Proof SBool) trueIsProvable = runTP $ lemma "true" sTrue []@@ -68,7 +68,7 @@ -- -- We have: -- >>> largerIntegerExists--- Lemma: largerIntegerExists Q.E.D.+-- Lemma: largerIntegerExists Q.E.D. -- [Proven] largerIntegerExists :: Ɐx ∷ Integer → ∃y ∷ Integer → Bool largerIntegerExists :: IO (Proof (Forall "x" Integer -> Exists "y" Integer -> SBool)) largerIntegerExists = runTP $ lemma "largerIntegerExists"@@ -80,7 +80,7 @@ -- | Pushing a universal through conjunction. We have: -- -- >>> forallConjunction @Integer (uninterpret "p") (uninterpret "q")--- Lemma: forallConjunction Q.E.D.+-- Lemma: forallConjunction Q.E.D. -- [Proven] forallConjunction :: Bool forallConjunction :: forall a. SymVal a => (SBV a -> SBool) -> (SBV a -> SBool) -> IO (Proof SBool) forallConjunction p q = runTP $ do@@ -96,7 +96,7 @@ -- | Pushing an existential through disjunction. We have: -- -- >>> existsDisjunction @Integer (uninterpret "p") (uninterpret "q")--- Lemma: existsDisjunction Q.E.D.+-- Lemma: existsDisjunction Q.E.D. -- [Proven] existsDisjunction :: Bool existsDisjunction :: forall a. SymVal a => (SBV a -> SBool) -> (SBV a -> SBool) -> IO (Proof SBool) existsDisjunction p q = runTP $ do@@ -180,7 +180,7 @@ -- Lemma: qcExample -- Step: 1 (passed 1000 tests) Q.E.D. [Modulo: quickCheck] -- Step: 2 (Failed during quickTest)--- +-- -- *** QuickCheck failed for qcExample.2 -- *** Failed! Assertion failed (after 1 test): -- n = 175 :: Word8@@ -207,8 +207,8 @@ -- -- >>> runTP (qcFermat 3) -- Lemma: qcFermat 3--- Step: 1 (qc: Running 1000 tests) QC OK--- Result: Q.E.D. [Modulo: quickCheck]+-- Step: 1 (qc: Running 1000 tests) QC OK+-- Result: Q.E.D. [Modulo: quickCheck] -- [Modulo: quickCheck] qcFermat 3 :: Ɐx ∷ Integer → Ɐy ∷ Integer → Ɐz ∷ Integer → Bool qcFermat :: Integer -> TP (Proof (Forall "x" Integer -> Forall "y" Integer -> Forall "z" Integer -> SBool)) qcFermat e = calc ("qcFermat " <> show e)@@ -228,7 +228,7 @@ -- verified the termination of @sumToN@ before proceeding with the proof. -- -- >>> terminationDemo--- Lemma: sumToN_at_5 Q.E.D.+-- Lemma: sumToN_at_5 Q.E.D. -- Functions proven terminating: sumToN -- [Proven] sumToN_at_5 :: Ɐn ∷ Integer → Bool terminationDemo :: IO (Proof (Forall "n" Integer -> SBool))@@ -308,8 +308,8 @@ -- >>> axiomsAreDangerous -- Axiom: bad -- Lemma: axiomsCanBeInconsistent--- Step: 1 (bad @ (n |-> 0 :: SInteger)) Q.E.D.--- Result: Q.E.D.+-- Step: 1 (bad @ (n |-> 0 :: SInteger)) Q.E.D.+-- Result: Q.E.D. -- [Proven] axiomsCanBeInconsistent :: Bool axiomsAreDangerous :: IO (Proof SBool) axiomsAreDangerous = runTP $ do@@ -379,7 +379,7 @@ -- 'lemma' proves from scratch and correctly fails: -- -- >>> runTP duplicateNames `catch` (\(_ :: SomeException) -> pure ())--- Lemma: evil Q.E.D.+-- Lemma: evil Q.E.D. -- Lemma: evil -- *** Failed to prove evil. -- Falsifiable
Documentation/SBV/Examples/TP/BinarySearch.hs view
@@ -63,52 +63,52 @@ -- We have: -- -- >>> correctness--- Lemma: notInRange Q.E.D.--- Lemma: inRangeHigh Q.E.D.--- Lemma: inRangeLow Q.E.D.--- Lemma: nonDecreasing Q.E.D.+-- Lemma: notInRange Q.E.D.+-- Lemma: inRangeHigh Q.E.D.+-- Lemma: inRangeLow Q.E.D.+-- Lemma: nonDecreasing Q.E.D. -- Inductive lemma (strong): bsearchAbsent--- Step: Measure is non-negative Q.E.D.--- Step: 1 (unfold bsearch) Q.E.D.--- Step: 2 (push isNothing down, simplify) Q.E.D.+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (unfold bsearch) Q.E.D.+-- Step: 2 (push isNothing down, simplify) Q.E.D. -- Step: 3 (2 way case split)--- Step: 3.1 Q.E.D.--- Step: 3.2.1 Q.E.D.--- Step: 3.2.2 Q.E.D.--- Step: 3.2.3 Q.E.D.--- Step: 3.2.4 Q.E.D.--- Step: 3.2.5 (simplify) Q.E.D.--- Step: 3.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 3.1 Q.E.D.+-- Step: 3.2.1 Q.E.D.+-- Step: 3.2.2 Q.E.D.+-- Step: 3.2.3 Q.E.D.+-- Step: 3.2.4 Q.E.D.+-- Step: 3.2.5 (simplify) Q.E.D.+-- Step: 3.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): bsearchPresent--- Step: Measure is non-negative Q.E.D.--- Step: 1 (unfold bsearch) Q.E.D.--- Step: 2 (simplify) Q.E.D.+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (unfold bsearch) Q.E.D.+-- Step: 2 (simplify) Q.E.D. -- Step: 3 (3 way case split)--- Step: 3.1 Q.E.D.--- Step: 3.2 Q.E.D.--- Step: 3.3.1 Q.E.D.+-- Step: 3.1 Q.E.D.+-- Step: 3.2 Q.E.D.+-- Step: 3.3.1 Q.E.D. -- Step: 3.3.2 (3 way case split)--- Step: 3.3.2.1 Q.E.D.--- Step: 3.3.2.2.1 Q.E.D.--- Step: 3.3.2.2.2 Q.E.D.--- Step: 3.3.2.3.1 Q.E.D.--- Step: 3.3.2.3.2 Q.E.D.--- Step: 3.3.2.Completeness Q.E.D.--- Step: 3.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 3.3.2.1 Q.E.D.+-- Step: 3.3.2.2.1 Q.E.D.+-- Step: 3.3.2.2.2 Q.E.D.+-- Step: 3.3.2.3.1 Q.E.D.+-- Step: 3.3.2.3.2 Q.E.D.+-- Step: 3.3.2.Completeness Q.E.D.+-- Step: 3.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: bsearchCorrect -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: bsearch -- [Proven] bsearchCorrect :: Ɐarr ∷ (ArrayModel Integer Integer) → Ɐlo ∷ Integer → Ɐhi ∷ Integer → Ɐx ∷ Integer → Bool correctness :: IO (Proof (Forall "arr" (ArrayModel Integer Integer) -> Forall "lo" Integer -> Forall "hi" Integer -> Forall "x" Integer -> SBool))-correctness = runTPWith (tpRibbon 50 cvc5) $ do+correctness = runTPWith cvc5 $ do -- Helper: if a value is not in a range, then it isn't in any subrange of it: notInRange <- lemma "notInRange"
Documentation/SBV/Examples/TP/CaseSplit.hs view
@@ -25,11 +25,11 @@ -- >>> notDiv3 -- Lemma: notDiv3 -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- [Proven] notDiv3 :: Ɐn ∷ Integer → Bool notDiv3 :: IO (Proof (Forall "n" Integer -> SBool)) notDiv3 = runTP $ do
Documentation/SBV/Examples/TP/Coins.hs view
@@ -79,17 +79,17 @@ -- -- >>> runTP correctness -- Inductive lemma (strong): mkChangeCorrect--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (5 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3 Q.E.D.--- Step: 1.4 Q.E.D.--- Step: 1.5.1 Q.E.D.--- Step: 1.5.2 Q.E.D.--- Step: 1.5.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.4 Q.E.D.+-- Step: 1.5.1 Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: mkChange -- [Proven] mkChangeCorrect :: Ɐn ∷ Integer → Bool correctness :: TP (Proof (Forall "n" Integer -> SBool))
Documentation/SBV/Examples/TP/Collatz.hs view
@@ -61,7 +61,7 @@ -- | Doubling doesn't change the Collatz result. -- -- >>> runTP doubling--- Lemma: doubling Q.E.D. [Modulo: collatz termination]+-- Lemma: doubling Q.E.D. [Modulo: collatz termination] -- [Modulo: collatz termination] doubling :: Ɐn ∷ Integer → Bool doubling :: TP (Proof (Forall "n" Integer -> SBool)) doubling = lemma "doubling" (\(Forall @"n" n) -> n .>= 1 .=> collatz (2 * n) .== collatz n) []@@ -70,10 +70,10 @@ -- -- >>> runTP pow2pos -- Inductive lemma: pow2pos--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: pow2 -- [Proven] pow2pos :: Ɐk ∷ Integer → Bool pow2pos :: TP (Proof (Forall "k" Integer -> SBool))@@ -91,14 +91,14 @@ -- | All powers of two reach 1 under the Collatz function. -- -- >>> runTP collatzPow2--- Lemma: doubling Q.E.D. [Modulo: collatz termination]--- Lemma: pow2pos Q.E.D.+-- Lemma: doubling Q.E.D. [Modulo: collatz termination]+-- Lemma: pow2pos Q.E.D. -- Inductive lemma: collatzPow2--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D. [Modulo: collatz termination]--- Step: 3 Q.E.D.--- Result: Q.E.D. [Modulo: collatz termination]+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D. [Modulo: collatz termination]+-- Step: 3 Q.E.D.+-- Result: Q.E.D. [Modulo: collatz termination] -- Functions proven terminating: pow2 -- [Modulo: collatz termination] collatzPow2 :: Ɐk ∷ Integer → Bool collatzPow2 :: TP (Proof (Forall "k" Integer -> SBool))
Documentation/SBV/Examples/TP/ConstFold.hs view
@@ -140,7 +140,7 @@ -- | The size measure is always non-negative. -- -- >>> runTP measureNonNeg--- Lemma: measureNonNeg Q.E.D.+-- Lemma: measureNonNeg Q.E.D. -- Functions proven terminating: exprSize -- [Proven] measureNonNeg :: Ɐe ∷ (Expr String Integer) → Bool measureNonNeg :: TP (Proof (Forall "e" Exp -> SBool))@@ -151,7 +151,7 @@ -- | Congruence for squaring: if @a == b@ then @a*a == b*b@. -- -- >>> runTP sqrCong--- Lemma: sqrCong Q.E.D.+-- Lemma: sqrCong Q.E.D. -- [Proven] sqrCong :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool sqrCong :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) sqrCong = lemma "sqrCong"@@ -161,7 +161,7 @@ -- | Congruence for addition on the left: if @a == b@ then @a+c == b+c@. -- -- >>> runTP addCongL--- Lemma: addCongL Q.E.D.+-- Lemma: addCongL Q.E.D. -- [Proven] addCongL :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool addCongL :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool)) addCongL = lemma "addCongL"@@ -171,7 +171,7 @@ -- | Congruence for addition on the right: if @b == c@ then @a+b == a+c@. -- -- >>> runTP addCongR--- Lemma: addCongR Q.E.D.+-- Lemma: addCongR Q.E.D. -- [Proven] addCongR :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool addCongR :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool)) addCongR = lemma "addCongR"@@ -181,7 +181,7 @@ -- | Congruence for multiplication on the left: if @a == b@ then @a*c == b*c@. -- -- >>> runTP mulCongL--- Lemma: mulCongL Q.E.D.+-- Lemma: mulCongL Q.E.D. -- [Proven] mulCongL :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool mulCongL :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool)) mulCongL = lemma "mulCongL"@@ -191,7 +191,7 @@ -- | Congruence for multiplication on the right: if @b == c@ then @a*b == a*c@. -- -- >>> runTP mulCongR--- Lemma: mulCongR Q.E.D.+-- Lemma: mulCongR Q.E.D. -- [Proven] mulCongR :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool mulCongR :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool)) mulCongR = lemma "mulCongR"@@ -201,7 +201,7 @@ -- | Unfolding @interpInEnv@ over @Sqr@. -- -- >>> runTP sqrHelper--- Lemma: sqrHelper Q.E.D.+-- Lemma: sqrHelper Q.E.D. -- Functions proven terminating: interpInEnv, sbv.lookup -- [Proven] sqrHelper :: Ɐenv ∷ [(String, Integer)] → Ɐa ∷ (Expr String Integer) → Bool sqrHelper :: TP (Proof (Forall "env" EL -> Forall "a" Exp -> SBool))@@ -212,7 +212,7 @@ -- | Unfolding @interpInEnv@ over @Add@. -- -- >>> runTP addHelper--- Lemma: addHelper Q.E.D.+-- Lemma: addHelper Q.E.D. -- Functions proven terminating: interpInEnv, sbv.lookup -- [Proven] addHelper :: Ɐenv ∷ [(String, Integer)] → Ɐa ∷ (Expr String Integer) → Ɐb ∷ (Expr String Integer) → Bool addHelper :: TP (Proof (Forall "env" EL -> Forall "a" Exp -> Forall "b" Exp -> SBool))@@ -223,7 +223,7 @@ -- | Unfolding @interpInEnv@ over @Mul@. -- -- >>> runTP mulHelper--- Lemma: mulHelper Q.E.D.+-- Lemma: mulHelper Q.E.D. -- Functions proven terminating: interpInEnv, sbv.lookup -- [Proven] mulHelper :: Ɐenv ∷ [(String, Integer)] → Ɐa ∷ (Expr String Integer) → Ɐb ∷ (Expr String Integer) → Bool mulHelper :: TP (Proof (Forall "env" EL -> Forall "a" Exp -> Forall "b" Exp -> SBool))@@ -234,7 +234,7 @@ -- | Unfolding @interpInEnv@ over @Let@. -- -- >>> runTP letHelper--- Lemma: letHelper Q.E.D.+-- Lemma: letHelper Q.E.D. -- Functions proven terminating: interpInEnv, sbv.lookup -- [Proven] letHelper :: Ɐenv ∷ [(String, Integer)] → Ɐnm ∷ String → Ɐa ∷ (Expr String Integer) → Ɐb ∷ (Expr String Integer) → Bool letHelper :: TP (Proof (Forall "env" EL -> Forall "nm" String -> Forall "a" Exp -> Forall "b" Exp -> SBool))@@ -249,11 +249,11 @@ -- >>> runTP lookupSwap -- Lemma: lookupSwap -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.lookup -- [Proven] lookupSwap :: Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool lookupSwap :: TP (Proof (Forall "k" String -> Forall "b1" (String, Integer)@@ -283,7 +283,7 @@ -- @define-fun-rec@ but struggles to fold it back, so we provide this as a reusable hint. -- -- >>> runTP lookupCons--- Lemma: lookupCons Q.E.D.+-- Lemma: lookupCons Q.E.D. -- Functions proven terminating: sbv.lookup -- [Proven] lookupCons :: Ɐk ∷ String → Ɐb ∷ (String, Integer) → Ɐrest ∷ [(String, Integer)] → Bool lookupCons :: TP (Proof (Forall "k" String -> Forall "b" (String, Integer) -> Forall "rest" EL -> SBool))@@ -297,19 +297,19 @@ -- a prefix does not affect lookup. -- -- >>> runTP lookupSwapPfx--- Lemma: lookupSwap Q.E.D.--- Lemma: lookupCons Q.E.D.+-- Lemma: lookupSwap Q.E.D.+-- Lemma: lookupCons Q.E.D. -- Inductive lemma (strong): lookupSwapPfx--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 (base) Q.E.D.--- Step: 1.2.1 (cons) Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.2.5 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 (base) Q.E.D.+-- Step: 1.2.1 (cons) Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.2.5 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.lookup -- [Proven] lookupSwapPfx :: Ɐpfx ∷ [(String, Integer)] → Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool lookupSwapPfx :: TP (Proof (Forall "pfx" EL -> Forall "k" String -> Forall "b1" (String, Integer)@@ -356,7 +356,7 @@ -- | A shadowed binding does not affect lookup: if the same key appears first, the second is irrelevant. -- -- >>> runTP lookupShadow--- Lemma: lookupShadow Q.E.D.+-- Lemma: lookupShadow Q.E.D. -- Functions proven terminating: sbv.lookup -- [Proven] lookupShadow :: Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool lookupShadow :: TP (Proof (Forall "k" String -> Forall "b1" (String, Integer)@@ -373,19 +373,19 @@ -- | Generalized shadow: a shadowed binding behind a prefix does not affect lookup. -- -- >>> runTP lookupShadowPfx--- Lemma: lookupShadow Q.E.D.--- Lemma: lookupCons Q.E.D.+-- Lemma: lookupShadow Q.E.D.+-- Lemma: lookupCons Q.E.D. -- Inductive lemma (strong): lookupShadowPfx--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 (base) Q.E.D.--- Step: 1.2.1 (cons) Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.2.5 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 (base) Q.E.D.+-- Step: 1.2.1 (cons) Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.2.5 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.lookup -- [Proven] lookupShadowPfx :: Ɐpfx ∷ [(String, Integer)] → Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool lookupShadowPfx :: TP (Proof (Forall "pfx" EL -> Forall "k" String -> Forall "b1" (String, Integer)@@ -433,40 +433,40 @@ -- to happen at any depth in the environment. -- -- >>> runTPWith cvc5 envSwap--- Lemma: measureNonNeg Q.E.D.--- Lemma: lookupSwapPfx Q.E.D.--- Lemma: sqrCong Q.E.D.--- Lemma: sqrHelper Q.E.D.--- Lemma: addCongL Q.E.D.--- Lemma: addCongR Q.E.D.--- Lemma: addHelper Q.E.D.--- Lemma: mulCongL Q.E.D.--- Lemma: mulCongR Q.E.D.--- Lemma: mulHelper Q.E.D.--- Lemma: letHelper Q.E.D.+-- Lemma: measureNonNeg Q.E.D.+-- Lemma: lookupSwapPfx Q.E.D.+-- Lemma: sqrCong Q.E.D.+-- Lemma: sqrHelper Q.E.D.+-- Lemma: addCongL Q.E.D.+-- Lemma: addCongR Q.E.D.+-- Lemma: addHelper Q.E.D.+-- Lemma: mulCongL Q.E.D.+-- Lemma: mulCongR Q.E.D.+-- Lemma: mulHelper Q.E.D.+-- Lemma: letHelper Q.E.D. -- Inductive lemma (strong): envSwap--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (7 way case split)--- Step: 1.1 (Var) Q.E.D.--- Step: 1.2 (Con) Q.E.D.--- Step: 1.3.1 (Sqr) Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.4 (Inc) Q.E.D.--- Step: 1.5.1 (Add) Q.E.D.--- Step: 1.5.2 Q.E.D.--- Step: 1.5.3 Q.E.D.--- Step: 1.5.4 Q.E.D.--- Step: 1.6.1 (Mul) Q.E.D.--- Step: 1.6.2 Q.E.D.--- Step: 1.6.3 Q.E.D.--- Step: 1.6.4 Q.E.D.--- Step: 1.7.1 (Let) Q.E.D.--- Step: 1.7.2 Q.E.D.--- Step: 1.7.3 Q.E.D.--- Step: 1.7.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 (Var) Q.E.D.+-- Step: 1.2 (Con) Q.E.D.+-- Step: 1.3.1 (Sqr) Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.4 (Inc) Q.E.D.+-- Step: 1.5.1 (Add) Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.6.1 (Mul) Q.E.D.+-- Step: 1.6.2 Q.E.D.+-- Step: 1.6.3 Q.E.D.+-- Step: 1.6.4 Q.E.D.+-- Step: 1.7.1 (Let) Q.E.D.+-- Step: 1.7.2 Q.E.D.+-- Step: 1.7.3 Q.E.D.+-- Step: 1.7.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: exprSize, interpInEnv, sbv.lookup -- [Proven] envSwap :: Ɐe ∷ (Expr String Integer) → Ɐpfx ∷ [(String, Integer)] → Ɐenv ∷ [(String, Integer)] → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Bool envSwap :: TP (Proof (Forall "e" Exp -> Forall "pfx" EL -> Forall "env" EL@@ -590,40 +590,40 @@ -- The @pfx@ parameter allows the shadow to occur at any depth. -- -- >>> runTPWith cvc5 envShadow--- Lemma: measureNonNeg Q.E.D.--- Lemma: lookupShadowPfx Q.E.D.--- Lemma: sqrCong Q.E.D.--- Lemma: sqrHelper Q.E.D.--- Lemma: addCongL Q.E.D.--- Lemma: addCongR Q.E.D.--- Lemma: addHelper Q.E.D.--- Lemma: mulCongL Q.E.D.--- Lemma: mulCongR Q.E.D.--- Lemma: mulHelper Q.E.D.--- Lemma: letHelper Q.E.D.+-- Lemma: measureNonNeg Q.E.D.+-- Lemma: lookupShadowPfx Q.E.D.+-- Lemma: sqrCong Q.E.D.+-- Lemma: sqrHelper Q.E.D.+-- Lemma: addCongL Q.E.D.+-- Lemma: addCongR Q.E.D.+-- Lemma: addHelper Q.E.D.+-- Lemma: mulCongL Q.E.D.+-- Lemma: mulCongR Q.E.D.+-- Lemma: mulHelper Q.E.D.+-- Lemma: letHelper Q.E.D. -- Inductive lemma (strong): envShadow--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (7 way case split)--- Step: 1.1 (Var) Q.E.D.--- Step: 1.2 (Con) Q.E.D.--- Step: 1.3.1 (Sqr) Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.4 (Inc) Q.E.D.--- Step: 1.5.1 (Add) Q.E.D.--- Step: 1.5.2 Q.E.D.--- Step: 1.5.3 Q.E.D.--- Step: 1.5.4 Q.E.D.--- Step: 1.6.1 (Mul) Q.E.D.--- Step: 1.6.2 Q.E.D.--- Step: 1.6.3 Q.E.D.--- Step: 1.6.4 Q.E.D.--- Step: 1.7.1 (Let) Q.E.D.--- Step: 1.7.2 Q.E.D.--- Step: 1.7.3 Q.E.D.--- Step: 1.7.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 (Var) Q.E.D.+-- Step: 1.2 (Con) Q.E.D.+-- Step: 1.3.1 (Sqr) Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.4 (Inc) Q.E.D.+-- Step: 1.5.1 (Add) Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.6.1 (Mul) Q.E.D.+-- Step: 1.6.2 Q.E.D.+-- Step: 1.6.3 Q.E.D.+-- Step: 1.6.4 Q.E.D.+-- Step: 1.7.1 (Let) Q.E.D.+-- Step: 1.7.2 Q.E.D.+-- Step: 1.7.3 Q.E.D.+-- Step: 1.7.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: exprSize, interpInEnv, sbv.lookup -- [Proven] envShadow :: Ɐe ∷ (Expr String Integer) → Ɐpfx ∷ [(String, Integer)] → Ɐenv ∷ [(String, Integer)] → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Bool envShadow :: TP (Proof (Forall "e" Exp -> Forall "pfx" EL -> Forall "env" EL@@ -748,7 +748,7 @@ -- | Unfolding @interpInEnv@ over @Var@. -- -- >>> runTP varHelper--- Lemma: varHelper Q.E.D.+-- Lemma: varHelper Q.E.D. -- Functions proven terminating: interpInEnv, sbv.lookup -- [Proven] varHelper :: Ɐenv ∷ [(String, Integer)] → Ɐnm ∷ String → Bool varHelper :: TP (Proof (Forall "env" EL -> Forall "nm" String -> SBool))@@ -760,63 +760,63 @@ -- is the same as substituting and interpreting in the original environment. -- -- >>> runTPWith cvc5 substCorrect--- Lemma: measureNonNeg Q.E.D.--- Lemma: sqrCong Q.E.D.--- Lemma: sqrHelper Q.E.D.--- Lemma: addHelper Q.E.D.--- Lemma: mulCongL Q.E.D.--- Lemma: mulCongR Q.E.D.--- Lemma: mulHelper Q.E.D.--- Lemma: letHelper Q.E.D.--- Lemma: varHelper Q.E.D.--- Lemma: envSwap Q.E.D.--- Lemma: envShadow Q.E.D.+-- Lemma: measureNonNeg Q.E.D.+-- Lemma: sqrCong Q.E.D.+-- Lemma: sqrHelper Q.E.D.+-- Lemma: addHelper Q.E.D.+-- Lemma: mulCongL Q.E.D.+-- Lemma: mulCongR Q.E.D.+-- Lemma: mulHelper Q.E.D.+-- Lemma: letHelper Q.E.D.+-- Lemma: varHelper Q.E.D.+-- Lemma: envSwap Q.E.D.+-- Lemma: envShadow Q.E.D. -- Inductive lemma (strong): substCorrect--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (7 way case split) -- Step: 1.1 (2 way case split)--- Step: 1.1.1.1 (Var) Q.E.D.--- Step: 1.1.1.2 Q.E.D.--- Step: 1.1.1.3 Q.E.D.--- Step: 1.1.1.4 Q.E.D.--- Step: 1.1.1.5 Q.E.D.--- Step: 1.1.2.1 (Var) Q.E.D.--- Step: 1.1.2.2 Q.E.D.--- Step: 1.1.2.3 Q.E.D.--- Step: 1.1.2.4 Q.E.D.--- Step: 1.1.2.5 Q.E.D.--- Step: 1.1.Completeness Q.E.D.--- Step: 1.2 (Con) Q.E.D.--- Step: 1.3.1 (Sqr) Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.3.4 Q.E.D.--- Step: 1.4 (Inc) Q.E.D.--- Step: 1.5.1 (Add) Q.E.D.--- Step: 1.5.2 Q.E.D.--- Step: 1.5.3 Q.E.D.--- Step: 1.5.4 Q.E.D.--- Step: 1.6.1 (Mul) Q.E.D.--- Step: 1.6.2 Q.E.D.--- Step: 1.6.3 Q.E.D.--- Step: 1.6.4 Q.E.D.--- Step: 1.6.5 Q.E.D.--- Step: 1.7.1 (Let) Q.E.D.+-- Step: 1.1.1.1 (Var) Q.E.D.+-- Step: 1.1.1.2 Q.E.D.+-- Step: 1.1.1.3 Q.E.D.+-- Step: 1.1.1.4 Q.E.D.+-- Step: 1.1.1.5 Q.E.D.+-- Step: 1.1.2.1 (Var) Q.E.D.+-- Step: 1.1.2.2 Q.E.D.+-- Step: 1.1.2.3 Q.E.D.+-- Step: 1.1.2.4 Q.E.D.+-- Step: 1.1.2.5 Q.E.D.+-- Step: 1.1.Completeness Q.E.D.+-- Step: 1.2 (Con) Q.E.D.+-- Step: 1.3.1 (Sqr) Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.4 (Inc) Q.E.D.+-- Step: 1.5.1 (Add) Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.6.1 (Mul) Q.E.D.+-- Step: 1.6.2 Q.E.D.+-- Step: 1.6.3 Q.E.D.+-- Step: 1.6.4 Q.E.D.+-- Step: 1.6.5 Q.E.D.+-- Step: 1.7.1 (Let) Q.E.D. -- Step: 1.7.2 (2 way case split)--- Step: 1.7.2.1.1 Q.E.D.--- Step: 1.7.2.1.2 (shadow) Q.E.D.--- Step: 1.7.2.1.3 Q.E.D.--- Step: 1.7.2.1.4 Q.E.D.--- Step: 1.7.2.1.5 Q.E.D.--- Step: 1.7.2.2.1 Q.E.D.--- Step: 1.7.2.2.2 (swap) Q.E.D.--- Step: 1.7.2.2.3 Q.E.D.--- Step: 1.7.2.2.4 Q.E.D.--- Step: 1.7.2.2.5 Q.E.D.--- Step: 1.7.2.2.6 Q.E.D.--- Step: 1.7.2.Completeness Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.7.2.1.1 Q.E.D.+-- Step: 1.7.2.1.2 (shadow) Q.E.D.+-- Step: 1.7.2.1.3 Q.E.D.+-- Step: 1.7.2.1.4 Q.E.D.+-- Step: 1.7.2.1.5 Q.E.D.+-- Step: 1.7.2.2.1 Q.E.D.+-- Step: 1.7.2.2.2 (swap) Q.E.D.+-- Step: 1.7.2.2.3 Q.E.D.+-- Step: 1.7.2.2.4 Q.E.D.+-- Step: 1.7.2.2.5 Q.E.D.+-- Step: 1.7.2.2.6 Q.E.D.+-- Step: 1.7.2.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: exprSize, interpInEnv, sbv.lookup, subst -- [Proven] substCorrect :: Ɐe ∷ (Expr String Integer) → Ɐnm ∷ String → Ɐv ∷ Integer → Ɐenv ∷ [(String, Integer)] → Bool substCorrect :: TP (Proof (Forall "e" Exp -> Forall "nm" String -> Forall "v" Integer -> Forall "env" EL -> SBool))@@ -967,130 +967,130 @@ -- | Simplification preserves semantics. -- -- >>> runTPWith cvc5 simpCorrect--- Lemma: sqrCong Q.E.D.--- Lemma: sqrHelper Q.E.D.--- Lemma: addHelper Q.E.D.--- Lemma: mulCongL Q.E.D.--- Lemma: mulCongR Q.E.D.--- Lemma: mulHelper Q.E.D.--- Lemma: letHelper Q.E.D.--- Lemma: substCorrect Q.E.D.+-- Lemma: sqrCong Q.E.D.+-- Lemma: sqrHelper Q.E.D.+-- Lemma: addHelper Q.E.D.+-- Lemma: mulCongL Q.E.D.+-- Lemma: mulCongR Q.E.D.+-- Lemma: mulHelper Q.E.D.+-- Lemma: letHelper Q.E.D.+-- Lemma: substCorrect Q.E.D. -- Lemma: simpCorrect -- Step: 1 (7 way case split)--- Step: 1.1.1 (Var) Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.1.3 Q.E.D.--- Step: 1.2.1 (Con) Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.3.1 (Sqr) Q.E.D.+-- Step: 1.1.1 (Var) Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.1.3 Q.E.D.+-- Step: 1.2.1 (Con) Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.3.1 (Sqr) Q.E.D. -- Step: 1.3.2 (2 way case split)--- Step: 1.3.2.1.1 Q.E.D.--- Step: 1.3.2.1.2 (Sqr Con) Q.E.D.--- Step: 1.3.2.1.3 Q.E.D.--- Step: 1.3.2.1.4 Q.E.D.--- Step: 1.3.2.1.5 Q.E.D.--- Step: 1.3.2.2.1 Q.E.D.--- Step: 1.3.2.2.2 (Sqr _) Q.E.D.--- Step: 1.3.2.Completeness Q.E.D.--- Step: 1.4.1 (Inc) Q.E.D.+-- Step: 1.3.2.1.1 Q.E.D.+-- Step: 1.3.2.1.2 (Sqr Con) Q.E.D.+-- Step: 1.3.2.1.3 Q.E.D.+-- Step: 1.3.2.1.4 Q.E.D.+-- Step: 1.3.2.1.5 Q.E.D.+-- Step: 1.3.2.2.1 Q.E.D.+-- Step: 1.3.2.2.2 (Sqr _) Q.E.D.+-- Step: 1.3.2.Completeness Q.E.D.+-- Step: 1.4.1 (Inc) Q.E.D. -- Step: 1.4.2 (2 way case split)--- Step: 1.4.2.1.1 Q.E.D.--- Step: 1.4.2.1.2 (Inc Con) Q.E.D.--- Step: 1.4.2.1.3 Q.E.D.--- Step: 1.4.2.2.1 Q.E.D.--- Step: 1.4.2.2.2 (Inc _) Q.E.D.--- Step: 1.4.2.Completeness Q.E.D.--- Step: 1.5.1 (Add) Q.E.D.+-- Step: 1.4.2.1.1 Q.E.D.+-- Step: 1.4.2.1.2 (Inc Con) Q.E.D.+-- Step: 1.4.2.1.3 Q.E.D.+-- Step: 1.4.2.2.1 Q.E.D.+-- Step: 1.4.2.2.2 (Inc _) Q.E.D.+-- Step: 1.4.2.Completeness Q.E.D.+-- Step: 1.5.1 (Add) Q.E.D. -- Step: 1.5.2 (6 way case split)--- Step: 1.5.2.1.1 Q.E.D.--- Step: 1.5.2.1.2 (Add 0+b) Q.E.D.--- Step: 1.5.2.1.3 Q.E.D.--- Step: 1.5.2.2.1 Q.E.D.--- Step: 1.5.2.2.2 (Add a+0) Q.E.D.--- Step: 1.5.2.2.3 Q.E.D.--- Step: 1.5.2.3.1 Q.E.D.--- Step: 1.5.2.3.2 (Add Con) Q.E.D.--- Step: 1.5.2.3.3 Q.E.D.+-- Step: 1.5.2.1.1 Q.E.D.+-- Step: 1.5.2.1.2 (Add 0+b) Q.E.D.+-- Step: 1.5.2.1.3 Q.E.D.+-- Step: 1.5.2.2.1 Q.E.D.+-- Step: 1.5.2.2.2 (Add a+0) Q.E.D.+-- Step: 1.5.2.2.3 Q.E.D.+-- Step: 1.5.2.3.1 Q.E.D.+-- Step: 1.5.2.3.2 (Add Con) Q.E.D.+-- Step: 1.5.2.3.3 Q.E.D. -- Step: 1.5.2.4 (2 way case split)--- Step: 1.5.2.4.1.1 Q.E.D.--- Step: 1.5.2.4.1.2 (Add 0,_) Q.E.D.--- Step: 1.5.2.4.1.3 Q.E.D.--- Step: 1.5.2.4.2.1 Q.E.D.--- Step: 1.5.2.4.2.2 (Add C,_) Q.E.D.--- Step: 1.5.2.4.Completeness Q.E.D.+-- Step: 1.5.2.4.1.1 Q.E.D.+-- Step: 1.5.2.4.1.2 (Add 0,_) Q.E.D.+-- Step: 1.5.2.4.1.3 Q.E.D.+-- Step: 1.5.2.4.2.1 Q.E.D.+-- Step: 1.5.2.4.2.2 (Add C,_) Q.E.D.+-- Step: 1.5.2.4.Completeness Q.E.D. -- Step: 1.5.2.5 (2 way case split)--- Step: 1.5.2.5.1.1 Q.E.D.--- Step: 1.5.2.5.1.2 (Add _,0) Q.E.D.--- Step: 1.5.2.5.1.3 Q.E.D.--- Step: 1.5.2.5.2.1 Q.E.D.--- Step: 1.5.2.5.2.2 (Add _,C) Q.E.D.--- Step: 1.5.2.5.Completeness Q.E.D.--- Step: 1.5.2.6.1 Q.E.D.--- Step: 1.5.2.6.2 (Add _,_) Q.E.D.--- Step: 1.5.2.Completeness Q.E.D.--- Step: 1.6.1 (Mul) Q.E.D.+-- Step: 1.5.2.5.1.1 Q.E.D.+-- Step: 1.5.2.5.1.2 (Add _,0) Q.E.D.+-- Step: 1.5.2.5.1.3 Q.E.D.+-- Step: 1.5.2.5.2.1 Q.E.D.+-- Step: 1.5.2.5.2.2 (Add _,C) Q.E.D.+-- Step: 1.5.2.5.Completeness Q.E.D.+-- Step: 1.5.2.6.1 Q.E.D.+-- Step: 1.5.2.6.2 (Add _,_) Q.E.D.+-- Step: 1.5.2.Completeness Q.E.D.+-- Step: 1.6.1 (Mul) Q.E.D. -- Step: 1.6.2 (8 way case split)--- Step: 1.6.2.1.1 Q.E.D.--- Step: 1.6.2.1.2 (Mul 0*b) Q.E.D.--- Step: 1.6.2.1.3 Q.E.D.--- Step: 1.6.2.2.1 Q.E.D.--- Step: 1.6.2.2.2 (Mul a*0) Q.E.D.--- Step: 1.6.2.2.3 Q.E.D.--- Step: 1.6.2.3.1 Q.E.D.--- Step: 1.6.2.3.2 (Mul 1*b) Q.E.D.--- Step: 1.6.2.3.3 Q.E.D.--- Step: 1.6.2.3.4 Q.E.D.--- Step: 1.6.2.3.5 Q.E.D.--- Step: 1.6.2.4.1 Q.E.D.--- Step: 1.6.2.4.2 (Mul a*1) Q.E.D.--- Step: 1.6.2.4.3 Q.E.D.--- Step: 1.6.2.4.4 Q.E.D.--- Step: 1.6.2.4.5 Q.E.D.--- Step: 1.6.2.5.1 Q.E.D.--- Step: 1.6.2.5.2 (Mul Con) Q.E.D.--- Step: 1.6.2.5.3 Q.E.D.--- Step: 1.6.2.5.4 Q.E.D.--- Step: 1.6.2.5.5 Q.E.D.--- Step: 1.6.2.5.6 Q.E.D.+-- Step: 1.6.2.1.1 Q.E.D.+-- Step: 1.6.2.1.2 (Mul 0*b) Q.E.D.+-- Step: 1.6.2.1.3 Q.E.D.+-- Step: 1.6.2.2.1 Q.E.D.+-- Step: 1.6.2.2.2 (Mul a*0) Q.E.D.+-- Step: 1.6.2.2.3 Q.E.D.+-- Step: 1.6.2.3.1 Q.E.D.+-- Step: 1.6.2.3.2 (Mul 1*b) Q.E.D.+-- Step: 1.6.2.3.3 Q.E.D.+-- Step: 1.6.2.3.4 Q.E.D.+-- Step: 1.6.2.3.5 Q.E.D.+-- Step: 1.6.2.4.1 Q.E.D.+-- Step: 1.6.2.4.2 (Mul a*1) Q.E.D.+-- Step: 1.6.2.4.3 Q.E.D.+-- Step: 1.6.2.4.4 Q.E.D.+-- Step: 1.6.2.4.5 Q.E.D.+-- Step: 1.6.2.5.1 Q.E.D.+-- Step: 1.6.2.5.2 (Mul Con) Q.E.D.+-- Step: 1.6.2.5.3 Q.E.D.+-- Step: 1.6.2.5.4 Q.E.D.+-- Step: 1.6.2.5.5 Q.E.D.+-- Step: 1.6.2.5.6 Q.E.D. -- Step: 1.6.2.6 (3 way case split)--- Step: 1.6.2.6.1.1 Q.E.D.--- Step: 1.6.2.6.1.2 (Mul 0,_) Q.E.D.--- Step: 1.6.2.6.1.3 Q.E.D.--- Step: 1.6.2.6.2.1 Q.E.D.--- Step: 1.6.2.6.2.2 (Mul 1,_) Q.E.D.--- Step: 1.6.2.6.2.3 Q.E.D.--- Step: 1.6.2.6.2.4 Q.E.D.--- Step: 1.6.2.6.2.5 Q.E.D.--- Step: 1.6.2.6.3.1 Q.E.D.--- Step: 1.6.2.6.3.2 (Mul C,_) Q.E.D.--- Step: 1.6.2.6.Completeness Q.E.D.+-- Step: 1.6.2.6.1.1 Q.E.D.+-- Step: 1.6.2.6.1.2 (Mul 0,_) Q.E.D.+-- Step: 1.6.2.6.1.3 Q.E.D.+-- Step: 1.6.2.6.2.1 Q.E.D.+-- Step: 1.6.2.6.2.2 (Mul 1,_) Q.E.D.+-- Step: 1.6.2.6.2.3 Q.E.D.+-- Step: 1.6.2.6.2.4 Q.E.D.+-- Step: 1.6.2.6.2.5 Q.E.D.+-- Step: 1.6.2.6.3.1 Q.E.D.+-- Step: 1.6.2.6.3.2 (Mul C,_) Q.E.D.+-- Step: 1.6.2.6.Completeness Q.E.D. -- Step: 1.6.2.7 (3 way case split)--- Step: 1.6.2.7.1.1 Q.E.D.--- Step: 1.6.2.7.1.2 (Mul _,0) Q.E.D.--- Step: 1.6.2.7.1.3 Q.E.D.--- Step: 1.6.2.7.2.1 Q.E.D.--- Step: 1.6.2.7.2.2 (Mul _,1) Q.E.D.--- Step: 1.6.2.7.2.3 Q.E.D.--- Step: 1.6.2.7.2.4 Q.E.D.--- Step: 1.6.2.7.2.5 Q.E.D.--- Step: 1.6.2.7.3.1 Q.E.D.--- Step: 1.6.2.7.3.2 (Mul _,C) Q.E.D.--- Step: 1.6.2.7.Completeness Q.E.D.--- Step: 1.6.2.8.1 Q.E.D.--- Step: 1.6.2.8.2 (Mul _,_) Q.E.D.--- Step: 1.6.2.Completeness Q.E.D.--- Step: 1.7.1 (Let) Q.E.D.+-- Step: 1.6.2.7.1.1 Q.E.D.+-- Step: 1.6.2.7.1.2 (Mul _,0) Q.E.D.+-- Step: 1.6.2.7.1.3 Q.E.D.+-- Step: 1.6.2.7.2.1 Q.E.D.+-- Step: 1.6.2.7.2.2 (Mul _,1) Q.E.D.+-- Step: 1.6.2.7.2.3 Q.E.D.+-- Step: 1.6.2.7.2.4 Q.E.D.+-- Step: 1.6.2.7.2.5 Q.E.D.+-- Step: 1.6.2.7.3.1 Q.E.D.+-- Step: 1.6.2.7.3.2 (Mul _,C) Q.E.D.+-- Step: 1.6.2.7.Completeness Q.E.D.+-- Step: 1.6.2.8.1 Q.E.D.+-- Step: 1.6.2.8.2 (Mul _,_) Q.E.D.+-- Step: 1.6.2.Completeness Q.E.D.+-- Step: 1.7.1 (Let) Q.E.D. -- Step: 1.7.2 (2 way case split)--- Step: 1.7.2.1.1 Q.E.D.--- Step: 1.7.2.1.2 (Let Con) Q.E.D.--- Step: 1.7.2.1.3 Q.E.D.--- Step: 1.7.2.1.4 Q.E.D.--- Step: 1.7.2.2.1 Q.E.D.--- Step: 1.7.2.2.2 (Let _) Q.E.D.--- Step: 1.7.2.Completeness Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.7.2.1.1 Q.E.D.+-- Step: 1.7.2.1.2 (Let Con) Q.E.D.+-- Step: 1.7.2.1.3 Q.E.D.+-- Step: 1.7.2.1.4 Q.E.D.+-- Step: 1.7.2.2.1 Q.E.D.+-- Step: 1.7.2.2.2 (Let _) Q.E.D.+-- Step: 1.7.2.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: exprSize, interpInEnv, sbv.lookup, simplify, subst -- [Proven] simpCorrect :: Ɐe ∷ (Expr String Integer) → Ɐenv ∷ [(String, Integer)] → Bool simpCorrect :: TP (Proof (Forall "e" Exp -> Forall "env" EL -> SBool))@@ -1369,54 +1369,54 @@ -- is the same as constant-folding it first and then interpreting the result. -- -- >>> runTPWith cvc5 cfoldCorrect--- Lemma: measureNonNeg Q.E.D.--- Lemma: simpCorrect Q.E.D.--- Cached: sqrCong Q.E.D.--- Cached: sqrHelper Q.E.D.--- Cached: mulCongL Q.E.D.--- Cached: mulCongR Q.E.D.--- Cached: mulHelper Q.E.D.+-- Lemma: measureNonNeg Q.E.D.+-- Lemma: simpCorrect Q.E.D.+-- Lemma: sqrCong Q.E.D. [Cached]+-- Lemma: sqrHelper Q.E.D. [Cached]+-- Lemma: mulCongL Q.E.D. [Cached]+-- Lemma: mulCongR Q.E.D. [Cached]+-- Lemma: mulHelper Q.E.D. [Cached] -- Inductive lemma (strong): cfoldCorrect--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (7 way case split)--- Step: 1.1.1 (case Var) Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.1.3 Q.E.D.--- Step: 1.2.1 (case Con) Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.3.1 (case Sqr) Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.3.4 Q.E.D.--- Step: 1.3.5 Q.E.D.--- Step: 1.3.6 Q.E.D.--- Step: 1.3.7 Q.E.D.--- Step: 1.4.1 (case Inc) Q.E.D.--- Step: 1.4.2 Q.E.D.--- Step: 1.4.3 Q.E.D.--- Step: 1.4.4 Q.E.D.--- Step: 1.4.5 Q.E.D.--- Step: 1.5.1 (case Add) Q.E.D.--- Step: 1.5.2 Q.E.D.--- Step: 1.5.3 Q.E.D.--- Step: 1.5.4 Q.E.D.--- Step: 1.5.5 Q.E.D.--- Step: 1.6.1 (case Mul) Q.E.D.--- Step: 1.6.2 Q.E.D.--- Step: 1.6.3 Q.E.D.--- Step: 1.6.4 Q.E.D.--- Step: 1.6.5 Q.E.D.--- Step: 1.6.6 Q.E.D.--- Step: 1.6.7 Q.E.D.--- Step: 1.6.8 Q.E.D.--- Step: 1.7.1 (case Let) Q.E.D.--- Step: 1.7.2 Q.E.D.--- Step: 1.7.3 Q.E.D.--- Step: 1.7.4 Q.E.D.--- Step: 1.7.5 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 (case Var) Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.1.3 Q.E.D.+-- Step: 1.2.1 (case Con) Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.3.1 (case Sqr) Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.3.6 Q.E.D.+-- Step: 1.3.7 Q.E.D.+-- Step: 1.4.1 (case Inc) Q.E.D.+-- Step: 1.4.2 Q.E.D.+-- Step: 1.4.3 Q.E.D.+-- Step: 1.4.4 Q.E.D.+-- Step: 1.4.5 Q.E.D.+-- Step: 1.5.1 (case Add) Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.5.5 Q.E.D.+-- Step: 1.6.1 (case Mul) Q.E.D.+-- Step: 1.6.2 Q.E.D.+-- Step: 1.6.3 Q.E.D.+-- Step: 1.6.4 Q.E.D.+-- Step: 1.6.5 Q.E.D.+-- Step: 1.6.6 Q.E.D.+-- Step: 1.6.7 Q.E.D.+-- Step: 1.6.8 Q.E.D.+-- Step: 1.7.1 (case Let) Q.E.D.+-- Step: 1.7.2 Q.E.D.+-- Step: 1.7.3 Q.E.D.+-- Step: 1.7.4 Q.E.D.+-- Step: 1.7.5 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: cfold, exprSize, interpInEnv, sbv.lookup, simplify, subst -- [Proven] cfoldCorrect :: Ɐe ∷ (Expr String Integer) → Ɐenv ∷ [(String, Integer)] → Bool cfoldCorrect :: TP (Proof (Forall "e" Exp -> Forall "env" EL -> SBool))
Documentation/SBV/Examples/TP/Countdown.hs view
@@ -47,7 +47,7 @@ -- | Prove that @countdown n@ always starts with @n@, for positive @n@. -- -- >>> runTP countdownHead--- Lemma: countdownHead Q.E.D.+-- Lemma: countdownHead Q.E.D. -- Functions proven terminating: countdown -- [Proven] countdownHead :: Ɐn ∷ Integer → Bool countdownHead :: TP (Proof (Forall "n" Integer -> SBool))@@ -57,10 +57,10 @@ -- -- >>> runTP countdownNonEmpty -- Inductive lemma: countdownNonEmpty--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: countdown -- [Proven] countdownNonEmpty :: Ɐn ∷ Integer → Bool countdownNonEmpty :: TP (Proof (Forall "n" Integer -> SBool))@@ -77,11 +77,11 @@ -- -- >>> runTP countdownLen -- Inductive lemma: countdownLen--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: countdown -- [Proven] countdownLen :: Ɐn ∷ Integer → Bool countdownLen :: TP (Proof (Forall "n" Integer -> SBool))@@ -105,13 +105,13 @@ -- covers the entire domain of the goal. -- -- >>> runTP countdownElem--- Lemma: countdownLen Q.E.D.--- Lemma: elemOne Q.E.D.+-- Lemma: countdownLen Q.E.D.+-- Lemma: elemOne Q.E.D. -- Inductive lemma: countdownElem--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: countdown -- [Proven] countdownElem :: Ɐn ∷ Integer → Ɐk ∷ Integer → Bool countdownElem :: TP (Proof (Forall "n" Integer -> Forall "k" Integer -> SBool))
Documentation/SBV/Examples/TP/Fibonacci.hs view
@@ -51,15 +51,15 @@ -- -- >>> correctness -- Inductive lemma: helper--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 (unfold fibonacci) Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 (unfold fibonacci) Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: fibCorrect--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: fib, fibonacci -- [Proven] fibCorrect :: Ɐn ∷ Integer → Bool correctness :: IO (Proof (Forall "n" Integer -> SBool))
Documentation/SBV/Examples/TP/GCD.hs view
@@ -62,14 +62,14 @@ -- ==== __Proof__ -- >>> runTP gcdNonNegative -- Inductive lemma (strong): nonNegativeNGCD--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.--- Lemma: nonNegative Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: nonNegative Q.E.D. -- Functions proven terminating: nGCD -- [Proven] nonNegative :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdNonNegative :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))@@ -96,14 +96,14 @@ -- ==== __Proof__ -- >>> runTP gcdZero -- Inductive lemma (strong): nGCDZero--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.--- Lemma: gcdZero Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: gcdZero Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdZero :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdZero :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))@@ -124,7 +124,7 @@ ] lemma "gcdZero"- (\(Forall @"a" a) (Forall @"b" b) -> gcd a b .== 0 .=> a .== 0 .&& b .== 0) + (\(Forall @"a" a) (Forall @"b" b) -> gcd a b .== 0 .=> a .== 0 .&& b .== 0) [proofOf nGCDZero] -- | \(\gcd\, a\ b=\gcd\, b\ a\)@@ -132,12 +132,12 @@ -- ==== __Proof__ -- >>> runTP commutative -- Lemma: nGCDCommutative--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Lemma: commutative--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] commutative :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool commutative :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))@@ -166,7 +166,7 @@ -- -- ==== __Proof__ -- >>> runTP negGCD--- Lemma: negGCD Q.E.D.+-- Lemma: negGCD Q.E.D. -- Functions proven terminating: nGCD -- [Proven] negGCD :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool negGCD :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))@@ -176,7 +176,7 @@ -- -- ==== __Proof__ -- >>> runTP zeroGCD--- Lemma: negGCD Q.E.D.+-- Lemma: negGCD Q.E.D. -- Functions proven terminating: nGCD -- [Proven] negGCD :: Ɐa ∷ Integer → Bool zeroGCD :: TP (Proof (Forall "a" Integer -> SBool))@@ -204,11 +204,11 @@ -- >>> runTP dvdMul -- Lemma: dvdMul -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- [Proven] dvdMul :: Ɐd ∷ Integer → Ɐa ∷ Integer → Ɐk ∷ Integer → Bool dvdMul :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> Forall "k" Integer -> SBool)) dvdMul = calc "dvdMul"@@ -234,20 +234,20 @@ -- -- ==== __Proof__ -- >>> runTP dvdAbs--- Lemma: dvdMul Q.E.D.+-- Lemma: dvdMul Q.E.D. -- Lemma: dvdAbs_l2r -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: dvdAbs_r2l -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.--- Lemma: dvdAbs Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: dvdAbs Q.E.D. -- [Proven] dvdAbs :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool dvdAbs :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) dvdAbs = do@@ -287,11 +287,11 @@ -- >>> runTP dvdOddThenOdd -- Lemma: dvdOddThenOdd -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- [Proven] dvdOddThenOdd :: Ɐd ∷ Integer → Ɐa ∷ Integer → Bool dvdOddThenOdd :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> SBool)) dvdOddThenOdd = calc "dvdOddThenOdd"@@ -308,14 +308,14 @@ -- ==== __Proof__ -- >>> runTP dvdEvenWhenOdd -- Lemma: dvdEvenWhenOdd--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Result: Q.E.D. -- [Proven] dvdEvenWhenOdd :: Ɐd ∷ Integer → Ɐa ∷ Integer → Bool dvdEvenWhenOdd :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> SBool)) dvdEvenWhenOdd = calc "dvdEvenWhenOdd"@@ -357,12 +357,12 @@ -- >>> runTP dvdSum1 -- Lemma: dvdSum1 -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- [Proven] dvdSum1 :: Ɐd ∷ Integer → Ɐa ∷ Integer → Ɐb ∷ Integer → Bool dvdSum1 :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> Forall "b" Integer -> SBool)) dvdSum1 =@@ -383,12 +383,12 @@ -- >>> runTP dvdSum2 -- Lemma: dvdSum2 -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- [Proven] dvdSum2 :: Ɐd ∷ Integer → Ɐa ∷ Integer → Ɐb ∷ Integer → Bool dvdSum2 :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> Forall "b" Integer -> SBool)) dvdSum2 =@@ -414,19 +414,19 @@ -- -- ==== __Proof__ -- >>> runTP gcdDivides--- Lemma: dvdAbs Q.E.D.+-- Lemma: dvdAbs Q.E.D. -- Lemma: helper--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): dvdNGCD--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.--- Lemma: gcdDivides Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: gcdDivides Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdDivides :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdDivides :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))@@ -474,32 +474,32 @@ -- -- ==== __Proof__ -- >>> runTP gcdMaximal--- Lemma: dvdAbs Q.E.D.--- Lemma: commutative Q.E.D.--- Lemma: eDiv Q.E.D.+-- Lemma: dvdAbs Q.E.D.+-- Lemma: commutative Q.E.D.+-- Lemma: eDiv Q.E.D. -- Lemma: helper--- Step: 1 (x `dvd` a && x `dvd` b) Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 (x `dvd` a && x `dvd` b) Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): mNGCD--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: gcdMaximal -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdMaximal :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐx ∷ Integer → Bool gcdMaximal :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "x" Integer -> SBool))@@ -574,12 +574,12 @@ -- -- ==== __Proof__ -- >>> runTP gcdCorrect--- Lemma: gcdDivides Q.E.D.--- Lemma: gcdMaximal Q.E.D.+-- Lemma: gcdDivides Q.E.D.+-- Lemma: gcdMaximal Q.E.D. -- Lemma: gcdCorrect--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdCorrect :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdCorrect :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))@@ -613,13 +613,13 @@ -- -- ==== __Proof__ -- >>> runTP gcdLargest--- Lemma: gcdMaximal Q.E.D.--- Lemma: gcdZero Q.E.D.--- Lemma: nonNegative Q.E.D.+-- Lemma: gcdMaximal Q.E.D.+-- Lemma: gcdZero Q.E.D.+-- Lemma: nonNegative Q.E.D. -- Lemma: gcdLargest--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdLargest :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐx ∷ Integer → Bool gcdLargest :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "x" Integer -> SBool))@@ -645,19 +645,19 @@ -- -- ==== __Proof__ -- >>> runTP gcdAdd--- Lemma: dvdSum1 Q.E.D.--- Lemma: dvdSum2 Q.E.D.--- Lemma: gcdDivides Q.E.D.--- Lemma: gcdLargest Q.E.D.+-- Lemma: dvdSum1 Q.E.D.+-- Lemma: dvdSum2 Q.E.D.+-- Lemma: gcdDivides Q.E.D.+-- Lemma: gcdLargest Q.E.D. -- Lemma: gcdAdd--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdAdd :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdAdd :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))@@ -706,28 +706,28 @@ -- -- ==== __Proof__ -- >>> runTP gcdEvenEven--- Lemma: red2 Q.E.D.+-- Lemma: red2 Q.E.D. -- Lemma: modEE--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): nGCDEvenEven--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: gcdEvenEven--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdEvenEven :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdEvenEven :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))@@ -776,21 +776,21 @@ -- -- ==== __Proof__ -- >>> runTP gcdOddEven--- Lemma: gcdDivides Q.E.D.--- Lemma: gcdLargest Q.E.D.--- Cached: dvdMul Q.E.D.--- Lemma: dvdOddThenOdd Q.E.D.--- Lemma: dvdEvenWhenOdd Q.E.D.+-- Lemma: gcdDivides Q.E.D.+-- Lemma: gcdLargest Q.E.D.+-- Lemma: dvdMul Q.E.D. [Cached]+-- Lemma: dvdOddThenOdd Q.E.D.+-- Lemma: dvdEvenWhenOdd Q.E.D. -- Lemma: gcdOddEven--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Step: 8 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Step: 8 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdOddEven :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdOddEven :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))@@ -866,29 +866,29 @@ -- -- ==== __Proof__ -- >>> runTP gcdSubEquiv--- Lemma: commutative Q.E.D.--- Lemma: gcdAdd Q.E.D.+-- Lemma: commutative Q.E.D.+-- Lemma: gcdAdd Q.E.D. -- Inductive lemma (strong): nGCDSubEquiv--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (5 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3 Q.E.D.--- Step: 1.4.1 Q.E.D.--- Step: 1.4.2 Q.E.D.--- Step: 1.4.3 Q.E.D.--- Step: 1.5.1 Q.E.D.--- Step: 1.5.2 Q.E.D.--- Step: 1.5.3 Q.E.D.--- Step: 1.5.4 Q.E.D.--- Step: 1.5.5 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.4.1 Q.E.D.+-- Step: 1.4.2 Q.E.D.+-- Step: 1.4.3 Q.E.D.+-- Step: 1.5.1 Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.5.5 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: gcdSubEquiv--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: nGCD, nGCDSub -- [Proven] gcdSubEquiv :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdSubEquiv :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))@@ -959,41 +959,41 @@ -- -- ==== __Proof__ -- >>> runTP gcdBinEquiv--- Lemma: gcdEvenEven Q.E.D.--- Lemma: gcdOddEven Q.E.D.--- Lemma: gcdAdd Q.E.D.--- Cached: commutative Q.E.D.+-- Lemma: gcdEvenEven Q.E.D.+-- Lemma: gcdOddEven Q.E.D.+-- Lemma: gcdAdd Q.E.D.+-- Lemma: commutative Q.E.D. [Cached] -- Inductive lemma (strong): nGCDBinEquiv--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (5 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3.1 Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.4.1 Q.E.D.--- Step: 1.4.2 Q.E.D.--- Step: 1.4.3 Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.4.1 Q.E.D.+-- Step: 1.4.2 Q.E.D.+-- Step: 1.4.3 Q.E.D. -- Step: 1.5 (3 way case split)--- Step: 1.5.1 Q.E.D.--- Step: 1.5.2.1 Q.E.D.--- Step: 1.5.2.2 Q.E.D.--- Step: 1.5.2.3 Q.E.D.--- Step: 1.5.2.4 Q.E.D.--- Step: 1.5.2.5 Q.E.D.--- Step: 1.5.2.6 Q.E.D.--- Step: 1.5.3.1 Q.E.D.--- Step: 1.5.3.2 Q.E.D.--- Step: 1.5.3.3 Q.E.D.--- Step: 1.5.3.4 Q.E.D.--- Step: 1.5.Completeness Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.5.1 Q.E.D.+-- Step: 1.5.2.1 Q.E.D.+-- Step: 1.5.2.2 Q.E.D.+-- Step: 1.5.2.3 Q.E.D.+-- Step: 1.5.2.4 Q.E.D.+-- Step: 1.5.2.5 Q.E.D.+-- Step: 1.5.2.6 Q.E.D.+-- Step: 1.5.3.1 Q.E.D.+-- Step: 1.5.3.2 Q.E.D.+-- Step: 1.5.3.3 Q.E.D.+-- Step: 1.5.3.4 Q.E.D.+-- Step: 1.5.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: gcdBinEquiv--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: nGCD, nGCDBin -- [Proven] gcdBinEquiv :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdBinEquiv :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool))
Documentation/SBV/Examples/TP/InsertionSort.hs view
@@ -80,49 +80,49 @@ -- We have: -- -- >>> correctness @Integer--- Lemma: nonDecrTail Q.E.D.+-- Lemma: nonDecrTail Q.E.D. -- Inductive lemma: insertNonDecreasing--- Step: Base Q.E.D.--- Step: 1 (unfold insert) Q.E.D.--- Step: 2 (push nonDecreasing down) Q.E.D.--- Step: 3 (unfold simplify) Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 (unfold insert) Q.E.D.+-- Step: 2 (push nonDecreasing down) Q.E.D.+-- Step: 3 (unfold simplify) Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: sortNonDecreasing--- Step: Base Q.E.D.--- Step: 1 (unfold insertionSort) Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 (unfold insertionSort) Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: insertIsElem--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: removeAfterInsert--- Step: Base Q.E.D.--- Step: 1 (expand insert) Q.E.D.--- Step: 2 (push removeFirst down ite) Q.E.D.--- Step: 3 (unfold removeFirst on 'then') Q.E.D.--- Step: 4 (unfold removeFirst on 'else') Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 (simplify) Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 (expand insert) Q.E.D.+-- Step: 2 (push removeFirst down ite) Q.E.D.+-- Step: 3 (unfold removeFirst on 'then') Q.E.D.+-- Step: 4 (unfold removeFirst on 'else') Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 (simplify) Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: sortIsPermutation--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.--- Lemma: insertionSortIsCorrect Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D.+-- Lemma: insertionSortIsCorrect Q.E.D. -- Functions proven terminating: insert, insertionSort, isPermutation, nonDecreasing, removeFirst -- [Proven] insertionSortIsCorrect :: Ɐxs ∷ [Integer] → Bool correctness :: forall a. (OrdSymbolic (SBV a), Eq a, SymVal a) => IO (Proof (Forall "xs" [a] -> SBool))-correctness = runTPWith (tpRibbon 45 cvc5) $ do+correctness = runTPWith cvc5 $ do -------------------------------------------------------------------------------------------- -- Part I. Import helper lemmas, definitions
Documentation/SBV/Examples/TP/Kadane.hs view
@@ -129,16 +129,16 @@ -- -- >>> runTPWith cvc5 correctness -- Inductive lemma: kadaneHelperInvariant--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Lemma: correctness--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: kadaneHelper, mss, mssBegin -- [Proven] correctness :: Ɐxs ∷ [Integer] → Bool correctness :: TP (Proof (Forall "xs" [Integer] -> SBool))
Documentation/SBV/Examples/TP/Kleene.hs view
@@ -69,20 +69,20 @@ -- Axiom: ldistrib -- Axiom: unfold -- Axiom: least_fix--- Lemma: par_lzero Q.E.D.--- Lemma: par_monotone Q.E.D.--- Lemma: seq_monotone Q.E.D.+-- Lemma: par_lzero Q.E.D.+-- Lemma: par_monotone Q.E.D.+-- Lemma: seq_monotone Q.E.D. -- Lemma: star_star_1--- Step: 1 (unfold) Q.E.D.--- Step: 2 (factor out x * star x) Q.E.D.--- Step: 3 (par_idem) Q.E.D.--- Step: 4 (unfold) Q.E.D.--- Result: Q.E.D.--- Lemma: subset_eq Q.E.D.--- Lemma: star_star_2_2 Q.E.D.--- Lemma: star_star_2_3 Q.E.D.--- Lemma: star_star_2_1 Q.E.D.--- Lemma: star_star_2 Q.E.D.+-- Step: 1 (unfold) Q.E.D.+-- Step: 2 (factor out x * star x) Q.E.D.+-- Step: 3 (par_idem) Q.E.D.+-- Step: 4 (unfold) Q.E.D.+-- Result: Q.E.D.+-- Lemma: subset_eq Q.E.D.+-- Lemma: star_star_2_2 Q.E.D.+-- Lemma: star_star_2_3 Q.E.D.+-- Lemma: star_star_2_1 Q.E.D.+-- Lemma: star_star_2 Q.E.D. kleeneProofs :: IO () kleeneProofs = runTP $ do
Documentation/SBV/Examples/TP/Lists.hs view
@@ -95,7 +95,7 @@ -- | @xs ++ [] == xs@ -- -- >>> runTP $ appendNull @Integer--- Lemma: appendNull Q.E.D.+-- Lemma: appendNull Q.E.D. -- [Proven] appendNull :: Ɐxs ∷ [Integer] → Bool appendNull :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool)) appendNull = lemma "appendNull"@@ -105,7 +105,7 @@ -- | @(x : xs) ++ ys == x : (xs ++ ys)@ -- -- >>> runTP $ consApp @Integer--- Lemma: consApp Q.E.D.+-- Lemma: consApp Q.E.D. -- [Proven] consApp :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool consApp :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> Forall "ys" [a] -> SBool)) consApp = lemma "consApp"@@ -115,7 +115,7 @@ -- | @(xs ++ ys) ++ zs == xs ++ (ys ++ zs)@ -- -- >>> runTP $ appendAssoc @Integer--- Lemma: appendAssoc Q.E.D.+-- Lemma: appendAssoc Q.E.D. -- [Proven] appendAssoc :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐzs ∷ [Integer] → Bool -- -- Surprisingly, z3 can prove this without any induction. (Since SBV's append translates directly to@@ -131,9 +131,9 @@ -- -- >>> runTP $ initsLength @Integer -- Inductive lemma (strong): initsLength--- Step: Measure is non-negative Q.E.D.--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.inits -- [Proven] initsLength :: Ɐxs ∷ [Integer] → Bool initsLength :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))@@ -150,12 +150,12 @@ -- -- >>> runTP $ tailsLength @Integer -- Inductive lemma: tailsLength--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.tails -- [Proven] tailsLength :: Ɐxs ∷ [Integer] → Bool tailsLength :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))@@ -180,22 +180,22 @@ -- -- >>> runTPWith cvc5 $ tailsAppend @Integer -- Inductive lemma: base case--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: helper--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: tailsAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.closureMap, sbv.tails -- [Proven] tailsAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool tailsAppend :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))@@ -247,12 +247,12 @@ -- -- >>> runTP $ revLen @Integer -- Inductive lemma: revLen--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.reverse -- [Proven] revLen :: Ɐxs ∷ [Integer] → Bool revLen :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))@@ -270,13 +270,13 @@ -- -- >>> runTP $ revApp @Integer -- Inductive lemma: revApp--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.reverse -- [Proven] revApp :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool revApp :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))@@ -294,7 +294,7 @@ -- | @reverse (x:xs) == reverse xs ++ [x]@ -- -- >>> runTP $ revCons @Integer--- Lemma: revCons Q.E.D.+-- Lemma: revCons Q.E.D. -- Functions proven terminating: sbv.reverse -- [Proven] revCons :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool revCons :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool))@@ -306,14 +306,14 @@ -- -- >>> runTP $ revSnoc @Integer -- Inductive lemma: revApp--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.--- Lemma: revSnoc Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D.+-- Lemma: revSnoc Q.E.D. -- Functions proven terminating: sbv.reverse -- [Proven] revSnoc :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool revSnoc :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool))@@ -328,20 +328,20 @@ -- -- >>> runTP $ revRev @Integer -- Inductive lemma: revApp--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: revRev--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.reverse -- [Proven] revRev :: Ɐxs ∷ [Integer] → Bool revRev :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))@@ -366,15 +366,15 @@ -- -- >>> runTP enumLen -- Inductive lemma (strong): enumLen--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up -- [Proven] enumLen :: Ɐn ∷ Integer → Ɐm ∷ Integer → Bool enumLen :: TP (Proof (Forall "n" Integer -> Forall "m" Integer -> SBool))@@ -398,21 +398,21 @@ -- -- >>> runTP $ revNM -- Inductive lemma (strong): helper--- Step: Measure is non-negative Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): revNM--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: -- EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up, sbv.reverse -- [Proven] revNM :: Ɐn ∷ Integer → Ɐm ∷ Integer → Bool@@ -447,7 +447,7 @@ -- | @length (x : xs) == 1 + length xs@ -- -- >>> runTP $ lengthTail @Integer--- Lemma: lengthTail Q.E.D.+-- Lemma: lengthTail Q.E.D. -- [Proven] lengthTail :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool lengthTail :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool)) lengthTail = lemma "lengthTail"@@ -457,7 +457,7 @@ -- | @length (xs ++ ys) == length xs + length ys@ -- -- >>> runTP $ lenAppend @Integer--- Lemma: lenAppend Q.E.D.+-- Lemma: lenAppend Q.E.D. -- [Proven] lenAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool lenAppend :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) lenAppend = lemma "lenAppend"@@ -467,7 +467,7 @@ -- | @length xs == length ys -> length (xs ++ ys) == 2 * length xs@ -- -- >>> runTP $ lenAppend2 @Integer--- Lemma: lenAppend2 Q.E.D.+-- Lemma: lenAppend2 Q.E.D. -- [Proven] lenAppend2 :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool lenAppend2 :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) lenAppend2 = lemma "lenAppend2"@@ -478,15 +478,15 @@ -- -- >>> runTP $ replicateLength @Integer -- Inductive lemma: replicateLength--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.replicate -- [Proven] replicateLength :: Ɐk ∷ Integer → Ɐx ∷ Integer → Bool replicateLength :: forall a. SymVal a => TP (Proof (Forall "k" Integer -> Forall "x" a -> SBool))@@ -508,12 +508,12 @@ -- -- >>> runTP allAny -- Inductive lemma: allAny--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr -- [Proven] allAny :: Ɐxs ∷ [Bool] → Bool allAny :: TP (Proof (Forall "xs" [Bool] -> SBool))@@ -531,12 +531,12 @@ -- -- >>> runTP $ mapEquiv @Integer @Integer (uninterpret "f") (uninterpret "g") -- Inductive lemma: mapEquiv--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.map -- [Proven] mapEquiv :: Ɐxs ∷ [Integer] → Bool mapEquiv :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> (SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> SBool))@@ -558,13 +558,13 @@ -- -- >>> runTP $ mapAppend @Integer @Integer (uninterpret "f") -- Inductive lemma: mapAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.map -- [Proven] mapAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool mapAppend :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))@@ -584,22 +584,22 @@ -- -- >>> runTP $ mapReverse @Integer @String (uninterpret "f") -- Inductive lemma: mapAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: mapReverse--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.map, sbv.reverse -- [Proven] mapReverse :: Ɐxs ∷ [Integer] → Bool mapReverse :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> SBool))@@ -623,13 +623,13 @@ -- -- >>> runTP $ mapCompose @Integer @Bool @String (uninterpret "f") (uninterpret "g") -- Inductive lemma: mapCompose--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.map -- [Proven] mapCompose :: Ɐxs ∷ [Integer] → Bool mapCompose :: forall a b c. (SymVal a, SymVal b, SymVal c) => (SBV a -> SBV b) -> (SBV b -> SBV c) -> TP (Proof (Forall "xs" [a] -> SBool))@@ -648,15 +648,15 @@ -- | @map f . concat = concat . map (map f)@ -- -- >>> runTP $ mapConcat @Integer @Bool (uninterpret "f")--- Lemma: mapAppend Q.E.D.+-- Lemma: mapAppend Q.E.D. -- Inductive lemma: mapConcat--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr, sbv.map -- [Proven] mapConcat :: Ɐxs ∷ [[Integer]] → Bool mapConcat :: (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "xs" [[a]] -> SBool))@@ -679,12 +679,12 @@ -- -- >>> runTP $ foldrMapFusion @String @Bool @Integer (uninterpret "a") (uninterpret "b") (uninterpret "c") -- Inductive lemma: foldrMapFusion--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr, sbv.map -- [Proven] foldrMapFusion :: Ɐxs ∷ [String] → Bool foldrMapFusion :: forall a b c. (SymVal a, SymVal b, SymVal c) => SBV c -> (SBV a -> SBV b) -> (SBV b -> SBV c -> SBV c) -> TP (Proof (Forall "xs" [a] -> SBool))@@ -708,12 +708,12 @@ -- -- >>> runTP $ foldrFusion @String @Bool @Integer (uninterpret "a") (uninterpret "b") (uninterpret "f") (uninterpret "g") (uninterpret "h") -- Inductive lemma: foldrFusion--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr -- [Proven] foldrFusion :: Ɐxs ∷ [String] → Bool foldrFusion :: forall a b c. (SymVal a, SymVal b, SymVal c) => SBV c -> SBV b -> (SBV c -> SBV b) -> (SBV a -> SBV c -> SBV c) -> (SBV a -> SBV b -> SBV b) -> TP (Proof (Forall "xs" [a] -> SBool))@@ -736,12 +736,12 @@ -- -- >>> runTP $ foldrOverAppend @Integer (uninterpret "a") (uninterpret "f") -- Inductive lemma: foldrOverAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr -- [Proven] foldrOverAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool foldrOverAppend :: forall a. SymVal a => SBV a -> (SBV a -> SBV a -> SBV a) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))@@ -760,11 +760,11 @@ -- -- >>> runTP $ foldlOverAppend @Integer @Bool (uninterpret "f") -- Inductive lemma: foldlOverAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldl -- [Proven] foldlOverAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐe ∷ Bool → Bool foldlOverAppend :: forall a b. (SymVal a, SymVal b) => (SBV b -> SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> Forall "e" b -> SBool))@@ -784,20 +784,20 @@ -- -- >>> runTP $ foldrFoldlDuality @Integer @String (uninterpret "f") -- Inductive lemma: foldlOverAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: foldrFoldlDuality--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldl, sbv.foldr, sbv.reverse -- [Proven] foldrFoldlDuality :: Ɐxs ∷ [Integer] → Ɐe ∷ String → Bool foldrFoldlDuality :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b -> SBV b) -> TP (Proof (Forall "xs" [a] -> Forall "e" b -> SBool))@@ -835,21 +835,21 @@ -- -- >>> runTP $ foldrFoldlDualityGeneralized @Integer (uninterpret "e") (uninterpret "|@|") -- Inductive lemma: helper--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: foldrFoldlDuality--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldl, sbv.foldr -- [Proven] foldrFoldlDuality :: Ɐxs ∷ [Integer] → Bool foldrFoldlDualityGeneralized :: forall a. SymVal a => SBV a -> (SBV a -> SBV a -> SBV a) -> TP (Proof (Forall "xs" [a] -> SBool))@@ -905,20 +905,20 @@ -- -- >>> runTP $ foldrFoldl @Integer @String (uninterpret "<+>") (uninterpret "<*>") (uninterpret "e") -- Inductive lemma: foldl over <*>/<+>--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: foldrFoldl--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldl, sbv.foldr -- [Proven] foldrFoldl :: Ɐxs ∷ [Integer] → Bool foldrFoldl :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b -> SBV b) -> (SBV b -> SBV a -> SBV b) -> SBV b -> TP (Proof (Forall "xs" [a] -> SBool))@@ -965,28 +965,28 @@ -- -- >>> runTP $ bookKeeping @Integer (uninterpret "a") (uninterpret "f") -- Inductive lemma: foldBase--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: foldrOverAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: bookKeeping--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr, sbv.map -- [Proven] bookKeeping :: Ɐxss ∷ [[Integer]] → Bool --@@ -1047,13 +1047,13 @@ -- -- >>> runTP $ filterAppend @Integer (uninterpret "p") -- Inductive lemma: filterAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.filter -- [Proven] filterAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool filterAppend :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))@@ -1073,19 +1073,19 @@ -- -- >>> runTP $ filterConcat @Integer (uninterpret "f") -- Inductive lemma: filterAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: filterConcat--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.filter, sbv.foldr, sbv.map -- [Proven] filterConcat :: Ɐxss ∷ [[Integer]] → Bool filterConcat :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xss" [[a]] -> SBool))@@ -1106,14 +1106,14 @@ -- -- >>> runTP $ takeDropWhile @Integer (uninterpret "f") -- Inductive lemma: takeDropWhile--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.dropWhile, sbv.takeWhile -- [Proven] takeDropWhile :: Ɐxs ∷ [Integer] → Bool takeDropWhile :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> SBool))@@ -1143,32 +1143,32 @@ -- -- >>> runTP $ destutterIdempotent @Integer -- Inductive lemma: helper1--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: helper2--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): helper3--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3.1 Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3.1 Q.E.D. -- Step: 1.3.2 (2 way case split)--- Step: 1.3.2.1.1 Q.E.D.--- Step: 1.3.2.1.2 Q.E.D.--- Step: 1.3.2.2.1 Q.E.D.--- Step: 1.3.2.2.2 Q.E.D.--- Step: 1.3.2.Completeness Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.--- Lemma: destutterIdempotent Q.E.D.+-- Step: 1.3.2.1.1 Q.E.D.+-- Step: 1.3.2.1.2 Q.E.D.+-- Step: 1.3.2.2.1 Q.E.D.+-- Step: 1.3.2.2.2 Q.E.D.+-- Step: 1.3.2.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: destutterIdempotent Q.E.D. -- Functions proven terminating: destutter, noAdd -- [Proven] destutterIdempotent :: Ɐxs ∷ [Integer] → Bool destutterIdempotent :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))@@ -1236,11 +1236,11 @@ -- -- >>> runTP $ appendDiff @Integer -- Inductive lemma: appendDiff--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.diff -- [Proven] appendDiff :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Ɐcs ∷ [Integer] → Bool appendDiff :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> Forall "cs" [a] -> SBool))@@ -1257,12 +1257,12 @@ -- -- >>> runTP $ diffAppend @Integer -- Inductive lemma: diffAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.diff -- [Proven] diffAppend :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Ɐcs ∷ [Integer] → Bool diffAppend :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> Forall "cs" [a] -> SBool))@@ -1281,27 +1281,27 @@ -- -- >>> runTP $ diffDiff @Integer -- Inductive lemma: diffDiff--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D. -- Step: 1.1.3 (2 way case split)--- Step: 1.1.3.1 Q.E.D.--- Step: 1.1.3.2.1 Q.E.D.--- Step: 1.1.3.2.2 (a ∉ cs) Q.E.D.--- Step: 1.1.3.Completeness Q.E.D.--- Step: 1.2.1 Q.E.D.+-- Step: 1.1.3.1 Q.E.D.+-- Step: 1.1.3.2.1 Q.E.D.+-- Step: 1.1.3.2.2 (a ∉ cs) Q.E.D.+-- Step: 1.1.3.Completeness Q.E.D.+-- Step: 1.2.1 Q.E.D. -- Step: 1.2.2 (2 way case split)--- Step: 1.2.2.1.1 Q.E.D.--- Step: 1.2.2.1.2 Q.E.D.--- Step: 1.2.2.1.3 (a ∈ cs) Q.E.D.--- Step: 1.2.2.2.1 Q.E.D.--- Step: 1.2.2.2.2 Q.E.D.--- Step: 1.2.2.2.3 (a ∉ bs) Q.E.D.--- Step: 1.2.2.2.4 (a ∉ cs) Q.E.D.--- Step: 1.2.2.Completeness Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.2.2.1.1 Q.E.D.+-- Step: 1.2.2.1.2 Q.E.D.+-- Step: 1.2.2.1.3 (a ∈ cs) Q.E.D.+-- Step: 1.2.2.2.1 Q.E.D.+-- Step: 1.2.2.2.2 Q.E.D.+-- Step: 1.2.2.2.3 (a ∉ bs) Q.E.D.+-- Step: 1.2.2.2.4 (a ∉ cs) Q.E.D.+-- Step: 1.2.2.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.diff -- [Proven] diffDiff :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Ɐcs ∷ [Integer] → Bool diffDiff :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> Forall "cs" [a] -> SBool))@@ -1349,10 +1349,10 @@ -- -- >>> runTP $ disjointDiff @Integer -- Inductive lemma: disjointDiff--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: disjoint, sbv.diff -- [Proven] disjointDiff :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Bool disjointDiff :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> SBool))@@ -1369,12 +1369,12 @@ -- -- >>> runTP $ partition1 @Integer (uninterpret "f") -- Inductive lemma: partition1--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.filter, sbv.partition -- [Proven] partition1 :: Ɐxs ∷ [Integer] → Bool partition1 :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> SBool))@@ -1396,12 +1396,12 @@ -- -- >>> runTP $ partition2 @Integer (uninterpret "f") -- Inductive lemma: partition2--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.filter, sbv.partition -- [Proven] partition2 :: Ɐxs ∷ [Integer] → Bool partition2 :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> SBool))@@ -1422,7 +1422,7 @@ -- | @take n (take m xs) == take (n `smin` m) xs@ -- -- >>> runTP $ take_take @Integer--- Lemma: take_take Q.E.D.+-- Lemma: take_take Q.E.D. -- [Proven] take_take :: Ɐm ∷ Integer → Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool take_take :: forall a. SymVal a => TP (Proof (Forall "m" Integer -> Forall "n" Integer -> Forall "xs" [a] -> SBool)) take_take = lemma "take_take"@@ -1432,7 +1432,7 @@ -- | @n >= 0 && m >= 0 ==> drop n (drop m xs) == drop (n + m) xs@ -- -- >>> runTP $ drop_drop @Integer--- Lemma: drop_drop Q.E.D.+-- Lemma: drop_drop Q.E.D. -- [Proven] drop_drop :: Ɐm ∷ Integer → Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool drop_drop :: forall a. SymVal a => TP (Proof (Forall "m" Integer -> Forall "n" Integer -> Forall "xs" [a] -> SBool)) drop_drop = lemma "drop_drop"@@ -1442,7 +1442,7 @@ -- | @take n xs ++ drop n xs == xs@ -- -- >>> runTP $ take_drop @Integer--- Lemma: take_drop Q.E.D.+-- Lemma: take_drop Q.E.D. -- [Proven] take_drop :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool take_drop :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) take_drop = lemma "take_drop"@@ -1452,7 +1452,7 @@ -- | @n .> 0 ==> take n (x .: xs) == x .: take (n - 1) xs@ -- -- >>> runTP $ take_cons @Integer--- Lemma: take_cons Q.E.D.+-- Lemma: take_cons Q.E.D. -- [Proven] take_cons :: Ɐn ∷ Integer → Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool take_cons :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "x" a -> Forall "xs" [a] -> SBool)) take_cons = lemma "take_cons"@@ -1462,20 +1462,20 @@ -- | @take n (map f xs) == map f (take n xs)@ -- -- >>> runTP $ take_map @Integer @Integer (uninterpret "f")--- Lemma: take_cons Q.E.D.--- Lemma: map1 Q.E.D.--- Lemma: take_map.n <= 0 Q.E.D.+-- Lemma: take_cons Q.E.D.+-- Lemma: map1 Q.E.D.+-- Lemma: take_map.n <= 0 Q.E.D. -- Inductive lemma: take_map.n > 0--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Lemma: take_map--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.map -- [Proven] take_map :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool take_map :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool))@@ -1514,7 +1514,7 @@ -- | @n .> 0 ==> drop n (x .: xs) == drop (n - 1) xs@ -- -- >>> runTP $ drop_cons @Integer--- Lemma: drop_cons Q.E.D.+-- Lemma: drop_cons Q.E.D. -- [Proven] drop_cons :: Ɐn ∷ Integer → Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool drop_cons :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "x" a -> Forall "xs" [a] -> SBool)) drop_cons = lemma "drop_cons"@@ -1524,22 +1524,22 @@ -- | @drop n (map f xs) == map f (drop n xs)@ -- -- >>> runTP $ drop_map @Integer @String (uninterpret "f")--- Lemma: drop_cons Q.E.D.--- Lemma: drop_cons Q.E.D.--- Lemma: drop_map.n <= 0 Q.E.D.+-- Lemma: drop_cons Q.E.D.+-- Lemma: drop_cons Q.E.D.+-- Lemma: drop_map.n <= 0 Q.E.D. -- Inductive lemma: drop_map.n > 0--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Lemma: drop_map--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.map -- [Proven] drop_map :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool drop_map :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool))@@ -1580,7 +1580,7 @@ -- | @n >= 0 ==> length (take n xs) == length xs \`min\` n@ -- -- >>> runTP $ length_take @Integer--- Lemma: length_take Q.E.D.+-- Lemma: length_take Q.E.D. -- [Proven] length_take :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool length_take :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) length_take = lemma "length_take"@@ -1590,7 +1590,7 @@ -- | @n >= 0 ==> length (drop n xs) == (length xs - n) \`max\` 0@ -- -- >>> runTP $ length_drop @Integer--- Lemma: length_drop Q.E.D.+-- Lemma: length_drop Q.E.D. -- [Proven] length_drop :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool length_drop :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) length_drop = lemma "length_drop"@@ -1600,7 +1600,7 @@ -- | @length xs \<= n ==\> take n xs == xs@ -- -- >>> runTP $ take_all @Integer--- Lemma: take_all Q.E.D.+-- Lemma: take_all Q.E.D. -- [Proven] take_all :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool take_all :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) take_all = lemma "take_all"@@ -1610,7 +1610,7 @@ -- | @length xs \<= n ==\> drop n xs == []@ -- -- >>> runTP $ drop_all @Integer--- Lemma: drop_all Q.E.D.+-- Lemma: drop_all Q.E.D. -- [Proven] drop_all :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool drop_all :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) drop_all = lemma "drop_all"@@ -1620,7 +1620,7 @@ -- | @take n (xs ++ ys) == (take n xs ++ take (n - length xs) ys)@ -- -- >>> runTP $ take_append @Integer--- Lemma: take_append Q.E.D.+-- Lemma: take_append Q.E.D. -- [Proven] take_append :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool take_append :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> Forall "ys" [a] -> SBool)) take_append = lemmaWith cvc5 "take_append"@@ -1632,7 +1632,7 @@ -- NB. As of Feb 2025, z3 struggles to prove this, but cvc5 gets it out-of-the-box. -- -- >>> runTP $ drop_append @Integer--- Lemma: drop_append Q.E.D.+-- Lemma: drop_append Q.E.D. -- [Proven] drop_append :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool drop_append :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> Forall "ys" [a] -> SBool)) drop_append = lemmaWith cvc5 "drop_append"@@ -1643,12 +1643,12 @@ -- -- >>> runTP $ map_fst_zip @Integer @Integer -- Inductive lemma: map_fst_zip--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.map, sbv.zip -- [Proven] map_fst_zip :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool map_fst_zip :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool))@@ -1667,12 +1667,12 @@ -- -- >>> runTP $ map_snd_zip @Integer @Integer -- Inductive lemma: map_snd_zip--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.map, sbv.zip -- [Proven] map_snd_zip :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool map_snd_zip :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool))@@ -1690,15 +1690,15 @@ -- | @map fst (zip xs ys) == take (min (length xs) (length ys)) xs@ -- -- >>> runTP $ map_fst_zip_take @Integer @Integer--- Lemma: take_cons Q.E.D.+-- Lemma: take_cons Q.E.D. -- Inductive lemma: map_fst_zip_take--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.map, sbv.zip -- [Proven] map_fst_zip_take :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool map_fst_zip_take :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool))@@ -1720,15 +1720,15 @@ -- | @map snd (zip xs ys) == take (min (length xs) (length ys)) xs@ -- -- >>> runTP $ map_snd_zip_take @Integer @Integer--- Lemma: take_cons Q.E.D.+-- Lemma: take_cons Q.E.D. -- Inductive lemma: map_snd_zip_take--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.map, sbv.zip -- [Proven] map_snd_zip_take :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool map_snd_zip_take :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool))@@ -1760,7 +1760,7 @@ -- @define-fun-rec@ but struggles to fold it back, so we provide this as a reusable hint. -- -- >>> runTP $ countOneStep @Integer--- Lemma: countOneStep Q.E.D.+-- Lemma: countOneStep Q.E.D. -- Functions proven terminating: count -- [Proven] countOneStep :: Ɐe ∷ Integer → Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool countOneStep :: forall a. SymVal a => TP (Proof (Forall "e" a -> Forall "x" a -> Forall "xs" [a] -> SBool))@@ -1784,14 +1784,14 @@ -- -- >>> runTP $ interleaveLen @Integer -- Inductive lemma (strong): interleaveLen--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: interleave -- [Proven] interleaveLen :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool interleaveLen :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))@@ -1828,26 +1828,26 @@ -- We have: -- -- >>> runTP $ interleaveRoundTrip @Integer--- Lemma: revCons Q.E.D.+-- Lemma: revCons Q.E.D. -- Inductive lemma (strong): roundTripGen--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3.1 Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.3.4 Q.E.D.--- Step: 1.3.5 Q.E.D.--- Step: 1.3.6 Q.E.D.--- Step: 1.3.7 Q.E.D.--- Step: 1.3.8 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.3.6 Q.E.D.+-- Step: 1.3.7 Q.E.D.+-- Step: 1.3.8 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: interleaveRoundTrip--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: interleave, sbv.reverse, uninterleave -- [Proven] interleaveRoundTrip :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool interleaveRoundTrip :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))@@ -1897,12 +1897,12 @@ -- -- >>> runTP $ countAppend @Integer -- Inductive lemma: countAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 (unfold count) Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 (simplify) Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 (unfold count) Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 (simplify) Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] countAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐe ∷ Integer → Bool countAppend :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> Forall "e" a -> SBool))@@ -1923,17 +1923,17 @@ -- -- >>> runTP $ takeDropCount @Integer -- Inductive lemma: countAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 (unfold count) Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 (simplify) Q.E.D.--- Result: Q.E.D.--- Lemma: take_drop Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 (unfold count) Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 (simplify) Q.E.D.+-- Result: Q.E.D.+-- Lemma: take_drop Q.E.D. -- Lemma: takeDropCount--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] takeDropCount :: Ɐxs ∷ [Integer] → Ɐn ∷ Integer → Ɐe ∷ Integer → Bool takeDropCount :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "n" Integer -> Forall "e" a -> SBool))@@ -1954,14 +1954,14 @@ -- -- >>> runTP $ countNonNeg @Integer -- Inductive lemma: countNonNeg--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] countNonNeg :: Ɐxs ∷ [Integer] → Ɐe ∷ Integer → Bool countNonNeg :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "e" a -> SBool))@@ -1983,23 +1983,23 @@ -- -- >>> runTP $ countElem @Integer -- Inductive lemma: countNonNeg--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: countElem--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] countElem :: Ɐxs ∷ [Integer] → Ɐe ∷ Integer → Bool countElem :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "e" a -> SBool))@@ -2025,13 +2025,13 @@ -- -- >>> runTP $ elemCount @Integer -- Inductive lemma: elemCount--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] elemCount :: Ɐxs ∷ [Integer] → Ɐe ∷ Integer → Bool elemCount :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "e" a -> SBool))
Documentation/SBV/Examples/TP/Majority.hs view
@@ -72,25 +72,25 @@ -- -- >>> correctness @Integer -- Inductive lemma: majorityGeneral--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D. -- Step: 1.2.2 (2 way case split)--- Step: 1.2.2.1.1 Q.E.D.--- Step: 1.2.2.1.2 Q.E.D.--- Step: 1.2.2.2.1 Q.E.D.--- Step: 1.2.2.2.2 Q.E.D.--- Step: 1.2.2.Completeness Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.--- Lemma: majority Q.E.D.--- Lemma: ifExistsFound Q.E.D.--- Lemma: ifNoMajority Q.E.D.+-- Step: 1.2.2.1.1 Q.E.D.+-- Step: 1.2.2.1.2 Q.E.D.+-- Step: 1.2.2.2.1 Q.E.D.+-- Step: 1.2.2.2.2 Q.E.D.+-- Step: 1.2.2.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: majority Q.E.D.+-- Lemma: ifExistsFound Q.E.D.+-- Lemma: ifNoMajority Q.E.D. -- Lemma: uniqueness--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: count, majority -- ([Proven] majority :: Ɐc ∷ Integer → Ɐxs ∷ [Integer] → Bool,[Proven] ifExistsFound :: Ɐc ∷ Integer → Ɐxs ∷ [Integer] → Bool,[Proven] ifNoMajority :: Ɐc ∷ Integer → Ɐxs ∷ [Integer] → Bool,[Proven] uniqueness :: Ɐm1 ∷ Integer → Ɐm2 ∷ Integer → Ɐxs ∷ [Integer] → Bool) correctness :: forall a. SymVal a
Documentation/SBV/Examples/TP/McCarthy91.hs view
@@ -49,20 +49,20 @@ -- and strong induction. We have: -- -- >>> correctness--- Lemma: case1 Q.E.D.--- Lemma: case2 Q.E.D.+-- Lemma: case1 Q.E.D.+-- Lemma: case2 Q.E.D. -- Inductive lemma (strong): case3--- Step: Measure is non-negative Q.E.D.--- Step: 1 (unfold) Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 (unfold) Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Lemma: mcCarthy91 -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: mcCarthy91 -- [Proven] mcCarthy91 :: Ɐn ∷ Integer → Bool correctness :: IO (Proof (Forall "n" Integer -> SBool))
Documentation/SBV/Examples/TP/MergeSort.hs view
@@ -66,78 +66,78 @@ -- We have: -- -- >>> correctness @Integer--- Lemma: nonDecrInsert Q.E.D.+-- Lemma: nonDecrInsert Q.E.D. -- Inductive lemma: countAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 (unfold count) Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 (simplify) Q.E.D.--- Result: Q.E.D.--- Lemma: take_drop Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 (unfold count) Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 (simplify) Q.E.D.+-- Result: Q.E.D.+-- Lemma: take_drop Q.E.D. -- Lemma: takeDropCount--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.--- Lemma: countOneStep Q.E.D.--- Lemma: mergeHead Q.E.D.--- Lemma: mergeUnfold Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Lemma: countOneStep Q.E.D.+-- Lemma: mergeHead Q.E.D.+-- Lemma: mergeUnfold Q.E.D. -- Inductive lemma (strong): mergeKeepsSort--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D. -- Step: 1.3 (2 way case split)--- Step: 1.3.1.1 (2 way case split) Q.E.D.--- Step: 1.3.1.2 Q.E.D.--- Step: 1.3.1.3 Q.E.D.--- Step: 1.3.2.1 (2 way case split) Q.E.D.--- Step: 1.3.2.2 Q.E.D.--- Step: 1.3.2.3 Q.E.D.--- Step: 1.3.Completeness Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.3.1.1 (2 way case split) Q.E.D.+-- Step: 1.3.1.2 Q.E.D.+-- Step: 1.3.1.3 Q.E.D.+-- Step: 1.3.2.1 (2 way case split) Q.E.D.+-- Step: 1.3.2.2 Q.E.D.+-- Step: 1.3.2.3 Q.E.D.+-- Step: 1.3.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): sortNonDecreasing--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 (unfold) Q.E.D.--- Step: 1.2.2 (push nonDecreasing down) Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 (unfold) Q.E.D.+-- Step: 1.2.2 (push nonDecreasing down) Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): mergeCount--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3.1 (unfold merge) Q.E.D.--- Step: 1.3.2 (push count inside) Q.E.D.--- Step: 1.3.3 (unfold count, twice) Q.E.D.--- Step: 1.3.4 Q.E.D.--- Step: 1.3.5 Q.E.D.--- Step: 1.3.6 (unfold count in reverse, twice) Q.E.D.--- Step: 1.3.7 (simplify) Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3.1 (unfold merge) Q.E.D.+-- Step: 1.3.2 (push count inside) Q.E.D.+-- Step: 1.3.3 (unfold count, twice) Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.3.6 (unfold count in reverse, twice) Q.E.D.+-- Step: 1.3.7 (simplify) Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): sortIsPermutation--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 (unfold mergeSort) Q.E.D.--- Step: 1.2.2 (push count down, simplify, rearrange) Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.2.5 Q.E.D.--- Step: 1.2.6 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.--- Lemma: mergeSortIsCorrect Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 (unfold mergeSort) Q.E.D.+-- Step: 1.2.2 (push count down, simplify, rearrange) Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.2.5 Q.E.D.+-- Step: 1.2.6 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: mergeSortIsCorrect Q.E.D. -- Functions proven terminating: count, merge, mergeSort, nonDecreasing -- [Proven] mergeSortIsCorrect :: Ɐxs ∷ [Integer] → Bool correctness :: forall a. (OrdSymbolic (SBV a), SymVal a) => IO (Proof (Forall "xs" [a] -> SBool))-correctness = runTPWith (tpRibbon 60 z3) $ do+correctness = runTP $ do -------------------------------------------------------------------------------------------- -- Part I. Import helper lemmas, definitions
Documentation/SBV/Examples/TP/MutualCorecursion.hs view
@@ -61,10 +61,10 @@ -- -- >>> runTP pingLen -- Inductive lemma: pingLen--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven productive: ping, pong -- [Proven] pingLen :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool pingLen :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool))@@ -81,10 +81,10 @@ -- -- >>> runTP pongLen -- Inductive lemma: pongLen--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven productive: ping, pong -- [Proven] pongLen :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool pongLen :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool))@@ -100,7 +100,7 @@ -- | Indexing past a cons: @(x .: y) !! k == y !! (k - 1)@ when @k > 0@ and in bounds. -- -- >>> runTP consIndex--- Lemma: consIndex Q.E.D.+-- Lemma: consIndex Q.E.D. -- [Proven] consIndex :: Ɐx ∷ Integer → Ɐy ∷ [Integer] → Ɐk ∷ Integer → Bool consIndex :: TP (Proof (Forall "x" Integer -> Forall "y" [Integer] -> Forall "k" Integer -> SBool)) consIndex = lemma "consIndex"@@ -114,17 +114,17 @@ -- elements are the same, by induction on @k@. -- -- >>> runTP pingEqPong--- Lemma: pingLen Q.E.D.--- Lemma: pongLen Q.E.D.--- Lemma: consIndex Q.E.D.+-- Lemma: pingLen Q.E.D.+-- Lemma: pongLen Q.E.D.+-- Lemma: consIndex Q.E.D. -- Inductive lemma: pingEqPong--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven productive: ping, pong -- [Proven] pingEqPong :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool pingEqPong :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool))@@ -152,17 +152,17 @@ -- | The @k@-th element of @ping n@ is @n + k@. -- -- >>> runTP pingElem--- Lemma: pingEqPong Q.E.D.--- Cached: consIndex Q.E.D.--- Cached: pongLen Q.E.D.+-- Lemma: pingEqPong Q.E.D.+-- Lemma: consIndex Q.E.D. [Cached]+-- Lemma: pongLen Q.E.D. [Cached] -- Inductive lemma: pingElem--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven productive: ping, pong -- [Proven] pingElem :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool pingElem :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool))
Documentation/SBV/Examples/TP/NatStream.hs view
@@ -50,7 +50,7 @@ -- NB. As of Mar 2026, z3 can't handle this but cvc5 can. -- -- >>> runTP natsHead--- Lemma: natsHead Q.E.D.+-- Lemma: natsHead Q.E.D. -- Functions proven productive: nats -- [Proven] natsHead :: Ɐn ∷ Integer → Bool natsHead :: TP (Proof (Forall "n" Integer -> SBool))@@ -65,10 +65,10 @@ -- -- >>> runTP natsLen -- Inductive lemma: natsLen--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven productive: nats -- [Proven] natsLen :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool natsLen :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool))@@ -87,15 +87,15 @@ -- NB. As of Mar 2026, z3 can't handle this but cvc5 can. -- -- >>> runTP natsElem--- Lemma: natsLen Q.E.D.--- Lemma: elemOne Q.E.D.+-- Lemma: natsLen Q.E.D.+-- Lemma: elemOne Q.E.D. -- Inductive lemma: natsElem--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven productive: nats -- [Proven] natsElem :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool natsElem :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool))
Documentation/SBV/Examples/TP/Numeric.hs view
@@ -40,12 +40,12 @@ -- -- >>> runTP $ sumConstProof (uninterpret "c") -- Inductive lemma: sumConst_correct--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr, sbv.replicate -- [Proven] sumConst_correct :: Ɐn ∷ Integer → Bool sumConstProof :: SInteger -> TP (Proof (Forall "n" Integer -> SBool))@@ -71,11 +71,11 @@ -- -- >>> runTP sumProof -- Inductive lemma: sum_correct--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: -- EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up, sbv.foldr -- [Proven] sum_correct :: Ɐn ∷ Integer → Bool@@ -95,14 +95,14 @@ -- -- >>> runTP sumSquareProof -- Inductive lemma: sumSquare_correct--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: -- EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up, -- sbv.foldr, sbv.map@@ -134,27 +134,27 @@ -- -- >>> runTP nicomachus -- Inductive lemma: sum_correct--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.--- Lemma: evenHalfSquared Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: evenHalfSquared Q.E.D. -- Inductive lemma: nn1IsEven--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: sum_squared--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: nicomachus--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: -- EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up, -- sbv.foldr, sumCubed@@ -224,18 +224,18 @@ -- NB. As of Feb 2025, z3 struggles with the inductive step in this proof, but cvc5 performs just fine. -- -- >>> runTP elevenMinusFour--- Lemma: powN Q.E.D.+-- Lemma: powN Q.E.D. -- Inductive lemma: elevenMinusFour--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Step: 8 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Step: 8 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: pow -- [Proven] elevenMinusFour :: Ɐn ∷ Integer → Bool elevenMinusFour :: TP (Proof (Forall "n" Integer -> SBool))@@ -276,21 +276,21 @@ -- -- >>> runTP sumMulFactorial -- Lemma: fact (n+1)--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: sumMulFactorial--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: -- EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up, -- sbv.foldr, sbv.map@@ -330,14 +330,14 @@ -- -- >>> runTP product0 -- Inductive lemma: product0--- Step: Base Q.E.D.--- Step: 1 Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D. -- Step: 2 (2 way case split)--- Step: 2.1 Q.E.D.--- Step: 2.2.1 Q.E.D.--- Step: 2.2.2 Q.E.D.--- Step: 2.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 2.1 Q.E.D.+-- Step: 2.2.1 Q.E.D.+-- Step: 2.2.2 Q.E.D.+-- Step: 2.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr -- [Proven] product0 :: Ɐxs ∷ [Integer] → Bool product0 :: TP (Proof (Forall "xs" [Integer] -> SBool))@@ -361,7 +361,7 @@ -- -- >>> badNonNegative `catch` (\(_ :: SomeException) -> pure ()) -- Inductive lemma: badNonNegative--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 -- *** Failed to prove badNonNegative.1. -- Falsifiable. Counter-example:
Documentation/SBV/Examples/TP/Peano.hs view
@@ -115,7 +115,7 @@ -- | \(\overline{n} \geq 0\) -- -- >>> runTP n2iNonNeg--- Lemma: n2iNonNeg Q.E.D.+-- Lemma: n2iNonNeg Q.E.D. -- Functions proven terminating: n2i -- [Proven] n2iNonNeg :: Ɐn ∷ Nat → Bool n2iNonNeg :: TP (Proof (Forall "n" Nat -> SBool))@@ -124,7 +124,7 @@ -- | \(\overline{\underline{i}} = \max(i, 0)\). -- -- >>> runTP i2n2i--- Lemma: i2n2i Q.E.D.+-- Lemma: i2n2i Q.E.D. -- Functions proven terminating: i2n, n2i -- [Proven] i2n2i :: Ɐi ∷ Integer → Bool i2n2i :: TP (Proof (Forall "i" Integer -> SBool))@@ -133,7 +133,7 @@ -- | \(\underline{\overline{n}} = n\) -- -- >>> runTP n2i2n--- Lemma: n2i2n Q.E.D.+-- Lemma: n2i2n Q.E.D. -- Functions proven terminating: i2n, n2i -- [Proven] n2i2n :: Ɐn ∷ Nat → Bool n2i2n :: TP (Proof (Forall "n" Nat -> SBool))@@ -142,7 +142,7 @@ -- | \(\overline{m + n} = \overline{m} + \overline{n}\) -- -- >>> runTP n2iAdd--- Lemma: n2iAdd Q.E.D.+-- Lemma: n2iAdd Q.E.D. -- Functions proven terminating: n2i, sNatPlus -- [Proven] n2iAdd :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool n2iAdd :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))@@ -155,7 +155,7 @@ -- | \(\overline{m + n} = \overline{m} + \overline{n}\) -- -- >>> runTP addCorrect--- Lemma: addCorrect Q.E.D.+-- Lemma: addCorrect Q.E.D. -- Functions proven terminating: n2i, sNatPlus -- [Proven] addCorrect :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool addCorrect :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))@@ -169,7 +169,7 @@ -- | \(0 + m = m\) -- -- >>> runTP addLeftUnit--- Lemma: addLeftUnit Q.E.D.+-- Lemma: addLeftUnit Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addLeftUnit :: Ɐm ∷ Nat → Bool addLeftUnit :: TP (Proof (Forall "m" Nat -> SBool))@@ -178,7 +178,7 @@ -- | \(m + 0 = m\) -- -- >>> runTP addRightUnit--- Lemma: addRightUnit Q.E.D.+-- Lemma: addRightUnit Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addRightUnit :: Ɐm ∷ Nat → Bool addRightUnit :: TP (Proof (Forall "m" Nat -> SBool))@@ -189,13 +189,13 @@ -- | \(m + \mathrm{Succ}\,n = \mathrm{Succ}\,(m + n)\) -- -- >>> runTP addSucc--- Lemma: caseZero Q.E.D.+-- Lemma: caseZero Q.E.D. -- Lemma: caseSucc--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.--- Lemma: addSucc Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: addSucc Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addSucc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool addSucc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))@@ -225,7 +225,7 @@ -- | \(m + (n + o) = (m + n) + o\) -- -- >>> runTP addAssoc--- Lemma: addAssoc Q.E.D.+-- Lemma: addAssoc Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addAssoc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool addAssoc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))@@ -239,16 +239,16 @@ -- | \(m + n = n + m\) -- -- >>> runTP addComm--- Lemma: addLeftUnit Q.E.D.--- Lemma: addRightUnit Q.E.D.--- Lemma: caseZero Q.E.D.--- Lemma: addSucc Q.E.D.+-- Lemma: addLeftUnit Q.E.D.+-- Lemma: addRightUnit Q.E.D.+-- Lemma: caseZero Q.E.D.+-- Lemma: addSucc Q.E.D. -- Lemma: caseSucc--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.--- Lemma: addComm Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: addComm Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addComm :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool addComm :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))@@ -284,16 +284,16 @@ -- | \(\overline{m * n} = \overline{m} * \overline{n}\) -- -- >>> runTP mulCorrect--- Lemma: caseZero Q.E.D.--- Lemma: addCorrect Q.E.D.+-- Lemma: caseZero Q.E.D.+-- Lemma: addCorrect Q.E.D. -- Lemma: caseSucc--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.--- Lemma: mullCorrect Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D.+-- Lemma: mullCorrect Q.E.D. -- Functions proven terminating: n2i, sNatPlus, sNatTimes -- [Proven] mullCorrect :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool mulCorrect :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))@@ -328,7 +328,7 @@ -- | \(0 * m = 0\) -- -- >>> runTP mulLeftAbsorb--- Lemma: mulLeftAbsorb Q.E.D.+-- Lemma: mulLeftAbsorb Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulLeftAbsorb :: Ɐm ∷ Nat → Bool mulLeftAbsorb :: TP (Proof (Forall "m" Nat -> SBool))@@ -337,7 +337,7 @@ -- | \(m * 0 = 0\) -- -- >>> runTP mulRightAbsorb--- Lemma: mulRightAbsorb Q.E.D.+-- Lemma: mulRightAbsorb Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulRightAbsorb :: Ɐm ∷ Nat → Bool mulRightAbsorb :: TP (Proof (Forall "m" Nat -> SBool))@@ -348,7 +348,7 @@ -- | \(\mathrm{Succ\,0} * m = m\) -- -- >>> runTP mulLeftUnit--- Lemma: mulLeftUnit Q.E.D.+-- Lemma: mulLeftUnit Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulLeftUnit :: Ɐm ∷ Nat → Bool mulLeftUnit :: TP (Proof (Forall "m" Nat -> SBool))@@ -357,7 +357,7 @@ -- | \(m * \mathrm{Succ\,0} = m\) -- -- >>> runTP mulRightUnit--- Lemma: mulRightUnit Q.E.D.+-- Lemma: mulRightUnit Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulRightUnit :: Ɐm ∷ Nat → Bool mulRightUnit :: TP (Proof (Forall "m" Nat -> SBool))@@ -368,21 +368,21 @@ -- | \(m * (n + o) = m * n + m * o\) -- -- >>> runTP distribLeft--- Lemma: caseZero Q.E.D.--- Lemma: addAssoc Q.E.D.--- Lemma: addComm Q.E.D.+-- Lemma: caseZero Q.E.D.+-- Lemma: addAssoc Q.E.D.+-- Lemma: addComm Q.E.D. -- Lemma: caseSucc--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Step: 8 Q.E.D.--- Step: 9 Q.E.D.--- Result: Q.E.D.--- Lemma: distribLeft Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Step: 8 Q.E.D.+-- Step: 9 Q.E.D.+-- Result: Q.E.D.+-- Lemma: distribLeft Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] distribLeft :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool distribLeft :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))@@ -422,20 +422,20 @@ -- | \((m + n) * o = m * o + n * o\) -- -- >>> runTP distribRight--- Lemma: caseZero Q.E.D.--- Lemma: addAssoc Q.E.D.--- Lemma: addComm Q.E.D.--- Cached: addSucc Q.E.D.+-- Lemma: caseZero Q.E.D.+-- Lemma: addAssoc Q.E.D.+-- Lemma: addComm Q.E.D.+-- Lemma: addSucc Q.E.D. [Cached] -- Lemma: caseSucc--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Result: Q.E.D.--- Lemma: distribRight Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Result: Q.E.D.+-- Lemma: distribRight Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] distribRight :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool distribRight :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))@@ -475,17 +475,17 @@ -- | \(m * \mathrm{Succ}\,n = m * n + m\) -- -- >>> runTP mulSucc--- Lemma: addLeftUnit Q.E.D.--- Lemma: distribLeft Q.E.D.--- Lemma: mulRightUnit Q.E.D.--- Cached: addComm Q.E.D.+-- Lemma: addLeftUnit Q.E.D.+-- Lemma: distribLeft Q.E.D.+-- Lemma: mulRightUnit Q.E.D.+-- Lemma: addComm Q.E.D. [Cached] -- Lemma: mulSucc--- Step: 1 Q.E.D.--- Step: 2 (defn of +) Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 (defn of +) Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulSucc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool mulSucc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))@@ -515,15 +515,15 @@ -- | \(m * (n * o) = (m * n) * o\) -- -- >>> runTP mulAssoc--- Lemma: caseZero Q.E.D.--- Lemma: distribRight Q.E.D.+-- Lemma: caseZero Q.E.D.+-- Lemma: distribRight Q.E.D. -- Lemma: caseSucc--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.--- Lemma: mulAssoc Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D.+-- Lemma: mulAssoc Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulAssoc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool mulAssoc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))@@ -557,19 +557,19 @@ -- | \(m * n = n * m\) -- -- >>> runTP mulComm--- Lemma: mulRightAbsorb Q.E.D.--- Lemma: caseZero Q.E.D.--- Lemma: mulRightUnit Q.E.D.--- Lemma: distribLeft Q.E.D.+-- Lemma: mulRightAbsorb Q.E.D.+-- Lemma: caseZero Q.E.D.+-- Lemma: mulRightUnit Q.E.D.+-- Lemma: distribLeft Q.E.D. -- Lemma: caseSucc--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.--- Lemma: mulComm Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D.+-- Lemma: mulComm Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulComm :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool mulComm :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))@@ -610,15 +610,15 @@ -- | \(m < n \;\wedge\; n < o \;\rightarrow\; m < o\) -- -- >>> runTP ltTrans--- Lemma: addAssoc Q.E.D.+-- Lemma: addAssoc Q.E.D. -- Lemma: ltTrans--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] ltTrans :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool ltTrans :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))@@ -645,11 +645,11 @@ -- | \(\neg(m < m)\) -- -- >>> runTP ltIrreflexive--- Lemma: cancel Q.E.D.+-- Lemma: cancel Q.E.D. -- Lemma: ltIrreflexive--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] ltIrreflexive :: Ɐm ∷ Nat → Bool ltIrreflexive :: TP (Proof (Forall "m" Nat -> SBool))@@ -672,37 +672,37 @@ -- | \(m \geq n = \overline{m} \geq \overline{n}\) -- -- >>> runTP lteEquiv--- Lemma: n2iAdd Q.E.D.--- Lemma: n2iNonNeg Q.E.D.--- Lemma: n2i2n Q.E.D.--- Lemma: i2n2i Q.E.D.--- Lemma: addRightUnit Q.E.D.+-- Lemma: n2iAdd Q.E.D.+-- Lemma: n2iNonNeg Q.E.D.+-- Lemma: n2i2n Q.E.D.+-- Lemma: i2n2i Q.E.D.+-- Lemma: addRightUnit Q.E.D. -- Lemma: lteEquiv_ltr -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: lteEquiv_rtl--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D. -- Step: 7 (2 way case split)--- Step: 7.1 Q.E.D.--- Step: 7.2.1 Q.E.D.--- Step: 7.2.2 Q.E.D.--- Step: 7.2.3 Q.E.D.--- Step: 7.2.4 Q.E.D.--- Step: 7.2.5 Q.E.D.--- Step: 7.Completeness Q.E.D.--- Result: Q.E.D.--- Lemma: lteEquiv Q.E.D.+-- Step: 7.1 Q.E.D.+-- Step: 7.2.1 Q.E.D.+-- Step: 7.2.2 Q.E.D.+-- Step: 7.2.3 Q.E.D.+-- Step: 7.2.4 Q.E.D.+-- Step: 7.2.5 Q.E.D.+-- Step: 7.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: lteEquiv Q.E.D. -- Functions proven terminating: i2n, n2i, sNatPlus -- [Proven] lteEquiv :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool lteEquiv :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))@@ -762,11 +762,11 @@ -- | \(m \geq n \;\lor\; n \geq m\) -- -- >>> runTP ordered--- Lemma: lteEquiv Q.E.D.+-- Lemma: lteEquiv Q.E.D. -- Lemma: ordered--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: i2n, n2i, sNatPlus -- [Proven] ordered :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool ordered :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))@@ -785,8 +785,8 @@ -- | \(m < n \;\lor\; m = n \;\lor\; n < m\) -- -- >>> runTP trichotomy--- Lemma: ordered Q.E.D.--- Lemma: trichotomy Q.E.D.+-- Lemma: ordered Q.E.D.+-- Lemma: trichotomy Q.E.D. -- Functions proven terminating: i2n, n2i, sNatPlus -- [Proven] trichotomy :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool trichotomy :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))@@ -802,15 +802,15 @@ -- | \(m < n \;\rightarrow\; m + o < n + o\) -- -- >>> runTP addOrder--- Lemma: addAssoc Q.E.D.--- Lemma: addComm Q.E.D.+-- Lemma: addAssoc Q.E.D.+-- Lemma: addComm Q.E.D. -- Lemma: addOrder--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addOrder :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool addOrder :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))@@ -838,15 +838,15 @@ -- | \(o > 0 \;\wedge\; m < n \;\rightarrow\; m * o < n * o\) -- -- >>> runTP mulOrder--- Lemma: distribRight Q.E.D.+-- Lemma: distribRight Q.E.D. -- Lemma: mulOrder--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulOrder :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool mulOrder :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool))@@ -873,7 +873,7 @@ -- | \(m < n \;\rightarrow\; \exists o.\; m + o = n\) -- -- >>> runTP orderSum--- Lemma: orderSum Q.E.D.+-- Lemma: orderSum Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] orderSum :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool orderSum :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool))@@ -886,7 +886,7 @@ -- | \(0 < 1\) -- -- >>> runTP zeroLtOne--- Lemma: zeroLtOne Q.E.D.+-- Lemma: zeroLtOne Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] zeroLtOne :: Bool zeroLtOne :: TP (Proof SBool)@@ -895,7 +895,7 @@ -- | \(m > 0 \;\rightarrow\; m \geq 1\) -- -- >>> runTP nothingBetweenZeroAndOne--- Lemma: nothingBetweenZeroAndOne Q.E.D.+-- Lemma: nothingBetweenZeroAndOne Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] nothingBetweenZeroAndOne :: Ɐm ∷ Nat → Bool nothingBetweenZeroAndOne :: TP (Proof (Forall "m" Nat -> SBool))@@ -908,7 +908,7 @@ -- | \(m \geq 0\) -- -- >>> runTP minimumElt--- Lemma: minimumElt Q.E.D.+-- Lemma: minimumElt Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] minimumElt :: Ɐm ∷ Nat → Bool minimumElt :: TP (Proof (Forall "m" Nat -> SBool))@@ -919,7 +919,7 @@ -- | \(\forall m \;\exists n \;.\; m < n\) -- -- >>> runTP noMaximumElt--- Lemma: noMaximumElt Q.E.D.+-- Lemma: noMaximumElt Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] noMaximumElt :: Ɐm ∷ Nat → ∃n ∷ Nat → Bool noMaximumElt :: TP (Proof (Forall "m" Nat -> Exists "n" Nat -> SBool))
Documentation/SBV/Examples/TP/PigeonHole.hs view
@@ -36,10 +36,10 @@ -- -- >>> runTP pigeonHole -- Inductive lemma: pigeonHole--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr --[Proven] pigeonHole :: Ɐxs ∷ [Integer] → Bool pigeonHole :: TP (Proof (Forall "xs" [Integer] -> SBool))
Documentation/SBV/Examples/TP/PowerMod.hs view
@@ -42,17 +42,17 @@ -- ==== __Proof__ -- >>> runTP modAddMultiple -- Inductive lemma: modAddMultiplePos--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- [Proven] modAddMultiple :: Ɐk ∷ Integer → Ɐn ∷ Integer → Ɐm ∷ Integer → Bool modAddMultiple :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> Forall "m" Integer -> SBool)) modAddMultiple = do@@ -89,21 +89,21 @@ -- ==== __Proof__ -- >>> runTP modAddRight -- Inductive lemma: modAddMultiplePos--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddRight--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- [Proven] modAddRight :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modAddRight :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modAddRight = do@@ -121,26 +121,26 @@ -- ==== __Proof__ -- >>> runTP modAddLeft -- Inductive lemma: modAddMultiplePos--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddRight--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddLeft--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- [Proven] modAddLeft :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modAddLeft :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modAddLeft = do@@ -159,22 +159,22 @@ -- ==== __Proof__ -- >>> runTP modSubRight -- Inductive lemma: modAddMultiplePos--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: modSubRight--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- [Proven] modSubRight :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modSubRight :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modSubRight = do@@ -194,36 +194,36 @@ -- ==== __Proof__ -- >>> runTP modMulRightNonneg -- Inductive lemma: modAddMultiplePos--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddRight--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddLeft--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.--- Cached: modAddRight Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: modAddRight Q.E.D. [Cached] -- Inductive lemma: modMulRightNonneg--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- [Proven] modMulRightNonneg :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modMulRightNonneg :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modMulRightNonneg = do@@ -250,36 +250,36 @@ -- ==== __Proof__ -- >>> runTP modMulRightNeg -- Inductive lemma: modAddMultiplePos--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddRight--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddLeft--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.--- Lemma: modSubRight Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: modSubRight Q.E.D. -- Inductive lemma: modMulRightNeg--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- [Proven] modMulRightNeg :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modMulRightNeg :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modMulRightNeg = do@@ -306,45 +306,45 @@ -- ==== __Proof__ -- >>> runTP modMulRight -- Inductive lemma: modAddMultiplePos--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddRight--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Lemma: modAddLeft--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.--- Cached: modAddRight Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: modAddRight Q.E.D. [Cached] -- Inductive lemma: modMulRightNonneg--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.--- Lemma: modMulRightNeg Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D.+-- Lemma: modMulRightNeg Q.E.D. -- Lemma: modMulRight -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- [Proven] modMulRight :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modMulRight :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modMulRight = do@@ -369,12 +369,12 @@ -- -- ==== __Proof__ -- >>> runTP modMulLeft--- Lemma: modMulRight Q.E.D.+-- Lemma: modMulRight Q.E.D. -- Lemma: modMulLeft--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- [Proven] modMulLeft :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modMulLeft :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modMulLeft = do@@ -393,18 +393,18 @@ -- -- ==== __Proof__ -- >>> runTP powerMod--- Lemma: modMulLeft Q.E.D.--- Cached: modMulRight Q.E.D.+-- Lemma: modMulLeft Q.E.D.+-- Lemma: modMulRight Q.E.D. [Cached] -- Inductive lemma: powerModInduct--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.--- Lemma: powerMod Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D.+-- Lemma: powerMod Q.E.D. -- Functions proven terminating: power -- [Proven] powerMod :: Ɐb ∷ Integer → Ɐn ∷ Integer → Ɐm ∷ Integer → Bool powerMod :: TP (Proof (Forall "b" Integer -> Forall "n" Integer -> Forall "m" Integer -> SBool))@@ -438,10 +438,10 @@ -- ==== __Proof__ -- >>> runTP onePower -- Inductive lemma: onePower--- Step: Base Q.E.D.--- Step: 1 (unfold power) Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 (unfold power) Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: power -- [Proven] onePower :: Ɐn ∷ Integer → Bool onePower :: TP (Proof (Forall "n" Integer -> SBool))@@ -458,14 +458,14 @@ -- -- ==== __Proof__ -- >>> runTP powerOf27--- Lemma: onePower Q.E.D.--- Lemma: powerMod Q.E.D.+-- Lemma: onePower Q.E.D.+-- Lemma: powerMod Q.E.D. -- Lemma: powerOf27--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: power -- [Proven] powerOf27 :: Ɐn ∷ Integer → Bool powerOf27 :: TP (Proof (Forall "n" Integer -> SBool))@@ -487,10 +487,10 @@ -- -- ==== __Proof__ -- >>> runTP powerOfThreeMod13VarDivisor--- Lemma: powerOf27 Q.E.D.+-- Lemma: powerOf27 Q.E.D. -- Lemma: powerOfThreeMod13VarDivisor--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: power -- [Proven] powerOfThreeMod13VarDivisor :: Ɐn ∷ Integer → Ɐm ∷ Integer → Bool powerOfThreeMod13VarDivisor :: TP (Proof (Forall "n" Integer -> Forall "m" Integer -> SBool))
Documentation/SBV/Examples/TP/Primes.hs view
@@ -41,12 +41,12 @@ -- >>> runTP dividesProduct -- Lemma: dividesProduct -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- [Proven] dividesProduct :: Ɐx ∷ Integer → Ɐy ∷ Integer → Ɐz ∷ Integer → Bool dividesProduct :: TP (Proof (Forall "x" Integer -> Forall "y" Integer -> Forall "z" Integer -> SBool)) dividesProduct = calc "dividesProduct"@@ -67,16 +67,16 @@ -- -- === __Proof__ -- >>> runTP dividesTransitive--- Lemma: dividesProduct Q.E.D.+-- Lemma: dividesProduct Q.E.D. -- Lemma: dividesTransitive -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- [Proven] dividesTransitive :: Ɐx ∷ Integer → Ɐy ∷ Integer → Ɐz ∷ Integer → Bool dividesTransitive :: TP (Proof (Forall "x" Integer -> Forall "y" Integer -> Forall "z" Integer -> SBool)) dividesTransitive = do@@ -117,12 +117,12 @@ -- === __Proof__ -- >>> runTP leastDivisorDivides -- Inductive lemma (strong): leastDivisorDivides--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: ld -- [Proven] leastDivisorDivides :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool leastDivisorDivides :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool))@@ -148,12 +148,12 @@ -- === __Proof__ -- >>> runTP leastDivisorIsLeast -- Inductive lemma (strong): leastDivisorisLeast--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: ld -- [Proven] leastDivisorisLeast :: Ɐk ∷ Integer → Ɐn ∷ Integer → Ɐd ∷ Integer → Bool leastDivisorIsLeast :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> Forall "d" Integer -> SBool))@@ -175,19 +175,19 @@ -- -- === __Proof__ -- >>> runTP leastDivisorTwice--- Lemma: dividesTransitive Q.E.D.--- Lemma: leastDivisorDivides Q.E.D.--- Lemma: leastDivisorisLeast Q.E.D.--- Lemma: helper1 Q.E.D.--- Lemma: helper2 Q.E.D.+-- Lemma: dividesTransitive Q.E.D.+-- Lemma: leastDivisorDivides Q.E.D.+-- Lemma: leastDivisorisLeast Q.E.D.+-- Lemma: helper1 Q.E.D.+-- Lemma: helper2 Q.E.D. -- Lemma: helper3--- Step: 1 Q.E.D.--- Result: Q.E.D.--- Lemma: helper4 Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Lemma: helper4 Q.E.D. -- Lemma: helper5--- Step: 1 Q.E.D.--- Result: Q.E.D.--- Lemma: leastDivisorTwice Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Lemma: leastDivisorTwice Q.E.D. -- Functions proven terminating: ld -- [Proven] leastDivisorTwice :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool leastDivisorTwice :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool))@@ -243,7 +243,7 @@ -- -- === __Proof__ -- >>> runTP primeAtLeast2--- Lemma: primeAtLeast2 Q.E.D.+-- Lemma: primeAtLeast2 Q.E.D. -- Functions proven terminating: ld -- [Proven] primeAtLeast2 :: Ɐp ∷ Integer → Bool primeAtLeast2 :: TP (Proof (Forall "p" Integer -> SBool))@@ -253,11 +253,11 @@ -- -- === __Proof__ -- >>> runTP leastDivisorIsPrime--- Lemma: leastDivisorTwice Q.E.D.--- Cached: leastDivisorDivides Q.E.D.+-- Lemma: leastDivisorTwice Q.E.D.+-- Lemma: leastDivisorDivides Q.E.D. [Cached] -- Lemma: leastDivisorIsPrime--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: ld -- [Proven] leastDivisorIsPrime :: Ɐn ∷ Integer → Bool leastDivisorIsPrime :: TP (Proof (Forall "n" Integer -> SBool))@@ -292,13 +292,13 @@ -- === __Proof__ -- >>> runTP factAtLeast1 -- Inductive lemma: factAtLeast1--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: fact -- [Proven] factAtLeast1 :: Ɐn ∷ Integer → Bool factAtLeast1 :: TP (Proof (Forall "n" Integer -> SBool))@@ -316,17 +316,17 @@ -- -- === __Proof__ -- >>> runTP dividesFact--- Lemma: dividesProduct Q.E.D.+-- Lemma: dividesProduct Q.E.D. -- Inductive lemma: dividesFact--- Step: Base Q.E.D.--- Step: 1 Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D. -- Step: 2 (2 way case split)--- Step: 2.1.1 Q.E.D.--- Step: 2.1.2 Q.E.D.--- Step: 2.2.1 Q.E.D.--- Step: 2.2.2 Q.E.D.--- Step: 2.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 2.1.1 Q.E.D.+-- Step: 2.1.2 Q.E.D.+-- Step: 2.2.1 Q.E.D.+-- Step: 2.2.2 Q.E.D.+-- Step: 2.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: fact -- [Proven] dividesFact :: Ɐn ∷ Integer → Ɐk ∷ Integer → Bool dividesFact :: TP (Proof (Forall "n" Integer -> Forall "k" Integer -> SBool))@@ -353,12 +353,12 @@ -- -- === __Proof__ -- >>> runTP notDividesFactP1--- Lemma: dividesFact Q.E.D.+-- Lemma: dividesFact Q.E.D. -- Lemma: notDividesFactP1--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: fact -- [Proven] notDividesFactP1 :: Ɐn ∷ Integer → Ɐk ∷ Integer → Bool notDividesFactP1 :: TP (Proof (Forall "n" Integer -> Forall "k" Integer -> SBool))@@ -385,13 +385,13 @@ -- -- === __Proof__ -- >>> runTP greaterPrimeDivides--- Lemma: leastDivisorDivides Q.E.D.--- Lemma: factAtLeast1 Q.E.D.+-- Lemma: leastDivisorDivides Q.E.D.+-- Lemma: factAtLeast1 Q.E.D. -- Lemma: greaterPrimeDivides--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: fact, ld -- [Proven] greaterPrimeDivides :: Ɐn ∷ Integer → Bool greaterPrimeDivides :: TP (Proof (Forall "n" Integer -> SBool))@@ -413,19 +413,19 @@ -- -- === __Proof__ -- >>> runTP greaterPrimeGreater--- Lemma: notDividesFactP1 Q.E.D.--- Lemma: greaterPrimeDivides Q.E.D.--- Lemma: leastDivisorIsPrime Q.E.D.--- Cached: factAtLeast1 Q.E.D.--- Lemma: primeAtLeast2 Q.E.D.+-- Lemma: notDividesFactP1 Q.E.D.+-- Lemma: greaterPrimeDivides Q.E.D.+-- Lemma: leastDivisorIsPrime Q.E.D.+-- Lemma: factAtLeast1 Q.E.D. [Cached]+-- Lemma: primeAtLeast2 Q.E.D. -- Lemma: greaterPrimeGreater--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: fact, ld -- [Proven] greaterPrimeGreater :: Ɐn ∷ Integer → Bool greaterPrimeGreater :: TP (Proof (Forall "n" Integer -> SBool))@@ -461,14 +461,14 @@ -- -- === __Proof__ -- >>> runTP infinitudeOfPrimes--- Lemma: leastDivisorIsPrime Q.E.D.--- Lemma: factAtLeast1 Q.E.D.--- Lemma: greaterPrimeGreater Q.E.D.+-- Lemma: leastDivisorIsPrime Q.E.D.+-- Lemma: factAtLeast1 Q.E.D.+-- Lemma: greaterPrimeGreater Q.E.D. -- Lemma: infinitudeOfPrimes--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: fact, ld -- [Proven] infinitudeOfPrimes :: Ɐn ∷ Integer → Bool infinitudeOfPrimes :: TP (Proof (Forall "n" Integer -> SBool))@@ -496,11 +496,11 @@ -- -- === __Proof__ -- >>> runTP noLargestPrime--- Lemma: infinitudeOfPrimes Q.E.D.+-- Lemma: infinitudeOfPrimes Q.E.D. -- Lemma: helper--- Step: 1 Q.E.D.--- Result: Q.E.D.--- Lemma: noLargestPrime Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Lemma: noLargestPrime Q.E.D. -- Functions proven terminating: fact, ld -- [Proven] noLargestPrime :: Ɐn ∷ Integer → ∃p ∷ Integer → Bool noLargestPrime :: TP (Proof (Forall "n" Integer -> Exists "p" Integer -> SBool))
Documentation/SBV/Examples/TP/QuickSort.hs view
@@ -74,14 +74,14 @@ -- -- >>> runTP $ partitionFstBound @Integer -- Inductive lemma (strong): partitionNotLongerFst--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 (simplify) Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 (simplify) Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: partition -- [Proven] partitionNotLongerFst :: Ɐl ∷ [Integer] → Ɐpivot ∷ Integer → Bool partitionFstBound :: forall a. (OrdSymbolic (SBV a), SymVal a) => TP (Proof (Forall "l" [a] -> Forall "pivot" a -> SBool))@@ -109,14 +109,14 @@ -- -- >>> runTP $ partitionSndBound @Integer -- Inductive lemma (strong): partitionNotLongerSnd--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 (simplify) Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 (simplify) Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: partition -- [Proven] partitionNotLongerSnd :: Ɐl ∷ [Integer] → Ɐpivot ∷ Integer → Bool partitionSndBound :: forall a. (OrdSymbolic (SBV a), SymVal a) => TP (Proof (Forall "l" [a] -> Forall "pivot" a -> SBool))@@ -147,155 +147,154 @@ -- -- >>> correctness @Integer -- Inductive lemma: countAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 (unfold count) Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 (simplify) Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 (unfold count) Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 (simplify) Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: countNonNeg--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: countElem--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: elemCount--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: sublistCorrect--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Lemma: sublistElem--- Step: 1 Q.E.D.--- Result: Q.E.D.--- Lemma: sublistTail Q.E.D.--- Lemma: sublistIfPerm Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D.+-- Lemma: sublistTail Q.E.D.+-- Lemma: sublistIfPerm Q.E.D. -- Inductive lemma: lltCorrect--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: lgeCorrect--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: lltSublist--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Lemma: lltPermutation--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: lgeSublist--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Lemma: lgePermutation--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: partitionFstLT--- Step: Base Q.E.D.--- Step: 1 (unroll partition) Q.E.D.--- Step: 2 (push fst down, simplify) Q.E.D.--- Step: 3 (push llt down) Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 (unroll partition) Q.E.D.+-- Step: 2 (push fst down, simplify) Q.E.D.+-- Step: 3 (push llt down) Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: partitionSndGE--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 (push lge down) Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.--- Lemma: partitionNotLongerFst Q.E.D.--- Lemma: partitionNotLongerSnd Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 (push lge down) Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: partitionNotLongerFst Q.E.D.+-- Lemma: partitionNotLongerSnd Q.E.D. -- Inductive lemma: countPartition--- Step: Base Q.E.D.--- Step: 1 (expand partition) Q.E.D.--- Step: 2 (push countTuple down) Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 (expand partition) Q.E.D.+-- Step: 2 (push countTuple down) Q.E.D. -- Step: 3 (2 way case split)--- Step: 3.1.1 Q.E.D.--- Step: 3.1.2 (simplify) Q.E.D.--- Step: 3.1.3 Q.E.D.--- Step: 3.2.1 Q.E.D.--- Step: 3.2.2 (simplify) Q.E.D.--- Step: 3.2.3 Q.E.D.--- Step: 3.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 3.1.1 Q.E.D.+-- Step: 3.1.2 (simplify) Q.E.D.+-- Step: 3.1.3 Q.E.D.+-- Step: 3.2.1 Q.E.D.+-- Step: 3.2.2 (simplify) Q.E.D.+-- Step: 3.2.3 Q.E.D.+-- Step: 3.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): sortCountsMatch--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 (expand quickSort) Q.E.D.--- Step: 1.2.3 (push count down) Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.2.5 Q.E.D.--- Step: 1.2.6 (IH on lo) Q.E.D.--- Step: 1.2.7 (IH on hi) Q.E.D.--- Step: 1.2.8 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.--- Lemma: sortIsPermutation Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 (expand quickSort) Q.E.D.+-- Step: 1.2.3 (push count down) Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.2.5 Q.E.D.+-- Step: 1.2.6 (IH on lo) Q.E.D.+-- Step: 1.2.7 (IH on hi) Q.E.D.+-- Step: 1.2.8 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: sortIsPermutation Q.E.D. -- Inductive lemma: nonDecreasingMerge--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.2.5 Q.E.D.--- Step: 1.2.6 Q.E.D.--- Step: 1.2.7 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.2.5 Q.E.D.+-- Step: 1.2.6 Q.E.D.+-- Step: 1.2.7 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): sortIsNonDecreasing--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 (expand quickSort) Q.E.D.--- Step: 1.2.3 (push nonDecreasing down) Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.--- Lemma: quickSortIsCorrect Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 (expand quickSort) Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: quickSortIsCorrect Q.E.D. -- Inductive lemma: partitionSortedLeft--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: partitionSortedRight--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: unchangedIfNondecreasing--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.--- Lemma: ifChangedThenUnsorted Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D.+-- Lemma: ifChangedThenUnsorted Q.E.D. -- == Proof tree: -- quickSortIsCorrect -- ├╴sortIsPermutation@@ -330,7 +329,7 @@ -- Functions proven terminating: count, lge, llt, nonDecreasing, partition, quickSort -- [Proven] quickSortIsCorrect :: Ɐxs ∷ [Integer] → Bool correctness :: forall a. (Eq a, OrdSymbolic (SBV a), SymVal a) => IO (Proof (Forall "xs" [a] -> SBool))-correctness = runTPWith (tpRibbon 60 z3) $ do+correctness = runTP $ do -------------------------------------------------------------------------------------------- -- Part I. Import helper lemmas, definitions@@ -538,28 +537,27 @@ =: [pCase| xs of [] -> trivial whole@(a : as) ->- count e (quickSort whole)- ?? "expand quickSort"- =: count e (case partition a as of- (lo, hi) -> quickSort lo ++ [a] ++ quickSort hi)- ?? "push count down"- =: case partition a as of- (lo, hi) -> count e (quickSort lo ++ [a] ++ quickSort hi)- ?? countAppend `at` (Inst @"xs" (quickSort lo), Inst @"ys" ([a] ++ quickSort hi), Inst @"e" e)- =: count e (quickSort lo) + count e ([a] ++ quickSort hi)- ?? countAppend `at` (Inst @"xs" [a], Inst @"ys" (quickSort hi), Inst @"e" e)- =: count e (quickSort lo) + count e [a] + count e (quickSort hi)- ?? ih `at` (Inst @"xs" lo, Inst @"e" e)- ?? partitionNotLongerFst `at` (Inst @"l" as, Inst @"pivot" a)- ?? "IH on lo"- =: count e lo + count e [a] + count e (quickSort hi)- ?? ih `at` (Inst @"xs" hi, Inst @"e" e)- ?? partitionNotLongerSnd `at` (Inst @"l" as, Inst @"pivot" a)- ?? "IH on hi"- =: count e lo + count e [a] + count e hi- ?? countPartition `at` (Inst @"xs" as, Inst @"pivot" a, Inst @"e" e)- =: count e xs- =: qed+ let (lo, hi) = untuple (partition a as)+ in count e (quickSort whole)+ ?? "expand quickSort"+ =: count e (quickSort lo ++ [a] ++ quickSort hi)+ ?? "push count down"+ =: count e (quickSort lo ++ [a] ++ quickSort hi)+ ?? countAppend `at` (Inst @"xs" (quickSort lo), Inst @"ys" ([a] ++ quickSort hi), Inst @"e" e)+ =: count e (quickSort lo) + count e ([a] ++ quickSort hi)+ ?? countAppend `at` (Inst @"xs" [a], Inst @"ys" (quickSort hi), Inst @"e" e)+ =: count e (quickSort lo) + count e [a] + count e (quickSort hi)+ ?? ih `at` (Inst @"xs" lo, Inst @"e" e)+ ?? partitionNotLongerFst `at` (Inst @"l" as, Inst @"pivot" a)+ ?? "IH on lo"+ =: count e lo + count e [a] + count e (quickSort hi)+ ?? ih `at` (Inst @"xs" hi, Inst @"e" e)+ ?? partitionNotLongerSnd `at` (Inst @"l" as, Inst @"pivot" a)+ ?? "IH on hi"+ =: count e lo + count e [a] + count e hi+ ?? countPartition `at` (Inst @"xs" as, Inst @"pivot" a, Inst @"e" e)+ =: count e xs+ =: qed |] sortIsPermutation <- lemma "sortIsPermutation" (\(Forall xs) -> isPermutation xs (quickSort xs)) [proofOf sortCountsMatch]@@ -603,37 +601,34 @@ =: [pCase| xs of [] -> trivial whole@(a : as) ->- nonDecreasing (quickSort whole)+ let (lo, hi) = untuple (partition a as)+ in nonDecreasing (quickSort whole) ?? "expand quickSort"- =: nonDecreasing (case partition a as of- (lo, hi) -> quickSort lo ++ [a] ++ quickSort hi)- ?? "push nonDecreasing down"- =: case partition a as of- (lo, hi) -> nonDecreasing (quickSort lo ++ [a] ++ quickSort hi)- -- Deduce that lo/hi is not longer than as, and hence, shorter than xs- ?? partitionNotLongerFst `at` (Inst @"l" as, Inst @"pivot" a)- ?? partitionNotLongerSnd `at` (Inst @"l" as, Inst @"pivot" a)+ =: nonDecreasing (quickSort lo ++ [a] ++ quickSort hi)+ -- Deduce that lo/hi is not longer than as, and hence, shorter than xs+ ?? partitionNotLongerFst `at` (Inst @"l" as, Inst @"pivot" a)+ ?? partitionNotLongerSnd `at` (Inst @"l" as, Inst @"pivot" a) - -- Use the inductive hypothesis twice to deduce quickSort of lo and hi are nonDecreasing- ?? ih `at` Inst @"xs" lo -- nonDecreasing (quickSort lo)- ?? ih `at` Inst @"xs" hi -- nonDecreasing (quickSort hi)+ -- Use the inductive hypothesis twice to deduce quickSort of lo and hi are nonDecreasing+ ?? ih `at` Inst @"xs" lo -- nonDecreasing (quickSort lo)+ ?? ih `at` Inst @"xs" hi -- nonDecreasing (quickSort hi) - -- Deduce that lo is all less than a, and hi is all greater than or equal to a- ?? partitionFstLT `at` (Inst @"l" as, Inst @"pivot" a)- ?? partitionSndGE `at` (Inst @"l" as, Inst @"pivot" a)+ -- Deduce that lo is all less than a, and hi is all greater than or equal to a+ ?? partitionFstLT `at` (Inst @"l" as, Inst @"pivot" a)+ ?? partitionSndGE `at` (Inst @"l" as, Inst @"pivot" a) - -- Deduce that quickSort lo is all less than a- ?? sortIsPermutation `at` Inst @"xs" lo- ?? lltPermutation `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" lo)+ -- Deduce that quickSort lo is all less than a+ ?? sortIsPermutation `at` Inst @"xs" lo+ ?? lltPermutation `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" lo) - -- Deduce that quickSort hi is all greater than or equal to a- ?? sortIsPermutation `at` Inst @"xs" hi- ?? lgePermutation `at` (Inst @"xs" (quickSort hi), Inst @"pivot" a, Inst @"ys" hi)+ -- Deduce that quickSort hi is all greater than or equal to a+ ?? sortIsPermutation `at` Inst @"xs" hi+ ?? lgePermutation `at` (Inst @"xs" (quickSort hi), Inst @"pivot" a, Inst @"ys" hi) - -- Finally conclude that the whole reconstruction is non-decreasing- ?? nonDecreasingMerge `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" (quickSort hi))- =: sTrue- =: qed+ -- Finally conclude that the whole reconstruction is non-decreasing+ ?? nonDecreasingMerge `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" (quickSort hi))+ =: sTrue+ =: qed |] --------------------------------------------------------------------------------------------@@ -691,10 +686,12 @@ [proofOf unchangedIfNondecreasing] --------------------------------------------------------------------------------------------- -- | We can display the dependencies in a proof+ -- We can display the dependencies in a proof.+ -- Note that we do avoid doing this during the+ -- dry-run of the proof to avoid duplicate output. --------------------------------------------------------------------------------------------- liftIO $ do putStrLn "== Proof tree:"- putStr $ showProofTree True qs+ unlessDryRun $ liftIO $ do putStrLn "== Proof tree:"+ putStr $ showProofTree True qs pure qs
Documentation/SBV/Examples/TP/RevAcc.hs view
@@ -52,13 +52,13 @@ -- -- >>> correctness @Integer -- Inductive lemma: revAccCorrect--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.--- Lemma: revCorrect Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D.+-- Lemma: revCorrect Q.E.D. -- Functions proven terminating: revAcc, sbv.reverse -- [Proven] revCorrect :: Ɐxs ∷ [Integer] → Bool correctness :: forall a. SymVal a => IO (Proof (Forall "xs" [a] -> SBool))
Documentation/SBV/Examples/TP/Reverse.hs view
@@ -60,15 +60,15 @@ -- -- >>> runTP $ revPreservesLen @Integer -- Inductive lemma (strong): revPreservesLen--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3.1 Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: rev -- [Proven] revPreservesLen :: Ɐxs ∷ [Integer] → Bool revPreservesLen :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool))
Documentation/SBV/Examples/TP/ShefferStroke.hs view
@@ -142,195 +142,195 @@ -- Axiom: a ⏐ (b ⏐ ﬧb) == ﬧa -- Axiom: ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a) -- Lemma: a | b = b | a--- Step: 1 (ﬧﬧa == a) Q.E.D.--- Step: 2 (ﬧﬧa == a) Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 (ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a)) Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 (ﬧﬧa == a) Q.E.D.--- Step: 7 (ﬧﬧa == a) Q.E.D.--- Result: Q.E.D.+-- Step: 1 (ﬧﬧa == a) Q.E.D.+-- Step: 2 (ﬧﬧa == a) Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 (ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a)) Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 (ﬧﬧa == a) Q.E.D.+-- Step: 7 (ﬧﬧa == a) Q.E.D.+-- Result: Q.E.D. -- Lemma: a | a′ = b | b′--- Step: 1 (ﬧﬧa == a) Q.E.D.--- Step: 2 (a ⏐ (b ⏐ ﬧb) == ﬧa) Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 (a ⏐ (b ⏐ ﬧb) == ﬧa) Q.E.D.--- Step: 5 (ﬧﬧa == a) Q.E.D.--- Result: Q.E.D.--- Lemma: a ⊔ b = b ⊔ a Q.E.D.--- Lemma: a ⊓ b = b ⊓ a Q.E.D.--- Lemma: a ⊔ ⲳ = a Q.E.D.--- Lemma: a ⊓ т = a Q.E.D.--- Lemma: a ⊔ (b ⊓ c) = (a ⊔ b) ⊓ (a ⊔ c) Q.E.D.--- Lemma: a ⊓ (b ⊔ c) = (a ⊓ b) ⊔ (a ⊓ c) Q.E.D.--- Lemma: a ⊔ aᶜ = т Q.E.D.--- Lemma: a ⊓ aᶜ = ⲳ Q.E.D.+-- Step: 1 (ﬧﬧa == a) Q.E.D.+-- Step: 2 (a ⏐ (b ⏐ ﬧb) == ﬧa) Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 (a ⏐ (b ⏐ ﬧb) == ﬧa) Q.E.D.+-- Step: 5 (ﬧﬧa == a) Q.E.D.+-- Result: Q.E.D.+-- Lemma: a ⊔ b = b ⊔ a Q.E.D.+-- Lemma: a ⊓ b = b ⊓ a Q.E.D.+-- Lemma: a ⊔ ⲳ = a Q.E.D.+-- Lemma: a ⊓ т = a Q.E.D.+-- Lemma: a ⊔ (b ⊓ c) = (a ⊔ b) ⊓ (a ⊔ c) Q.E.D.+-- Lemma: a ⊓ (b ⊔ c) = (a ⊓ b) ⊔ (a ⊓ c) Q.E.D.+-- Lemma: a ⊔ aᶜ = т Q.E.D.+-- Lemma: a ⊓ aᶜ = ⲳ Q.E.D. -- Lemma: a ⊔ т = т--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Lemma: a ⊓ ⲳ = ⲳ--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Lemma: a ⊔ (a ⊓ b) = a--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Lemma: a ⊓ (a ⊔ b) = a--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Lemma: a ⊓ a = a--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Lemma: a ⊔ a' = т → a ⊓ a' = ⲳ → a' = aᶜ--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Step: 8 Q.E.D.--- Step: 9 Q.E.D.--- Step: 10 Q.E.D.--- Step: 11 Q.E.D.--- Result: Q.E.D.--- Lemma: aᶜᶜ = a Q.E.D.--- Lemma: aᶜ = bᶜ → a = b Q.E.D.--- Lemma: a ⊔ bᶜ = т → a ⊓ bᶜ = ⲳ → a = b Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Step: 8 Q.E.D.+-- Step: 9 Q.E.D.+-- Step: 10 Q.E.D.+-- Step: 11 Q.E.D.+-- Result: Q.E.D.+-- Lemma: aᶜᶜ = a Q.E.D.+-- Lemma: aᶜ = bᶜ → a = b Q.E.D.+-- Lemma: a ⊔ bᶜ = т → a ⊓ bᶜ = ⲳ → a = b Q.E.D. -- Lemma: a ⊔ (aᶜ ⊔ b) = т--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Lemma: a ⊓ (aᶜ ⊓ b) = ⲳ--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.--- Lemma: (a ⊔ b)ᶜ = aᶜ ⊓ bᶜ Q.E.D.--- Lemma: (a ⨅ b)ᶜ = aᶜ ⨆ bᶜ Q.E.D.--- Lemma: (a ⊔ (b ⊔ c)) ⊔ aᶜ = т Q.E.D.--- Lemma: b ⊓ (a ⊔ (b ⊔ c)) = b Q.E.D.--- Lemma: b ⊔ (a ⊓ (b ⊓ c)) = b Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D.+-- Lemma: (a ⊔ b)ᶜ = aᶜ ⊓ bᶜ Q.E.D.+-- Lemma: (a ⨅ b)ᶜ = aᶜ ⨆ bᶜ Q.E.D.+-- Lemma: (a ⊔ (b ⊔ c)) ⊔ aᶜ = т Q.E.D.+-- Lemma: b ⊓ (a ⊔ (b ⊔ c)) = b Q.E.D.+-- Lemma: b ⊔ (a ⊓ (b ⊓ c)) = b Q.E.D. -- Lemma: (a ⊔ (b ⊔ c)) ⊔ bᶜ = т--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Step: 8 Q.E.D.--- Step: 9 Q.E.D.--- Result: Q.E.D.--- Lemma: (a ⊔ (b ⊔ c)) ⊔ cᶜ = т Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Step: 8 Q.E.D.+-- Step: 9 Q.E.D.+-- Result: Q.E.D.+-- Lemma: (a ⊔ (b ⊔ c)) ⊔ cᶜ = т Q.E.D. -- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ a = ⲳ--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Step: 8 Q.E.D.--- Step: 9 Q.E.D.--- Result: Q.E.D.--- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ b = ⲳ Q.E.D.--- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ c = ⲳ Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Step: 8 Q.E.D.+-- Step: 9 Q.E.D.+-- Result: Q.E.D.+-- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ b = ⲳ Q.E.D.+-- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ c = ⲳ Q.E.D. -- Lemma: (a ⊔ (b ⊔ c)) ⊔ ((a ⊔ b) ⊔ c)ᶜ = т--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Step: 8 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Step: 8 Q.E.D.+-- Result: Q.E.D. -- Lemma: (a ⊔ (b ⊔ c)) ⊓ ((a ⊔ b) ⊔ c)ᶜ = ⲳ--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Step: 8 Q.E.D.--- Step: 9 Q.E.D.--- Step: 10 Q.E.D.--- Step: 11 Q.E.D.--- Step: 12 Q.E.D.--- Result: Q.E.D.--- Lemma: a ⊔ (b ⊔ c) = (a ⊔ b) ⊔ c Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Step: 8 Q.E.D.+-- Step: 9 Q.E.D.+-- Step: 10 Q.E.D.+-- Step: 11 Q.E.D.+-- Step: 12 Q.E.D.+-- Result: Q.E.D.+-- Lemma: a ⊔ (b ⊔ c) = (a ⊔ b) ⊔ c Q.E.D. -- Lemma: a ⊓ (b ⊓ c) = (a ⊓ b) ⊓ c--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: a ≤ b → b ≤ a → a = b--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.--- Lemma: a ≤ a Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: a ≤ a Q.E.D. -- Lemma: a ≤ b → b ≤ c → a ≤ c--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.--- Lemma: a < b ↔ a ≤ b ∧ ¬b ≤ a Q.E.D.--- Lemma: a ≤ a ⊔ b Q.E.D.--- Lemma: b ≤ a ⊔ b Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D.+-- Lemma: a < b ↔ a ≤ b ∧ ¬b ≤ a Q.E.D.+-- Lemma: a ≤ a ⊔ b Q.E.D.+-- Lemma: b ≤ a ⊔ b Q.E.D. -- Lemma: a ≤ c → b ≤ c → a ⊔ b ≤ c--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.--- Lemma: a ⊓ b ≤ a Q.E.D.--- Lemma: a ⊓ b ≤ b Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Lemma: a ⊓ b ≤ a Q.E.D.+-- Lemma: a ⊓ b ≤ b Q.E.D. -- Lemma: a ≤ b → a ≤ c → a ≤ b ⊓ c--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.--- Lemma: (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z Q.E.D.--- Lemma: x ⊓ xᶜ ≤ ⊥ Q.E.D.--- Lemma: ⊤ ≤ x ⊔ xᶜ Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z Q.E.D.+-- Lemma: x ⊓ xᶜ ≤ ⊥ Q.E.D.+-- Lemma: ⊤ ≤ x ⊔ xᶜ Q.E.D. -- Lemma: a ≤ ⊤--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Lemma: ⊥ ≤ a--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.--- Lemma: x \ y = x ⊓ yᶜ Q.E.D.--- Lemma: x ⇨ y = y ⊔ xᶜ Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Lemma: x \ y = x ⊓ yᶜ Q.E.D.+-- Lemma: x ⇨ y = y ⊔ xᶜ Q.E.D. -- BooleanAlgebraProof { -- le_refl : [Proven] a ≤ a :: Ɐa ∷ Stroke → Bool -- le_trans : [Proven] a ≤ b → b ≤ c → a ≤ c :: Ɐa ∷ Stroke → Ɐb ∷ Stroke → Ɐc ∷ Stroke → Bool@@ -351,7 +351,7 @@ -- himp_eq : [Proven] x ⇨ y = y ⊔ xᶜ :: Ɐx ∷ Stroke → Ɐy ∷ Stroke → Bool -- } shefferBooleanAlgebra :: IO BooleanAlgebraProof-shefferBooleanAlgebra = runTPWith (tpRibbon 60 z3) $ do+shefferBooleanAlgebra = runTP $ do -- shorthand let p = proofOf
Documentation/SBV/Examples/TP/SortHelpers.hs view
@@ -50,7 +50,7 @@ -- | The tail of a non-decreasing list is non-decreasing. We have: -- -- >>> runTP $ nonDecrTail @Integer--- Lemma: nonDecrTail Q.E.D.+-- Lemma: nonDecrTail Q.E.D. -- Functions proven terminating: nonDecreasing -- [Proven] nonDecrTail :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool nonDecrTail :: forall a. (OrdSymbolic (SBV a), SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool))@@ -61,7 +61,7 @@ -- | If we insert an element that is less than the head of a nonDecreasing list, it remains nondecreasing. We have: -- -- >>> runTP $ nonDecrIns @Integer--- Lemma: nonDecrInsert Q.E.D.+-- Lemma: nonDecrInsert Q.E.D. -- Functions proven terminating: nonDecreasing -- [Proven] nonDecrInsert :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool nonDecrIns :: forall a. (OrdSymbolic (SBV a), SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool))@@ -77,34 +77,34 @@ -- -- >>> runTP $ sublistCorrect @Integer -- Inductive lemma: countNonNeg--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: countElem--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: elemCount--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: sublistCorrect--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] sublistCorrect :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐx ∷ Integer → Bool sublistCorrect :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> Forall "x" a -> SBool))@@ -126,37 +126,37 @@ -- -- >>> runTP $ sublistElem @Integer -- Inductive lemma: countNonNeg--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: countElem--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: elemCount--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: sublistCorrect--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Lemma: sublistElem--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] sublistElem :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool sublistElem :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> Forall "ys" [a] -> SBool))@@ -174,7 +174,7 @@ -- | If one list is a sublist of another so is its tail. We have: -- -- >>> runTP $ sublistTail @Integer--- Lemma: sublistTail Q.E.D.+-- Lemma: sublistTail Q.E.D. -- Functions proven terminating: count -- [Proven] sublistTail :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool sublistTail :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> Forall "ys" [a] -> SBool))@@ -186,7 +186,7 @@ -- | Permutation implies sublist. We have: -- -- >>> runTP $ sublistIfPerm @Integer--- Lemma: sublistIfPerm Q.E.D.+-- Lemma: sublistIfPerm Q.E.D. -- Functions proven terminating: count -- [Proven] sublistIfPerm :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool sublistIfPerm :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool))
Documentation/SBV/Examples/TP/Sqrt2IsIrrational.hs view
@@ -48,15 +48,15 @@ -- -- >>> sqrt2IsIrrational -- Lemma: oddSquaredIsOdd--- Step: 1 Q.E.D.--- Step: 2 (expand square) Q.E.D.--- Result: Q.E.D.--- Lemma: squareEvenImpliesEven Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 (expand square) Q.E.D.+-- Result: Q.E.D.+-- Lemma: squareEvenImpliesEven Q.E.D. -- Lemma: evenSquaredIsMult4--- Step: 1 Q.E.D.--- Step: 2 (expand square) Q.E.D.--- Result: Q.E.D.--- Lemma: sqrt2IsIrrational Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 (expand square) Q.E.D.+-- Result: Q.E.D.+-- Lemma: sqrt2IsIrrational Q.E.D. -- [Proven] sqrt2IsIrrational :: Bool sqrt2IsIrrational :: IO (Proof SBool) sqrt2IsIrrational = runTP $ do
Documentation/SBV/Examples/TP/StrongInduction.hs view
@@ -40,15 +40,15 @@ -- -- >>> oddSequence1 -- Inductive lemma (strong): oddSequence1--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3.1 Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: seq -- [Proven] oddSequence1 :: Ɐn ∷ Integer → Bool oddSequence1 :: IO (Proof (Forall "n" Integer -> SBool))@@ -81,29 +81,29 @@ -- We have: -- -- >>> oddSequence2--- Lemma: oddSequence_0 Q.E.D.--- Lemma: oddSequence_1 Q.E.D.+-- Lemma: oddSequence_0 Q.E.D.+-- Lemma: oddSequence_1 Q.E.D. -- Inductive lemma (strong): oddSequence_sNp2--- Step: Measure is non-negative Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 (simplify) Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 (simplify) Q.E.D.--- Step: 6 Q.E.D.--- Result: Q.E.D.+-- Step: Measure is non-negative Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 (simplify) Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 (simplify) Q.E.D.+-- Step: 6 Q.E.D.+-- Result: Q.E.D. -- Lemma: oddSequence2 -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3.1 Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: seq -- [Proven] oddSequence2 :: Ɐn ∷ Integer → Bool oddSequence2 :: IO (Proof (Forall "n" Integer -> SBool))-oddSequence2 = runTPWith (tpRibbon 50 z3) $ do+oddSequence2 = runTP $ do let s :: SInteger -> SInteger s = smtFunction "seq" $ \n -> [sCase| n of@@ -180,7 +180,7 @@ -- -- >>> won'tProve2 `catch` (\(_ :: SomeException) -> pure ()) -- Inductive lemma (strong): badLength--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 -- *** Failed to prove badLength.1. -- Falsifiable. Counter-example:@@ -271,24 +271,24 @@ -- -- >>> sumHalves -- Inductive lemma: sumAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma (strong): sumHalves--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3.1 Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.3.4 Q.E.D.--- Step: 1.3.5 Q.E.D.--- Step: 1.3.6 (simplify) Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.3.6 (simplify) Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: halvingSum, sbv.foldr -- [Proven] sumHalves :: Ɐxs ∷ [Integer] → Bool sumHalves :: IO (Proof (Forall "xs" [Integer] -> SBool))
Documentation/SBV/Examples/TP/SumReverse.hs view
@@ -37,21 +37,21 @@ -- -- >>> revSum @Integer -- Inductive lemma: sumAppend--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 (associativity) Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 (associativity) Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Inductive lemma: sumReverse--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 (commutativity) Q.E.D.--- Step: 5 Q.E.D.--- Result: Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 (commutativity) Q.E.D.+-- Step: 5 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr, sbv.reverse -- [Proven] sumReverse :: Ɐxs ∷ [Integer] → Bool revSum :: forall a. (SymVal a, Num (SBV a)) => IO (Proof (Forall "xs" [a] -> SBool))
Documentation/SBV/Examples/TP/Tao.hs view
@@ -49,7 +49,7 @@ -- We have: -- -- >>> tao @T (uninterpret "op")--- Lemma: tao Q.E.D.+-- Lemma: tao Q.E.D. -- [Proven] tao :: Bool tao :: forall a. SymVal a => (SBV a -> SBV a -> SBV a) -> IO (Proof SBool) tao op = runTP $
Documentation/SBV/Examples/TP/TautologyChecker.hs view
@@ -69,7 +69,7 @@ -- | \(\mathit{ifDepth}(f) \geq 0\) -- -- >>> runTP ifDepthNonNeg--- Lemma: ifDepthNonNeg Q.E.D.+-- Lemma: ifDepthNonNeg Q.E.D. -- Functions proven terminating: ifDepth -- [Proven] ifDepthNonNeg :: Ɐf ∷ Formula → Bool ifDepthNonNeg :: TP (Proof (Forall "f" Formula -> SBool))@@ -86,7 +86,7 @@ -- | \(\mathit{ifComplexity}(f) > 0\) -- -- >>> runTP ifComplexityPos--- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexityPos Q.E.D. -- Functions proven terminating: ifComplexity -- [Proven] ifComplexityPos :: Ɐf ∷ Formula → Bool ifComplexityPos :: TP (Proof (Forall "f" Formula -> SBool))@@ -97,10 +97,10 @@ -- \(\mathit{ifComplexity}(c) < \mathit{ifComplexity}(\mathit{If}(c, l, r)) \land \mathit{ifComplexity}(l) < \mathit{ifComplexity}(\mathit{If}(c, l, r)) \land \mathit{ifComplexity}(r) < \mathit{ifComplexity}(\mathit{If}(c, l, r))\) -- -- >>> runTP ifComplexitySmaller--- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexityPos Q.E.D. -- Lemma: ifComplexitySmaller--- Step: 1 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: ifComplexity -- [Proven] ifComplexitySmaller :: Ɐc ∷ Formula → Ɐl ∷ Formula → Ɐr ∷ Formula → Bool ifComplexitySmaller :: TP (Proof (Forall "c" Formula -> Forall "l" Formula -> Forall "r" Formula -> SBool))@@ -164,16 +164,16 @@ -- \(\mathit{ifComplexity}(\mathit{If}(p, \mathit{If}(q, l, r), \mathit{If}(s, l, r))) = \mathit{ifComplexity}(\mathit{If}(\mathit{If}(p, q, s), l, r))\) -- -- >>> runTP normalizePreservesComplexity--- Lemma: helper Q.E.D.+-- Lemma: helper Q.E.D. -- Lemma: normalizePreservesComplexity--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Step: 5 Q.E.D.--- Step: 6 Q.E.D.--- Step: 7 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Step: 5 Q.E.D.+-- Step: 6 Q.E.D.+-- Step: 7 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: ifComplexity -- [Proven] normalizePreservesComplexity :: Ɐp ∷ Formula → Ɐq ∷ Formula → Ɐs ∷ Formula → Ɐl ∷ Formula → Ɐr ∷ Formula → Bool normalizePreservesComplexity :: TP (Proof (Forall "p" Formula -> Forall "q" Formula -> Forall "s" Formula -> Forall "l" Formula -> Forall "r" Formula -> SBool))@@ -244,7 +244,7 @@ -- | Adding a binding preserves existing assignments. -- -- >>> runTP isAssignedExtends--- Lemma: isAssignedExtends Q.E.D.+-- Lemma: isAssignedExtends Q.E.D. -- Functions proven terminating: isAssigned -- [Proven] isAssignedExtends :: Ɐi ∷ Integer → Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool isAssignedExtends :: TP (Proof (Forall "i" Integer -> Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool))@@ -255,7 +255,7 @@ -- | Looking up a variable in extended bindings: if already assigned, value is preserved. -- -- >>> runTP lookUpExtends--- Lemma: lookUpExtends Q.E.D.+-- Lemma: lookUpExtends Q.E.D. -- Functions proven terminating: isAssigned, lookUp -- [Proven] lookUpExtends :: Ɐi ∷ Integer → Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool lookUpExtends :: TP (Proof (Forall "i" Integer -> Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool))@@ -267,7 +267,7 @@ -- | Looking up a variable that was just added returns the added value. -- -- >>> runTP lookUpSame--- Lemma: lookUpSame Q.E.D.+-- Lemma: lookUpSame Q.E.D. -- Functions proven terminating: lookUp -- [Proven] lookUpSame :: Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool lookUpSame :: TP (Proof (Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool))@@ -276,7 +276,7 @@ -- | Adding a binding for a variable makes it assigned. -- -- >>> runTP isAssignedSame--- Lemma: isAssignedSame Q.E.D.+-- Lemma: isAssignedSame Q.E.D. -- Functions proven terminating: isAssigned -- [Proven] isAssignedSame :: Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool isAssignedSame :: TP (Proof (Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool))@@ -338,14 +338,14 @@ -- -- >>> runTP lookUpStable -- Inductive lemma: lookUpStable--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: isAssigned, lookUp -- [Proven] lookUpStable :: Ɐa ∷ [Binding] → Ɐx ∷ Integer → Ɐb ∷ [Binding] → Bool lookUpStable :: TP (Proof (Forall "a" [Binding] -> Forall "x" Integer -> Forall "b" [Binding] -> SBool))@@ -369,13 +369,13 @@ -- -- >>> runTP trueIsAssigned -- Inductive lemma: trueIsAssigned--- Step: Base Q.E.D.+-- Step: Base Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: isAssigned, lookUp -- [Proven] trueIsAssigned :: Ɐa ∷ [Binding] → Ɐx ∷ Integer → Bool trueIsAssigned :: TP (Proof (Forall "a" [Binding] -> Forall "x" Integer -> SBool))@@ -453,7 +453,7 @@ -- | Key soundness lemma: If a normalized formula is a tautology under bindings @b@, -- then it evaluates to true under @b ++ a@ for any @a@. ----- >>> runTPWith (tpRibbon 50 cvc5) tautologyImpliesEval+-- >>> runTPWith cvc5 tautologyImpliesEval -- Lemma: ifComplexityPos Q.E.D. -- Lemma: ifComplexitySmaller Q.E.D. -- Lemma: lookUpStable Q.E.D.@@ -605,28 +605,28 @@ -- -- Normalization produces normalized formulas. ----- >>> runTPWith (tpRibbon 50 z3) normalizeCorrect--- Lemma: ifComplexityPos Q.E.D.--- Lemma: ifComplexitySmaller Q.E.D.--- Lemma: normalizePreservesComplexity Q.E.D.--- Lemma: ifDepthNonNeg Q.E.D.+-- >>> runTP normalizeCorrect+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Lemma: normalizePreservesComplexity Q.E.D.+-- Lemma: ifDepthNonNeg Q.E.D. -- Inductive lemma (strong): normalizeCorrect--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3 Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D. -- Step: 1.4 (2 way case split)--- Step: 1.4.1.1 Q.E.D.--- Step: 1.4.1.2 Q.E.D.--- Step: 1.4.2.1 Q.E.D.--- Step: 1.4.2.2 Q.E.D.--- Step: 1.4.2.3 Q.E.D.--- Step: 1.4.2.4 Q.E.D.--- Step: 1.4.2.5 Q.E.D.--- Step: 1.4.Completeness Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.4.1.1 Q.E.D.+-- Step: 1.4.1.2 Q.E.D.+-- Step: 1.4.2.1 Q.E.D.+-- Step: 1.4.2.2 Q.E.D.+-- Step: 1.4.2.3 Q.E.D.+-- Step: 1.4.2.4 Q.E.D.+-- Step: 1.4.2.5 Q.E.D.+-- Step: 1.4.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: ifComplexity, ifDepth, isNormal, normalize -- [Proven] normalizeCorrect :: Ɐf ∷ Formula → Bool normalizeCorrect :: TP (Proof (Forall "f" Formula -> SBool))@@ -675,19 +675,19 @@ -- -- Normalizing a normalized formula is the identity. ----- >>> runTPWith (tpRibbon 50 z3) normalizeSame--- Lemma: ifComplexityPos Q.E.D.--- Lemma: ifComplexitySmaller Q.E.D.+-- >>> runTP normalizeSame+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D. -- Inductive lemma (strong): normalizeSame--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3 Q.E.D.--- Step: 1.4.1 Q.E.D.--- Step: 1.4.2 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.4.1 Q.E.D.+-- Step: 1.4.2 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: ifComplexity, isNormal, normalize -- [Proven] normalizeSame :: Ɐf ∷ Formula → Bool normalizeSame :: TP (Proof (Forall "f" Formula -> SBool))@@ -719,25 +719,25 @@ -- -- Normalization preserves semantics. ----- >>> runTPWith (tpRibbon 50 z3) normalizeRespectsTruth--- Lemma: ifComplexityPos Q.E.D.--- Lemma: ifComplexitySmaller Q.E.D.--- Lemma: normalizePreservesComplexity Q.E.D.--- Lemma: ifDepthNonNeg Q.E.D.+-- >>> runTP normalizeRespectsTruth+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Lemma: normalizePreservesComplexity Q.E.D.+-- Lemma: ifDepthNonNeg Q.E.D. -- Inductive lemma (strong): normalizeRespectsTruth--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3 Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D. -- Step: 1.4 (2 way case split)--- Step: 1.4.1 Q.E.D.--- Step: 1.4.2.1 Q.E.D.--- Step: 1.4.2.2 Q.E.D.--- Step: 1.4.2.3 Q.E.D.--- Step: 1.4.Completeness Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.4.1 Q.E.D.+-- Step: 1.4.2.1 Q.E.D.+-- Step: 1.4.2.2 Q.E.D.+-- Step: 1.4.2.3 Q.E.D.+-- Step: 1.4.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: eval, ifComplexity, ifDepth, lookUp, normalize -- [Proven] normalizeRespectsTruth :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Bool normalizeRespectsTruth :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> SBool))@@ -787,13 +787,13 @@ -- to true under any binding environment. This is the soundness theorem. -- -- >>> runTP soundness--- Lemma: tautologyImpliesEval Q.E.D.--- Lemma: normalizeRespectsTruth Q.E.D.--- Lemma: normalizeCorrect Q.E.D.+-- Lemma: tautologyImpliesEval Q.E.D.+-- Lemma: normalizeRespectsTruth Q.E.D.+-- Lemma: normalizeCorrect Q.E.D. -- Lemma: soundness--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: eval, ifComplexity, ifDepth, isAssigned, isNormal, isTautology', lookUp, normalize -- [Proven] soundness :: Ɐf ∷ Formula → Ɐbindings ∷ [Binding] → Bool soundness :: TP (Proof (Forall "f" Formula -> Forall "bindings" [Binding] -> SBool))@@ -856,18 +856,18 @@ -- | If a normalized formula is not a tautology, then falsify' returns falsified = true. ----- >>> runTPWith (tpRibbon 50 cvc5) nonTautIsFalsified--- Lemma: ifComplexityPos Q.E.D.--- Lemma: ifComplexitySmaller Q.E.D.+-- >>> runTPWith cvc5 nonTautIsFalsified+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D. -- Inductive lemma (strong): nonTautIsFalsified--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3 Q.E.D.--- Step: 1.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: eval, falsify', ifComplexity, isAssigned, isNormal, isTautology', lookUp -- [Proven] nonTautIsFalsified :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Bool nonTautIsFalsified :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> SBool))@@ -898,20 +898,20 @@ -- | If a variable is assigned in the input bindings and falsify' succeeds, -- the lookup value is preserved in the output bindings. ----- >>> runTPWith (tpRibbon 50 cvc5) falsifyExtendsBindings--- Lemma: ifComplexityPos Q.E.D.--- Lemma: ifComplexitySmaller Q.E.D.--- Lemma: isAssignedExtends Q.E.D.--- Lemma: lookUpExtends Q.E.D.+-- >>> runTPWith cvc5 falsifyExtendsBindings+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Lemma: isAssignedExtends Q.E.D.+-- Lemma: lookUpExtends Q.E.D. -- Inductive lemma (strong): falsifyExtendsBindings--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2 Q.E.D.--- Step: 1.3 Q.E.D.--- Step: 1.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2 Q.E.D.+-- Step: 1.3 Q.E.D.+-- Step: 1.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: eval, falsify', ifComplexity, isAssigned, lookUp -- [Proven] falsifyExtendsBindings :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Ɐi ∷ Integer → Bool falsifyExtendsBindings :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> Forall "i" Integer -> SBool))@@ -955,41 +955,41 @@ -- | If falsify' returns falsified = true, then evaluating the formula -- with the returned bindings gives false. ----- >>> runTPWith (tpRibbon 50 cvc5) falsifyFalsifies--- Lemma: ifComplexityPos Q.E.D.--- Lemma: ifComplexitySmaller Q.E.D.--- Lemma: falsifyExtendsBindings Q.E.D.--- Lemma: lookUpSame Q.E.D.--- Lemma: isAssignedSame Q.E.D.+-- >>> runTPWith cvc5 falsifyFalsifies+-- Lemma: ifComplexityPos Q.E.D.+-- Lemma: ifComplexitySmaller Q.E.D.+-- Lemma: falsifyExtendsBindings Q.E.D.+-- Lemma: lookUpSame Q.E.D.+-- Lemma: isAssignedSame Q.E.D. -- Inductive lemma (strong): falsifyFalsifies--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split)--- Step: 1.1.1 Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.1.3 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.3.1 Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.+-- Step: 1.1.1 Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.1.3 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.3.1 Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D. -- Step: 1.4 (4 way case split)--- Step: 1.4.1 Q.E.D.--- Step: 1.4.2 Q.E.D.+-- Step: 1.4.1 Q.E.D.+-- Step: 1.4.2 Q.E.D. -- Step: 1.4.3 (2 way case split) -- Step: 1.4.3.1 (2 way case split)--- Step: 1.4.3.1.1 Q.E.D.--- Step: 1.4.3.1.2 Q.E.D.--- Step: 1.4.3.1.Completeness Q.E.D.+-- Step: 1.4.3.1.1 Q.E.D.+-- Step: 1.4.3.1.2 Q.E.D.+-- Step: 1.4.3.1.Completeness Q.E.D. -- Step: 1.4.3.2 (2 way case split)--- Step: 1.4.3.2.1 Q.E.D.--- Step: 1.4.3.2.2 Q.E.D.--- Step: 1.4.3.2.Completeness Q.E.D.--- Step: 1.4.3.Completeness Q.E.D.--- Step: 1.4.4 Q.E.D.--- Step: 1.4.Completeness Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.4.3.2.1 Q.E.D.+-- Step: 1.4.3.2.2 Q.E.D.+-- Step: 1.4.3.2.Completeness Q.E.D.+-- Step: 1.4.3.Completeness Q.E.D.+-- Step: 1.4.4 Q.E.D.+-- Step: 1.4.Completeness Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: eval, falsify', ifComplexity, isAssigned, isNormal, lookUp -- [Proven] falsifyFalsifies :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Bool falsifyFalsifies :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> SBool))@@ -1082,10 +1082,10 @@ -- evaluating its normalization with falsify's bindings gives false. -- -- >>> runTPWith cvc5 completenessHelper--- Lemma: falsifyFalsifies Q.E.D.--- Lemma: nonTautIsFalsified Q.E.D.--- Lemma: normalizeCorrect Q.E.D.--- Lemma: completenessHelper Q.E.D.+-- Lemma: falsifyFalsifies Q.E.D.+-- Lemma: nonTautIsFalsified Q.E.D.+-- Lemma: normalizeCorrect Q.E.D.+-- Lemma: completenessHelper Q.E.D. -- Functions proven terminating: -- eval, falsify', ifComplexity, ifDepth, isAssigned, isNormal, isTautology', lookUp, normalize -- [Proven] completenessHelper :: Ɐf ∷ Formula → Bool@@ -1108,9 +1108,9 @@ -- This is the completeness theorem. -- -- >>> runTPWith cvc5 completeness--- Lemma: completenessHelper Q.E.D.--- Lemma: normalizeRespectsTruth Q.E.D.--- Lemma: completeness Q.E.D.+-- Lemma: completenessHelper Q.E.D.+-- Lemma: normalizeRespectsTruth Q.E.D.+-- Lemma: completeness Q.E.D. -- Functions proven terminating: -- eval, falsify', ifComplexity, ifDepth, isAssigned, isNormal, isTautology', lookUp, normalize -- [Proven] completeness :: Ɐf ∷ Formula → Bool
Documentation/SBV/Examples/TP/UpDown.hs view
@@ -71,19 +71,19 @@ -- | Prove that @reverse (down n)@ is the same as @up n@ -- -- >>> runTP upDown--- Lemma: n2iNonNeg Q.E.D.--- Lemma: revCons Q.E.D.+-- Lemma: n2iNonNeg Q.E.D.+-- Lemma: revCons Q.E.D. -- Inductive lemma (strong): upDownGen--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split)--- Step: 1.1 Q.E.D.--- Step: 1.2.1 Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.2.4 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.--- Lemma: upDown Q.E.D.+-- Step: 1.1 Q.E.D.+-- Step: 1.2.1 Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.2.4 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D.+-- Lemma: upDown Q.E.D. -- Functions proven terminating: down, n2i, sbv.reverse, up -- [Proven] upDown :: Ɐn ∷ Nat → Bool upDown :: TP (Proof (Forall "n" Nat -> SBool))
Documentation/SBV/Examples/TP/VM.hs view
@@ -194,77 +194,77 @@ -- -- >>> runTP (correctness @String @Integer) -- Inductive lemma: runSeq--- Step: Base Q.E.D.--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Result: Q.E.D.--- Lemma: runOne Q.E.D.+-- Step: Base Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Result: Q.E.D.+-- Lemma: runOne Q.E.D. -- Lemma: runTwo--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Result: Q.E.D.--- Lemma: runMul Q.E.D.--- Lemma: measureNonNeg Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Result: Q.E.D.+-- Lemma: runMul Q.E.D.+-- Lemma: measureNonNeg Q.E.D. -- Inductive lemma (strong): helper--- Step: Measure is non-negative Q.E.D.+-- Step: Measure is non-negative Q.E.D. -- Step: 1 (7 way case split)--- Step: 1.1.1 (case Var) Q.E.D.--- Step: 1.1.2 Q.E.D.--- Step: 1.2.1 (case Con) Q.E.D.--- Step: 1.2.2 Q.E.D.--- Step: 1.2.3 Q.E.D.--- Step: 1.3.1 (case Sqr) Q.E.D.--- Step: 1.3.2 Q.E.D.--- Step: 1.3.3 Q.E.D.--- Step: 1.3.4 Q.E.D.--- Step: 1.3.5 Q.E.D.--- Step: 1.3.6 Q.E.D.--- Step: 1.3.7 Q.E.D.--- Step: 1.4.1 (case Inc) Q.E.D.--- Step: 1.4.2 Q.E.D.--- Step: 1.4.3 Q.E.D.--- Step: 1.4.4 Q.E.D.--- Step: 1.4.5 Q.E.D.--- Step: 1.4.6 Q.E.D.--- Step: 1.4.7 Q.E.D.--- Step: 1.5.1 (case sAdd) Q.E.D.--- Step: 1.5.2 Q.E.D.--- Step: 1.5.3 Q.E.D.--- Step: 1.5.4 Q.E.D.--- Step: 1.5.5 Q.E.D.--- Step: 1.5.6 Q.E.D.--- Step: 1.5.7 Q.E.D.--- Step: 1.5.8 Q.E.D.--- Step: 1.5.9 Q.E.D.--- Step: 1.6.1 (case sMul) Q.E.D.--- Step: 1.6.2 Q.E.D.--- Step: 1.6.3 Q.E.D.--- Step: 1.6.4 Q.E.D.--- Step: 1.6.5 Q.E.D.--- Step: 1.6.6 Q.E.D.--- Step: 1.6.7 Q.E.D.--- Step: 1.6.8 Q.E.D.--- Step: 1.6.9 Q.E.D.--- Step: 1.7.1 (case Let) Q.E.D.--- Step: 1.7.2 Q.E.D.--- Step: 1.7.3 Q.E.D.--- Step: 1.7.4 Q.E.D.--- Step: 1.7.5 Q.E.D.--- Step: 1.7.6 Q.E.D.--- Step: 1.7.7 Q.E.D.--- Step: 1.7.8 Q.E.D.--- Step: 1.7.9 Q.E.D.--- Step: 1.7.10 Q.E.D.--- Step: 1.7.11 Q.E.D.--- Step: 1.Completeness Q.E.D.--- Result: Q.E.D.+-- Step: 1.1.1 (case Var) Q.E.D.+-- Step: 1.1.2 Q.E.D.+-- Step: 1.2.1 (case Con) Q.E.D.+-- Step: 1.2.2 Q.E.D.+-- Step: 1.2.3 Q.E.D.+-- Step: 1.3.1 (case Sqr) Q.E.D.+-- Step: 1.3.2 Q.E.D.+-- Step: 1.3.3 Q.E.D.+-- Step: 1.3.4 Q.E.D.+-- Step: 1.3.5 Q.E.D.+-- Step: 1.3.6 Q.E.D.+-- Step: 1.3.7 Q.E.D.+-- Step: 1.4.1 (case Inc) Q.E.D.+-- Step: 1.4.2 Q.E.D.+-- Step: 1.4.3 Q.E.D.+-- Step: 1.4.4 Q.E.D.+-- Step: 1.4.5 Q.E.D.+-- Step: 1.4.6 Q.E.D.+-- Step: 1.4.7 Q.E.D.+-- Step: 1.5.1 (case sAdd) Q.E.D.+-- Step: 1.5.2 Q.E.D.+-- Step: 1.5.3 Q.E.D.+-- Step: 1.5.4 Q.E.D.+-- Step: 1.5.5 Q.E.D.+-- Step: 1.5.6 Q.E.D.+-- Step: 1.5.7 Q.E.D.+-- Step: 1.5.8 Q.E.D.+-- Step: 1.5.9 Q.E.D.+-- Step: 1.6.1 (case sMul) Q.E.D.+-- Step: 1.6.2 Q.E.D.+-- Step: 1.6.3 Q.E.D.+-- Step: 1.6.4 Q.E.D.+-- Step: 1.6.5 Q.E.D.+-- Step: 1.6.6 Q.E.D.+-- Step: 1.6.7 Q.E.D.+-- Step: 1.6.8 Q.E.D.+-- Step: 1.6.9 Q.E.D.+-- Step: 1.7.1 (case Let) Q.E.D.+-- Step: 1.7.2 Q.E.D.+-- Step: 1.7.3 Q.E.D.+-- Step: 1.7.4 Q.E.D.+-- Step: 1.7.5 Q.E.D.+-- Step: 1.7.6 Q.E.D.+-- Step: 1.7.7 Q.E.D.+-- Step: 1.7.8 Q.E.D.+-- Step: 1.7.9 Q.E.D.+-- Step: 1.7.10 Q.E.D.+-- Step: 1.7.11 Q.E.D.+-- Step: 1.Completeness Q.E.D.+-- Result: Q.E.D. -- Lemma: correctness--- Step: 1 Q.E.D.--- Step: 2 Q.E.D.--- Step: 3 Q.E.D.--- Step: 4 Q.E.D.--- Result: Q.E.D.+-- Step: 1 Q.E.D.+-- Step: 2 Q.E.D.+-- Step: 3 Q.E.D.+-- Step: 4 Q.E.D.+-- Result: Q.E.D. -- Functions proven terminating: compile, exprSize, interpInEnv, sbv.foldl, sbv.lookup -- [Proven] correctness :: Ɐexpr ∷ (Expr String Integer) → Bool correctness :: forall nm val. (SymVal nm, SymVal val, Num (SBV val)) => TP (Proof (Forall "expr" (Expr nm val) -> SBool))
Documentation/SBV/Examples/Transformers/SymbolicEval.hs view
@@ -20,7 +20,6 @@ -- named @x@ and @y@. ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -41,12 +40,8 @@ import Data.SBV.Internals (SBV(SBV), unSBV) import Data.SBV.Trans.Control --- Starting with base 4.16; Data.Bits exports And, which conflicts with the definition here-#if MIN_VERSION_base(4,16,0)+-- Data.Bits exports And, which conflicts with the definition here import Data.SBV.Trans hiding(And)-#else-import Data.SBV.Trans-#endif -- * Allocation of symbolic variables, so we can extract a model later.
Documentation/SBV/Examples/Uninterpreted/Deduce.hs view
@@ -64,8 +64,8 @@ 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)+ pure $ not (p `or` (q `and` r))+ .== (not p `and` not q) `or` (not p `and` not r) -- Hlint gets confused and thinks the use of @not@ above is from the prelude. Sigh. {- HLint ignore test "Redundant not" -}
Documentation/SBV/Examples/Uninterpreted/EUFLogic.hs view
@@ -262,20 +262,20 @@ -- | Interpret an 'Op' into a function over SBV values interpOp :: Op ins out -> InterpM (OpTypes2SBV ins out) interpOp (Op_Unint uop) = state (unintEnsure uop)-interpOp Op_And = return (.&&)-interpOp Op_Or = return (.||)-interpOp Op_Not = return sNot-interpOp (Op_BoolLit b) = return $ fromBool b-interpOp (Op_IfThenElse Repr_Bool) = return ite-interpOp (Op_IfThenElse (Repr_BV BVWidth{})) = return ite-interpOp (Op_Plus BVWidth{}) = return (+)-interpOp (Op_Minus BVWidth{}) = return (-)-interpOp (Op_Times BVWidth{}) = return (*)-interpOp (Op_Abs BVWidth{}) = return abs-interpOp (Op_Signum BVWidth{}) = return signum-interpOp (Op_BVLit BVWidth{} i) = return $ fromInteger i-interpOp (Op_BVEq BVWidth{}) = return (.==)-interpOp (Op_BVLt BVWidth{}) = return (.<)+interpOp Op_And = pure (.&&)+interpOp Op_Or = pure (.||)+interpOp Op_Not = pure sNot+interpOp (Op_BoolLit b) = pure $ fromBool b+interpOp (Op_IfThenElse Repr_Bool) = pure ite+interpOp (Op_IfThenElse (Repr_BV BVWidth{})) = pure ite+interpOp (Op_Plus BVWidth{}) = pure (+)+interpOp (Op_Minus BVWidth{}) = pure (-)+interpOp (Op_Times BVWidth{}) = pure (*)+interpOp (Op_Abs BVWidth{}) = pure abs+interpOp (Op_Signum BVWidth{}) = pure signum+interpOp (Op_BVLit BVWidth{} i) = pure $ fromInteger i+interpOp (Op_BVEq BVWidth{}) = pure (.==)+interpOp (Op_BVLt BVWidth{}) = pure (.<) -- | Interpret an t'EUFExpr' into an SBV value. interpEUFExpr :: EUFExpr tp -> InterpM (Type2SBV tp)@@ -284,7 +284,7 @@ -- | Apply an interpretation of an operator to the interpretations of a sequence of arguments for it. interpApplyEUFExprs :: ghost out -> OpTypes2SBV ins out -> EUFExprs ins -> InterpM (Type2SBV out)-interpApplyEUFExprs _ f EUFExprsNil = return f+interpApplyEUFExprs _ f EUFExprsNil = pure f interpApplyEUFExprs out f (EUFExprsCons e es) = do f_app <- f <$> interpEUFExpr e interpApplyEUFExprs out f_app es
Documentation/SBV/Examples/Uninterpreted/Multiply.hs view
@@ -13,7 +13,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Uninterpreted.Multiply where @@ -86,5 +86,6 @@ -- and rest assured that we have a correctly synthesized circuit! synthMul22 :: ConstraintSet synthMul22 = constrain $ \(Forall (a :: SWord8)) (Forall b) -> mul22 (lsb2 a) (lsb2 b) .== lsb2 (a * b)- where lsb2 x = let [x1, x0] = reverse $ take 2 $ blastLE x- in (x1, x0)+ where lsb2 x = case blastLE x of+ (x0 : x1 : _) -> (x1, x0)+ _ -> error "synthMul22: Can't get enough bits from x!"
Documentation/SBV/Examples/Uninterpreted/Sort.hs view
@@ -42,7 +42,7 @@ -- f _ = Q_1 t1 :: IO SatResult t1 = sat $ do x <- free "x"- return $ f x ./= x+ pure $ 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@@ -53,4 +53,4 @@ t2 :: IO SatResult t2 = sat $ do x <- free "x" constrain $ \(Forall a) (Forall b) -> a .== (b :: SQ)- return $ f x ./= x+ pure $ f x ./= x
Documentation/SBV/Examples/Uninterpreted/UISortAllSat.hs view
@@ -85,4 +85,4 @@ constrain $ classify l0 .== 0 constrain $ classify l1 .== 1 constrain $ classify l2 .== 2- return $ l .== l0 .|| l .== l1 .|| l .== l2+ pure $ l .== l0 .|| l .== l1 .|| l .== l2
Documentation/SBV/Examples/WeakestPreconditions/Append.hs view
@@ -89,7 +89,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeAppend :: Program A-imperativeAppend = Program { setup = return ()+imperativeAppend = Program { setup = pure () , precondition = const sTrue -- no precondition , program = algorithm , postcondition = postcondition
Documentation/SBV/Examples/WeakestPreconditions/Basics.hs view
@@ -90,7 +90,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeInc :: Stmt I -> Stmt I -> Program I-imperativeInc before after = Program { setup = return ()+imperativeInc before after = Program { setup = pure () , precondition = pre , program = algorithm before after , postcondition = post
Documentation/SBV/Examples/WeakestPreconditions/IntDiv.hs view
@@ -93,7 +93,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeDiv :: Invariant D -> Maybe (WPMeasure D) -> Program D-imperativeDiv inv msr = Program { setup = return ()+imperativeDiv inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post
Documentation/SBV/Examples/WeakestPreconditions/IntSqrt.hs view
@@ -103,7 +103,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeSqrt :: Invariant S -> Maybe (WPMeasure S) -> Program S-imperativeSqrt inv msr = Program { setup = return ()+imperativeSqrt inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post
Documentation/SBV/Examples/WeakestPreconditions/Length.hs view
@@ -92,7 +92,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeLength :: Invariant S -> Maybe (WPMeasure S) -> Program S-imperativeLength inv msr = Program { setup = return ()+imperativeLength inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post
Documentation/SBV/Examples/WeakestPreconditions/Sum.hs view
@@ -100,7 +100,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeSum :: Invariant S -> Maybe (WPMeasure S) -> Program S-imperativeSum inv msr = Program { setup = return ()+imperativeSum inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post@@ -207,8 +207,8 @@ Following proof obligation failed: ================================== Invariant for loop "i < n" is not maintained by the body:- Before: SumS {n = 2, i = 1, s = 1}- After : SumS {n = 2, i = 2, s = 3}+ Before: SumS {n = 3, i = 1, s = 1}+ After : SumS {n = 3, i = 2, s = 3} Here, we posed the extra incorrect invariant that @s <= i@ must be maintained, and SBV found us a reachable state that violates the invariant. The /before/ state indeed satisfies @s <= i@, but the /after/ state does not. Note that the proof fails in this case not because the program@@ -224,8 +224,8 @@ Following proof obligation failed: ================================== Measure for loop "i < n" is negative:- State : SumS {n = 3, i = 2, s = 3}- Measure: -1+ State : SumS {n = 7, i = 6, s = 21}+ Measure: -5 The failure is pretty obvious in this case: Measure produces a negative value.
SBVBenchSuite/BenchSuite/Bench/Bench.hs view
@@ -10,7 +10,7 @@ -- Assessing the overhead of calling solving examples via sbv vs individual solvers ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}
SBVBenchSuite/BenchSuite/Existentials/Diophantine.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Existentials.Diophantine ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Existentials.Diophantine(benchmarks) where
SBVBenchSuite/BenchSuite/Misc/NoDiv0.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Misc.NoDiv0 ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Misc.NoDiv0(benchmarks) where
SBVBenchSuite/BenchSuite/Optimization/Instances.hs view
@@ -10,7 +10,7 @@ -- Helper file to provide common orphaned instances for Optimization benchmarks ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Optimization.Instances where
SBVBenchSuite/BenchSuite/ProofTools/BMC.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.BMC ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.BMC(benchmarks) where
SBVBenchSuite/BenchSuite/ProofTools/Fibonacci.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.Fibonacci ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.Fibonacci(benchmarks) where
SBVBenchSuite/BenchSuite/ProofTools/Strengthen.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.Strengthen ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.Strengthen(benchmarks) where
SBVBenchSuite/BenchSuite/ProofTools/Sum.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.Sum ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.Sum(benchmarks) where
SBVBenchSuite/BenchSuite/Queries/Enums.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Queries.Enums ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Queries.Enums(benchmarks) where
SBVBenchSuite/BenchSuite/Queries/GuessNumber.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Queries.GuessNumber ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Queries.GuessNumber(benchmarks) where
SBVBenchSuite/BenchSuite/Transformers/SymbolicEval.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Transformers.SymbolicEval ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Transformers.SymbolicEval(benchmarks) where
SBVBenchSuite/BenchSuite/Uninterpreted/AUF.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Uninterpreted.AUF ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE ScopedTypeVariables #-} module BenchSuite.Uninterpreted.AUF(benchmarks) where
SBVBenchSuite/BenchSuite/Uninterpreted/Deduce.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Uninterpreted.Deduce ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE ScopedTypeVariables #-} module BenchSuite.Uninterpreted.Deduce(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/Append.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Append ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Append(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/Basics.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Basics ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE NamedFieldPuns #-} module BenchSuite.WeakestPreconditions.Basics(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/Fib.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Fig ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Fib(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/GCD.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.GCD ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.GCD(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/Instances.hs view
@@ -10,7 +10,7 @@ -- Helper file to provide common orphaned instances for WeakestPrecondition benchmarks ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Instances where
SBVBenchSuite/BenchSuite/WeakestPreconditions/IntDiv.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.IntDiv ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.IntDiv(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/IntSqrt.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.IntSqrt ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.IntSqrt(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/Length.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Length ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Length(benchmarks) where
SBVBenchSuite/BenchSuite/WeakestPreconditions/Sum.hs view
@@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Sum ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE NamedFieldPuns #-} module BenchSuite.WeakestPreconditions.Sum(benchmarks) where
SBVBenchSuite/Utils/SBVBenchFramework.hs view
@@ -14,7 +14,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-} -- for ProvableM orphan+{-# OPTIONS_GHC -Wno-orphans -Wno-missing-methods #-} -- for ProvableM orphan module Utils.SBVBenchFramework ( mkExecString
SBVTestSuite/GoldFiles/adt01.gold view
@@ -72,7 +72,7 @@ (KRational (getKRational_1 SBVRational)) )) [GOOD] ; --- literal constants ----[GOOD] (define-fun s1 () ADT ((as APair ADT) ((as AInt64 ADT) #x0000000000000004) ((as AMaybe ADT) ((as Just (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))) (mkSBVTuple3 0.0 ((_ to_fp 8 24) roundNearestTiesToEven (/ 12.0 1.0)) (mkSBVTuple2 ((as Left (Either Int (_ FloatingPoint 8 24))) 3) (seq.++ (seq.unit false) (seq.unit true))))))))+[GOOD] (define-fun s1 () ADT ((as APair ADT) ((as AInt64 ADT) #x0000000000000004) ((as AMaybe ADT) ((as Just (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))) (mkSBVTuple3 0.0 (fp #b0 #b10000010 #b10000000000000000000000) (mkSBVTuple2 ((as Left (Either Int (_ FloatingPoint 8 24))) 3) (seq.++ (seq.unit false) (seq.unit true)))))))) [GOOD] ; --- top level inputs --- [GOOD] (declare-fun s0 () ADT) ; tracks user variable "e" [GOOD] (assert (and (= 1 (str.len (getKChar_1 s0)))
SBVTestSuite/GoldFiles/adt05.gold view
@@ -68,7 +68,7 @@ (KRational (getKRational_1 SBVRational)) )) [GOOD] ; --- literal constants ----[GOOD] (define-fun s4 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 4.0 1.0)))+[GOOD] (define-fun s4 () (_ FloatingPoint 8 24) (fp #b0 #b10000001 #b00000000000000000000000)) [GOOD] ; --- top level inputs --- [GOOD] (declare-fun s0 () ADT) ; tracks user variable "a" [GOOD] (assert (and (= 1 (str.len (getKChar_1 s0)))@@ -104,7 +104,7 @@ [SEND] (get-value (s1)) [RECV] ((s1 (AFloat (fp #b0 #b11111111 #b10000000000000000000000)))) [GOOD] (push 1)-[GOOD] (define-fun s11 () ADT ((as AFloat ADT) ((_ to_fp 8 24) roundNearestTiesToEven (/ 4.0 1.0))))+[GOOD] (define-fun s11 () ADT ((as AFloat ADT) (fp #b0 #b10000001 #b00000000000000000000000))) [GOOD] (define-fun s12 () Bool (= s0 s11)) [GOOD] (define-fun s13 () Bool (not s12)) [GOOD] (assert s13)
SBVTestSuite/GoldFiles/freshVars.gold view
@@ -73,10 +73,10 @@ [GOOD] (define-fun s33 () (_ BitVec 64) #x0000000000000008) [GOOD] (define-fun s34 () Bool (= s11 s33)) [GOOD] (assert s34)-[GOOD] (define-fun s35 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 9.0 1.0)))+[GOOD] (define-fun s35 () (_ FloatingPoint 8 24) (fp #b0 #b10000010 #b00100000000000000000000)) [GOOD] (define-fun s36 () Bool (fp.eq s12 s35)) [GOOD] (assert s36)-[GOOD] (define-fun s37 () (_ FloatingPoint 11 53) ((_ to_fp 11 53) roundNearestTiesToEven (/ 10.0 1.0)))+[GOOD] (define-fun s37 () (_ FloatingPoint 11 53) (fp #b0 #b10000000010 #b0100000000000000000000000000000000000000000000000000)) [GOOD] (define-fun s38 () Bool (fp.eq s13 s37)) [GOOD] (assert s38) [GOOD] (define-fun s39 () Real (/ 11.0 1.0))
SBVTestSuite/GoldFiles/pareto1.gold view
@@ -47,11 +47,11 @@ max_x_plus_y = 6 :: Integer min_y = 4 :: Integer Pareto front #9: Optimal model:- x = 3 :: Integer- y = 4 :: Integer- min_x = 3 :: Integer+ x = 4 :: Integer+ y = 3 :: Integer+ min_x = 4 :: Integer max_x_plus_y = 7 :: Integer- min_y = 4 :: Integer+ min_y = 3 :: Integer Pareto front #10: Optimal model: x = 5 :: Integer y = 2 :: Integer@@ -59,35 +59,35 @@ max_x_plus_y = 7 :: Integer min_y = 2 :: Integer Pareto front #11: Optimal model:- x = 4 :: Integer- y = 4 :: Integer- min_x = 4 :: Integer- max_x_plus_y = 8 :: Integer- min_y = 4 :: Integer-Pareto front #12: Optimal model:- x = 4 :: Integer- y = 3 :: Integer- min_x = 4 :: Integer- max_x_plus_y = 7 :: Integer- min_y = 3 :: Integer-Pareto front #13: Optimal model: x = 5 :: Integer y = 3 :: Integer min_x = 5 :: Integer max_x_plus_y = 8 :: Integer min_y = 3 :: Integer-Pareto front #14: Optimal model:- x = 5 :: Integer+Pareto front #12: Optimal model:+ x = 3 :: Integer y = 4 :: Integer- min_x = 5 :: Integer- max_x_plus_y = 9 :: Integer+ min_x = 3 :: Integer+ max_x_plus_y = 7 :: Integer min_y = 4 :: Integer-Pareto front #15: Optimal model:+Pareto front #13: Optimal model: x = 4 :: Integer y = 2 :: Integer min_x = 4 :: Integer max_x_plus_y = 6 :: Integer min_y = 2 :: Integer+Pareto front #14: Optimal model:+ x = 4 :: Integer+ y = 4 :: Integer+ min_x = 4 :: Integer+ max_x_plus_y = 8 :: Integer+ min_y = 4 :: Integer+Pareto front #15: Optimal model:+ x = 5 :: Integer+ y = 4 :: Integer+ min_x = 5 :: Integer+ max_x_plus_y = 9 :: Integer+ min_y = 4 :: Integer Pareto front #16: Optimal model: x = 1 :: Integer y = 0 :: Integer@@ -107,65 +107,65 @@ max_x_plus_y = 2 :: Integer min_y = 0 :: Integer Pareto front #19: Optimal model:- x = 3 :: Integer- y = 0 :: Integer- min_x = 3 :: Integer- max_x_plus_y = 3 :: Integer- min_y = 0 :: Integer-Pareto front #20: Optimal model: x = 0 :: Integer y = 1 :: Integer min_x = 0 :: Integer max_x_plus_y = 1 :: Integer min_y = 1 :: Integer-Pareto front #21: Optimal model:+Pareto front #20: Optimal model: x = 2 :: Integer y = 1 :: Integer min_x = 2 :: Integer max_x_plus_y = 3 :: Integer min_y = 1 :: Integer-Pareto front #22: Optimal model:+Pareto front #21: Optimal model: x = 1 :: Integer y = 2 :: Integer min_x = 1 :: Integer max_x_plus_y = 3 :: Integer min_y = 2 :: Integer-Pareto front #23: Optimal model:+Pareto front #22: Optimal model: x = 0 :: Integer y = 2 :: Integer min_x = 0 :: Integer max_x_plus_y = 2 :: Integer min_y = 2 :: Integer-Pareto front #24: Optimal model:+Pareto front #23: Optimal model: x = 0 :: Integer- y = 4 :: Integer+ y = 3 :: Integer min_x = 0 :: Integer- max_x_plus_y = 4 :: Integer- min_y = 4 :: Integer-Pareto front #25: Optimal model:+ max_x_plus_y = 3 :: Integer+ min_y = 3 :: Integer+Pareto front #24: Optimal model: x = 1 :: Integer y = 3 :: Integer min_x = 1 :: Integer max_x_plus_y = 4 :: Integer min_y = 3 :: Integer+Pareto front #25: Optimal model:+ x = 0 :: Integer+ y = 4 :: Integer+ min_x = 0 :: Integer+ max_x_plus_y = 4 :: Integer+ min_y = 4 :: Integer Pareto front #26: Optimal model:- x = 2 :: Integer- y = 3 :: Integer- min_x = 2 :: Integer- max_x_plus_y = 5 :: Integer- min_y = 3 :: Integer-Pareto front #27: Optimal model: x = 1 :: Integer y = 4 :: Integer min_x = 1 :: Integer max_x_plus_y = 5 :: Integer min_y = 4 :: Integer-Pareto front #28: Optimal model:- x = 0 :: Integer+Pareto front #27: Optimal model:+ x = 2 :: Integer y = 3 :: Integer- min_x = 0 :: Integer- max_x_plus_y = 3 :: Integer+ min_x = 2 :: Integer+ max_x_plus_y = 5 :: Integer min_y = 3 :: Integer+Pareto front #28: Optimal model:+ x = 3 :: Integer+ y = 0 :: Integer+ min_x = 3 :: Integer+ max_x_plus_y = 3 :: Integer+ min_y = 0 :: Integer Pareto front #29: Optimal model: x = 4 :: Integer y = 0 :: Integer
SBVTestSuite/GoldFiles/pareto2.gold view
@@ -1,182 +1,182 @@ Pareto front #1: Optimal model:- x = 0 :: Integer- y = -1 :: Integer- min_x = 0 :: Integer- max_y = -1 :: Integer- max_x_plus_y = -1 :: Integer+ x = 0 :: Integer+ y = 1 :: Integer+ min_x = 0 :: Integer+ max_y = 1 :: Integer+ max_x_plus_y = 1 :: Integer Pareto front #2: Optimal model:- x = 0 :: Integer- y = -3 :: Integer- min_x = 0 :: Integer- max_y = -3 :: Integer- max_x_plus_y = -3 :: Integer+ x = 0 :: Integer+ y = 2 :: Integer+ min_x = 0 :: Integer+ max_y = 2 :: Integer+ max_x_plus_y = 2 :: Integer Pareto front #3: Optimal model:- x = 0 :: Integer- y = -5 :: Integer- min_x = 0 :: Integer- max_y = -5 :: Integer- max_x_plus_y = -5 :: Integer+ x = 0 :: Integer+ y = 3 :: Integer+ min_x = 0 :: Integer+ max_y = 3 :: Integer+ max_x_plus_y = 3 :: Integer Pareto front #4: Optimal model:- x = 0 :: Integer- y = -7 :: Integer- min_x = 0 :: Integer- max_y = -7 :: Integer- max_x_plus_y = -7 :: Integer+ x = 0 :: Integer+ y = 5 :: Integer+ min_x = 0 :: Integer+ max_y = 5 :: Integer+ max_x_plus_y = 5 :: Integer Pareto front #5: Optimal model:- x = 0 :: Integer- y = -9 :: Integer- min_x = 0 :: Integer- max_y = -9 :: Integer- max_x_plus_y = -9 :: Integer+ x = 0 :: Integer+ y = 6 :: Integer+ min_x = 0 :: Integer+ max_y = 6 :: Integer+ max_x_plus_y = 6 :: Integer Pareto front #6: Optimal model:- x = 0 :: Integer- y = -10 :: Integer- min_x = 0 :: Integer- max_y = -10 :: Integer- max_x_plus_y = -10 :: Integer+ x = 0 :: Integer+ y = 7 :: Integer+ min_x = 0 :: Integer+ max_y = 7 :: Integer+ max_x_plus_y = 7 :: Integer Pareto front #7: Optimal model:- x = 0 :: Integer- y = -11 :: Integer- min_x = 0 :: Integer- max_y = -11 :: Integer- max_x_plus_y = -11 :: Integer+ x = 0 :: Integer+ y = 9 :: Integer+ min_x = 0 :: Integer+ max_y = 9 :: Integer+ max_x_plus_y = 9 :: Integer Pareto front #8: Optimal model:- x = 0 :: Integer- y = -13 :: Integer- min_x = 0 :: Integer- max_y = -13 :: Integer- max_x_plus_y = -13 :: Integer+ x = 0 :: Integer+ y = 8 :: Integer+ min_x = 0 :: Integer+ max_y = 8 :: Integer+ max_x_plus_y = 8 :: Integer Pareto front #9: Optimal model:- x = 0 :: Integer- y = -15 :: Integer- min_x = 0 :: Integer- max_y = -15 :: Integer- max_x_plus_y = -15 :: Integer+ x = 0 :: Integer+ y = 11 :: Integer+ min_x = 0 :: Integer+ max_y = 11 :: Integer+ max_x_plus_y = 11 :: Integer Pareto front #10: Optimal model:- x = 0 :: Integer- y = -16 :: Integer- min_x = 0 :: Integer- max_y = -16 :: Integer- max_x_plus_y = -16 :: Integer+ x = 0 :: Integer+ y = 13 :: Integer+ min_x = 0 :: Integer+ max_y = 13 :: Integer+ max_x_plus_y = 13 :: Integer Pareto front #11: Optimal model:- x = 0 :: Integer- y = -18 :: Integer- min_x = 0 :: Integer- max_y = -18 :: Integer- max_x_plus_y = -18 :: Integer+ x = 0 :: Integer+ y = 14 :: Integer+ min_x = 0 :: Integer+ max_y = 14 :: Integer+ max_x_plus_y = 14 :: Integer Pareto front #12: Optimal model:- x = 0 :: Integer- y = -20 :: Integer- min_x = 0 :: Integer- max_y = -20 :: Integer- max_x_plus_y = -20 :: Integer+ x = 0 :: Integer+ y = 15 :: Integer+ min_x = 0 :: Integer+ max_y = 15 :: Integer+ max_x_plus_y = 15 :: Integer Pareto front #13: Optimal model:- x = 0 :: Integer- y = -22 :: Integer- min_x = 0 :: Integer- max_y = -22 :: Integer- max_x_plus_y = -22 :: Integer+ x = 0 :: Integer+ y = 17 :: Integer+ min_x = 0 :: Integer+ max_y = 17 :: Integer+ max_x_plus_y = 17 :: Integer Pareto front #14: Optimal model:- x = 0 :: Integer- y = -23 :: Integer- min_x = 0 :: Integer- max_y = -23 :: Integer- max_x_plus_y = -23 :: Integer+ x = 0 :: Integer+ y = 19 :: Integer+ min_x = 0 :: Integer+ max_y = 19 :: Integer+ max_x_plus_y = 19 :: Integer Pareto front #15: Optimal model:- x = 0 :: Integer- y = -24 :: Integer- min_x = 0 :: Integer- max_y = -24 :: Integer- max_x_plus_y = -24 :: Integer+ x = 0 :: Integer+ y = 21 :: Integer+ min_x = 0 :: Integer+ max_y = 21 :: Integer+ max_x_plus_y = 21 :: Integer Pareto front #16: Optimal model:- x = 0 :: Integer- y = -26 :: Integer- min_x = 0 :: Integer- max_y = -26 :: Integer- max_x_plus_y = -26 :: Integer+ x = 0 :: Integer+ y = 22 :: Integer+ min_x = 0 :: Integer+ max_y = 22 :: Integer+ max_x_plus_y = 22 :: Integer Pareto front #17: Optimal model:- x = 0 :: Integer- y = -28 :: Integer- min_x = 0 :: Integer- max_y = -28 :: Integer- max_x_plus_y = -28 :: Integer+ x = 0 :: Integer+ y = 23 :: Integer+ min_x = 0 :: Integer+ max_y = 23 :: Integer+ max_x_plus_y = 23 :: Integer Pareto front #18: Optimal model:- x = 0 :: Integer- y = -29 :: Integer- min_x = 0 :: Integer- max_y = -29 :: Integer- max_x_plus_y = -29 :: Integer+ x = 0 :: Integer+ y = 25 :: Integer+ min_x = 0 :: Integer+ max_y = 25 :: Integer+ max_x_plus_y = 25 :: Integer Pareto front #19: Optimal model:- x = 0 :: Integer- y = -31 :: Integer- min_x = 0 :: Integer- max_y = -31 :: Integer- max_x_plus_y = -31 :: Integer+ x = 0 :: Integer+ y = 26 :: Integer+ min_x = 0 :: Integer+ max_y = 26 :: Integer+ max_x_plus_y = 26 :: Integer Pareto front #20: Optimal model:- x = 0 :: Integer- y = -32 :: Integer- min_x = 0 :: Integer- max_y = -32 :: Integer- max_x_plus_y = -32 :: Integer+ x = 0 :: Integer+ y = 28 :: Integer+ min_x = 0 :: Integer+ max_y = 28 :: Integer+ max_x_plus_y = 28 :: Integer Pareto front #21: Optimal model:- x = 0 :: Integer- y = -34 :: Integer- min_x = 0 :: Integer- max_y = -34 :: Integer- max_x_plus_y = -34 :: Integer+ x = 0 :: Integer+ y = 30 :: Integer+ min_x = 0 :: Integer+ max_y = 30 :: Integer+ max_x_plus_y = 30 :: Integer Pareto front #22: Optimal model:- x = 0 :: Integer- y = -35 :: Integer- min_x = 0 :: Integer- max_y = -35 :: Integer- max_x_plus_y = -35 :: Integer+ x = 0 :: Integer+ y = 32 :: Integer+ min_x = 0 :: Integer+ max_y = 32 :: Integer+ max_x_plus_y = 32 :: Integer Pareto front #23: Optimal model:- x = 0 :: Integer- y = -37 :: Integer- min_x = 0 :: Integer- max_y = -37 :: Integer- max_x_plus_y = -37 :: Integer+ x = 0 :: Integer+ y = 34 :: Integer+ min_x = 0 :: Integer+ max_y = 34 :: Integer+ max_x_plus_y = 34 :: Integer Pareto front #24: Optimal model:- x = 0 :: Integer- y = -38 :: Integer- min_x = 0 :: Integer- max_y = -38 :: Integer- max_x_plus_y = -38 :: Integer+ x = 0 :: Integer+ y = 36 :: Integer+ min_x = 0 :: Integer+ max_y = 36 :: Integer+ max_x_plus_y = 36 :: Integer Pareto front #25: Optimal model:- x = 0 :: Integer- y = -40 :: Integer- min_x = 0 :: Integer- max_y = -40 :: Integer- max_x_plus_y = -40 :: Integer+ x = 0 :: Integer+ y = 37 :: Integer+ min_x = 0 :: Integer+ max_y = 37 :: Integer+ max_x_plus_y = 37 :: Integer Pareto front #26: Optimal model:- x = 0 :: Integer- y = -41 :: Integer- min_x = 0 :: Integer- max_y = -41 :: Integer- max_x_plus_y = -41 :: Integer+ x = 0 :: Integer+ y = 39 :: Integer+ min_x = 0 :: Integer+ max_y = 39 :: Integer+ max_x_plus_y = 39 :: Integer Pareto front #27: Optimal model:- x = 0 :: Integer- y = -43 :: Integer- min_x = 0 :: Integer- max_y = -43 :: Integer- max_x_plus_y = -43 :: Integer+ x = 0 :: Integer+ y = 40 :: Integer+ min_x = 0 :: Integer+ max_y = 40 :: Integer+ max_x_plus_y = 40 :: Integer Pareto front #28: Optimal model:- x = 0 :: Integer- y = -44 :: Integer- min_x = 0 :: Integer- max_y = -44 :: Integer- max_x_plus_y = -44 :: Integer+ x = 0 :: Integer+ y = 41 :: Integer+ min_x = 0 :: Integer+ max_y = 41 :: Integer+ max_x_plus_y = 41 :: Integer Pareto front #29: Optimal model:- x = 0 :: Integer- y = -45 :: Integer- min_x = 0 :: Integer- max_y = -45 :: Integer- max_x_plus_y = -45 :: Integer+ x = 0 :: Integer+ y = 43 :: Integer+ min_x = 0 :: Integer+ max_y = 43 :: Integer+ max_x_plus_y = 43 :: Integer Pareto front #30: Optimal model:- x = 0 :: Integer- y = -47 :: Integer- min_x = 0 :: Integer- max_y = -47 :: Integer- max_x_plus_y = -47 :: Integer+ x = 0 :: Integer+ y = 44 :: Integer+ min_x = 0 :: Integer+ max_y = 44 :: Integer+ max_x_plus_y = 44 :: Integer *** Note: Pareto-front extraction was terminated as requested by the user. *** There might be many other results!
SBVTestSuite/GoldFiles/query_cvc5.gold view
@@ -4,7 +4,7 @@ [GOOD] (set-option :global-declarations true) [GOOD] (set-option :diagnostic-output-channel "stdout") [GOOD] (set-option :produce-models true)-[GOOD] (set-logic ALL) ; external query, using all logics.+[GOOD] (set-logic HO_ALL) ; external query, using all logics. [GOOD] ; --- tuples --- [GOOD] ; --- sums --- [GOOD] ; --- literal constants ---
SBVTestSuite/GoldFiles/query_uisatex1.gold view
@@ -22,26 +22,26 @@ [GOOD] (define-fun s21 () Int 5) [GOOD] (define-fun s23 () Int 7) [GOOD] (define-fun s25 () Int 6)-[GOOD] (define-fun s29 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 4508877.0 524288.0)))-[GOOD] (define-fun s32 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 5033165.0 524288.0)))+[GOOD] (define-fun s29 () (_ FloatingPoint 8 24) (fp #b0 #b10000010 #b00010011001100110011010))+[GOOD] (define-fun s32 () (_ FloatingPoint 8 24) (fp #b0 #b10000010 #b00110011001100110011010)) [GOOD] (define-fun s33 () Int 121) [GOOD] (define-fun s38 () Int 8) [GOOD] (define-fun s40 () (_ FloatingPoint 8 24) (_ +oo 8 24)) [GOOD] (define-fun s42 () String (_ char #x63)) [GOOD] (define-fun s43 () String "hey")-[GOOD] (define-fun s45 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 78.0 1.0)))+[GOOD] (define-fun s45 () (_ FloatingPoint 8 24) (fp #b0 #b10000101 #b00111000000000000000000)) [GOOD] (define-fun s47 () String "tey")-[GOOD] (define-fun s49 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 92.0 1.0)))+[GOOD] (define-fun s49 () (_ FloatingPoint 8 24) (fp #b0 #b10000101 #b01110000000000000000000)) [GOOD] (define-fun s51 () String (_ char #x72)) [GOOD] (define-fun s52 () String "foo")-[GOOD] (define-fun s54 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 7.0 2.0)))+[GOOD] (define-fun s54 () (_ FloatingPoint 8 24) (fp #b0 #b10000000 #b11000000000000000000000)) [GOOD] (define-fun s56 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3)))-[GOOD] (define-fun s57 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 3.0 1.0)))))+[GOOD] (define-fun s57 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (fp #b0 #b10000000 #b10000000000000000000000)))) [GOOD] (define-fun s60 () (Seq Int) (seq.++ (seq.unit 9) (seq.unit 5)))-[GOOD] (define-fun s61 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 9.0 1.0)))))+[GOOD] (define-fun s61 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (fp #b0 #b10000010 #b00100000000000000000000)))) [GOOD] (define-fun s63 () Int 21) [GOOD] (define-fun s65 () (Seq Int) (seq.unit 5))-[GOOD] (define-fun s66 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit (_ +zero 8 24))))+[GOOD] (define-fun s66 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (_ +zero 8 24)))) [GOOD] (define-fun s68 () Int 210) [GOOD] ; --- top level inputs --- [GOOD] (declare-fun s0 () Int)
SBVTestSuite/GoldFiles/query_uisatex2.gold view
@@ -22,26 +22,26 @@ [GOOD] (define-fun s21 () Int 5) [GOOD] (define-fun s23 () Int 7) [GOOD] (define-fun s25 () Int 6)-[GOOD] (define-fun s29 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 4508877.0 524288.0)))-[GOOD] (define-fun s32 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 5033165.0 524288.0)))+[GOOD] (define-fun s29 () (_ FloatingPoint 8 24) (fp #b0 #b10000010 #b00010011001100110011010))+[GOOD] (define-fun s32 () (_ FloatingPoint 8 24) (fp #b0 #b10000010 #b00110011001100110011010)) [GOOD] (define-fun s33 () Int 121) [GOOD] (define-fun s38 () Int 8) [GOOD] (define-fun s40 () (_ FloatingPoint 8 24) (_ +oo 8 24)) [GOOD] (define-fun s42 () String (_ char #x63)) [GOOD] (define-fun s43 () String "hey")-[GOOD] (define-fun s45 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 78.0 1.0)))+[GOOD] (define-fun s45 () (_ FloatingPoint 8 24) (fp #b0 #b10000101 #b00111000000000000000000)) [GOOD] (define-fun s47 () String "tey")-[GOOD] (define-fun s49 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 92.0 1.0)))+[GOOD] (define-fun s49 () (_ FloatingPoint 8 24) (fp #b0 #b10000101 #b01110000000000000000000)) [GOOD] (define-fun s51 () String (_ char #x72)) [GOOD] (define-fun s52 () String "foo")-[GOOD] (define-fun s54 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 7.0 2.0)))+[GOOD] (define-fun s54 () (_ FloatingPoint 8 24) (fp #b0 #b10000000 #b11000000000000000000000)) [GOOD] (define-fun s56 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3)))-[GOOD] (define-fun s57 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 3.0 1.0)))))+[GOOD] (define-fun s57 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (fp #b0 #b10000000 #b10000000000000000000000)))) [GOOD] (define-fun s60 () (Seq Int) (seq.++ (seq.unit 9) (seq.unit 5)))-[GOOD] (define-fun s61 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 9.0 1.0)))))+[GOOD] (define-fun s61 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (fp #b0 #b10000010 #b00100000000000000000000)))) [GOOD] (define-fun s63 () Int 21) [GOOD] (define-fun s65 () (Seq Int) (seq.unit 5))-[GOOD] (define-fun s66 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit (_ +zero 8 24))))+[GOOD] (define-fun s66 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (_ +zero 8 24)))) [GOOD] (define-fun s68 () Int 210) [GOOD] ; --- top level inputs --- [GOOD] (declare-fun s0 () Int)
SBVTestSuite/GoldFiles/recursive20_mutualTP.gold view
@@ -215,7 +215,7 @@ [GOOD] (assert s7) [SEND] (check-sat) [RECV] unsat- Q.E.D.+ Q.E.D. *** Solver : Z3 *** Exit code: ExitSuccess Functions proven terminating: mf_tp, mg_tp
SBVTestSuite/GoldFiles/recursive28_noTermCheck.gold view
@@ -47,7 +47,7 @@ [GOOD] (assert s7) [SEND] (check-sat) [RECV] unsat- Q.E.D. [Modulo: ntc28 termination]+ Q.E.D. [Modulo: ntc28 termination] *** Solver : Z3 *** Exit code: ExitSuccess [Modulo: ntc28 termination] ntc_at_5 :: Ɐn ∷ Integer → Bool
SBVTestSuite/GoldFiles/recursive6_uselessContract.gold view
@@ -112,21 +112,21 @@ [SEND] (check-sat) [RECV] sat [SEND] (get-value (s28))-[RECV] ((s28 101))+[RECV] ((s28 12)) [SEND] (get-value (s31))-[RECV] ((s31 90))+[RECV] ((s31 1)) [SEND] (get-value (s34))-[RECV] ((s34 101))+[RECV] ((s34 12)) [SEND] (get-value (s0))-[RECV] ((s0 0))+[RECV] ((s0 89)) [SEND] (get-value (s7))-[RECV] ((s7 0))+[RECV] ((s7 89)) [SEND] (get-value (s8)) [RECV] ((s8 0)) [SEND] (get-value (s13)) [RECV] ((s13 0)) [SEND] (get-value (s14))-[RECV] ((s14 0))+[RECV] ((s14 89)) [SEND] (get-value (s20)) [RECV] ((s20 0)) [SEND] (get-value (s21))@@ -141,10 +141,10 @@ *** Function: mc91triv :: SBV Integer -> SBV Integer *** *** Falsifiable. Counter-example:-*** arg = 0 :: Integer-*** before = 101 :: Integer-*** then[1] = 90 :: Integer-*** then[2] = 101 :: Integer+*** arg = 89 :: Integer+*** before = 12 :: Integer+*** then[1] = 1 :: Integer+*** then[2] = 12 :: Integer *** *** The measure must strictly decrease at every recursive call, *** and the contract must hold for the function's output.
SBVTestSuite/GoldFiles/tpCache_alias.gold view
@@ -1,3 +1,3 @@-Lemma: nameA Q.E.D.-Lemma: nameB Q.E.D.-Cached: nameC Q.E.D. (a.k.a. nameA, nameB)+Lemma: nameA Q.E.D.+Lemma: nameB Q.E.D.+Lemma: nameC Q.E.D. [Cached] (a.k.a. nameA, nameB)
+ SBVTestSuite/GoldFiles/tpCache_barFail.gold view
@@ -0,0 +1,4 @@+Lemma: foo+*** Failed to prove foo.+Falsifiable. Counter-example:+ x = 0 :: Integer
SBVTestSuite/GoldFiles/tpCache_calcCollapse.gold view
@@ -1,4 +1,4 @@ Lemma: addZero- Step: 1 Q.E.D.- Result: Q.E.D.-Cached: addZero Q.E.D.+ Step: 1 Q.E.D.+ Result: Q.E.D.+Lemma: addZero Q.E.D. [Cached]
+ SBVTestSuite/GoldFiles/tpCache_fooFail.gold view
@@ -0,0 +1,4 @@+Lemma: foo+*** Failed to prove foo.+Falsifiable. Counter-example:+ x = 0 :: Integer
SBVTestSuite/GoldFiles/tpCache_hit.gold view
@@ -1,2 +1,2 @@-Lemma: fact Q.E.D.-Cached: fact Q.E.D.+Lemma: fact Q.E.D.+Lemma: fact Q.E.D. [Cached]
SBVTestSuite/GoldFiles/tpCache_miss.gold view
@@ -1,1 +1,1 @@-Lemma: fact Q.E.D.+Lemma: fact Q.E.D.
SBVTestSuite/GoldFiles/tpCache_nested.gold view
@@ -1,3 +1,3 @@-Lemma: inner Q.E.D.-Lemma: outer Q.E.D.-Cached: outer Q.E.D. (a.k.a. inner)+Lemma: inner Q.E.D.+Lemma: outer Q.E.D.+Lemma: outer Q.E.D. [Cached] (a.k.a. inner)
+ SBVTestSuite/GoldFiles/tpCache_recallFail.gold view
@@ -0,0 +1,4 @@+Lemma: bad+*** Failed to prove bad.+Falsifiable. Counter-example:+ x = 0 :: Integer
SBVTestSuite/GoldFiles/tpCache_statsHit.gold view
@@ -1,4 +1,4 @@ Lemma: addZero- Step: 1 Q.E.D.- Result: Q.E.D.-Cached: addZero Q.E.D.+ Step: 1 Q.E.D.+ Result: Q.E.D.+Lemma: addZero Q.E.D. [Cached]
SBVTestSuite/GoldFiles/tpCache_statsMiss.gold view
@@ -1,3 +1,3 @@ Lemma: addZero- Step: 1 Q.E.D.- Result: Q.E.D.+ Step: 1 Q.E.D.+ Result: Q.E.D.
SBVTestSuite/GoldFiles/tpCache_statsNested.gold view
@@ -1,4 +1,4 @@-Lemma: inner Q.E.D.-Lemma: outer Q.E.D.-Cached: inner Q.E.D. (a.k.a. outer)-Cached: outer Q.E.D. (a.k.a. inner)+Lemma: inner Q.E.D.+Lemma: outer Q.E.D.+Lemma: inner Q.E.D. [Cached] (a.k.a. outer)+Lemma: outer Q.E.D. [Cached] (a.k.a. inner)
SBVTestSuite/TestSuite/Arrays/InitVals.hs view
@@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DataKinds #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -Werror #-}
SBVTestSuite/TestSuite/Arrays/Memory.hs view
@@ -9,7 +9,7 @@ -- Test suite for Examples.Arrays.Memory ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wall -Werror #-}
SBVTestSuite/TestSuite/Basics/ArithNoSolver.hs view
@@ -10,15 +10,10 @@ -- the constant folding based arithmetic implementation in SBV ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} -#if MIN_VERSION_base(4,19,0) {-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns -Wno-x-partial #-}-#else-{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}-#endif module TestSuite.Basics.ArithNoSolver(tests) where
SBVTestSuite/TestSuite/Basics/ArithNoSolver2.hs view
@@ -10,20 +10,15 @@ -- the constant folding based arithmetic implementation in SBV ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE QuasiQuotes #-} -#if MIN_VERSION_base(4,19,0) {-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns -Wno-x-partial #-}-#else-{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}-#endif module TestSuite.Basics.ArithNoSolver2(tests) where
SBVTestSuite/TestSuite/Basics/ArithSolver.hs view
@@ -11,21 +11,16 @@ -- constant folding. ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -#if MIN_VERSION_base(4,19,0) {-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns -Wno-x-partial #-}-#else-{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-}-#endif module TestSuite.Basics.ArithSolver(tests) where
SBVTestSuite/TestSuite/Basics/BasicTests.hs view
@@ -9,7 +9,7 @@ -- Test suite for Examples.Basics.BasicTests ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -Werror #-}
SBVTestSuite/TestSuite/Basics/TPCaching.hs view
@@ -19,23 +19,25 @@ import Utils.SBVTestFramework -import Data.SBV.TP (runTPWith, lemma, calc, recall, tpStats, (|-), (=:), qed)+import Data.SBV.TP (TP, Proof, runTPWith, lemma, calc, recall, tpStats, (|-), (=:), qed) import Control.Monad (void)+import Control.Exception (try, SomeException) import Data.Char (isSpace) import Data.List (isPrefixOf, dropWhileEnd) import Control.DeepSeq (($!!)) --- | Strip timing info [0.05s] from the end of output lines.+-- | Strip timing info like @[0.05s]@ from the end of output lines.+-- Only matches brackets whose content looks like a time value (digits, dots, and 's').+-- Handles multiple consecutive timings like @[0.001s][0.002s]@. stripTiming :: String -> String-stripTiming s- | (_, rest@('[':_)) <- break (== '[') (dropWhileEnd isSpace s)- , last rest == ']'- = dropWhileEnd isSpace $ take (length s - length rest) s- | True- = s+stripTiming s = reverse $ go $ reverse $ dropWhileEnd isSpace s+ where go (']':rest) | (inner, '[':before) <- break (== '[') rest+ , all (`elem` ("0123456789.s" :: String)) inner+ = go $ dropWhile isSpace before+ go xs = xs -- | Filter out the statistics summary line from verbose output. isStatsLine :: String -> Bool@@ -57,7 +59,7 @@ recall (lemma "fact" sTrue []) -- Normal mode: direct proof then recall (cache hit).- -- The direct proof shows "Lemma:", the recall shows "Cached:".+ -- The direct proof shows "Lemma:", the recall shows "Lemma: ... [Cached]". , goldenCapturedIO "tpCache_hit" $ \rf -> do let cfg = z3 { redirectVerbose = Just rf } void $ runTPWith cfg $ do@@ -65,7 +67,7 @@ recall (lemma "fact" sTrue []) -- Normal mode: same proposition proved under two names, then recalled (aliases).- -- The recall shows "Cached:" with "(a.k.a. ...)" listing the other name.+ -- The recall shows "Lemma: ... [Cached]" with "(a.k.a. ...)" listing the other name. , goldenCapturedIO "tpCache_alias" $ \rf -> do let cfg = z3 { redirectVerbose = Just rf } void $ runTPWith cfg $ do@@ -110,7 +112,7 @@ writeFile rf $!! cleanStatsOutput contents -- Stats mode: direct proof then recall (cache hit).- -- Direct proof shows full steps; recall shows "Cached:" one-liner.+ -- Direct proof shows full steps; recall shows "Lemma: ... [Cached]" one-liner. , goldenCapturedIO "tpCache_statsHit" $ \rf -> do let cfg = (tpStats z3) { redirectVerbose = Just rf } void $ runTPWith cfg $ do@@ -125,7 +127,7 @@ writeFile rf $!! cleanStatsOutput contents -- Stats mode: nested recall showing inner cache dynamics.- -- First recall misses (shows full inner proofs). Second recall hits (shows "Cached:").+ -- First recall misses (shows full inner proofs). Second recall hits (shows "Lemma: ... [Cached]"). , goldenCapturedIO "tpCache_statsNested" $ \rf -> do let cfg = (tpStats z3) { redirectVerbose = Just rf } void $ runTPWith cfg $ do@@ -135,4 +137,42 @@ recall (lemma "outer" sTrue []) contents <- readFile rf writeFile rf $!! cleanStatsOutput contents++ -- Recall of a failing proof: the lemma is false (x > x), so the proof should fail.+ , goldenCapturedIO "tpCache_recallFail" $ \rf -> do+ let cfg = z3 { redirectVerbose = Just rf }+ res <- try $ void $ runTPWith cfg $+ recall bad+ case res of+ Left (_ :: SomeException) -> pure ()+ Right _ -> appendFile rf "Unexpected success\n"++ -- Direct proof of a false lemma.+ , goldenCapturedIO "tpCache_fooFail" $ \rf -> do+ let cfg = z3 { redirectVerbose = Just rf }+ res <- try $ void $ runTPWith cfg foo+ case res of+ Left (_ :: SomeException) -> pure ()+ Right _ -> appendFile rf "Unexpected success\n"++ -- Recall of a failing lemma inside a larger proof.+ , goldenCapturedIO "tpCache_barFail" $ \rf -> do+ let cfg = z3 { redirectVerbose = Just rf }+ res <- try $ void $ runTPWith cfg bar+ case res of+ Left (_ :: SomeException) -> pure ()+ Right _ -> appendFile rf "Unexpected success\n" ]++-- | A trivially false lemma, used to test recall of a failing proof.+bad :: TP (Proof (Forall "x" Integer -> SBool))+bad = lemma "bad" (\(Forall @"x" (x :: SInteger)) -> x .> x) []++-- | A false lemma: x == x+1.+foo :: TP (Proof (Forall "x" Integer -> SBool))+foo = lemma "foo" (\(Forall @"x" (x :: SInteger)) -> x .== x + 1) []++-- | Recalls foo (which fails), then tries to prove another false lemma.+bar :: TP (Proof (Forall "x" Integer -> SBool))+bar = do _f <- recall foo+ lemma "bar" (\(Forall @"x" (x :: SInteger)) -> x .== x + 2) []
SBVTestSuite/TestSuite/CompileTests/PCase/PCase17.stderr view
@@ -15,8 +15,8 @@ (isLet e ==> (e .== e =: qed))] PCase17.hs:18:14: error: [GHC-83865] " Couldn't match expected type: Proof SBool- with actual type: sbv-14.0:Data.SBV.TP.TP.TPProofGen- (SBV Bool) [sbv-14.0:Data.SBV.TP.TP.Helper] ()+ with actual type: sbv-14.1:Data.SBV.TP.TP.TPProofGen+ (SBV Bool) [sbv-14.1:Data.SBV.TP.TP.Helper] () " In the expression: cases [(isZero e ==> (e .== e =: qed)), (isNum e ==> (e .== e =: qed)),
SBVTestSuite/TestSuite/CompileTests/PCase/PCase38.stderr view
@@ -15,8 +15,8 @@ (isLet e ==> undefined)] PCase38.hs:12:14: error: [GHC-83865] " Couldn't match expected type: Proof SBool- with actual type: sbv-14.0:Data.SBV.TP.TP.TPProofGen- a0 [sbv-14.0:Data.SBV.TP.TP.Helper] ()+ with actual type: sbv-14.1:Data.SBV.TP.TP.TPProofGen+ a0 [sbv-14.1:Data.SBV.TP.TP.Helper] () " In the expression: cases [(isZero e ==> undefined), (isNum e ==> undefined),
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wall -Werror -Wno-name-shadowing -ddump-splices #-}++-- Positive: Scoping regression test for pCase. Pattern var 'k' from 'Num k' is+-- used in one branch of a nested case on SBool, while a sibling branch shadows+-- 'k' with a let binding. Old scope-unaware freeVars would drop the accessor+-- binding for 'k', causing a compilation error. See also SCase107 for the sCase+-- counterpart.+module T where++import Expr+import Data.SBV+import Data.SBV.TP++t :: TP (Proof (Forall "e" Expr -> Forall "b" Bool -> SBool))+t = calc "t" (\(Forall @"e" (e :: SExpr)) (Forall @"b" (_ :: SBool)) -> e .== e) $ \e b -> []+ |- [pCase| e of+ Zero -> e .== e =: qed+ Num k -> case b of+ True -> let k = (0 :: SInteger) in k .== k =: e .== e =: qed+ False -> k .>= 0 .|| e .== e =: sTrue =: qed+ Var _ -> e .== e =: qed+ Add _ _ -> e .== e =: qed+ Let _ _ _ -> e .== e =: qed+ |]
+ SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.stderr view
@@ -0,0 +1,24 @@+PCase77.hs:(22,15)-(30,9): Splicing expression+ ghc-internal:GHC.Internal.TH.Quote.quoteExp+ pCase+ " e of\n\+ \ Zero -> e .== e =: qed\n\+ \ Num k -> case b of\n\+ \ True -> let k = (0 :: SInteger) in k .== k =: e .== e =: qed\n\+ \ False -> k .>= 0 .|| e .== e =: sTrue =: qed\n\+ \ Var _ -> e .== e =: qed\n\+ \ Add _ _ -> e .== e =: qed\n\+ \ Let _ _ _ -> e .== e =: qed\n\+ \ "+ ======>+ cases+ [(isZero e ==> (e .== e =: qed)),+ (isNum e+ ==>+ (let k = getNum_1 e+ in+ cases+ [(b ==> (let k = (0 :: SInteger) in k .== k =: e .== e =: qed)),+ (sNot b ==> (k .>= 0 .|| e .== e =: sTrue =: qed))])),+ (isVar e ==> (e .== e =: qed)), (isAdd e ==> (e .== e =: qed)),+ (isLet e ==> (e .== e =: qed))]
SBVTestSuite/TestSuite/CompileTests/SCase/SCase101.stderr view
@@ -28,4 +28,4 @@ ((\ _ -> 1) (Data.SBV.Maybe.getJust_1 m)) (ite (Data.SBV.Maybe.isNothing m) 0- (symWithKind "unmatched_sCase_Maybe_6989586621679034927")))+ (symWithKind "unmatched_sCase_Maybe_6989586621679034926")))
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE QuasiQuotes #-}++{-# OPTIONS_GHC -Wall -Werror -Wno-name-shadowing -ddump-splices #-}++-- Positive: Scoping regression test. Nested pattern var 'k' from 'Add (Num k) _'+-- is used in one branch of a nested case on SMaybe, while a sibling branch shadows+-- 'k' with a let binding. Old scope-unaware freeVars would drop the accessor binding+-- for 'k', causing a compilation error. See also PCase77 for the pCase counterpart.+module T where++import Expr+import Data.SBV++t :: SExpr -> SMaybe Integer -> SInteger+t e m = [sCase| e of+ Zero -> 0+ Num _ -> 0+ Var _ -> 0+ Add (Num k) _ -> case m of+ Nothing -> let k = 42 in k+ Just v -> k + v+ Add _ _ -> 0+ Let _ _ _ -> 0+ |]
+ SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.stderr view
@@ -0,0 +1,31 @@+SCase107.hs:(15,16)-(24,9): Splicing expression+ ghc-internal:GHC.Internal.TH.Quote.quoteExp+ sCase+ " e of\n\+ \ Zero -> 0\n\+ \ Num _ -> 0\n\+ \ Var _ -> 0\n\+ \ Add (Num k) _ -> case m of\n\+ \ Nothing -> let k = 42 in k\n\+ \ Just v -> k + v\n\+ \ Add _ _ -> 0\n\+ \ Let _ _ _ -> 0\n\+ \ "+ ======>+ ite+ (isZero e) 0+ (ite+ (isNum e) ((\ _ -> 0) (getNum_1 e))+ (ite+ (isVar e) ((\ _ -> 0) (getVar_1 e))+ (ite+ ((.&&)+ (isAdd e)+ ((\ _ _ -> isNum (getAdd_1 e)) (getAdd_1 e) (getAdd_2 e)))+ ((\ _ _+ -> let k = getNum_1 (getAdd_1 e)+ in Data.SBV.Maybe.sCaseMaybe (let k = 42 in k) (\ v -> k + v) m)+ (getAdd_1 e) (getAdd_2 e))+ (ite+ (isAdd e) ((\ _ _ -> 0) (getAdd_1 e) (getAdd_2 e))+ ((\ _ _ _ -> 0) (getLet_1 e) (getLet_2 e) (getLet_3 e))))))
SBVTestSuite/TestSuite/CompileTests/SCase/SCase59.stderr view
@@ -24,4 +24,4 @@ ((\ _ -> Data.SBV.Either.isRight (Data.SBV.Maybe.getJust_1 m)) (Data.SBV.Maybe.getJust_1 m))) ((\ _ -> 1) (Data.SBV.Maybe.getJust_1 m))- (symWithKind "unmatched_sCase_Maybe_6989586621679034927")))+ (symWithKind "unmatched_sCase_Maybe_6989586621679034926")))
SBVTestSuite/TestSuite/CompileTests/SCase/SCase66.stderr view
@@ -30,4 +30,4 @@ (ite (Data.SBV.Either.isRight e) ((\ _ -> 1) (Data.SBV.Either.getRight_1 e))- (symWithKind "unmatched_sCase_Either_6989586621679034889")))+ (symWithKind "unmatched_sCase_Either_6989586621679034888")))
SBVTestSuite/TestSuite/CompileTests/SCase/SCase89.stderr view
@@ -40,4 +40,4 @@ (isVar e) ((\ _ -> 1) (getVar_1 e)) (ite (isLet e) ((\ _ _ _ -> 3) (getLet_1 e) (getLet_2 e) (getLet_3 e))- (symWithKind "unmatched_sCase_Expr_6989586621679081395"))))))+ (symWithKind "unmatched_sCase_Expr_6989586621679081419"))))))
SBVTestSuite/TestSuite/Overflows/Arithmetic.hs view
@@ -11,7 +11,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-}
SBVTestSuite/TestSuite/Overflows/Casts.hs view
@@ -9,7 +9,7 @@ -- Test suite for overflow checking ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -Werror #-}
SBVTestSuite/TestSuite/Queries/Tables.hs view
@@ -12,7 +12,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE QuantifiedConstraints #-} {-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}
SBVTestSuite/TestSuite/QuickCheck/QC.hs view
@@ -9,7 +9,7 @@ -- Quick-check based test suite for SBV ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wall -Werror #-}
sbv.cabal view
@@ -1,7 +1,7 @@ Cabal-Version: 2.2 Name : sbv-Version : 14.0+Version : 14.1 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@@ -62,6 +62,7 @@ MultiParamTypeClasses NamedFieldPuns NegativeLiterals+ NumericUnderscores OverloadedLists OverloadedRecordDot OverloadedStrings@@ -69,7 +70,6 @@ ParallelListComp QuantifiedConstraints QuasiQuotes- Rank2Types RankNTypes RecordWildCards ScopedTypeVariables@@ -83,12 +83,9 @@ TypeOperators UndecidableInstances ViewPatterns-- if impl(ghc >= 9.8.1)- other-extensions: TypeAbstractions+ TypeAbstractions - if impl(ghc >= 8.10.1)- ghc-options : -Wunused-packages+ ghc-options : -Wunused-packages Library import : common-settings